Unixutils 1.48.1 → 1.50

raw patch · 12 files changed

+105/−1388 lines, 12 filesdep −HUnitdep −arraydep −containersdep ~basedep ~processsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies removed: HUnit, array, containers, mtl, old-time, parallel, time

Dependency ranges changed: base, process

API changes (from Hackage documentation)

Files

• Setup.hs +1/−8
• System/Unix/Chroot.hs +22/−36
• System/Unix/Misc.hs +0/−1
• System/Unix/Mount.hs +9/−12
• System/Unix/OldProgress.hs +0/−380
• System/Unix/Process.hs +71/−349
• System/Unix/ProcessExtra.hs +0/−48
• System/Unix/ProcessStrict.hs +0/−84
• System/Unix/Progress.hs +0/−316
• System/Unix/QIO.hs +0/−133
• Tests.hs +0/−10
• Unixutils.cabal +2/−11

@@ -4,11 +4,4 @@ import System.Cmd import System.Exit -main = defaultMainWithHooks simpleUserHooks {-         postBuild = runTestScript-       , runTests = runTestScript-       }--runTestScript _args _flag _pd _lbi =-    system "runhaskell Tests.hs" >>=-    \ code -> if code == ExitSuccess then return () else error "Test Failure"+main = defaultMainWithHooks simpleUserHooks

@@ -3,8 +3,8 @@ module System.Unix.Chroot     ( fchroot     , useEnv-    , forceList-    , forceList'+    -- , forceList  -- moved to progress+    -- , forceList'     ) where  import Control.Exception (finally, evaluate)@@ -14,17 +14,21 @@ import Foreign.C.Error import Foreign.C.String import System.Directory (createDirectoryIfMissing)+import System.Exit (ExitCode(ExitSuccess)) import System.FilePath (dropTrailingPathSeparator, dropFileName) import System.IO (hPutStr, stderr) import System.Posix.Env (getEnv) import System.Posix.IO import System.Posix.Directory-import System.Unix.Process (Output(..))-import System.Unix.Progress (lazyCommandF)-import System.Unix.QIO (quieter, qPutStrLn)+import System.Process (readProcessWithExitCode, showCommandForUser)  foreign import ccall unsafe "chroot" c_chroot :: CString -> IO Int +{-# DEPRECATED forceList "If you need forceList enable it in progress-System.Unix.Process." #-}+forceList = undefined+{-# DEPRECATED forceList' "If you need forceList' enable it in progress-System.Unix.Process." #-}+forceList' = undefined+ -- |chroot changes the root directory to filepath -- NOTE: it does not change the working directory, just the root directory -- NOTE: will throw IOError if chroot fails@@ -60,7 +64,6 @@        -- at default quietness.  If you want to suppress it while seeing        -- the output from your action, you need to say something like        -- quieter (+ 1) (useEnv (quieter (\x->x-1) action))-       qPutStrLn $ "Entering environment at " ++ rootPath        sockPath <- getEnv "SSH_AUTH_SOCK"        home <- getEnv "HOME"        copySSH home@@ -72,43 +75,26 @@       copySSH Nothing = return ()       copySSH (Just home) =           -- Do NOT preserve ownership, files must be owned by root.-          system' ("rsync -rlptgDHxS --delete " ++ home ++ "/.ssh/ " ++ rootPath ++ "/root/.ssh")+          run "/usr/bin/rsync" ["-rlptgDHxS", "--delete", home ++ "/.ssh/", rootPath ++ "/root/.ssh"]       withSock Nothing action = action       withSock (Just sockPath) action =           withMountBind dir (rootPath ++ dir) action           where dir = dropTrailingPathSeparator (dropFileName sockPath)       withMountBind toMount mountPoint action =-          doMount-          where-            doMount =-                do createDirectoryIfMissing True mountPoint-                   system' $ "mount --bind " ++ escapePathForMount toMount ++ " " ++ escapePathForMount mountPoint-                   result <- action-                   system' $ "umount " ++ escapePathForMount mountPoint-                   return result+          do createDirectoryIfMissing True mountPoint+             run "/bin/mount" ["--bind", escapePathForMount toMount, escapePathForMount mountPoint]+             result <- action+             run "/bin/umount" [escapePathForMount mountPoint]+             return result       escapePathForMount = id	-- FIXME - Path arguments should be escaped-      system' s = lazyCommandF s L.empty >> return ()-          -- system s >>= testcode-          -- where testcode (ExitFailure n) = error (show s ++ " -> " ++ show n)-          --       testcode ExitSuccess = return () --- |A function to force the process output by examining it but not--- printing anything.-forceList :: [a] -> IO [a]-forceList output = evaluate (length output) >> return output---- |First send the process output to the and then force it.-forceList' :: [Output] -> IO [Output]-forceList' output = printOutput output >>= forceList---- |Print all the output to the appropriate output channel-printOutput :: [Output] -> IO [Output]-printOutput output =-    mapM print output-    where-      print x@(Stdout s) = putStr (B.unpack s) >> return x-      print x@(Stderr s) = hPutStr stderr (B.unpack s) >> return x-      print x = return x+      run cmd args =+          do (code, out, err) <- readProcessWithExitCode cmd args ""+             case code of+               ExitSuccess -> return ()+               _ -> error ("Exception in System.Unix.Chroot.useEnv: " ++ showCommandForUser cmd args ++ " -> " ++ show code +++                           "\n\nstdout:\n " ++ prefix "> " out ++ "\n\nstderr:\n" ++ prefix "> " err)+      prefix pre s = unlines (map (pre ++) (lines s))  {- printDots :: Int -> [Output] -> IO [Output]

@@ -17,7 +17,6 @@ import System.IO import System.Posix.Files import System.Process-import System.Unix.Process  {-# DEPRECATED md5sum "Use Data.ByteString.Lazy.Char8.readFile path >>= return . show . Data.Digest.Pure.MD5.md5" #-} md5sum :: FilePath -> IO String

@@ -12,15 +12,12 @@ import Data.List import System.Directory import System.Exit-import System.IO (readFile)+import System.IO (readFile, hPutStrLn, stderr) import System.Posix.Files-import System.Unix.Process-import System.Unix.QIO (quieter, qPutStrLn)+import System.Process (readProcessWithExitCode)  -- Local Modules -import System.Unix.Process- -- In ghc610 readFile "/proc/mounts" hangs.  Use this instead. -- rf path = lazyCommand ("cat '" ++ path ++ "'") empty >>= return . (\ (o, _, _) -> o) . collectOutputUnpacked @@ -48,23 +45,23 @@ -- See also: 'umountSucceeded' umountBelow :: Bool     -- ^ Lazy (umount -l flag) if true             -> FilePath -- ^ canonicalised, absolute path-            -> IO [(FilePath, (String, String, ExitCode))] -- ^ paths that we attempted to umount, and the responding output from the umount command-umountBelow lazy belowPath = quieter (\x->x-9) $+            -> IO [(FilePath, (ExitCode, String, String))] -- ^ paths that we attempted to umount, and the responding output from the umount command+umountBelow lazy belowPath =     do procMount <- readFile "/proc/mounts"        let mountPoints = map (unescape . (!! 1) . words) (lines procMount)            maybeMounts = filter (isPrefixOf belowPath) (concat (map tails mountPoints))            args path = ["-f"] ++ if lazy then ["-l"] else [] ++ [path]        needsUmount <- filterM isMountPoint maybeMounts-       results <- mapM (\ path -> qPutStrLn ("umountBelow: umount " ++ intercalate " " (args path)) >> umount (args path) >>= return . ((,) path)) needsUmount+       results <- mapM (\ path -> hPutStrLn stderr ("umountBelow: umount " ++ intercalate " " (args path)) >> umount (args path) >>= return . ((,) path)) needsUmount        let results' = map fixNotMounted results-       mapM_ (\ (result, result') -> qPutStrLn (show result ++ (if result /= result' then " -> " ++ show result' else ""))) (zip results results')+       mapM_ (\ (result, result') -> hPutStrLn stderr (show result ++ (if result /= result' then " -> " ++ show result' else ""))) (zip results results')        -- Did /proc/mounts change?  If so we should try again because        -- nested mounts might have been revealed.        procMount' <- readFile "/proc/mounts"        results'' <- if procMount /= procMount' then umountBelow lazy belowPath else return []        return $ results' ++ results''     where-      fixNotMounted (path, ("", err, ExitFailure 1)) | err == ("umount: " ++ path ++ ": not mounted\n") = (path, ("", "" , ExitSuccess))+      fixNotMounted (path, (ExitFailure 1, "", err)) | err == ("umount: " ++ path ++ ": not mounted\n") = (path, (ExitSuccess, "", ""))       fixNotMounted x = x  -- |umountSucceeded - predicated suitable for filtering results of 'umountBelow'@@ -95,8 +92,8 @@ -- NOTE: this function uses exec, so you do /not/ need to shell-escape -- 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 = lazyProcess "umount" args Nothing Nothing empty >>= return . collectOutputUnpacked+umount :: [String] -> IO (ExitCode, String, String)+umount args = readProcessWithExitCode "umount" args ""  isMountPoint :: FilePath -> IO Bool -- This implements the functionality of mountpoint(1), deciding

@@ -1,380 +0,0 @@-{-# 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

@@ -1,367 +1,89 @@-{-# LANGUAGE PackageImports, ScopedTypeVariables #-}-{-# OPTIONS -Wwarn -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures #-}--- |functions for killing processes, running processes, etc+-- | Variations of the readProcess and readProcessWithExitCode functions+-- from System.Process which read and write ByteStrings and have an+-- extra argument to modify the CreateProcess value before the process+-- is started. module System.Unix.Process-    (-    -- * Lazy process running-      Process-    , Output(Stdout, Stderr, Result)-    , lazyRun		-- L.ByteString -> Process -> m [Output]-    , lazyCommand	-- String -> m [Output]-    , lazyProcess	-- FilePath -> [String] -> Maybe FilePath-			--     -> Maybe [(String, String)] -> m [Output]-    , stdoutOnly	-- [Output] -> L.ByteString-    , stderrOnly	-- [Output] -> L.ByteString-    , outputOnly	-- [Output] -> L.ByteString-    , checkResult-    , discardStdout-    , discardStderr-    , discardOutput-    , mergeToStderr-    , mergeToStdout-    , collectStdout-    , collectStderr-    , collectOutput-    , collectOutputUnpacked-    , collectResult-    , ExitCode(ExitSuccess, ExitFailure)-    , exitCodeOnly	-- [Output] -> ExitCode-    , hPutNonBlocking	-- Handle -> B.ByteString -> IO Int-    -- * Process killing-    , killByCwd		-- FilePath -> IO [(String, Maybe String)]+    ( readProcess+    , readProcessWithExitCode     ) where -import Control.Concurrent (threadDelay)-import Control.Monad (liftM, filterM)-import "mtl" 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, 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.Unsafe (unsafeInterleaveIO)-import System.Directory (getDirectoryContents)-import System.Exit (ExitCode(ExitFailure, ExitSuccess))-import System.Posix.Files (readSymbolicLink)-import System.Posix.Signals (signalProcess, sigTERM)--import Foreign.Ptr (plusPtr)			-- for hPutNonBlocking only-import Foreign.ForeignPtr (withForeignPtr)	-- for hPutNonBlocking only--{--NOTE:--+ We should make sure this works if we are inside a chroot.--+ path needs to be absolute or we might kill processes living in-  similar named, but different directories.--+ path is an canoncialised, absolute path, such as what realpath returns---}--- | Kill the processes whose working directory is in or under the--- given directory.-killByCwd :: FilePath -> IO [(String, Maybe String)]-killByCwd path =-    do pids <- liftM (filter (all isDigit)) (getDirectoryContents "/proc")-       cwdPids <- filterM (isCwd path) pids-       exePaths <- mapM exePath cwdPids-       mapM_ kill cwdPids-       return (zip cwdPids exePaths)-    where-      isCwd :: FilePath -> String -> IO Bool-      isCwd cwd pid =-          catch (liftM (isPrefixOf cwd) (readSymbolicLink ("/proc/" ++ pid ++"/cwd"))) (const (return False))-      exePath :: String -> IO (Maybe String)-      exePath pid = catch (readSymbolicLink ("/proc/" ++ pid ++"/exe") >>= return . Just) (const (return Nothing))-      kill :: String -> IO ()-      kill pidStr = signalProcess sigTERM (read pidStr)--{- 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-   handle is ready for reading the process sleeps and tries again,-   with the sleep intervals increasing from 8 microseconds to a-   maximum of 0.1 seconds. -}---- | This is the type returned by 'System.Process.runInteractiveProcess' et. al.-type Process = (Handle, Handle, Handle, ProcessHandle)---- | 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 :: 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 :: MonadIO m =>-               FilePath-            -> [String]-            -> Maybe FilePath-            -> Maybe [(String, String)]-            -> L.ByteString-            -> m Outputs-lazyProcess exec args cwd env 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 :: MonadIO m => L.ByteString -> Process -> m Outputs-lazyRun input (inh, outh, errh, pid) =-    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, 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-             -- 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-      -- Add some output to the result value-      elements (input, inh, outh, errh, elems) =-          do-            etc <- unsafeInterleaveIO (elements (input, inh, outh, errh, []))-            return $ elems ++ etc---- A quick fix for the issue where hWaitForInput has actually started--- raising the isEOFError exception in ghc 6.10.-data Readyness = Ready | Unready | EndOfFile--hReady' :: Handle -> IO Readyness-hReady' h = (hReady h >>= (\ flag -> return (if flag then Ready else Unready))) `catch` (\ (e :: IOError) ->-                                                                                             case E.ioe_type e of-                                                                                               E.EOF -> return EndOfFile-                                                                                               _ -> error (show e))---- | Wait until at least one handle is ready and then write input or--- read output.  Note that there is no way to check whether the input--- handle is ready except to try to write to it and see if any bytes--- 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, 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-      errReady <- maybe (return Unready) hReady' errh-      case (input, inh, outReady, errReady) of-        -- Input exhausted, close the input handle.-        ([], Just handle, Unready, Unready) ->-            do hClose handle-               ready  waitUSecs ([], Nothing, outh, errh, elems)-        -- Input handle closed and there are no ready output handles,-        -- wait a bit-        ([], Nothing, Unready, Unready) ->-            do threadDelay waitUSecs-               --ePut0 ("Slept " ++ show uSecs ++ " microseconds\n")-               ready (min maxUSecs (2 * waitUSecs)) (input, inh, outh, errh, elems)-        -- Input is available and there are no ready output handles-        (input : etc, Just handle, Unready, Unready)-            -- Discard a zero byte input-            | input == B.empty -> ready waitUSecs (etc, inh, outh, errh, elems)-            -- Send some input to the process-            | True ->-                do count' <- hPutNonBlocking handle input >>= return . fromInteger . toInteger-                   case count' of-                     -- Input buffer is full too, sleep.-                     0 -> do threadDelay uSecs-                             ready (min maxUSecs (2 * waitUSecs)) (input : etc, inh, outh, errh, elems)-                     -- We wrote some input, discard it and continue-                     _n -> do let input' = B.drop count' input : etc-                              return (input', Just handle, outh, errh, elems)-        -- One or both output handles are ready, try to read from them-        _ ->-            do (out1, errh') <- nextOut errh errReady Stderr-               (out2, outh') <- nextOut outh outReady Stdout-               return (input, inh, outh', errh', elems ++ out1 ++ out2)---- | Return the next output element and the updated handle--- from a handle which is assumed ready.-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-nextOut (Just handle) Ready constructor =	-- Perform a read -    do-      a <- B.hGetNonBlocking handle bufSize-      case B.length a of-        -- A zero length read, unlike a zero length write, always-        -- means EOF.-        0 -> do hClose handle-                return ([], Nothing)-        -- Got some input-        _n -> return ([constructor a], Just handle)---- | Filter everything except stdout from the output list.-stdoutOnly :: Outputs -> L.ByteString-stdoutOnly out =-    L.fromChunks $ f out-    where -      f (Stdout s : etc) = s : f etc-      f (_ : etc) = f etc-      f [] = []---- | Filter everything except stderr from the output list.-stderrOnly :: Outputs -> L.ByteString-stderrOnly out =-    L.fromChunks $ f out-    where-      f (Stderr s : etc) = s : f etc-      f (_ : etc) = f etc-      f [] = []---- | Filter the exit codes output list and merge the two output--- streams in the order they appear.-outputOnly :: Outputs -> L.ByteString-outputOnly out =-    L.fromChunks $ f out-    where-      f (Stderr s : etc) = s : f etc-      f (Stdout s : etc) = s : f etc-      f (_ : etc) = f etc-      f [] = []+import Control.Concurrent (newEmptyMVar, forkIO, putMVar, takeMVar)+import qualified Control.Exception as C+import Control.Monad (when)+import qualified Data.ByteString.Lazy.Char8 as B+import GHC.IO.Exception (IOErrorType(OtherError))+import System.Exit (ExitCode(..))+import System.IO (hFlush, hClose)+import System.IO.Error (mkIOError)+import System.Process (CreateProcess(std_in, std_out, std_err, cwd), createProcess, waitForProcess, proc, StdStream(CreatePipe, Inherit), showCommandForUser) --- | 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 [] = error "exitCodeOnly - no Result found"+readProcessWithExitCode+    :: FilePath                         -- ^ command to run+    -> [String]                         -- ^ any arguments+    -> (CreateProcess -> CreateProcess) -- ^ Modify process with this - use id for System.Process.readProcessWithExitCode behavior+    -> B.ByteString                     -- ^ standard input+    -> IO (ExitCode, B.ByteString, B.ByteString) -- ^ exitcode, stdout, stderr+readProcessWithExitCode cmd args modify input = do+    let modify' p = modify (p {std_in  = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }) --- | This belongs in Data.ByteString.  See ticket 1070,--- <http://hackage.haskell.org/trac/ghc/ticket/1070>.-hPutNonBlocking :: Handle -> B.ByteString -> IO Int64-hPutNonBlocking h b =-    case toForeignPtr b of-      (_, _, 0) -> return 0-      (ps, s, l) -> withForeignPtr ps $ \ p-> hPutBufNonBlocking h (p `plusPtr` s) l >>= return . fromInteger . toInteger+    (Just inh, Just outh, Just errh, pid) <-+        createProcess (modify' (proc cmd args)) --- Examples:------ > runInteractiveCommand "ls -l /usr/bin" >>= lazyRun [] >>= mapM_ (putStrLn . show)--- Stdout: \"total 137411\n-rwxr-xr-x 1 root\" ... (4066 additional bytes)--- Stdout: \"oot       7642 2006-12-07 17:0\" ... (65506 additional bytes)--- Stdout: \"oot      57220 2006-10-24 01:1\" ... (31961 additional bytes)--- ExitSuccess------ > lazyCommand "cat -n" (map stringToByteString ["abc\n", "def\n"]) >>= mapM_ (putStrLn . show)------ > lazyCommand "yes" [] >>= return . stdoutOnly >>= lazyCommand "cat -n" >>= mapM_ (putStrLn . show)+    outMVar <- newEmptyMVar +    -- fork off a thread to start consuming stdout+    out  <- B.hGetContents outh+    _ <- forkIO $ C.evaluate (B.length out) >> putMVar outMVar () -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+    -- fork off a thread to start consuming stderr+    err  <- B.hGetContents errh+    _ <- forkIO $ C.evaluate (B.length err) >> putMVar outMVar () -discardStdout :: Outputs -> Outputs-discardStdout (Stdout _ : more) = discardStdout more-discardStdout (x : more) = x : discardStdout more-discardStdout [] = []+    -- now write and flush any input+    when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh+    hClose inh -- done with stdin -discardStderr :: Outputs -> Outputs-discardStderr (Stderr _ : more) = discardStderr more-discardStderr (x : more) = x : discardStderr more-discardStderr [] = []+    -- wait on the output+    takeMVar outMVar+    takeMVar outMVar+    hClose outh+    hClose errh -discardOutput :: Outputs -> Outputs-discardOutput = discardStdout . discardStderr+    -- wait on the process+    ex <- waitForProcess pid --- |Turn all the Stdout text into Stderr, preserving the order.-mergeToStderr :: Outputs -> Outputs-mergeToStderr output =-    map merge output-    where-      merge (Stdout s) = Stderr s-      merge x = x+    return (ex, out, err) --- |Turn all the Stderr text into Stdout, preserving the order.-mergeToStdout :: Outputs -> Outputs-mergeToStdout output =-    map merge output-    where-      merge (Stderr s) = Stdout s-      merge x = x+readProcess+    :: FilePath		-- ^ command to run+    -> [String]		-- ^ any arguments+    -> (CreateProcess -> CreateProcess) -- ^ modifies CreateProcess before passing to createProcess+    -> B.ByteString	-- ^ standard input+    -> IO B.ByteString	-- ^ stdout+readProcess cmd args modify input = do+    let modify' p = modify (p {std_in  = CreatePipe, std_out = CreatePipe, std_err = Inherit })+    (Just inh, Just outh, _, pid) <-+        createProcess (modify' (proc cmd args)) --- |Split out and concatenate Stdout-collectStdout :: Outputs -> (L.ByteString, Outputs)-collectStdout output =-    (L.fromChunks out, other)-    where-      (out, other) = foldr collect ([], []) output-      collect (Stdout s) (text, result) = (s : text, result)-      collect x (text, result) = (text, x : result)+    -- fork off a thread to start consuming the output+    output  <- B.hGetContents outh+    outMVar <- newEmptyMVar+    _ <- forkIO $ C.evaluate (B.length output) >> putMVar outMVar () --- |Split out and concatenate Stderr-collectStderr :: Outputs -> (L.ByteString, Outputs)-collectStderr output =-    (L.fromChunks err, other)-    where-      (err, other) = foldr collect ([], []) output-      collect (Stderr s) (text, result) = (s : text, result)-      collect x (text, result) = (text, x : result)+    -- now write and flush any input+    when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh+    hClose inh -- done with stdin --- |Split out and concatenate both Stdout and Stderr, leaving only the exit code.-collectOutput :: Outputs -> (L.ByteString, L.ByteString, ExitCode)-collectOutput output =-    (L.fromChunks out, L.fromChunks err, code)-    where-      (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 result) (out, err, _) = (out, err, result)+    -- wait on the output+    takeMVar outMVar+    hClose outh --- |Collect all output, unpack and concatenate.-collectOutputUnpacked :: Outputs -> (String, String, ExitCode)-collectOutputUnpacked =-    unpack . collectOutput-    where unpack (out, err, result) = (C.unpack out, C.unpack err, result)+    -- wait on the process+    ex <- waitForProcess pid --- |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"+    case ex of+      ExitSuccess   -> return output+      ExitFailure r ->+          ioError (mkIOError OtherError ("readProcess: " ++ showCommandForUser cmd args +++                                                             " (exit " ++ show r ++ ")")+                   Nothing Nothing)

@@ -1,48 +0,0 @@--- |A place to collect and hopefully retire all the random ways of--- running shell commands that have accumulated over the years.-module System.Unix.ProcessExtra where--import Control.Exception (ErrorCall(ErrorCall), try)-import Control.Monad.Trans (liftIO)-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString as B-import Data.List (intercalate)-import System.Exit-import qualified System.IO as IO-import System.Unix.Process (Output(..), lazyCommand, collectOutput, lazyProcess)--cmdOutput :: String -> IO (Either ErrorCall L.ByteString)-cmdOutput cmd =-    do (out, err, code) <- lazyCommand cmd L.empty >>= return . collectOutput-       case code of-         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)-         _ -> 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 (o, e, c) = (toStrict o, toStrict e, c)--toLazy :: B.ByteString -> L.ByteString-toLazy b = L.fromChunks [b]--toStrict :: L.ByteString -> B.ByteString-toStrict b = B.concat (L.toChunks b)-echoCommand :: String -> L.ByteString -> IO [Output]-echoCommand command input =-    ePutStrBl ("# " ++ command) >>-    liftIO (lazyCommand command input)---- |Echo the process arguments and then run the process-echoProcess :: FilePath -> [String] -> L.ByteString -> IO [Output]-echoProcess exec args input =-    ePutStrBl (intercalate " " ("#" : exec : args)) >>-    liftIO (lazyProcess exec args Nothing Nothing input)--ePutStrBl :: String -> IO ()-ePutStrBl s = IO.hPutStrLn IO.stderr s

@@ -1,84 +0,0 @@-{-# 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 (rdeepseq)-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 (rdeepseq outStr) -- read output strictly-       _ <- evaluate (rdeepseq 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 (rdeepseq outStr) -- read output strictly-       _ <- evaluate (rdeepseq 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

@@ -1,316 +0,0 @@--- | Support for changing the output of a lazyCommand in several ways:--- ---     * Output a dot for every 128 characters of the original output--- ---     * Increase the quietness level before running the command--- ---     * Output only if (and when) the command fails--- ---     * Throw an exception if the command fails--- ---     * No output-{-# LANGUAGE FlexibleContexts, PackageImports, RankNTypes, ScopedTypeVariables #-}-{-# OPTIONS -Wall -Werror -fno-warn-name-shadowing #-}-module System.Unix.Progress-    ( -- * The Progress Monad-      ProgressFlag(..)-    -- * Process launching-    , lazyCommandP-    , lazyProcessP-    , timeTask-    , showElapsed-    -- * Unit tests-    , tests-    -- * A set of lazyCommand functions for an example set of verbosity levels-    , lazyCommandV -- Print everything - command, stdout, stderr, result-    , lazyProcessV-    , lazyCommandF -- Like V, but throws exception on failure-    , lazyProcessF-    , lazyCommandE -- Print everything on failure-    , lazyProcessE-    , lazyCommandEF -- E and F combo-    , lazyProcessEF-    ) where--import Control.Exception (evaluate)-import "mtl" Control.Monad.Trans ( MonadIO, liftIO )-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as L-import Data.List (intercalate)-import qualified Data.Set as Set-import Data.Time (NominalDiffTime, getCurrentTime, diffUTCTime)-import System.Exit (ExitCode(..))-import System.Unix.Process (lazyProcess, lazyCommand, Output(Stdout, Stderr),-                            exitCodeOnly, stdoutOnly, mergeToStdout)-import System.Unix.QIO (quietness, ePutStr, ePutStrLn, qPutStr)-import Test.HUnit--type ProgressState = Set.Set ProgressFlag---- |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      -- ^ If Echo is present this has no effect-    | AllOnFail       -- ^ If All is present this has no effect-    | ErrorsOnFail-    | ResultOnFail-    | ExceptionOnFail-    deriving (Ord, Eq)--lazyCommandV :: MonadIO m => String -> L.ByteString -> m [Output]-lazyCommandV cmd input =-    progressFlags Set.empty >>= lazyCommandP cmd input--lazyProcessV :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]-lazyProcessV cmd args wd env input =-    progressFlags Set.empty >>= lazyProcessP cmd args wd env input--lazyCommandF :: MonadIO m => String -> L.ByteString -> m [Output]-lazyCommandF cmd input =-    progressFlags (Set.fromList [ExceptionOnFail]) >>= lazyCommandP cmd input--lazyProcessF :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]-lazyProcessF cmd args wd env input =-    progressFlags (Set.fromList [ExceptionOnFail]) >>= lazyProcessP cmd args wd env input--lazyCommandE :: MonadIO m => String -> L.ByteString -> m [Output]-lazyCommandE cmd input =-    progressFlags (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail]) >>= lazyCommandP cmd input--lazyProcessE :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]-lazyProcessE cmd args wd env input =-    progressFlags (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail]) >>= lazyProcessP cmd args wd env input--lazyCommandEF :: MonadIO m => String -> L.ByteString -> m [Output]-lazyCommandEF cmd input =-    progressFlags (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail, ExceptionOnFail]) >>= lazyCommandP cmd input--lazyProcessEF :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]-lazyProcessEF cmd args wd env input =-    progressFlags (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail, ExceptionOnFail]) >>= lazyProcessP cmd args wd env input---- 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.---- |Normally (when quietness is 0) we see the command echoed and dots--- for progress indication.  If quietness is -1 we also see the--- command's output as it runs.  If quietness is 1 we don't see the--- dots or the result code, and if it is 2 we don't see anything.-progressFlags :: MonadIO m => Set.Set ProgressFlag -> m (Set.Set ProgressFlag)-progressFlags extra =-    quietness >>= return . merge extra . Set.fromList . flags-    where-      flags n | n < 0 = [Echo, All, Result]-      flags 0 = [Echo, Dots, Result]-      flags 1 = [Echo]-      flags _ = []-      merge extra flags =-          (if Set.member All flags then Set.delete AllOnFail else id) .-          (if Set.member Echo flags then Set.delete EchoOnFail else id) .-          (if Set.member Result flags then Set.delete ResultOnFail else id) $ Set.union extra flags--{--defaultLevels :: Int -> Set.Set ProgressFlag-defaultLevels n =-    if n < 0 then default-    where-      levels = map Set.fromList-               [ [Echo, All, Result]  -- when quietness == 0-               , [Echo, Dots, Result] -- when quietness == 1-               , [Echo]               -- when quietness == 2-               , [] ]                 -- when quietness == 2---- |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--}--{---- |A monad for controlling progress reporting of subprocesses.-type Progress m a = MonadIO m => StateT ProgressState m a---- |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 =>-            -> Progress m a      -- ^ The progress task to be run-            -> m a-runProgress flags action =-    quietness >>= evalStateT action . flags--}---- |The @P@ versions are the most general cases, here you can specify--- a function that turns the quietness level into any set of progress--- flags you like.-lazyCommandP :: MonadIO m => String -> L.ByteString -> Set.Set ProgressFlag -> m [Output]-lazyCommandP cmd input flags =-    liftIO (lazyCommand cmd input) >>= doProgress flags cmd--lazyProcessP :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> Set.Set ProgressFlag -> m [Output]-lazyProcessP exec args cwd env input flags =-    liftIO (lazyProcess exec args cwd env input) >>= doProgress flags (intercalate " " (exec : args))---- |Inject a command's output into the Progress monad, handling--- command echoing, output formatting, result code reporting, and--- exception on failure.  The flag set we get from the monad already--- reflects the program's current quietness level, so calling quieter--- and using the qPutStr functions here is not necessary.-doProgress :: MonadIO m => ProgressState -> String -> [Output] -> m [Output]-doProgress flags cmd output =-    doEcho flags output >>= doOutput flags >>= doFailOutput flags >>= doResult flags >>= doFail flags-    where-      doEcho flags output-          | Set.member Echo flags =-              ePutStrLn ("-> " ++ cmd) >> return output-          | Set.member EchoOnFail flags && exitCodeOnly output /= ExitSuccess =-              ePutStrLn ("-> " ++ cmd) >> return output-          | True = return output-      doOutput flags output-          | Set.member All flags =-              printOutput (prefixes opre epre output)-          | Set.member Dots flags =-              dotOutput 128 output-          | Set.member Errors flags =-              printErrors (prefixes opre epre output)-          | True = return output-      doFailOutput flags output-          | Set.member All flags =-              return output-          | Set.member AllOnFail flags && exitCodeOnly output /= ExitSuccess =-              ePutStrLn ("*** FAILURE: " ++ cmd ++ " -> " ++ show (exitCodeOnly output)) >>-              printOutput (prefixes opre epre output)-          | Set.member Errors flags =-              return output-          | Set.member ErrorsOnFail flags && exitCodeOnly output /= ExitSuccess =-              ePutStrLn ("*** FAILURE: " ++ cmd ++ " -> " ++ show (exitCodeOnly output)) >>-              printErrors (prefixes opre epre output)-          | True =-              return output-      doResult flags output-          | Set.member Result flags =-              ePutStrLn ("<- " ++ show (exitCodeOnly output)) >> return output-          | Set.member ResultOnFail flags && exitCodeOnly output /= ExitSuccess =-              ePutStrLn ("<- " ++ show (exitCodeOnly output)) >> return output-          | True = return output-      doFail flags output-          | Set.member ExceptionOnFail flags =-              case exitCodeOnly output of-                ExitSuccess -> return output-                result -> fail ("*** FAILURE: " ++ cmd ++ " -> " ++ show result)-          | True = return output-      opre = B.pack " 1> "-      epre = B.pack " 2> "---- |Print one dot to stderr for every COUNT characters of output.-dotOutput :: MonadIO m => Int -> [Output] -> m [Output]-dotOutput groupSize output =-    ePutStr "." >> mapM (\ (count, elem) -> ePutStr (replicate count '.') >> return elem) pairs >>= \ x -> ePutStr ".\n" >> return x-    where-      pairs = zip (dots 0 (map length output)) output-      dots _ [] = []-      dots rem (count : more) =-          let (count', rem') = divMod (count + rem) groupSize in-          count' : dots rem' more-      length (Stdout s) = B.length s-      length (Stderr s) = B.length s-      length _ = 0---- |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-      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')---- |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-      print' (x, y) = print y >> return x-      print (Stdout s) = liftIO $ putStr (B.unpack s)-      print (Stderr s) = ePutStr (B.unpack s)-      print _ = return ()---- |Print all the error output to the appropriate output channel-printErrors :: MonadIO m => [(Output, Output)] -> m [Output]-printErrors output =-    mapM print' output-    where-      print' (x, y) = print y >> return x-      print (Stderr s) = ePutStr (B.unpack s)-      print _ = return ()---- |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-       qPutStr (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-      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)--}---- |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

@@ -1,133 +0,0 @@--- | Functions to manage the verbosity of a console program by storing--- the quietness level in the system environment, specifically in the--- $QUIETNESS variable.  This lets you avoid creating a StateT monad--- to hold the quietness level.  Note that you don't attach a--- verbosity level to individual message commands, you control the--- quietness level for entire regions of your program and messages--- only appear when quietness is less than one.-{-# LANGUAGE PackageImports, ScopedTypeVariables #-}-{-# OPTIONS -Wall #-}-module System.Unix.QIO-    ( ePutStr-    , ePutStrLn-    , eMessage-    , eMessageLn-    -- * Get/set quietness levels-    , initialQuietness-    , quietness-    -- * Do task with modified quietness level-    -- , modQuietness-    , quieter-    , quieter'-    -- , qZero-    -- * Do a task if quietness < 1-    , qDo-    -- * Output to stderr when quietness < 1-    , qPutStr-    , qPutStrLn-    , qMessage-    , qMessageLn-    -- * Some idioms-    , q12-    , q02-    , v1-    , v2-    , v3-    , showQ-    ) where--import Control.Exception (try, SomeException)-import "mtl" Control.Monad.Trans ( MonadIO, liftIO )-import System.Environment (getArgs, getEnv)-import System.IO (hPutStrLn, stderr, hPutStr)-import System.Posix.Env (setEnv)--ePutStr :: MonadIO m => String -> m ()-ePutStr s = liftIO $ hPutStr stderr s--ePutStrLn :: MonadIO m => String -> m ()-ePutStrLn s = liftIO $ hPutStrLn stderr s--eMessage :: MonadIO m => String -> b -> m b-eMessage s x = liftIO (hPutStr stderr s) >> return x--eMessageLn :: MonadIO m => String -> b -> m b-eMessageLn s x = liftIO (hPutStrLn stderr s) >> return x---- | Compute an initial value for $QUIETNESS by examining the--- $QUIETNESS and $VERBOSITY variables and counting the -v and -q--- options on the command line.-initialQuietness :: MonadIO m => m Int-initialQuietness = 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'---- |Get the current quietness level from the QUIETNESS environment variable.-quietness :: MonadIO m => m Int-quietness = liftIO (try (getEnv "QUIETNESS" >>= return . read)) >>=-            either (\ (_ :: SomeException) -> return 0) return---- |Perform a task with the quietness level tansformed by f.  Use--- @defaultQuietness >>= modQuietness . const@ to initialize the ----- verbosity for a program.-quieter :: MonadIO m => (Int -> Int) -> m a -> m a-quieter 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---- |Dummy version of quieter, sometimes you want to strip out all the--- quieter calls and see how things look, then restore them gradually.--- Use this to help remember where they were.-quieter' :: MonadIO m => (Int -> Int) -> m a -> m a-quieter' _ x = x---- |Peform a task only if quietness < 1.-qDo :: MonadIO m => m () -> m ()-qDo task = quietness >>= \ q -> if (q < 1) then task else return ()---- |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 = qDo (ePutStr s)---- |@qPutStr@ with a terminating newline.-qPutStrLn :: MonadIO m => String -> m ()-qPutStrLn s = qDo (ePutStrLn s)---- |@eMessage@ controlled by the quietness level.-qMessage :: MonadIO m => String -> a -> m a-qMessage message output = qDo (ePutStr message) >> return output---- |@qMessage@ with a terminating newline.-qMessageLn :: MonadIO m => String -> a -> m a-qMessageLn message output = qDo (ePutStrLn message) >> return output---- |Print a message at quietness +1 and then do a task at quietness +3.--- This is a pattern which gives the following behaviors:--- Normally there is no output.  With -v only the messages are printed.--- With -v -v the messages and the shell commands are printed with dots--- to show progress.  With -v -v -v everything is printed.-q12 :: MonadIO m => String -> m a -> m a-q12 s a = quieter (+ 1) $ qPutStrLn s >> quieter (+ 2) a--q02 :: MonadIO m => String -> m a -> m a-q02 s a = qPutStrLn s >> quieter (+ 2) a--v1, v2, v3 :: (MonadIO m) => m a -> m a-v1 a = quieter (\x->x-1) a-v2 a = quieter (\x->x-2) a-v3 a = quieter (\x->x-3) a---- |For debugging-showQ :: MonadIO m => String -> m a -> m a-showQ s a = quietness >>= \ n -> ePutStrLn (s ++ ": quietness=" ++ show n) >> a

@@ -1,10 +0,0 @@-import System.Exit-import System.Unix.Progress (tests)-import Test.HUnit--main =-    do (c,st) <- runTestText putTextToShowS (TestList $ System.Unix.Progress.tests)-       putStrLn (st "")-       case (failures c) + (errors c) of-         0 -> return ()-         n -> exitFailure

@@ -1,5 +1,5 @@ Name:           Unixutils-Version:        1.48.1+Version:        1.50 License:        BSD3 License-File:	COPYING Author:         Jeremy Shaw, David Fox@@ -14,7 +14,7 @@ Cabal-Version: >= 1.2  Library -    Build-Depends:  array, base >= 4 && <5, containers, mtl, HUnit, unix, regex-tdfa, process < 3, bytestring, directory, time, old-time, parallel >= 2, filepath, pureMD5, zlib+    Build-Depends:  base >= 4 && <5, bytestring, directory, filepath, process, pureMD5, regex-tdfa, unix, zlib     ghc-options:	-O2     Exposed-modules:         System.Unix.Chroot,@@ -24,16 +24,7 @@         System.Unix.Misc,         System.Unix.Mount,         System.Unix.Process,-        System.Unix.ProcessExtra,-        System.Unix.ProcessStrict,-        System.Unix.Progress,-        System.Unix.OldProgress,-        System.Unix.QIO,         System.Unix.SpecialDevice,         System.Unix.Files     if !os(darwin)         Extra-libraries: crypt--Executable unixtutils-test-    Main-is: Tests.hs-    Buildable: False