module System.Unix.Progress
(
ProgressFlag(..)
, lazyCommandP
, lazyProcessP
, timeTask
, showElapsed
, tests
, lazyCommandV
, lazyProcessV
, lazyCommandF
, lazyProcessF
, lazyCommandE
, lazyProcessE
, lazyCommandEF
, lazyProcessEF
) where
import Control.Exception (evaluate)
import "mtl" Control.Monad.Trans ( MonadIO, liftIO )
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.List (intercalate)
import qualified Data.Set as Set
import Data.Time (NominalDiffTime, getCurrentTime, diffUTCTime)
import System.Exit (ExitCode(..))
import System.Unix.Process (lazyProcess, lazyCommand, Output(Stdout, Stderr),
exitCodeOnly, stdoutOnly, mergeToStdout)
import System.Unix.QIO (quietness, ePutStr, ePutStrLn, qPutStr)
import Test.HUnit
type ProgressState = Set.Set ProgressFlag
data ProgressFlag
= Echo
| Dots
| All
| Errors
| Result
| EchoOnFail
| AllOnFail
| ErrorsOnFail
| ResultOnFail
| ExceptionOnFail
deriving (Ord, Eq)
lazyCommandV :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandV cmd input =
progressFlags Set.empty >>= lazyCommandP cmd input
lazyProcessV :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]
lazyProcessV cmd args wd env input =
progressFlags Set.empty >>= lazyProcessP cmd args wd env input
lazyCommandF :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandF cmd input =
progressFlags (Set.fromList [ExceptionOnFail]) >>= lazyCommandP cmd input
lazyProcessF :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]
lazyProcessF cmd args wd env input =
progressFlags (Set.fromList [ExceptionOnFail]) >>= lazyProcessP cmd args wd env input
lazyCommandE :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandE cmd input =
progressFlags (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail]) >>= lazyCommandP cmd input
lazyProcessE :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]
lazyProcessE cmd args wd env input =
progressFlags (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail]) >>= lazyProcessP cmd args wd env input
lazyCommandEF :: MonadIO m => String -> L.ByteString -> m [Output]
lazyCommandEF cmd input =
progressFlags (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail, ExceptionOnFail]) >>= lazyCommandP cmd input
lazyProcessEF :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]
lazyProcessEF cmd args wd env input =
progressFlags (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail, ExceptionOnFail]) >>= lazyProcessP cmd args wd env input
progressFlags :: MonadIO m => Set.Set ProgressFlag -> m (Set.Set ProgressFlag)
progressFlags extra =
quietness >>= return . merge extra . Set.fromList . flags
where
flags n | n < 0 = [Echo, All, Result]
flags 0 = [Echo, Dots, Result]
flags 1 = [Echo]
flags _ = []
merge extra flags =
(if Set.member All flags then Set.delete AllOnFail else id) .
(if Set.member Echo flags then Set.delete EchoOnFail else id) .
(if Set.member Result flags then Set.delete ResultOnFail else id) $ Set.union extra flags
lazyCommandP :: MonadIO m => String -> L.ByteString -> Set.Set ProgressFlag -> m [Output]
lazyCommandP cmd input flags =
liftIO (lazyCommand cmd input) >>= doProgress flags cmd
lazyProcessP :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> Set.Set ProgressFlag -> m [Output]
lazyProcessP exec args cwd env input flags =
liftIO (lazyProcess exec args cwd env input) >>= doProgress flags (intercalate " " (exec : args))
doProgress :: MonadIO m => ProgressState -> String -> [Output] -> m [Output]
doProgress flags cmd output =
doEcho flags output >>= doOutput flags >>= doFailOutput flags >>= doResult flags >>= doFail flags
where
doEcho flags output
| Set.member Echo flags =
ePutStrLn ("-> " ++ cmd) >> return output
| Set.member EchoOnFail flags && exitCodeOnly output /= ExitSuccess =
ePutStrLn ("-> " ++ cmd) >> return output
| True = return output
doOutput flags output
| Set.member All flags =
printOutput (prefixes opre epre output)
| Set.member Dots flags =
dotOutput 128 output
| Set.member Errors flags =
printErrors (prefixes opre epre output)
| True = return output
doFailOutput flags output
| Set.member All flags =
return output
| Set.member AllOnFail flags && exitCodeOnly output /= ExitSuccess =
ePutStrLn ("*** FAILURE: " ++ cmd ++ " -> " ++ show (exitCodeOnly output)) >>
printOutput (prefixes opre epre output)
| Set.member Errors flags =
return output
| Set.member ErrorsOnFail flags && exitCodeOnly output /= ExitSuccess =
ePutStrLn ("*** FAILURE: " ++ cmd ++ " -> " ++ show (exitCodeOnly output)) >>
printErrors (prefixes opre epre output)
| True =
return output
doResult flags output
| Set.member Result flags =
ePutStrLn ("<- " ++ show (exitCodeOnly output)) >> return output
| Set.member ResultOnFail flags && exitCodeOnly output /= ExitSuccess =
ePutStrLn ("<- " ++ show (exitCodeOnly output)) >> return output
| True = return output
doFail flags output
| Set.member ExceptionOnFail flags =
case exitCodeOnly output of
ExitSuccess -> return output
result -> fail ("*** FAILURE: " ++ cmd ++ " -> " ++ show result)
| True = return output
opre = B.pack " 1> "
epre = B.pack " 2> "
dotOutput :: MonadIO m => Int -> [Output] -> m [Output]
dotOutput groupSize output =
ePutStr "." >> mapM (\ (count, elem) -> ePutStr (replicate count '.') >> return elem) pairs >>= \ x -> ePutStr ".\n" >> return x
where
pairs = zip (dots 0 (map length output)) output
dots _ [] = []
dots rem (count : more) =
let (count', rem') = divMod (count + rem) groupSize in
count' : dots rem' more
length (Stdout s) = B.length s
length (Stderr s) = B.length s
length _ = 0
prefixes :: B.ByteString -> B.ByteString -> [Output] -> [(Output, Output)]
prefixes opre epre output =
f True output
where
f :: Bool -> [Output] -> [(Output, Output)]
f _ [] = []
f bol (x@(Stdout s) : output') = let (s', bol') = doOutput bol opre s in (x, Stdout s') : f bol' output'
f bol (x@(Stderr s) : output') = let (s', bol') = doOutput bol epre s in (x, Stderr s') : f bol' output'
f bol (x : output') = (x, Stdout B.empty) : f bol output'
doOutput :: Bool -> B.ByteString -> B.ByteString -> (B.ByteString, Bool)
doOutput bol pre s =
let (a, b) = B.span (/= '\n') s in
if B.null a
then if B.null b
then (B.empty, bol)
else let x = (if bol then pre else B.empty)
(s', bol') = doOutput True pre (B.tail b) in
(B.concat [x, (B.pack "\n"), s'], bol')
else let x = (if bol then B.append pre a else a)
(s', bol') = doOutput False pre b in
(B.append x s', bol')
printOutput :: MonadIO m => [(Output, Output)] -> m [Output]
printOutput output =
mapM (liftIO . print') output
where
print' (x, y) = print y >> return x
print (Stdout s) = liftIO $ putStr (B.unpack s)
print (Stderr s) = ePutStr (B.unpack s)
print _ = return ()
printErrors :: MonadIO m => [(Output, Output)] -> m [Output]
printErrors output =
mapM print' output
where
print' (x, y) = print y >> return x
print (Stderr s) = ePutStr (B.unpack s)
print _ = return ()
timeTask :: MonadIO m => m a -> m (a, NominalDiffTime)
timeTask x =
do start <- liftIO getCurrentTime
result <- x >>= liftIO . evaluate
finish <- liftIO getCurrentTime
return (result, diffUTCTime finish start)
showElapsed :: MonadIO m => String -> m a -> m a
showElapsed label f =
do (result, time) <- timeTask f
qPutStr (label ++ formatTime' time)
return result
formatTime' :: NominalDiffTime -> String
formatTime' diff = show diff
tests :: [Test]
tests =
[TestCase (assertEqual "Check behavior of code to insert prefixes into Output"
(collect (prefixes (p "[1] ") (p "[2] ")
[Stdout (p "abc\ndef\n\n"), Stderr (p "\nghi\njkl\n")]))
"[1] abc\n[1] def\n[1] \n[2] \n[2] ghi\n[2] jkl\n")]
where
p = B.pack
collect :: [(Output, Output)] -> String
collect = L.unpack . stdoutOnly . mergeToStdout . snd . unzip