diff --git a/COPYING b/COPYING --- a/COPYING +++ b/COPYING @@ -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. + diff --git a/System/Unix/List.hs b/System/Unix/List.hs deleted file mode 100644 --- a/System/Unix/List.hs +++ /dev/null @@ -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 diff --git a/System/Unix/Misc.hs b/System/Unix/Misc.hs --- a/System/Unix/Misc.hs +++ b/System/Unix/Misc.hs @@ -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 diff --git a/System/Unix/Mount.hs b/System/Unix/Mount.hs --- a/System/Unix/Mount.hs +++ b/System/Unix/Mount.hs @@ -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 diff --git a/System/Unix/OldProgress.hs b/System/Unix/OldProgress.hs new file mode 100644 --- /dev/null +++ b/System/Unix/OldProgress.hs @@ -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 diff --git a/System/Unix/Process.hs b/System/Unix/Process.hs --- a/System/Unix/Process.hs +++ b/System/Unix/Process.hs @@ -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, -- . @@ -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" diff --git a/System/Unix/ProcessExtra.hs b/System/Unix/ProcessExtra.hs --- a/System/Unix/ProcessExtra.hs +++ b/System/Unix/ProcessExtra.hs @@ -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) >> diff --git a/System/Unix/ProcessStrict.hs b/System/Unix/ProcessStrict.hs new file mode 100644 --- /dev/null +++ b/System/Unix/ProcessStrict.hs @@ -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 diff --git a/System/Unix/Progress.hs b/System/Unix/Progress.hs --- a/System/Unix/Progress.hs +++ b/System/Unix/Progress.hs @@ -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 diff --git a/Unixutils.cabal b/Unixutils.cabal --- a/Unixutils.cabal +++ b/Unixutils.cabal @@ -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: