module Debian.Shell
( echoCommand
, echoProcess
, dotOutput
, vOutput
, runCommand
, runCommandQuietly
, runCommandTimed
, runCommandQuietlyTimed
, runCommandMsg
, ShellTask(..)
, SimpleTask(..)
, FullTask(..)
, commandTask
, processTask
, showCommand
, setStart
, setFinish
, setError
, runTask
, runTaskAndTest
, timeTask
, timeTaskAndTest
, timeCommand
, showElapsed
, myTimeDiffToString
) where
import Control.Exception
import Control.Monad.Trans
import qualified Data.ByteString.Lazy.Char8 as L
import Data.List
import Debian.Extra.CIO (dotOutput, printOutput, vMessage)
import Extra.CIO (CIO, ePutStrBl, vEPutStrBl, ePutStr, eBOL, ev, setStyle, addPrefixes)
import Prelude hiding (putStr)
import System.Locale
import System.Time
import System.Unix.Process
import Text.Printf
myDiffClockTimes (TOD sa pa) (TOD sb pb) =
case pa >= pb of
True ->
noTimeDiff{ tdSec = fromIntegral (sa sb)
, tdPicosec = pa pb
}
False ->
noTimeDiff{ tdSec = fromIntegral (sa sb 1)
, tdPicosec = pa + 1000000000000 pb
}
echoCommand :: CIO m => String -> L.ByteString -> m [Output]
echoCommand command input =
ePutStrBl ("# " ++ command) >>
liftIO (lazyCommand command input)
echoProcess :: CIO m => FilePath -> [String] -> L.ByteString -> m [Output]
echoProcess exec args input =
ePutStrBl (intercalate " " ("#" : exec : args)) >>
liftIO (lazyProcess exec args Nothing Nothing input)
vOutput :: CIO m => Int -> [Output] -> m [Output]
vOutput v output =
do v' <- ev v
case () of
_ | v' <= (2) -> return output
| v' <= (1) -> dotOutput 128 output
| True -> setStyle (addPrefixes "[1] " "[2] ") (printOutput output)
showElapsed :: CIO m => String -> m a -> m a
showElapsed label f =
do (result, time) <- timeTask f
ePutStr (label ++ myTimeDiffToString time)
return result
myTimeDiffToString diff =
do
case () of
_ | isPrefixOf "00:00:0" s -> drop 7 s ++ printf ".%03d" ms ++ " s."
_ | isPrefixOf "00:00:" s -> drop 6 s ++ printf ".%03d" ms ++ " s."
_ | isPrefixOf "00:" s -> drop 3 s
_ -> s
where
s = formatTimeDiff defaultTimeLocale "%T" diff
ms = ps2ms ps
ps2ms ps = quot (ps + 500000000) 1000000000
ps = tdPicosec diff
timeCommand :: CIO m => m (Either String [Output]) -> m (Either String ([Output], TimeDiff))
timeCommand result =
timeTask result >>= \ (result, elapsed) -> return (either Left (\ output -> Right (output, elapsed)) result)
class ShellTask a where
command :: a -> Either String (FilePath, [String], Maybe FilePath, Maybe [(String, String)])
input :: a -> L.ByteString
input _ = L.empty
quietness :: a -> Int
quietness _ = 0
introMsg :: a -> Maybe String
introMsg _ = Nothing
failMsg :: a -> Maybe (Int -> String)
failMsg _ = Nothing
finishMsg :: a -> Maybe String
finishMsg _ = Nothing
data SimpleTask = SimpleTask Int String
instance ShellTask SimpleTask where
command (SimpleTask _ s) = (Left s)
quietness (SimpleTask n _) = n
introMsg (SimpleTask _ _) = Nothing
data FullTask =
FullTask { taskQuietness :: Int
, taskCommand :: Either String (FilePath, [String], Maybe FilePath, Maybe [(String, String)])
, taskIntroMsg :: Maybe String
, taskFailMsg :: Maybe (Int -> String)
, taskFinishMsg :: Maybe String }
commandTask command =
FullTask { taskQuietness = 0
, taskCommand = Left command
, taskIntroMsg = Nothing
, taskFailMsg = Nothing
, taskFinishMsg = Nothing }
processTask exec args path env =
FullTask { taskQuietness = 0
, taskCommand = Right (exec, args, path, env)
, taskIntroMsg = Nothing
, taskFailMsg = Nothing
, taskFinishMsg = Nothing }
setStart :: (Maybe String) -> FullTask -> FullTask
setStart s task = task {taskIntroMsg = s}
setFinish :: (Maybe String) -> FullTask -> FullTask
setFinish s task = task {taskFinishMsg = s}
setError :: (Maybe (Int -> String)) -> FullTask -> FullTask
setError s task = task {taskFailMsg = s}
showCommand task = either id (\ (exec, args, _, _) -> intercalate " " ([exec] ++ args)) (command task)
instance ShellTask FullTask where
quietness = taskQuietness
command = taskCommand
introMsg = taskIntroMsg
failMsg = taskFailMsg
finishMsg = taskFinishMsg
runTask :: (ShellTask a, CIO m) => a -> m [Output]
runTask task =
liftIO (either (\ cmd -> lazyCommand cmd (input task))
(\ (exec, args, path, env) -> lazyProcess exec args path env (input task)) (command task)) >>=
maybe return (vMessage 0) (introMsg task) >>=
vOutput 2 >>=
(\ output ->
(case (failMsg task, finishMsg task) of
(Nothing, Nothing) -> return output
_ -> checkResult (onFail task) (onFinish task) output >> return output))
where
onFail :: (ShellTask a, CIO m) => a -> Int -> m ()
onFail task n = maybe (return ()) (\ f -> vEPutStrBl 0 (f n)) (failMsg task)
onFinish :: (ShellTask a, CIO m) => a -> m ()
onFinish task = maybe (return ()) (\ s -> vEPutStrBl 0 s) (finishMsg task)
runTaskAndTest :: (ShellTask a, CIO m) => a -> m (Either String [Output])
runTaskAndTest task =
do output <- runTask task
checkResult fail (ok output) output
where
fail n = return (Left (maybe ("*** FAILURE: " ++ showCommand task ++ " -> " ++ show n) (\ f -> f n) (failMsg task)))
ok output = return (Right output)
timeTask :: MonadIO m => m a -> m (a, TimeDiff)
timeTask x =
do start <- liftIO getClockTime
result <- x >>= liftIO . evaluate
finish <- liftIO getClockTime
return (result, myDiffClockTimes finish start)
timeTaskAndTest :: (ShellTask a, CIO m) => a -> m (Either String ([Output], TimeDiff))
timeTaskAndTest task =
timeTask (runTaskAndTest task) >>= return . fixResult
where
fixResult (Left x, _) = Left x
fixResult (Right x, t) = Right (x, t)
runCommand :: CIO m => Int -> String -> m (Either String [Output])
runCommand v cmd = runTaskAndTest (SimpleTask v cmd)
runCommandTimed :: CIO m => Int -> String -> m (Either String ([Output], TimeDiff))
runCommandTimed v cmd = timeCommand (runCommand v cmd)
runCommandQuietly :: CIO m => String -> m (Either String [Output])
runCommandQuietly = runCommand 1
runCommandQuietlyTimed :: CIO m => String -> m (Either String ([Output], TimeDiff))
runCommandQuietlyTimed = runCommandTimed 1
runCommandMsg :: CIO m => Int -> Maybe String -> String -> (Int -> m (Either String ())) -> m (Either String ())
runCommandMsg v start cmd fail =
do eBOL >>
maybe (return ()) (vEPutStrBl v) start >>
vEPutStrBl (v+1) ("# " ++ cmd) >>
liftIO (lazyCommand cmd L.empty) >>=
vOutput (v+2) >>=
checkResult fail (return (Right ()))