Unixutils 1.36 → 1.44

raw patch · 9 files changed

+456/−227 lines, 9 filesdep +pureMD5dep +zlibdep ~basesetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: pureMD5, zlib

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Setup.hs +10/−1
• System/Unix/Chroot.hs +123/−0
• System/Unix/Files.hs +4/−2
• System/Unix/Misc.hs +11/−4
• System/Unix/Mount.hs +17/−10
• System/Unix/Process.hs +1/−1
• System/Unix/Progress.hs +141/−204
• System/Unix/QIO.hs +132/−0
• Unixutils.cabal +17/−5

@@ -1,5 +1,14 @@ #!/usr/bin/runhaskell  import Distribution.Simple+import System.Cmd+import System.Exit -main = defaultMainWithHooks simpleUserHooks+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"

@@ -0,0 +1,123 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- | This module, except for useEnv, is copied from the build-env package.+module System.Unix.Chroot+    ( fchroot+    , useEnv+    , forceList+    , forceList'+    ) where++import Control.Exception (finally, evaluate)++import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import Foreign.C.Error+import Foreign.C.String+import System.Directory (createDirectoryIfMissing)+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)++foreign import ccall unsafe "chroot" c_chroot :: CString -> IO Int++-- |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+chroot :: FilePath -> IO ()+chroot fp = withCString fp $ \cfp -> throwErrnoIfMinus1_ "chroot" (c_chroot cfp)++-- |fchroot runs an IO action inside a chroot+-- fchroot performs a chroot, runs the action, and then restores the+-- original root and working directory. This probably affects the+-- chroot and working directory of all the threads in the process,+-- so...+-- NOTE: will throw IOError if internal chroot fails+fchroot :: FilePath -> IO a -> IO a+fchroot path action =+    do origWd <- getWorkingDirectory+       rootFd <- openFd "/" ReadOnly Nothing defaultFileFlags+       chroot path+       changeWorkingDirectory "/"+       action `finally` (breakFree origWd rootFd)+    where+      breakFree origWd rootFd =+          do changeWorkingDirectoryFd rootFd+             closeFd rootFd+             chroot "."+             changeWorkingDirectory origWd++-- |The ssh inside of the chroot needs to be able to talk to the+-- running ssh-agent.  Therefore we mount --bind the ssh agent socket+-- dir inside the chroot (and umount it when we exit the chroot.+useEnv :: FilePath -> (a -> IO a) -> IO a -> IO a+useEnv rootPath force action =+    do -- In order to minimize confusion, this QIO message is output+       -- 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+       -- We need to force the output before we exit the changeroot.+       -- Otherwise we lose our ability to communicate with the ssh+       -- agent and we get errors.+       withSock sockPath . fchroot rootPath $ (action >>= force)+    where+      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")+      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+      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++{-+printDots :: Int -> [Output] -> IO [Output]+printDots cpd output =+    foldM f 0 output >> return output+    where+      print rem (Stdout s) =+          let (dots, rem') = quotRem (rem + length s) in+          hPutStr stderr (replicate dots '.')+          return rem'+      print rem (Stderr s) = print rem (Stdout s)+-}

@@ -1,7 +1,9 @@ module System.Unix.Files where -import System.Posix.Files-import System.IO.Error+import Control.Exception (catch)+import Prelude hiding (catch)+import System.Posix.Files (createSymbolicLink, removeLink)+import System.IO.Error (isAlreadyExistsError)  -- |calls 'createSymbolicLink' but will remove the target and retry if -- 'createSymbolicLink' raises EEXIST.

@@ -7,7 +7,9 @@     where  import Control.Exception-import Data.ByteString.Lazy.Char8 (empty)+import qualified Codec.Compression.GZip+import Data.ByteString.Lazy.Char8 (empty, readFile, writeFile)+import Data.Digest.Pure.MD5 (md5) import Data.Maybe import System.Cmd import System.Directory@@ -17,8 +19,10 @@ 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-md5sum path =+md5sum path = Data.ByteString.Lazy.Char8.readFile path >>= return . show . md5+{-     do       (text, _, exitCode) <- lazyProcess "md5sum" [path] Nothing Nothing empty >>= return . collectOutputUnpacked       let output = listToMaybe (words text)@@ -28,12 +32,15 @@               Nothing -> error ("Error in output of 'md5sum " ++ path ++ "'")               Just checksum -> return checksum         _ -> error ("Error running 'md5sum " ++ path ++ "'")+-} -{-# WARNING gzip "System.Unix.Misc.gzip does not properly escape its path arguments" #-}+{-# DEPRECATED gzip "Use Data.ByteString.Lazy.Char8.readFile path >>= Data.ByteString.Lazy.Char8.writeFile (path ++ \".gz\")" #-} gzip :: FilePath -> IO ()-gzip path =+gzip path = Data.ByteString.Lazy.Char8.readFile path >>= Data.ByteString.Lazy.Char8.writeFile (path ++ ".gz")+{-     do       result <- system ("gzip < " ++ path ++ " > " ++ path ++ ".gz")       case result of         ExitSuccess -> return ()         e -> error (show e)+-}

@@ -12,15 +12,17 @@ import Data.List import System.Directory import System.Exit+import System.IO (readFile) import System.Posix.Files import System.Unix.Process+import System.Unix.QIO (quieter, qPutStrLn)  -- 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+-- rf path = lazyCommand ("cat '" ++ path ++ "'") empty >>= return . (\ (o, _, _) -> o) . collectOutputUnpacked  -- |'umountBelow' - unmounts all mount points below /belowPath/ -- \/proc\/mounts must be present and readable.  Because of the way@@ -44,21 +46,26 @@ -- in \/proc\/mounts, which means we need to run "umount \/proc\/bus\/usb". -- -- See also: 'umountSucceeded'-umountBelow :: FilePath -- ^ canonicalised, absolute path+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 belowPath =-    do procMount <- rf "/proc/mounts"+umountBelow lazy belowPath = quieter (\x->x-9) $+    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-       result <- mapM (\path -> umount [path,"-f","-l"] >>= return . ((,) path)) needsUmount+       results <- mapM (\ path -> qPutStrLn ("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')        -- Did /proc/mounts change?  If so we should try again because        -- nested mounts might have been revealed.-       procMount' <- rf "/proc/mounts"-       result' <- if procMount /= procMount' then-                      umountBelow belowPath else-                      return []-       return $ result ++ result'+       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 x = x  -- |umountSucceeded - predicated suitable for filtering results of 'umountBelow' umountSucceeded :: (FilePath, (String, String, ExitCode)) -> Bool

@@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures -Werror #-}+{-# OPTIONS -Wwarn -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures #-} -- |functions for killing processes, running processes, etc module System.Unix.Process     (

@@ -1,38 +1,28 @@+-- | 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 -fno-warn-name-shadowing #-}--- |Control the progress reporting and output of subprocesses.+{-# OPTIONS -Wall -Werror -fno-warn-name-shadowing #-} module System.Unix.Progress     ( -- * The Progress Monad-      Progress-    , ProgressFlag(..)-    , quietnessLevels-    , runProgress+      ProgressFlag(..)     -- * 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+    , lazyCommandV -- Print everything - command, stdout, stderr, result     , lazyProcessV     , lazyCommandF -- Like V, but throws exception on failure     , lazyProcessF@@ -40,36 +30,24 @@     , lazyProcessE     , lazyCommandEF -- E and F combo     , lazyProcessEF-    , lazyCommandD -- Dots-    , lazyCommandQ -- Quiet-    , lazyCommandS -- Silent-    , lazyCommandSF     ) where -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 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.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 System.Unix.QIO (quietness, ePutStr, ePutStrLn, qPutStr) import Test.HUnit  type ProgressState = Set.Set ProgressFlag --- |A monad for controlling progress reporting of subprocesses.-type Progress m a = MonadIO m => StateT ProgressState m a- -- |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@.@@ -79,13 +57,77 @@     | All     | Errors     | Result-    | EchoOnFail-    | AllOnFail+    | 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@@ -93,88 +135,77 @@     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 =>-               (Int -> Set.Set ProgressFlag)             -> Progress m a      -- ^ The progress task to be run             -> m a runProgress flags action =     quietness >>= evalStateT action . flags--lazyCommandP :: MonadIO m => (Int -> Set.Set ProgressFlag) -> String -> L.ByteString -> m [Output]-lazyCommandP flags cmd input =-    runProgress flags (lift (lazyCommand cmd input) >>= doProgress cmd)--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)))---- |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---- |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+-} --- |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+-- |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 --- |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+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.-doProgress :: MonadIO m => String -> [Output] -> Progress m [Output]-doProgress cmd output =-    get >>= \ s ->-    doEcho s output >>= doOutput s >>= doResult s >>= doFail s+-- |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 s output-          | Set.member Echo s || (Set.member EchoOnFail s && exitCodeOnly output /= ExitSuccess) =-              liftIO (ePutStrLn ("-> " ++ cmd)) >> return output+      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 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))+      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-      doResult s output-          | Set.member Result s || (Set.member ResultOnFail s && exitCodeOnly output /= ExitSuccess) =-              liftIO (ePutStrLn ("<- " ++ show (exitCodeOnly output))) >> 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 :: MonadIO m => ProgressState -> [Output] -> Progress m [Output]-      doFail s output-          | Set.member ExceptionOnFail s =+      doFail flags output+          | Set.member ExceptionOnFail flags =               case exitCodeOnly output of                 ExitSuccess -> return output                 result -> fail ("*** FAILURE: " ++ cmd ++ " -> " ++ show result)@@ -185,7 +216,7 @@ -- |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 ""+    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 _ [] = []@@ -229,7 +260,7 @@     mapM (liftIO . print') output     where       print' (x, y) = print y >> return x-      print (Stdout s) = putStr (B.unpack s)+      print (Stdout s) = liftIO $ putStr (B.unpack s)       print (Stderr s) = ePutStr (B.unpack s)       print _ = return () @@ -254,7 +285,7 @@ showElapsed :: MonadIO m => String -> m a -> m a showElapsed label f =     do (result, time) <- timeTask f-       ePutStr (label ++ formatTime' time)+       qPutStr (label ++ formatTime' time)        return result  formatTime' :: NominalDiffTime -> String@@ -272,39 +303,6 @@       toMilliseconds f = round (f * 1000) -} --- |Send a string to stderr.-ePutStr :: MonadIO m => String -> m ()-ePutStr = liftIO . hPutStr stderr---- |@ePutStr@ with a terminating newline.-ePutStrLn :: MonadIO m => String -> m ()-ePutStrLn = liftIO . hPutStrLn stderr---- |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)---- |@qPutStr@ with a terminating newline.-qPutStrLn :: MonadIO m => String -> m ()-qPutStrLn s = quietness >>= \ q -> when (q < 0) (ePutStrLn s)---- |Print a message and return the second argument unevaluated.-eMessage :: MonadIO m => String -> a -> m a-eMessage message output = ePutStr message >> return output---- |@eMessage@ with a terminating newline.-eMessageLn :: MonadIO m => String -> a -> m a-eMessageLn message output = ePutStrLn message >> return output---- |@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---- |@qMessage@ with a terminating newline.-qMessageLn :: MonadIO m => String -> a -> m a-qMessageLn message output = quietness >>= \ q -> when (q < 0) (ePutStrLn message) >> return output- -- |Unit tests. tests :: [Test] tests =@@ -316,64 +314,3 @@       p = B.pack       collect :: [(Output, Output)] -> String       collect = L.unpack . stdoutOnly . mergeToStdout . snd . unzip---- 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.--defaultLevels :: [Set.Set ProgressFlag]-defaultLevels =-    map Set.fromList [ [Echo, All, Result]-                     -- , [Echo, Errors, Result]-                     , [Echo, Dots, Result]-                     -- , [Echo, Result]-                     , [Echo]-                     , [] ]--flags :: Int -> Set.Set ProgressFlag-flags = quietnessLevels defaultLevels--flagsF :: Int -> Set.Set ProgressFlag-flagsF = quietnessLevels (map (Set.union (Set.fromList [ExceptionOnFail])) defaultLevels)--flagsE :: Int -> Set.Set ProgressFlag-flagsE = quietnessLevels (map (Set.union (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail])) defaultLevels)--flagsEF :: Int -> Set.Set ProgressFlag-flagsEF = quietnessLevels (map (Set.union (Set.fromList [EchoOnFail, AllOnFail, ResultOnFail, ExceptionOnFail])) defaultLevels)--lazyCommandV :: MonadIO m => String -> L.ByteString -> m [Output]-lazyCommandV = lazyCommandP flags--lazyProcessV :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> L.ByteString -> m [Output]-lazyProcessV = lazyProcessP flags--lazyCommandF :: MonadIO m => String -> L.ByteString -> m [Output]-lazyCommandF = lazyCommandP flagsF--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

@@ -0,0 +1,132 @@+-- | 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 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,11 +1,11 @@ Name:           Unixutils-Version:        1.36+Version:        1.44 License:        BSD3 License-File:	COPYING Author:         Jeremy Shaw, David Fox Homepage:       http://src.seereason.com/haskell-unixutils Category:	System-Build-Depends:  array, base >= 4 && <5, containers, mtl, HUnit, unix, regex-tdfa, process < 3, bytestring, directory, time, old-time, parallel >= 2, filepath+Build-Depends:  array, base >= 4 && <5, containers, mtl, HUnit, unix, regex-tdfa, process < 3, bytestring, directory, time, old-time, parallel >= 2, filepath, pureMD5, zlib Synopsis:       A crude interface between Haskell and Unix-like operating systems Maintainer:     jeremy@n-heptane.com Description:@@ -14,9 +14,21 @@ Build-type:	Simple ghc-options:	-O2 Exposed-modules:-        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+        System.Unix.Chroot,+        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.QIO,+        System.Unix.Shadow,+        System.Unix.SpecialDevice,+        System.Unix.Files Extra-libraries: crypt  -- For more complex build options see: