packages feed

Unixutils 1.29 → 1.34

raw patch · 10 files changed

+923/−478 lines, 10 filesdep +HUnitdep +arraydep +containers

Dependencies added: HUnit, array, containers, time

Files

COPYING view
@@ -1,1 +1,31 @@-BSD+Copyright Jeremy Shaw 2007-2010+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++   * Redistributions of source code must retain the above copyright+     notice, this list of conditions and the following disclaimer.++   * Redistributions in binary form must reproduce the above+     copyright notice, this list of conditions and the following+     disclaimer in the documentation and/or other materials provided+     with the distribution.++   * Neither the name of the copyright holder nor the names of other+     contributors may be used to endorse or promote products derived+     from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
− System/Unix/List.hs 
@@ -1,15 +0,0 @@--- | A function taken From missingh, which will not build under--- sid at the moment.--module System.Unix.List-    (join,-     consperse)-    where--import Data.List--join :: [a] -> [[a]] -> [a]-join x l = concat . intersperse x $ l--consperse :: [a] -> [[a]] -> [a]-consperse = join
System/Unix/Misc.hs view
@@ -7,6 +7,7 @@     where  import Control.Exception+import Data.ByteString.Lazy.Char8 (empty) import Data.Maybe import System.Cmd import System.Directory@@ -19,15 +20,16 @@ md5sum :: FilePath -> IO String md5sum path =     do-      (text, _, exitCode) <- simpleProcess "md5sum" [path]+      (text, _, exitCode) <- lazyProcess "md5sum" [path] Nothing Nothing empty >>= return . collectOutputUnpacked       let output = listToMaybe (words text)       case exitCode of         ExitSuccess ->             case output of               Nothing -> error ("Error in output of 'md5sum " ++ path ++ "'")               Just checksum -> return checksum-        ExitFailure _ -> error ("Error running 'md5sum " ++ path ++ "'")+        _ -> error ("Error running 'md5sum " ++ path ++ "'") +{-# WARNING gzip "System.Unix.Misc.gzip does not properly escape its path arguments" #-} gzip :: FilePath -> IO () gzip path =     do
System/Unix/Mount.hs view
@@ -89,7 +89,7 @@ -- NOTE: we don't use the umount system call because the system call -- is not smart enough to update \/etc\/mtab umount :: [String] -> IO (String, String, ExitCode)-umount args = simpleProcess "umount" args+umount args = lazyProcess "umount" args Nothing Nothing empty >>= return . collectOutputUnpacked  isMountPoint :: FilePath -> IO Bool -- This implements the functionality of mountpoint(1), deciding
+ System/Unix/OldProgress.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |Run shell commands with various types of progress reporting.+--+-- Author: David Fox+module System.Unix.OldProgress {-# DEPRECATED "Use System.Unix.Progress" #-}+    (+     systemTask, 	-- [Style] -> String -> IO TimeDiff+     otherTask,		-- [Style] -> IO a -> IO a+     Style (Start, Finish, Error, Output, Echo, Elapsed, Verbosity, Indent),+     readStyle,		-- String -> Maybe Style+     Output (Indented, Dots, Done, Quiet),+     msg,		-- [Style] -> String -> IO ()+     msgLn,		-- [Style] -> String -> IO ()+     -- * Accessors+     output,		-- [Style] -> Maybe Output+     verbosity,		-- [Style] -> Int+     -- * Style Set modification+     setStyles,		-- [Style] -> [Style] -> [Style]+     setStyle,		-- Style -> [Style] -> [Style]+     addStyles,		-- [Style] -> [Style] -> [Style]+     addStyle,		-- Style -> [Style] -> [Style]+     removeStyle,	-- Style -> [Style] -> [Style]+     -- * Utilities+     stripDist,		-- FilePath -> FilePath+     showElapsed,	-- String -> IO a -> IO a+     System.Time.TimeDiff,+     System.Time.noTimeDiff,+     fixedTimeDiffToString+    ) where++import Control.Exception+import Data.List+import System.Exit+import System.IO+import System.Process+import System.Time++data Output+    = Indented |+      -- ^ Print all the command's output with each line+      -- indented using (by default) the string ' > '.+      Dots |+      -- ^ Print a dot for every 1024 characters the command+      -- outputs+      Done |+      -- ^ Print an ellipsis (...) when the command starts+      -- and then "done." when it finishes.+      Quiet+      -- ^ Print nothing.++instance Show Output where+    show Indented = "Indented"+    show Dots = "Dots"+    show Done = "Done"+    show Quiet  = "Quiet "++data Style+    = Start String |+      -- ^ Message printed before the execution begins+      Finish String |+      -- ^ Message printed on successful termination+      Error String |+      -- ^ Message printed on failure+      Output Output |+      -- ^ Type of output to generate during execution+      Echo Bool |+      -- ^ If true, echo the shell command before beginning+      Elapsed Bool |+      -- ^ If true print the elapsed time on termination+      Verbosity Int |+      -- ^ Set the verbosity level.  This value can be queried+      -- using the verbosity function, but is not otherwise used+      -- by the -- functions in this module.+      Indent String+      -- ^ Set the indentation string for the generated output.++instance Show Style where+    show (Start s) = "Start " ++ show s+    show (Finish s) = "Finish " ++ show s+    show (Error s) = "Error " ++ show s+    show (Output output) = "Output " ++ show output+    show (Echo flag) = "Echo " ++ show flag+    show (Elapsed flag) = "Elapsed " ++ show flag+    show (Verbosity n) = "Verbosity " ++ show n+    show (Indent s) = "Verbosity " ++ show s++styleClass (Start _) = "Start"+styleClass (Finish _) = "Finish"+styleClass (Error _) = "Error"+styleClass (Output _) = "Progress"+styleClass (Echo _) = "Echo"+styleClass (Elapsed _) = "Elapsed"+styleClass (Verbosity _) = "Verbosity"+styleClass (Indent _) = "Indent"++-- This definition of equivalence is used to add or replace a style+-- parameter - for example, supply a Start message if none is present.+instance Eq Style where+    a == b = styleClass a == styleClass b++-- |Create a task that sends its output to a handle and then can be+-- terminated using an IO operation that returns an exit status.+-- Throws an error if the command fails.+systemTask :: [Style] -> String -> IO TimeDiff+systemTask style command =+    do+      start <- getClockTime+      putIndent style+      startMessage style+      taskStart style+      (_, _, outputHandle, processHandle) <- runInteractiveCommand ("{ " ++ command ++ "; } 1>&2")+      text <- progressOutput (maybe Indented id (output style)) outputHandle;+      result <- waitForProcess processHandle+      finish <- getClockTime+      let elapsed = diffClockTimes finish start+      case result of+        ExitSuccess -> finishMessage style elapsed+        ExitFailure _ -> errorMessage style text+      return elapsed+    where+      taskStart (Echo True : etc) = do hPutStrLn stderr ("\n -> " ++ command); taskStart etc+      taskStart (_ : etc) = taskStart etc+      taskStart [] = return ()++otherTask :: [Style] -> IO a -> IO a+otherTask style task =+    do+      start <- getClockTime+      putIndent style+      startMessage style+      taskStart style+      result <- try task+      hPutStr stderr "..."+      finish <- getClockTime+      let elapsed = diffClockTimes finish start+      case result of+        Left (e :: SomeException) ->+            do errorMessage style (show e)+               error (show e)+        Right a ->+            do finishMessage style elapsed+               return a+    where+      taskStart (_ : etc) = taskStart etc+      taskStart [] = return ()++-- FIXME: these two should break up the text into lines and prepend+-- the indentation to each.+msg :: [Style] -> String -> IO ()+msg style text =+    do+      putIndent style+      hPutStr stderr text        ++msgLn :: [Style] -> String -> IO ()+msgLn style text =+    do+      putIndent style+      hPutStrLn stderr text        ++putIndent :: [Style] -> IO ()+putIndent style = hPutStr stderr (indent style)++startMessage :: [Style] -> IO ()+startMessage (Start message : etc) = do hPutStr stderr message; startMessage etc+startMessage (_ : etc) = startMessage etc+startMessage [] = return ()++progressOutput :: Output -> Handle -> IO String++progressOutput Dots handle =+    do+      hPutStr stderr "..."+      doText 0 ""+    where+      doText count text =+          do+            eof <- hIsEOF handle+            case eof of+              False ->+                  do+                    line <- hGetLine handle+                    let count' = count + length line + 1+                    let text' = text ++ line ++ "\n"+                    let (n, m) = quotRem count' 1024+                    hPutStr stderr (replicate n '.')+                    doText m text'+              True ->+                  do+                    -- hPutStr stderr "done."+                    return text++progressOutput Done handle =+    do+      hPutStr stderr "..."+      doText ""+    where+      doText text =+          do+            eof <- hIsEOF handle+            case eof of+              False ->+                  do+                    line <- hGetLine handle+                    let text' = text ++ line ++ "\n"+                    doText text'+              True ->+                  do+                    -- hPutStr stderr "done."+                    return text++progressOutput Indented handle =+    do+      hPutStrLn stderr ""+      doText+    where+      doText =+          do+            eof <- hIsEOF handle+            case eof of+              True -> return ""+              False ->+                  do+                    line <- hGetLine handle+                    -- Not collecting text here since it gets output.+                    -- This is a judgement call.+                    -- let text' = text ++ line ++ "\n"+                    hPutStrLn stdout (prefix ++ line)+                    hFlush stdout+                    doText+      prefix = " >    "++progressOutput Quiet handle =+    do+      doText ""+    where+      doText text =+          do+            eof <- hIsEOF handle+            case eof of+              False ->+                  do+                    line <- hGetLine handle+                    let text' = text ++ line ++ "\n"+                    doText text'+              True -> return text++finishMessage :: [Style] -> TimeDiff -> IO ()+finishMessage (Elapsed True : etc) elapsed =+    do+      hPutStr stderr ("  (Elapsed: " ++ fixedTimeDiffToString elapsed ++ ")")+      finishMessage etc elapsed+finishMessage (Finish message : etc) elapsed = do hPutStr stderr message; finishMessage etc elapsed+finishMessage (_ : etc) elapsed = finishMessage etc elapsed+finishMessage [] _ = do hPutStrLn stderr ""; return ()++errorMessage :: [Style] -> String -> IO ()+errorMessage (Error message : _) text =+    do+      hPutStrLn stderr text+      error message+errorMessage (_ : etc) text = errorMessage etc text+errorMessage [] text = errorMessage [Error "failed"] text++-- |Remove styles by class+removeStyle :: Style -> [Style] -> [Style]+removeStyle (Start _) style = filter (not . isStart) style +removeStyle (Finish _) style = filter (not . isFinish) style +removeStyle (Error _) style = filter (not. isError) style +removeStyle (Output _) style = filter (not . isOutput) style +removeStyle (Echo _) style = filter (not . isEcho) style +removeStyle old style = filter (/= old) style++-- |Add styles, replacing old ones if present+setStyles :: [Style] -> [Style] -> [Style]+setStyles [] style = style+setStyles (x:xs) style = setStyles xs (x : (removeStyle x style))++-- |Singleton case of setStyles+setStyle :: Style -> [Style] -> [Style]+setStyle new style = setStyles [new] style++-- |Singleton case of addStyles+addStyle :: Style -> [Style] -> [Style]+addStyle x@(Start _) style = case filter isStart style of [] -> x : style; _ -> style+addStyle x@(Finish _) style = case filter isFinish style of [] -> x : style; _ -> style+addStyle x@(Error _) style = case filter isError style of [] -> x : style; _ -> style+addStyle x@(Output _) style = case filter isOutput style of [] -> x : style; _ -> style+addStyle x@(Echo _) style = case filter isEcho style of [] -> x : style; _ -> style+addStyle x style = if elem x style then style else x : style++isStart (Start _) = True+isStart _ = False+isFinish (Finish _) = True+isFinish _ = False+isError (Error _) = True+isError _ = False+isOutput (Output _) = True+isOutput _ = False+isEcho (Echo _) = True+isEcho _ = False++output :: [Style] -> Maybe Output+output (Output x : _) = Just x+output (_  : xs) = output xs+output [] = Nothing++-- |Add styles only if not present+addStyles :: [Style] -> [Style] -> [Style]+addStyles styles style = foldr addStyle style styles++stripDist :: FilePath -> FilePath+stripDist path = maybe path (\ n -> "..." ++ drop (n + 7) path) (isSublistOf "/dists/" path)++verbosity :: [Style] -> Int+verbosity [] = 0+verbosity (Verbosity n : _) = n+verbosity (_ : etc) = verbosity etc++indent :: [Style] -> String+indent [] = ""+indent (Indent s : _) = s+indent (_ : etc) = indent etc++readStyle :: String -> Maybe Style+-- FIXME: implement this+readStyle text =+    case (mapSnd tail . break (== '=')) text of+      ("Start", message) -> Just $ Start message+      ("Finish", message) -> Just $ Finish message+      ("Error", message) -> Just $ Error message+      ("Output", "Indented") -> Just $ Output Indented+      ("Output", "Dots") -> Just $ Output Dots+      ("Output", "Done") -> Just $ Output Done+      ("Output", "Quiet") -> Just $ Output Quiet+      ("Echo", flag) -> Just $ Echo (readFlag flag)+      ("Elapsed", flag) -> Just $ Elapsed (readFlag flag)+      ("Verbosity", value) -> Just $ Verbosity (read value)+      ("Indent", prefix) -> Just $ Indent prefix+      _ -> Nothing+    where+      readFlag "yes" = True+      readFlag "no" = False+      readFlag "true" = True+      readFlag "false" = True+      readFlag text = error ("Unrecognized bool: " ++ text)++-- |The timeDiffToString function returns the empty string for+-- the zero time diff, this is not the behavior I need.+fixedTimeDiffToString :: TimeDiff -> [Char]+fixedTimeDiffToString diff =+    case timeDiffToString diff of+      "" -> "0 sec"+      s -> s++showElapsed :: String -> IO a -> IO a+showElapsed label f =+    do+      (result, time) <- elapsed f+      ePut (label ++ fixedTimeDiffToString time)+      return result++elapsed :: IO a -> IO (a, TimeDiff)+elapsed f =+    do+      start <- getClockTime+      result <- f+      finish <- getClockTime+      return (result, diffClockTimes finish start)++isSublistOf :: Eq a => [a] -> [a] -> Maybe Int+isSublistOf sub lst =+    maybe Nothing (\ s -> Just (length s - length sub))+              (find (isSuffixOf sub) (inits lst))++mapSnd :: (b -> c) -> (a, b) -> (a, c)+mapSnd f (a, b) = (a, f b)++ePut :: String -> IO ()+ePut s = hPutStrLn stderr s
System/Unix/Process.hs view
@@ -3,20 +3,13 @@ -- |functions for killing processes, running processes, etc module System.Unix.Process     (-    -- * Strict process running-      simpleProcess	-- FilePath -> [String] -> IO (String, String, ExitCode)-    , processResult	-- FilePath -> [String] -> IO (Either Int (String, String))-    , processOutput	-- FilePath -> [String] -> IO (Either Int String)-    , simpleCommand	-- String -> IO (String, String, ExitCode)-    , commandResult	-- String -> IO (Either Int (String, String))-    , commandOutput	-- String -> IO (Either Int String)     -- * Lazy process running-    , Process+      Process     , Output(Stdout, Stderr, Result)-    , lazyRun		-- L.ByteString -> Process -> IO [Output]-    , lazyCommand	-- String -> IO [Output]+    , lazyRun		-- L.ByteString -> Process -> m [Output]+    , lazyCommand	-- String -> m [Output]     , lazyProcess	-- FilePath -> [String] -> Maybe FilePath-			--     -> Maybe [(String, String)] -> IO [Output]+			--     -> Maybe [(String, String)] -> m [Output]     , stdoutOnly	-- [Output] -> L.ByteString     , stderrOnly	-- [Output] -> L.ByteString     , outputOnly	-- [Output] -> L.ByteString@@ -30,8 +23,9 @@     , collectStderr     , collectOutput     , collectOutputUnpacked+    , collectResult     , ExitCode(ExitSuccess, ExitFailure)-    , exitCodeOnly	-- [Output] -> [ExitCode]+    , exitCodeOnly	-- [Output] -> ExitCode     , hPutNonBlocking	-- Handle -> B.ByteString -> IO Int     -- * Process killing     , killByCwd		-- FilePath -> IO [(String, Maybe String)]@@ -39,18 +33,19 @@  import Control.Concurrent (threadDelay) import Control.Monad (liftM, filterM)-import Control.Exception hiding (catch)-import Control.Parallel.Strategies (rnf)+import Control.Monad.Trans (MonadIO(liftIO))+--import Control.Exception hiding (catch)+--import Control.Parallel.Strategies (rnf) import Data.Char (isDigit) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as C import Data.ByteString.Internal(toForeignPtr)	-- for hPutNonBlocking only-import Data.List (isPrefixOf)+import Data.List (isPrefixOf, partition) import Data.Int (Int64) import qualified GHC.IO.Exception as E import System.Process (ProcessHandle, waitForProcess, runInteractiveProcess, runInteractiveCommand)-import System.IO (Handle, hSetBinaryMode, hReady, hPutBufNonBlocking, hClose, hGetContents)+import System.IO (Handle, hSetBinaryMode, hReady, hPutBufNonBlocking, hClose {-, hGetContents-}) import System.IO.Unsafe (unsafeInterleaveIO) import System.Directory (getDirectoryContents) import System.Exit (ExitCode(ExitFailure, ExitSuccess))@@ -89,66 +84,6 @@       kill :: String -> IO ()       kill pidStr = signalProcess sigTERM (read pidStr) --- |'simpleProcess' - run a process returning (stdout, stderr, exitcode)------ /Warning/ - stdout and stderr will be read strictly so that we do--- not deadlock when trying to check the exitcode. Do not try doing--- something like, @simpleProcess [\"yes\"]@------ NOTE: this may still dead-lock because we first strictly read--- outStr and then errStr. Perhaps we should use forkIO or something?-simpleProcess :: FilePath -> [String] -> IO (String, String, ExitCode)-simpleProcess exec args =-    do (inp,out,err,pid) <- runInteractiveProcess exec args Nothing Nothing-       hSetBinaryMode out True-       hSetBinaryMode err True-       hClose inp-       outStr <- hGetContents out-       errStr <- hGetContents err-       evaluate (rnf outStr) -- read output strictly-       evaluate (rnf errStr) -- read stderr strictly-       ec <- waitForProcess pid-       return (outStr, errStr, ec)--processResult :: FilePath -> [String] -> IO (Either Int (String, String))-processResult exec args =-    simpleProcess exec args >>= return . resultOrCode-    where-      resultOrCode (_, _, ExitFailure n) = Left n-      resultOrCode (out, err, ExitSuccess) = Right (out, err)--processOutput :: FilePath -> [String] -> IO (Either Int String)-processOutput exec args =-    simpleProcess exec args >>= return . outputOrCode-    where-      outputOrCode (_, _, ExitFailure n) = Left n-      outputOrCode (out, _, ExitSuccess) = Right out--simpleCommand :: String -> IO (String, String, ExitCode)-simpleCommand cmd =-    do (inp,out,err,pid) <- runInteractiveCommand cmd-       hClose inp-       outStr <- hGetContents out-       errStr <- hGetContents err-       evaluate (rnf outStr) -- read output strictly-       evaluate (rnf errStr) -- read stderr strictly-       ec <- waitForProcess pid-       return (outStr, errStr, ec)--commandResult :: String -> IO (Either Int (String, String))-commandResult cmd =-    simpleCommand cmd >>= return . resultOrCode-    where-      resultOrCode (_, _, ExitFailure n) = Left n-      resultOrCode (out, err, ExitSuccess) = Right (out, err)--commandOutput :: String -> IO (Either Int String)-commandOutput cmd =-    simpleCommand cmd >>= return . outputOrCode-    where-      outputOrCode (_, _, ExitFailure n) = Left n-      outputOrCode (out, _, ExitSuccess) = Right out- {- Functions to run a process and return a lazy list of chunks from    standard output, standard error, and at the end of the list an    object indicating the process result code.  If neither output@@ -159,43 +94,61 @@ -- | This is the type returned by 'System.Process.runInteractiveProcess' et. al. type Process = (Handle, Handle, Handle, ProcessHandle) --- | The process returns a list of objects of type 'Output'.  There will be--- one Result object at the end of the list (if the list has an end.)+-- | The lazyCommand, lazyProcess and lazyRun functions each return a+-- list of 'Output'.  There will generally be one Result value at or+-- near the end of the list (if the list has an end.) data Output     = Stdout B.ByteString     | Stderr B.ByteString     | Result ExitCode       deriving Show +-- |An opaque type would give us additional type safety to ensure the+-- semantics of 'exitCodeOnly'.+type Outputs = [Output]+ bufSize = 65536		-- maximum chunk size uSecs = 8		-- minimum wait time, doubles each time nothing is ready maxUSecs = 100000	-- maximum wait time (microseconds)  -- | Create a process with 'runInteractiveCommand' and run it with 'lazyRun'.-lazyCommand :: String -> L.ByteString -> IO [Output]-lazyCommand cmd input = runInteractiveCommand cmd >>= lazyRun input+lazyCommand :: MonadIO m => String -> L.ByteString -> m Outputs+lazyCommand cmd input = liftIO (runInteractiveCommand cmd) >>= lazyRun input  -- | Create a process with 'runInteractiveProcess' and run it with 'lazyRun'.-lazyProcess :: FilePath -> [String] -> Maybe FilePath-            -> Maybe [(String, String)] -> L.ByteString -> IO [Output]+lazyProcess :: MonadIO m =>+               FilePath+            -> [String]+            -> Maybe FilePath+            -> Maybe [(String, String)]+            -> L.ByteString+            -> m Outputs lazyProcess exec args cwd env input =-    runInteractiveProcess exec args cwd env >>= lazyRun input+    liftIO (runInteractiveProcess exec args cwd env) >>= lazyRun input  -- | Take the tuple like that returned by 'runInteractiveProcess', -- create a process, send the list of inputs to its stdin and return -- the lazy list of 'Output' objects.-lazyRun :: L.ByteString -> Process -> IO [Output]+lazyRun :: MonadIO m => L.ByteString -> Process -> m Outputs lazyRun input (inh, outh, errh, pid) =-    hSetBinaryMode inh True >>-    hSetBinaryMode outh True >>-    hSetBinaryMode errh True >>-    elements (L.toChunks input, Just inh, Just outh, Just errh, [])+    liftIO (hSetBinaryMode inh True >>+            hSetBinaryMode outh True >>+            hSetBinaryMode errh True >>+            elements (L.toChunks input, Just inh, Just outh, Just errh, []))     where-      elements :: ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, [Output]) -> IO [Output]-      -- EOF on both output descriptors, get exit code+      elements :: ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, Outputs) -> IO Outputs+      -- EOF on both output descriptors, get exit code.  It can be+      -- argued that the list will always contain exactly one exit+      -- code if traversed to its end, because the only case of+      -- elements that does not recurse is the one that adds a Result,+      -- and there is nowhere else where a Result is added.  However,+      -- the process doing the traversing may die before that end is+      -- reached.       elements (_, _, Nothing, Nothing, elems) =           do result <- waitForProcess pid-             return $ elems ++ [Result result]+             -- Note that there is no need to insert the result code+             -- at the end of the list.+             return $ Result result : elems       -- The available output has been processed, send input and read       -- from the ready handles       elements tl@(_, _, _, _, []) = ready uSecs tl >>= elements@@ -221,8 +174,8 @@ -- are accepted.  If no input is accepted, or the input handle is -- already closed, and none of the output descriptors are ready for -- reading the function sleeps and tries again.-ready :: Int -> ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, [Output])-      -> IO ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, [Output])+ready :: Int -> ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, Outputs)+      -> IO ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, Outputs) ready waitUSecs (input, inh, outh, errh, elems) =     do       outReady <- maybe (return Unready) hReady' outh@@ -260,7 +213,7 @@  -- | Return the next output element and the updated handle -- from a handle which is assumed ready.-nextOut :: (Maybe Handle) -> Readyness -> (B.ByteString -> Output) -> IO ([Output], Maybe Handle)+nextOut :: (Maybe Handle) -> Readyness -> (B.ByteString -> Output) -> IO (Outputs, Maybe Handle) nextOut Nothing _ _ = return ([], Nothing)	-- Handle is closed nextOut _ EndOfFile _ = return ([], Nothing)	-- Handle is closed nextOut handle Unready _ = return ([], handle)	-- Handle is not ready@@ -276,7 +229,7 @@         _n -> return ([constructor a], Just handle)  -- | Filter everything except stdout from the output list.-stdoutOnly :: [Output] -> L.ByteString+stdoutOnly :: Outputs -> L.ByteString stdoutOnly out =     L.fromChunks $ f out     where @@ -285,7 +238,7 @@       f [] = []  -- | Filter everything except stderr from the output list.-stderrOnly :: [Output] -> L.ByteString+stderrOnly :: Outputs -> L.ByteString stderrOnly out =     L.fromChunks $ f out     where@@ -295,7 +248,7 @@  -- | Filter the exit codes output list and merge the two output -- streams in the order they appear.-outputOnly :: [Output] -> L.ByteString+outputOnly :: Outputs -> L.ByteString outputOnly out =     L.fromChunks $ f out     where@@ -304,11 +257,14 @@       f (_ : etc) = f etc       f [] = [] --- | Filter everything except the exit code from the output list.-exitCodeOnly :: [Output] -> [ExitCode]-exitCodeOnly (Result code : etc) = code : exitCodeOnly etc+-- | Filter everything except the exit code from the output list.  See+-- discussion in 'lazyRun' of why we are confident that the list will+-- contain exactly one 'Result'.  An opaque type to hold the 'Output'+-- list would lend additional safety here.+exitCodeOnly :: Outputs -> ExitCode+exitCodeOnly (Result code : _) = code exitCodeOnly (_ : etc) = exitCodeOnly etc-exitCodeOnly [] = []+exitCodeOnly [] = error "exitCodeOnly - no Result found"  -- | This belongs in Data.ByteString.  See ticket 1070, -- <http://hackage.haskell.org/trac/ghc/ticket/1070>.@@ -331,27 +287,27 @@ -- > lazyCommand "yes" [] >>= return . stdoutOnly >>= lazyCommand "cat -n" >>= mapM_ (putStrLn . show)  -checkResult :: (Int -> a) -> a -> [Output] -> a+checkResult :: (Int -> a) -> a -> Outputs -> a checkResult _ _ [] = error $ "*** FAILURE: Missing exit code" checkResult _ onSuccess (Result ExitSuccess : _) = onSuccess checkResult onFailure _ (Result (ExitFailure n) : _) = onFailure n checkResult onFailure onSuccess (_ : more) = checkResult onFailure onSuccess more -discardStdout :: [Output] -> [Output]+discardStdout :: Outputs -> Outputs discardStdout (Stdout _ : more) = discardStdout more discardStdout (x : more) = x : discardStdout more discardStdout [] = [] -discardStderr :: [Output] -> [Output]+discardStderr :: Outputs -> Outputs discardStderr (Stderr _ : more) = discardStderr more discardStderr (x : more) = x : discardStderr more discardStderr [] = [] -discardOutput :: [Output] -> [Output]+discardOutput :: Outputs -> Outputs discardOutput = discardStdout . discardStderr  -- |Turn all the Stdout text into Stderr, preserving the order.-mergeToStderr :: [Output] -> [Output]+mergeToStderr :: Outputs -> Outputs mergeToStderr output =     map merge output     where@@ -359,7 +315,7 @@       merge x = x  -- |Turn all the Stderr text into Stdout, preserving the order.-mergeToStdout :: [Output] -> [Output]+mergeToStdout :: Outputs -> Outputs mergeToStdout output =     map merge output     where@@ -367,7 +323,7 @@       merge x = x  -- |Split out and concatenate Stdout-collectStdout :: [Output] -> (L.ByteString, [Output])+collectStdout :: Outputs -> (L.ByteString, Outputs) collectStdout output =     (L.fromChunks out, other)     where@@ -376,7 +332,7 @@       collect x (text, result) = (text, x : result)  -- |Split out and concatenate Stderr-collectStderr :: [Output] -> (L.ByteString, [Output])+collectStderr :: Outputs -> (L.ByteString, Outputs) collectStderr output =     (L.fromChunks err, other)     where@@ -385,17 +341,27 @@       collect x (text, result) = (text, x : result)  -- |Split out and concatenate both Stdout and Stderr, leaving only the exit code.-collectOutput :: [Output] -> (L.ByteString, L.ByteString, [ExitCode])+collectOutput :: Outputs -> (L.ByteString, L.ByteString, ExitCode) collectOutput output =     (L.fromChunks out, L.fromChunks err, code)     where-      (out, err, code) = foldr collect ([], [], []) output+      (out, err, code) = foldr collect ([], [], ExitFailure 666) output       collect (Stdout s) (out, err, result) = (s : out, err, result)       collect (Stderr s) (out, err, result) = (out, s : err, result)-      collect (Result r) (out, err, result) = (out, err, r : result)+      collect (Result result) (out, err, _) = (out, err, result)  -- |Collect all output, unpack and concatenate.-collectOutputUnpacked :: [Output] -> (String, String, [ExitCode])+collectOutputUnpacked :: Outputs -> (String, String, ExitCode) collectOutputUnpacked =     unpack . collectOutput     where unpack (out, err, result) = (C.unpack out, C.unpack err, result)++-- |Partition the exit code from the outputs.+collectResult :: Outputs -> (ExitCode, Outputs)+collectResult output =+    unResult (partition isResult output)+    where+      isResult (Result _) = True+      isResult _ = False+      unResult ([Result x], out) = (x, out)+      unResult _ = error $ "Internal error - wrong number of results"
System/Unix/ProcessExtra.hs view
@@ -15,17 +15,17 @@ cmdOutput cmd =     do (out, err, code) <- lazyCommand cmd L.empty >>= return . collectOutput        case code of-         (ExitSuccess : _) -> return (Right out)+         ExitSuccess -> return (Right out)          _ -> return . Left . ErrorCall $ "Failure: " ++ show cmd ++ " -> " ++ show code ++ "\n\nstdpout:\n\n" ++ show (L.unpack out) ++ "\n\nstderr:\n\n" ++ show (L.unpack err)  cmdOutputStrict :: String -> IO (Either ErrorCall B.ByteString) cmdOutputStrict cmd =     do (out, err, code) <- lazyCommand cmd L.empty >>= return . f . collectOutput        case code of-         (ExitSuccess : _) -> return (Right out)+         ExitSuccess -> return (Right out)          _ -> return . Left . ErrorCall $ "Failure: " ++ show cmd ++ " -> " ++ show code ++ "\n\nstdpout:\n\n" ++ show (B.unpack out) ++ "\n\nstderr:\n\n" ++ show (B.unpack err)     where-      f :: (L.ByteString, L.ByteString, [ExitCode]) -> (B.ByteString, B.ByteString, [ExitCode])+      f :: (L.ByteString, L.ByteString, ExitCode) -> (B.ByteString, B.ByteString, ExitCode)       f (o, e, c) = (toStrict o, toStrict e, c)  toLazy :: B.ByteString -> L.ByteString@@ -33,7 +33,6 @@  toStrict :: L.ByteString -> B.ByteString toStrict b = B.concat (L.toChunks b)- echoCommand :: String -> L.ByteString -> IO [Output] echoCommand command input =     ePutStrBl ("# " ++ command) >>
+ System/Unix/ProcessStrict.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures -Werror #-}+-- | Strict process running+module System.Unix.ProcessStrict+    (+      simpleProcess	-- FilePath -> [String] -> IO (String, String, ExitCode)+    , processResult	-- FilePath -> [String] -> IO (Either Int (String, String))+    , processOutput	-- FilePath -> [String] -> IO (Either Int String)+    , simpleCommand	-- String -> IO (String, String, ExitCode)+    , commandResult	-- String -> IO (Either Int (String, String))+    , commandOutput	-- String -> IO (Either Int String)+    ) where+    +import Control.Exception hiding (catch)+import Control.Parallel.Strategies (rnf)+import System.Process (waitForProcess, runInteractiveProcess, runInteractiveCommand)+import System.IO (hSetBinaryMode, hClose, hGetContents)+import System.Unix.Process++{-# DEPRECATED simpleProcess "use lazyProcess exec args Nothing Nothing L.empty >>= return . collectOutputUnpacked" #-}+{-# DEPRECATED processOutput "use lazyProcess exec args Nothing Nothing L.empty" #-}+{-# DEPRECATED simpleCommand "use lazyCommand cmd L.empty >>= return . collectOutputUnpacked" #-}+{-# DEPRECATED commandResult "use lazyCommand cmd L.empty" #-}+{-# DEPRECATED commandOutput "use lazyCommand cmd L.empty" #-}++-- |'simpleProcess' - run a process returning (stdout, stderr, exitcode)+--+-- /Warning/ - stdout and stderr will be read strictly so that we do+-- not deadlock when trying to check the exitcode. Do not try doing+-- something like, @simpleProcess [\"yes\"]@+--+-- NOTE: this may still dead-lock because we first strictly read+-- outStr and then errStr. Perhaps we should use forkIO or something?+simpleProcess :: FilePath -> [String] -> IO (String, String, ExitCode)+simpleProcess exec args =+    do (inp,out,err,pid) <- runInteractiveProcess exec args Nothing Nothing+       hSetBinaryMode out True+       hSetBinaryMode err True+       hClose inp+       outStr <- hGetContents out+       errStr <- hGetContents err+       evaluate (rnf outStr) -- read output strictly+       evaluate (rnf errStr) -- read stderr strictly+       ec <- waitForProcess pid+       return (outStr, errStr, ec)++processResult :: FilePath -> [String] -> IO (Either Int (String, String))+processResult exec args =+    simpleProcess exec args >>= return . resultOrCode+    where+      resultOrCode (_, _, ExitFailure n) = Left n+      resultOrCode (out, err, ExitSuccess) = Right (out, err)++processOutput :: FilePath -> [String] -> IO (Either Int String)+processOutput exec args =+    simpleProcess exec args >>= return . outputOrCode+    where+      outputOrCode (_, _, ExitFailure n) = Left n+      outputOrCode (out, _, ExitSuccess) = Right out++simpleCommand :: String -> IO (String, String, ExitCode)+simpleCommand cmd =+    do (inp,out,err,pid) <- runInteractiveCommand cmd+       hClose inp+       outStr <- hGetContents out+       errStr <- hGetContents err+       evaluate (rnf outStr) -- read output strictly+       evaluate (rnf errStr) -- read stderr strictly+       ec <- waitForProcess pid+       return (outStr, errStr, ec)++commandResult :: String -> IO (Either Int (String, String))+commandResult cmd =+    simpleCommand cmd >>= return . resultOrCode+    where+      resultOrCode (_, _, ExitFailure n) = Left n+      resultOrCode (out, err, ExitSuccess) = Right (out, err)++commandOutput :: String -> IO (Either Int String)+commandOutput cmd =+    simpleCommand cmd >>= return . outputOrCode+    where+      outputOrCode (_, _, ExitFailure n) = Left n+      outputOrCode (out, _, ExitSuccess) = Right out
System/Unix/Progress.hs view
@@ -1,380 +1,379 @@-{-# LANGUAGE ScopedTypeVariables #-}--- |Run shell commands with various types of progress reporting.------ Author: David Fox+{-# LANGUAGE PackageImports, RankNTypes, ScopedTypeVariables #-}+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}+-- |Control the progress reporting and output of subprocesses. module System.Unix.Progress-    (-     systemTask, 	-- [Style] -> String -> IO TimeDiff-     otherTask,		-- [Style] -> IO a -> IO a-     Style (Start, Finish, Error, Output, Echo, Elapsed, Verbosity, Indent),-     readStyle,		-- String -> Maybe Style-     Output (Indented, Dots, Done, Quiet),-     msg,		-- [Style] -> String -> IO ()-     msgLn,		-- [Style] -> String -> IO ()-     -- * Accessors-     output,		-- [Style] -> Maybe Output-     verbosity,		-- [Style] -> Int-     -- * Style Set modification-     setStyles,		-- [Style] -> [Style] -> [Style]-     setStyle,		-- Style -> [Style] -> [Style]-     addStyles,		-- [Style] -> [Style] -> [Style]-     addStyle,		-- Style -> [Style] -> [Style]-     removeStyle,	-- Style -> [Style] -> [Style]-     -- * Utilities-     stripDist,		-- FilePath -> FilePath-     showElapsed,	-- String -> IO a -> IO a-     System.Time.TimeDiff,-     System.Time.noTimeDiff,-     fixedTimeDiffToString+    ( -- * The Progress Monad+      Progress+    , ProgressFlag(..)+    , quietnessLevels+    , runProgress+    -- * Process launching+    , lazyCommandP+    , lazyProcessP+    -- * Quietness control+    , defaultQuietness+    , modQuietness+    , quieter+    -- * Output stream processing+    -- , prefixes+    -- , printOutput+    -- , dotOutput+    , timeTask+    , showElapsed+    , ePutStr+    , ePutStrLn+    , qPutStr+    , qPutStrLn+    , eMessage+    , eMessageLn+    , qMessage+    , qMessageLn+    -- * Unit tests+    , tests+    -- * A set of lazyCommand functions for an example set of verbosity levels+    , defaultLevels+    , lazyCommandV -- Print everything+    , lazyProcessV+    , lazyCommandF -- Like V, but throws exception on failure+    , lazyProcessF+    , lazyCommandE -- Print everything on failure+    , lazyProcessE+    , lazyCommandEF -- E and F combo+    , lazyProcessEF+    , lazyCommandD -- Dots+    , lazyCommandQ -- Quiet+    , lazyCommandS -- Silent+    , lazyCommandSF     ) where -import Control.Exception-import Data.List-import System.Exit-import System.IO-import System.Process-import System.Time+import Control.Exception (evaluate, try, SomeException)+import Control.Monad (when)+import Control.Monad.State (StateT, get, evalStateT)+import "mtl" Control.Monad.Trans ( MonadIO, liftIO, lift )+import Data.Array ((!), array, bounds)+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.Environment (getArgs, getEnv)+import System.Exit (ExitCode(..))+import System.IO (hPutStrLn, stderr, hPutStr)+import System.Posix.Env (setEnv)+import System.Unix.Process (lazyProcess, lazyCommand, Output(Stdout, Stderr),+                            exitCodeOnly, stdoutOnly, mergeToStdout)+import Test.HUnit -data Output-    = Indented |-      -- ^ Print all the command's output with each line-      -- indented using (by default) the string ' > '.-      Dots |-      -- ^ Print a dot for every 1024 characters the command-      -- outputs-      Done |-      -- ^ Print an ellipsis (...) when the command starts-      -- and then "done." when it finishes.-      Quiet-      -- ^ Print nothing.+type ProgressState = Set.Set ProgressFlag -instance Show Output where-    show Indented = "Indented"-    show Dots = "Dots"-    show Done = "Done"-    show Quiet  = "Quiet "+-- |A monad for controlling progress reporting of subprocesses.+type Progress m a = MonadIO m => StateT ProgressState m a -data Style-    = Start String |-      -- ^ Message printed before the execution begins-      Finish String |-      -- ^ Message printed on successful termination-      Error String |-      -- ^ Message printed on failure-      Output Output |-      -- ^ Type of output to generate during execution-      Echo Bool |-      -- ^ If true, echo the shell command before beginning-      Elapsed Bool |-      -- ^ If true print the elapsed time on termination-      Verbosity Int |-      -- ^ Set the verbosity level.  This value can be queried-      -- using the verbosity function, but is not otherwise used-      -- by the -- functions in this module.-      Indent String-      -- ^ Set the indentation string for the generated output.+-- |The flags that control what type of output will be sent to stdout+-- and stderr.  Also, the ExceptionOnFail flag controls whether an+-- exception will be thrown if the @ExitCode@ is not @ExitSuccess@.+data ProgressFlag+    = Echo+    | Dots+    | All+    | Errors+    | Result+    | EchoOnFail+    | AllOnFail+    | ErrorsOnFail+    | ResultOnFail+    | ExceptionOnFail+    deriving (Ord, Eq) -instance Show Style where-    show (Start s) = "Start " ++ show s-    show (Finish s) = "Finish " ++ show s-    show (Error s) = "Error " ++ show s-    show (Output output) = "Output " ++ show output-    show (Echo flag) = "Echo " ++ show flag-    show (Elapsed flag) = "Elapsed " ++ show flag-    show (Verbosity n) = "Verbosity " ++ show n-    show (Indent s) = "Verbosity " ++ show s+-- |Create a function that returns the flags used for a given+-- quietness level.+quietnessLevels :: [Set.Set ProgressFlag] -> Int -> Set.Set ProgressFlag+quietnessLevels flagLists i =+    a ! (min r . max l $ i)+    where a = array (0, length flagLists - 1) (zip [0..] flagLists)+          (l, r) = bounds a -styleClass (Start _) = "Start"-styleClass (Finish _) = "Finish"-styleClass (Error _) = "Error"-styleClass (Output _) = "Progress"-styleClass (Echo _) = "Echo"-styleClass (Elapsed _) = "Elapsed"-styleClass (Verbosity _) = "Verbosity"-styleClass (Indent _) = "Indent"+-- |Run the Progress monad with the given flags.  The flag set is+-- compute from the current quietness level, <= 0 the most verbose+-- and >= 3 the least.+runProgress :: MonadIO m =>+               (Int -> Set.Set ProgressFlag)+            -> Progress m a      -- ^ The progress task to be run+            -> m a+runProgress flags action =+    quietness >>= evalStateT action . flags --- This definition of equivalence is used to add or replace a style--- parameter - for example, supply a Start message if none is present.-instance Eq Style where-    a == b = styleClass a == styleClass b+lazyCommandP :: MonadIO m => (Int -> Set.Set ProgressFlag) -> String -> L.ByteString -> m [Output]+lazyCommandP flags cmd input =+    runProgress flags (lift (lazyCommand cmd input) >>= doProgress cmd) --- |Create a task that sends its output to a handle and then can be--- terminated using an IO operation that returns an exit status.--- Throws an error if the command fails.-systemTask :: [Style] -> String -> IO TimeDiff-systemTask style command =-    do-      start <- getClockTime-      putIndent style-      startMessage style-      taskStart style-      (_, _, outputHandle, processHandle) <- runInteractiveCommand ("{ " ++ command ++ "; } 1>&2")-      text <- progressOutput (maybe Indented id (output style)) outputHandle;-      result <- waitForProcess processHandle-      finish <- getClockTime-      let elapsed = diffClockTimes finish start-      case result of-        ExitSuccess -> finishMessage style elapsed-        ExitFailure _ -> errorMessage style text-      return elapsed-    where-      taskStart (Echo True : etc) = do hPutStrLn stderr ("\n -> " ++ command); taskStart etc-      taskStart (_ : etc) = taskStart etc-      taskStart [] = return ()+lazyProcessP :: MonadIO m => (Int -> Set.Set ProgressFlag) -> FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]+lazyProcessP flags exec args cwd env input =+    runProgress flags (lift (lazyProcess exec args cwd env input) >>= doProgress (intercalate " " (exec : args))) -otherTask :: [Style] -> IO a -> IO a-otherTask style task =-    do-      start <- getClockTime-      putIndent style-      startMessage style-      taskStart style-      result <- try task-      hPutStr stderr "..."-      finish <- getClockTime-      let elapsed = diffClockTimes finish start-      case result of-        Left (e :: SomeException) ->-            do errorMessage style (show e)-               error (show e)-        Right a ->-            do finishMessage style elapsed-               return a-    where-      taskStart (_ : etc) = taskStart etc-      taskStart [] = return ()+-- |Look for occurrences of -v and -q in the command line arguments+-- and the current values of environment variables VERBOSITY and+-- QUIETNESS to compute a new value for QUIETNESS.  If you want to+-- ignore the current QUIETNESS value say @setQuietness 0 >>+-- computeQuietness@.+defaultQuietness :: MonadIO m => m Int+defaultQuietness = liftIO $+    do v1 <- try (getEnv "VERBOSITY" >>= return . read) >>= either (\ (_ :: SomeException) -> return 0) return+       v2 <- getArgs >>= return . length . filter (== "-v")+       q1 <- try (getEnv "QUIETNESS" >>= return . read) >>= either (\ (_ :: SomeException) -> return 0) return+       q2 <- getArgs >>= return . length . filter (== "-q")+       return $ q1 - v1 + q2 - v2 --- FIXME: these two should break up the text into lines and prepend--- the indentation to each.-msg :: [Style] -> String -> IO ()-msg style text =-    do-      putIndent style-      hPutStr stderr text        +-- |Look at the number of -v and -q arguments to get the baseline+-- quietness / verbosity level for progress reporting.+quietness :: MonadIO m => m Int+quietness = liftIO (try (getEnv "QUIETNESS" >>= return . read)) >>=+            either (\ (_ :: SomeException) -> return 0) return -msgLn :: [Style] -> String -> IO ()-msgLn style text =-    do-      putIndent style-      hPutStrLn stderr text        +-- |Perform a task with the given quietness level.+modQuietness :: MonadIO m => (Int -> Int) -> m a -> m a+modQuietness f task =+    quietness >>= \ q0 ->+    setQuietness (f q0) >>+    task >>= \ result ->+    setQuietness q0 >>+    return result+    where+      -- Set the value of QUIETNESS in the environment.+      setQuietness :: MonadIO m => Int -> m ()+      setQuietness q = liftIO $ setEnv "QUIETNESS" (show q) True -putIndent :: [Style] -> IO ()-putIndent style = hPutStr stderr (indent style)+-- |Do an IO task with additional -v or -q arguments so that the+-- progress reporting becomes more or less verbose.+quieter :: MonadIO m => Int -> m a -> m a+quieter q task = modQuietness (+ q) task -startMessage :: [Style] -> IO ()-startMessage (Start message : etc) = do hPutStr stderr message; startMessage etc-startMessage (_ : etc) = startMessage etc-startMessage [] = return ()+-- |Inject a command's output into the Progress monad, handling command echoing,+-- output formatting, result code reporting, and exception on failure.+doProgress :: MonadIO m => String -> [Output] -> Progress m [Output]+doProgress cmd output =+    get >>= \ s ->+    doEcho s output >>= doOutput s >>= doResult s >>= doFail s+    where+      doEcho s output+          | Set.member Echo s || (Set.member EchoOnFail s && exitCodeOnly output /= ExitSuccess) =+              liftIO (ePutStrLn ("-> " ++ cmd)) >> return output+          | True = return output+      doOutput s output+          | Set.member All s || (Set.member AllOnFail s && exitCodeOnly output /= ExitSuccess) =+              liftIO (printOutput (prefixes opre epre output))+          | Set.member Dots s =+              liftIO (dotOutput 128 output)+          | Set.member Errors s || (Set.member ErrorsOnFail s && exitCodeOnly output /= ExitSuccess) =+              liftIO (printErrors (prefixes opre epre output))+          | True = return output+      doResult s output+          | Set.member Result s || (Set.member ResultOnFail s && exitCodeOnly output /= ExitSuccess) =+              liftIO (ePutStrLn ("<- " ++ show (exitCodeOnly output))) >> return output+          | True = return output+      doFail :: MonadIO m => ProgressState -> [Output] -> Progress m [Output]+      doFail s output+          | Set.member ExceptionOnFail s =+              case exitCodeOnly output of+                ExitSuccess -> return output+                result -> fail ("*** FAILURE: " ++ cmd ++ " -> " ++ show result)+          | True = return output+      opre = B.pack " 1> "+      epre = B.pack " 2> " -progressOutput :: Output -> Handle -> IO String+-- |Print one dot to stderr for every COUNT characters of output.+dotOutput :: MonadIO m => Int -> [Output] -> m [Output]+dotOutput groupSize output =+    mapM (\ (count, elem) -> ePutStr (replicate count '.') >> return elem) pairs >>= eMessageLn ""+    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 -progressOutput Dots handle =-    do-      hPutStr stderr "..."-      doText 0 ""+-- |Add prefixes to the output stream after every newline that is followed+-- by additional text, and at the beginning +prefixes :: B.ByteString -> B.ByteString -> [Output] -> [(Output, Output)]+prefixes opre epre output =+    f True output     where-      doText count text =-          do-            eof <- hIsEOF handle-            case eof of-              False ->-                  do-                    line <- hGetLine handle-                    let count' = count + length line + 1-                    let text' = text ++ line ++ "\n"-                    let (n, m) = quotRem count' 1024-                    hPutStr stderr (replicate n '.')-                    doText m text'-              True ->-                  do-                    -- hPutStr stderr "done."-                    return text+      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')+          -- There is some text before a possible newline+          else let x = (if bol then B.append pre a else a)+                   (s', bol') = doOutput False pre b in +               (B.append x s', bol') -progressOutput Done handle =-    do-      hPutStr stderr "..."-      doText ""+-- |Print all the output to the appropriate output channel.  Each pair+-- is the original input (to be returned) and the modified input (to+-- be printed.)+printOutput :: MonadIO m => [(Output, Output)] -> m [Output]+printOutput output =+    mapM (liftIO . print') output     where-      doText text =-          do-            eof <- hIsEOF handle-            case eof of-              False ->-                  do-                    line <- hGetLine handle-                    let text' = text ++ line ++ "\n"-                    doText text'-              True ->-                  do-                    -- hPutStr stderr "done."-                    return text+      print' (x, y) = print y >> return x+      print (Stdout s) = putStr (B.unpack s)+      print (Stderr s) = ePutStr (B.unpack s)+      print _ = return () -progressOutput Indented handle =-    do-      hPutStrLn stderr ""-      doText+-- |Print all the error output to the appropriate output channel+printErrors :: MonadIO m => [(Output, Output)] -> m [Output]+printErrors output =+    mapM print' output     where-      doText =-          do-            eof <- hIsEOF handle-            case eof of-              True -> return ""-              False ->-                  do-                    line <- hGetLine handle-                    -- Not collecting text here since it gets output.-                    -- This is a judgement call.-                    -- let text' = text ++ line ++ "\n"-                    hPutStrLn stdout (prefix ++ line)-                    hFlush stdout-                    doText-      prefix = " >    "+      print' (x, y) = print y >> return x+      print (Stderr s) = ePutStr (B.unpack s)+      print _ = return () -progressOutput Quiet handle =-    do-      doText ""+-- |Run a task and return the elapsed time along with its result.+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)++-- |Perform a task, print the elapsed time it took, and return the result.+showElapsed :: MonadIO m => String -> m a -> m a+showElapsed label f =+    do (result, time) <- timeTask f+       ePutStr (label ++ formatTime' time)+       return result++formatTime' :: NominalDiffTime -> String+formatTime' diff = show diff+{-+    case () of+      _ | isPrefixOf "00:00:0" hms -> drop 7 hms ++ printf ".%03d" ms ++ " s."+      _ | isPrefixOf "00:00:" hms -> drop 6 hms ++ printf ".%03d" ms ++ " s."+      _ | isPrefixOf "00:" hms -> drop 3 hms+      _ -> hms     where-      doText text =-          do-            eof <- hIsEOF handle-            case eof of-              False ->-                  do-                    line <- hGetLine handle-                    let text' = text ++ line ++ "\n"-                    doText text'-              True -> return text+      hms = formatTime defaultTimeLocale "%T" diff+      (s, ms) = second toMilliseconds (properFraction diff) :: (Integer, Integer)+      toMilliseconds :: (RealFrac a, Integral b) => a -> b+      toMilliseconds f = round (f * 1000)+-} -finishMessage :: [Style] -> TimeDiff -> IO ()-finishMessage (Elapsed True : etc) elapsed =-    do-      hPutStr stderr ("  (Elapsed: " ++ fixedTimeDiffToString elapsed ++ ")")-      finishMessage etc elapsed-finishMessage (Finish message : etc) elapsed = do hPutStr stderr message; finishMessage etc elapsed-finishMessage (_ : etc) elapsed = finishMessage etc elapsed-finishMessage [] _ = do hPutStrLn stderr ""; return ()+-- |Send a string to stderr.+ePutStr :: MonadIO m => String -> m ()+ePutStr = liftIO . hPutStr stderr -errorMessage :: [Style] -> String -> IO ()-errorMessage (Error message : _) text =-    do-      hPutStrLn stderr text-      error message-errorMessage (_ : etc) text = errorMessage etc text-errorMessage [] text = errorMessage [Error "failed"] text+-- |@ePutStr@ with a terminating newline.+ePutStrLn :: MonadIO m => String -> m ()+ePutStrLn = liftIO . hPutStrLn stderr --- |Remove styles by class-removeStyle :: Style -> [Style] -> [Style]-removeStyle (Start _) style = filter (not . isStart) style -removeStyle (Finish _) style = filter (not . isFinish) style -removeStyle (Error _) style = filter (not. isError) style -removeStyle (Output _) style = filter (not . isOutput) style -removeStyle (Echo _) style = filter (not . isEcho) style -removeStyle old style = filter (/= old) style+-- |If the current quietness level is less than one print a message.+-- Control the quietness level using @quieter@.+qPutStr :: MonadIO m => String -> m ()+qPutStr s = quietness >>= \ q -> when (q < 0) (ePutStr s) --- |Add styles, replacing old ones if present-setStyles :: [Style] -> [Style] -> [Style]-setStyles [] style = style-setStyles (x:xs) style = setStyles xs (x : (removeStyle x style))+-- |@qPutStr@ with a terminating newline.+qPutStrLn :: MonadIO m => String -> m ()+qPutStrLn s = quietness >>= \ q -> when (q < 0) (ePutStrLn s) --- |Singleton case of setStyles-setStyle :: Style -> [Style] -> [Style]-setStyle new style = setStyles [new] style+-- |Print a message and return the second argument unevaluated.+eMessage :: MonadIO m => String -> a -> m a+eMessage message output = ePutStr message >> return output --- |Singleton case of addStyles-addStyle :: Style -> [Style] -> [Style]-addStyle x@(Start _) style = case filter isStart style of [] -> x : style; _ -> style-addStyle x@(Finish _) style = case filter isFinish style of [] -> x : style; _ -> style-addStyle x@(Error _) style = case filter isError style of [] -> x : style; _ -> style-addStyle x@(Output _) style = case filter isOutput style of [] -> x : style; _ -> style-addStyle x@(Echo _) style = case filter isEcho style of [] -> x : style; _ -> style-addStyle x style = if elem x style then style else x : style+-- |@eMessage@ with a terminating newline.+eMessageLn :: MonadIO m => String -> a -> m a+eMessageLn message output = ePutStrLn message >> return output -isStart (Start _) = True-isStart _ = False-isFinish (Finish _) = True-isFinish _ = False-isError (Error _) = True-isError _ = False-isOutput (Output _) = True-isOutput _ = False-isEcho (Echo _) = True-isEcho _ = False+-- |@eMessage@ controlled by the quietness level.+qMessage :: MonadIO m => String -> a -> m a+qMessage message output = quietness >>= \ q -> when (q < 0) (ePutStr message) >> return output -output :: [Style] -> Maybe Output-output (Output x : _) = Just x-output (_  : xs) = output xs-output [] = Nothing+-- |@qMessage@ with a terminating newline.+qMessageLn :: MonadIO m => String -> a -> m a+qMessageLn message output = quietness >>= \ q -> when (q < 0) (ePutStrLn message) >> return output --- |Add styles only if not present-addStyles :: [Style] -> [Style] -> [Style]-addStyles styles style = foldr addStyle style styles+-- |Unit tests.+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 -stripDist :: FilePath -> FilePath-stripDist path = maybe path (\ n -> "..." ++ drop (n + 7) path) (isSublistOf "/dists/" path)+-- A usable example of the construction of a verbosity level+-- specification.  You can supply your own defaultLevels list and+-- build the flags* and lazyCommand* functions in a similar way. -verbosity :: [Style] -> Int-verbosity [] = 0-verbosity (Verbosity n : _) = n-verbosity (_ : etc) = verbosity etc+defaultLevels :: [Set.Set ProgressFlag]+defaultLevels =+    map Set.fromList [ [Echo, All, Result]+                     -- , [Echo, Errors, Result]+                     , [Echo, Dots, Result]+                     -- , [Echo, Result]+                     , [Echo]+                     , [] ] -indent :: [Style] -> String-indent [] = ""-indent (Indent s : _) = s-indent (_ : etc) = indent etc+flags :: Int -> Set.Set ProgressFlag+flags = quietnessLevels defaultLevels -readStyle :: String -> Maybe Style--- FIXME: implement this-readStyle text =-    case (mapSnd tail . break (== '=')) text of-      ("Start", message) -> Just $ Start message-      ("Finish", message) -> Just $ Finish message-      ("Error", message) -> Just $ Error message-      ("Output", "Indented") -> Just $ Output Indented-      ("Output", "Dots") -> Just $ Output Dots-      ("Output", "Done") -> Just $ Output Done-      ("Output", "Quiet") -> Just $ Output Quiet-      ("Echo", flag) -> Just $ Echo (readFlag flag)-      ("Elapsed", flag) -> Just $ Elapsed (readFlag flag)-      ("Verbosity", value) -> Just $ Verbosity (read value)-      ("Indent", prefix) -> Just $ Indent prefix-      _ -> Nothing-    where-      readFlag "yes" = True-      readFlag "no" = False-      readFlag "true" = True-      readFlag "false" = True-      readFlag text = error ("Unrecognized bool: " ++ text)+flagsF :: Int -> Set.Set ProgressFlag+flagsF = quietnessLevels (map (Set.union (Set.fromList [ExceptionOnFail])) defaultLevels) --- |The timeDiffToString function returns the empty string for--- the zero time diff, this is not the behavior I need.-fixedTimeDiffToString :: TimeDiff -> [Char]-fixedTimeDiffToString diff =-    case timeDiffToString diff of-      "" -> "0 sec"-      s -> s+flagsE :: Int -> Set.Set ProgressFlag+flagsE = quietnessLevels (map (Set.union (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail])) defaultLevels) -showElapsed :: String -> IO a -> IO a-showElapsed label f =-    do-      (result, time) <- elapsed f-      ePut (label ++ fixedTimeDiffToString time)-      return result+flagsEF :: Int -> Set.Set ProgressFlag+flagsEF = quietnessLevels (map (Set.union (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail, ExceptionOnFail])) defaultLevels) -elapsed :: IO a -> IO (a, TimeDiff)-elapsed f =-    do-      start <- getClockTime-      result <- f-      finish <- getClockTime-      return (result, diffClockTimes finish start)+lazyCommandV :: MonadIO m => String -> L.ByteString -> m [Output]+lazyCommandV = lazyCommandP flags -isSublistOf :: Eq a => [a] -> [a] -> Maybe Int-isSublistOf sub lst =-    maybe Nothing (\ s -> Just (length s - length sub))-              (find (isSuffixOf sub) (inits lst))+lazyProcessV :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]+lazyProcessV = lazyProcessP flags -mapSnd :: (b -> c) -> (a, b) -> (a, c)-mapSnd f (a, b) = (a, f b)+lazyCommandF :: MonadIO m => String -> L.ByteString -> m [Output]+lazyCommandF = lazyCommandP flagsF -ePut :: String -> IO ()-ePut s = hPutStrLn stderr s+lazyProcessF :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]+lazyProcessF = lazyProcessP flagsF++lazyCommandE :: MonadIO m => String -> L.ByteString -> m [Output]+lazyCommandE = lazyCommandP flagsE++lazyProcessE :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]+lazyProcessE = lazyProcessP flagsE++lazyCommandEF :: MonadIO m => String -> L.ByteString -> m [Output]+lazyCommandEF = lazyCommandP flagsEF++lazyProcessEF :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]+lazyProcessEF = lazyProcessP flagsEF++lazyCommandD :: MonadIO m => String -> L.ByteString -> m [Output]+lazyCommandD cmd input = quieter 1 $ lazyCommandP flagsE cmd input++lazyCommandQ :: MonadIO m => String -> L.ByteString -> m [Output]+lazyCommandQ cmd input = quieter 3 $ lazyCommandP flagsE cmd input++lazyCommandS :: MonadIO m => String -> L.ByteString -> m [Output]+lazyCommandS cmd input = quieter 4 $ lazyCommandP flagsE cmd input++lazyCommandSF :: MonadIO m => String -> L.ByteString -> m [Output]+lazyCommandSF cmd input = quieter 4 $ lazyCommandP flagsEF cmd input
Unixutils.cabal view
@@ -1,11 +1,11 @@ Name:           Unixutils-Version:        1.29+Version:        1.34 License:        BSD3 License-File:	COPYING Author:         Jeremy Shaw Homepage:       http://src.seereason.com/haskell-unixutils Category:	System-Build-Depends:  base >= 4 && <5, mtl, unix, regex-tdfa, process < 3, bytestring, directory, old-time, parallel, filepath+Build-Depends:  array, base >= 4 && <5, containers, mtl, HUnit, unix, regex-tdfa, process < 3, bytestring, directory, time, old-time, parallel, filepath Synopsis:       A crude interface between Haskell and Unix-like operating systems Maintainer:     jeremy@n-heptane.com Description:@@ -14,9 +14,9 @@ Build-type:	Simple ghc-options:	-O2 Exposed-modules:-        System.Unix.Crypt, System.Unix.Directory, System.Unix.FilePath, System.Unix.List,-	System.Unix.Misc, System.Unix.Mount, System.Unix.Process, System.Unix.ProcessExtra,-	System.Unix.Progress, System.Unix.Shadow, System.Unix.SpecialDevice, System.Unix.Files+        System.Unix.Crypt, System.Unix.Directory, System.Unix.FilePath, System.Unix.Misc, System.Unix.Mount,+        System.Unix.Process, System.Unix.ProcessExtra, System.Unix.ProcessStrict,+	System.Unix.Progress, System.Unix.OldProgress, System.Unix.Shadow, System.Unix.SpecialDevice, System.Unix.Files Extra-libraries: crypt  -- For more complex build options see: