CUI.hs

{-# OPTIONS_GHC -cpp #-}
----------------------------------------------------------------------------------------------------
---- Èíôîðìèðîâàíèå ïîëüçîâàòåëÿ î õîäå âûïîëíåíèÿ ïðîãðàììû (CUI - Console User Interface).  ------
----------------------------------------------------------------------------------------------------
module CUI where

import Prelude hiding (catch)
import Control.Monad
import Control.Concurrent
import Data.Char
import Data.IORef
import Foreign
import Foreign.C
import Numeric           (showFFloat)
import System.CPUTime    (getCPUTime)
import System.IO
import System.Time
#ifdef FREEARC_WIN
import System.Win32.Types
#endif
#ifdef FREEARC_UNIX
import System.Posix.IO
import System.Posix.Terminal
#endif

import Utils
import Errors
import Files
import FileInfo
import Options
import UIBase


----------------------------------------------------------------------------------------------------
---- Îòîáðàæåíèå èíäèêàòîðà ïðîãðåññà --------------------------------------------------------------
----------------------------------------------------------------------------------------------------

-- |Çàïóñêàåò background thread äëÿ âûâîäà èíäèêàòîðà ïðîãðåññà
guiStartProgram = do
  -- Îáíîâëÿåì èíäèêàòîð ïðîãðåññà è çàãîëîâîê îêíà ðàç â 0.5 ñåêóíäû
  indicatorThread 0.5 $ \updateMode indicator indType title b bytes total processed p -> do
    myPutStr$ back_percents indicator ++ p
    myFlushStdout
    setConsoleTitle title

-- |Âûçûâàåòñÿ â íà÷àëå îáðàáîòêè àðõèâà
guiStartArchive = doNothing0

-- |Âûçûâàåòñÿ â íà÷àëå îáðàáîòêè ôàéëà
guiStartFile = do
  command <- val ref_command
  when (opt_indicator command == "2") $ do
    syncUI $ do
    uiSuspendProgressIndicator
    uiMessage' <- val uiMessage
    myPutStrLn   ""
    myPutStr$    left_justify 72 (msgFile(cmd_name command) ++ uiMessage')
    uiResumeProgressIndicator
    hFlush stdout

-- |Ïðèîñòàíîâèòü âûâîä èíäèêàòîðà ïðîãðåññà è ñòåðåòü åãî ñëåäû
uiSuspendProgressIndicator = do
  aProgressIndicatorEnabled =: False
  (indicator, indType, arcname, direction, b, bytes', total') <- val aProgressIndicatorState
  myPutStr$ clear_percents indicator
  myFlushStdout

-- |Âîçîáíîâèòü âûâîä èíäèêàòîðà ïðîãðåññà è âûâåñòè åãî òåêóùåå çíà÷åíèå
uiResumeProgressIndicator = do
  (indicator, indType, arcname, direction, b :: Rational, bytes', total') <- val aProgressIndicatorState
  bytes <- bytes' (round b);  total <- total'
  myPutStr$ percents indicator bytes total
  myFlushStdout
  aProgressIndicatorEnabled =: True

-- |Ñäåëàòü ïàóçó â âûïîëíåíèè ïðîãðàììû
guiPauseAtEnd = do
  withoutEcho getHiddenChar
  return ()

-- |Çàâåðøèòü âûïîëíåíèå ïðîãðàììû
guiDoneProgram = do
  return ()

{-# NOINLINE guiStartProgram #-}
{-# NOINLINE guiStartFile #-}
{-# NOINLINE uiSuspendProgressIndicator #-}
{-# NOINLINE uiResumeProgressIndicator #-}
{-# NOINLINE guiDoneProgram #-}


----------------------------------------------------------------------------------------------------
---- Çàïðîñû ê ïîëüçîâàòåëþ ("Ïåðåçàïèñàòü ôàéë?" è ò.ï.) ------------------------------------------
----------------------------------------------------------------------------------------------------

-- |Çàïðîñ î ïåðåçàïèñè ôàéëà
askOverwrite filename _ _ _ =  ask ("Overwrite " ++ filename)
{-# NOINLINE askOverwrite #-}

-- |Îáùèé ìåõàíèçì äëÿ âûäà÷è çàïðîñîâ ê ïîëüçîâàòåëþ
ask question ref_answer answer_on_u =  do
  old_answer <- val ref_answer
  new_answer <- case old_answer of
                  "a" -> return old_answer
                  "u" -> return old_answer
                  "s" -> return old_answer
                  _   -> ask_user question
  ref_answer =: new_answer
  case new_answer of
    "u" -> return answer_on_u
    _   -> return (new_answer `elem` ["y","a"])

-- |Ñîáñòâåííî îáùåíèå ñ ïîëüçîâàòåëåì ïðîèñõîäèò çäåñü
ask_user question = syncUI $ pauseTiming go  where
  go = do myPutStr$ "\n  "++question++" ("++valid_answers++")? "
          hFlush stdout
          answer  <-  getLine >>== strLower
          when (answer=="q") $ do
              terminateOperation
          if (answer `elem` (split '/' valid_answers))
            then return answer
            else myPutStr askHelp >> go

-- |Ïîäñêàçêà, âûâîäèìàÿ íà ýêðàí ïðè íåäîïóñòèìîì îòâåòå
askHelp = unlines [ "  Valid answers are:"
                  , "    y - yes"
                  , "    n - no"
                  , "    a - always, answer yes to all remaining queries"
                  , "    s - skip, answer no to all remaining queries"
                  , "    u - update remaining files (yes for each extracted file that is newer than file on disk)"
                  , "    q - quit program"
                  ]

valid_answers = "y/n/a/s/u/q"


----------------------------------------------------------------------------------------------------
---- Çàïðîñ ïàðîëåé --------------------------------------------------------------------------------
----------------------------------------------------------------------------------------------------

ask_passwords = (ask_encryption_password, ask_decryption_password, bad_decryption_password)

-- |Ïå÷àòàåò ñîîáùåíèå î òîì, ÷òî ââåä¸ííûé ïàðîëü íå ïîäõîäèò äëÿ äåøèôðîâàíèÿ
bad_decryption_password = myPutStrLn "Incorrect password"

-- |Çàïðîñ ïàðîëÿ ïðè ñæàòèè. Èñïîëüçóåòñÿ íåâèäèìûé ââîä
-- è çàïðîñ ïîâòîðÿåòñÿ äâàæäû äëÿ èñêëþ÷åíèÿ îøèáêè ïðè åãî ââîäå
ask_encryption_password opt_parseData = syncUI $ pauseTiming $ do
  withoutEcho $ go where
    go = do myPutStr "\n  Enter encryption password:"
            hFlush stdout
            answer <- getHiddenLine >>== opt_parseData 't'
            myPutStr "  Reenter encryption password:"
            hFlush stdout
            answer2 <- getHiddenLine >>== opt_parseData 't'
            if answer/=answer2
              then do myPutStrLn "  Passwords are different. You need to repeat input"
                      go
              else return answer

-- |Çàïðîñ ïàðîëÿ äëÿ ðàñïàêîâêè. Èñïîëüçóåòñÿ íåâèäèìûé ââîä
ask_decryption_password opt_parseData = syncUI $ pauseTiming $ do
  withoutEcho $ do
  myPutStr "\n  Enter decryption password:"
  hFlush stdout
  getHiddenLine >>== opt_parseData 't'

-- |Ââåñòè ñòðîêó, íå îòîáðàæàÿ å¸ íà ýêðàíå
getHiddenLine = go ""
  where go s = do c <- getHiddenChar
                  case c of
                    '\r' -> do myPutStrLn ""; return s
                    '\n' -> do myPutStrLn ""; return s
                    c    -> go (s++[c])


#ifdef FREEARC_WIN

-- |Ïåðåâåñòè êîíñîëü â ðåæèì íåâèäèìîãî ââîäà
withoutEcho = id
-- |Ââåñòè ñèìâîë áåç ýõà
getHiddenChar = liftM (chr.fromEnum) c_getch
foreign import ccall unsafe "conio.h getch"
   c_getch :: IO CInt

#else

getHiddenChar = getChar

withoutEcho action = do
  let setAttr attr = setTerminalAttributes stdInput attr Immediately
      disableEcho = do origAttr <- getTerminalAttributes stdInput
                       setAttr$ origAttr.$ flip withMode ProcessInput
                                        .$ flip withoutMode EnableEcho
                                        .$ flip withMode KeyboardInterrupts
                                        .$ flip withoutMode IgnoreBreak
                                        .$ flip withMode InterruptOnBreak
                       return origAttr
  --
  bracketCtrlBreak "restoreEcho" disableEcho setAttr (\_ -> action)

#endif

{-# NOINLINE ask_passwords #-}


----------------------------------------------------------------------------------------------------
---- Ââîä/âûâîä êîììåíòàðèåâ ê àðõèâó  -------------------------------------------------------------
----------------------------------------------------------------------------------------------------

-- |Âûâåñòè íà ýêðàí êîììåíòàðèé ê àðõèâó
uiPrintArcComment arcComment = do
  when (arcComment>"") $ do
    myPutStrLn arcComment

-- |Ââåñòè ñ stdin êîììåíòàðèé ê àðõèâó
uiInputArcComment old_comment = syncUI $ pauseTiming $ do
  myPutStrLn "Enter archive comment, ending with \".\" on separate line:"
  hFlush stdout
  let go xs = do line <- myGetLine
                 if line/="."
                   then go (line:xs)
                   else return$ joinWith "\n" $ reverse xs
  --
  go []

{-# NOINLINE uiPrintArcComment #-}
{-# NOINLINE uiInputArcComment #-}

----------------------------------------------------------------------------------------------------
----- External functions ---------------------------------------------------------------------------
----------------------------------------------------------------------------------------------------

#ifdef FREEARC_WIN
type TString = Ptr TCHAR
#else
withTString  = withCString
type TString = CString
#endif

-- |Set console title
setConsoleTitle title = do
  withTString title c_SetConsoleTitle

-- |Set console title (external)
foreign import ccall unsafe "Environment.h EnvSetConsoleTitle"
  c_SetConsoleTitle :: TString -> IO ()

-- |Reset console title
foreign import ccall unsafe "Environment.h EnvResetConsoleTitle"
  resetConsoleTitle :: IO ()