debian-3.14: Debian/Shell.hs

-- |This module probably belongs in haskell-unixutils.
module Debian.Shell 
    ( echoCommand
    , echoProcess
    , dotOutput
    , vOutput
    -- * Semi-obsolete
    , runCommand
    , runCommandQuietly
    , runCommandTimed
    , runCommandQuietlyTimed
    , runCommandMsg
    -- * Type Class
    , ShellTask(..)
    , SimpleTask(..)
    , FullTask(..)
    , commandTask
    , processTask
    , showCommand
    , setStart
    , setFinish
    , setError
    , runTask
    , runTaskAndTest
    , timeTask
{-
    , timeTask'
    , timeTask''
-}
    , timeTaskAndTest
    --, runCommandDots
    , timeCommand
    , showElapsed
    , myTimeDiffToString
    ) where

import		 Control.Exception
-- import		 Control.Monad
import		 Control.Monad.Trans
-- import qualified Data.ByteString.Char8 as B
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 -- as P
import		 Text.Printf

-- io = liftIO

-- There seems to be a bug in Haskell's TimeDiff code,
-- sometimes tdPicosec returns a negative number.
myDiffClockTimes (TOD sa pa) (TOD sb pb) =
    case pa >= pb of
      True ->
          noTimeDiff{ tdSec     = fromIntegral (sa - sb) 
                    -- FIXME: can handle just 68 years...
                    , tdPicosec = pa - pb
                    }
      False ->
          noTimeDiff{ tdSec     = fromIntegral (sa - sb - 1) 
                    -- FIXME: can handle just 68 years...
                    , tdPicosec = pa + 1000000000000 - pb
                    }

echoCommand :: CIO m => String -> L.ByteString -> m [Output]
echoCommand command input =
    ePutStrBl ("# " ++ command) >>
    liftIO (lazyCommand command input)

-- |Echo the process arguments and then run the process
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
       --lift (IO.hPutStr IO.stderr ("(ev=" ++ show (verbosity style) ++ "-" ++ show v ++ "=" ++ show ev ++ ")"))
       case () of
         _ | v' <= (-2) -> return output
           | v' <= (-1) -> dotOutput 128 output
           | True -> setStyle (addPrefixes "[1] " "[2] ") (printOutput output)

-- |Perform a task, print the elapsed time it took, and return the result.
showElapsed :: CIO m => String -> m a -> m a
showElapsed label f =
    do (result, time) <- timeTask f
       ePutStr (label ++ myTimeDiffToString time)
       return result

-- This is a copy of a function Jeremy made private in Debian.Repo.IO.
-- This probably means there is a standard replacement for it - must
-- find out.
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

-- |Run a command and return its result along with the amount of time it took.
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)

-- |Not sure if this is a useful approach.
class ShellTask a where
    command :: a -> Either String (FilePath, [String], Maybe FilePath, Maybe [(String, String)])
    input :: a -> L.ByteString					-- The command input
    input _ = L.empty
    quietness :: a -> Int					-- Verbosity level required for full output
    quietness _ = 0
    introMsg :: a -> Maybe String				-- Message printed before command starts
    introMsg _ = Nothing
    -- If failMsg or finishMsg are given, the command output will be forced
    failMsg :: a -> Maybe (Int -> String)			-- Message printed on failure
    failMsg _ = Nothing
    finishMsg :: a -> Maybe String				-- Message printed on successful finish
    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)

{-
-- |Run a task and return the elapsed time along with its result.
timeTask :: MonadIO m => a -> m (a, TimeDiff)
timeTask x =
    do start <- liftIO getClockTime
       result <- liftIO (evaluate x)
       finish <- liftIO getClockTime
       return (result, myDiffClockTimes finish start)

-- |Run a task and return the elapsed time along with its result.
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)

timeTask'' :: (ShellTask a, CIO m) => a -> m ([Output], TimeDiff)
timeTask'' task = runTask task >>= timeTask
-}

-- |Run a task and return the elapsed time along with its result.
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)

-- Reimplementations of old functions

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 =
    -- If the program is run with -v -v, v0 will be 2, meaning quit verbose output.
    -- The higher the v argument is the higher the v0 argument must be to achieve
    -- the same verbosity, so the "effective verbosity" ev is v0 - v.
    do eBOL >> 
            maybe (return ()) (vEPutStrBl v) start >>
            vEPutStrBl (v+1) ("# " ++ cmd) >>
            liftIO (lazyCommand cmd L.empty) >>=
            vOutput (v+2) >>=
            checkResult fail (return (Right ()))