packages feed

Unixutils 1.36 → 1.54.3

raw patch · 17 files changed

Files

Setup.hs view
@@ -1,5 +1,7 @@ #!/usr/bin/runhaskell  import Distribution.Simple+import System.Process+import System.Exit  main = defaultMainWithHooks simpleUserHooks
+ System/Unix/Chroot.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}+-- | This module, except for useEnv, is copied from the build-env package.+module System.Unix.Chroot+    ( fchroot+    , useEnv+    -- , forceList  -- moved to progress+    -- , forceList'+    ) where++import Control.Exception (evaluate)+import Control.Monad.Catch (MonadMask, finally)+import Control.Monad.Trans (MonadIO, liftIO)+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.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.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+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 :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a+fchroot path action =+    do origWd <- liftIO $ getWorkingDirectory+#if MIN_VERSION_unix(2,8,0)+       rootFd <- liftIO $ openFd "/" ReadOnly defaultFileFlags+#else+       rootFd <- liftIO $ openFd "/" ReadOnly Nothing defaultFileFlags+#endif+       liftIO $ chroot path+       liftIO $ changeWorkingDirectory "/"+       action `finally` (liftIO $ 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 :: (MonadIO m, MonadMask m) => FilePath -> (a -> m a) -> m a -> m 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))+       sockPath <- liftIO $ getEnv "SSH_AUTH_SOCK"+       home <- liftIO $ getEnv "HOME"+       liftIO $ 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.+          createDirectoryIfMissing True (rootPath ++ "/root") >>+          run "/usr/bin/rsync" ["-rlptgDHxS", "--delete", home ++ "/.ssh/", rootPath ++ "/root/.ssh"]+      withSock :: (MonadIO m, MonadMask m) => Maybe FilePath -> m a -> m a+      withSock Nothing action = action+      withSock (Just sockPath) action =+          withMountBind dir (rootPath ++ dir) action+          where dir = dropTrailingPathSeparator (dropFileName sockPath)+      withMountBind :: (MonadIO m, MonadMask m) => FilePath -> FilePath -> m a -> m a+      withMountBind toMount mountPoint action =+          (do liftIO $ createDirectoryIfMissing True mountPoint+              liftIO $ run "/bin/mount" ["--bind", escapePathForMount toMount, escapePathForMount mountPoint]+              action) `finally` (liftIO $ run "/bin/umount" [escapePathForMount mountPoint])+      escapePathForMount = id   -- FIXME - Path arguments should be escaped++      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]+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)+-}
System/Unix/Crypt.hs view
@@ -4,7 +4,7 @@ -- Module      :  System.Unix.Crypt -- Copyright   :  (c) 2010 -- License     :  BSD3--- +-- -- Maintainer  :  jeremy@seereason.com -- Stability   :  provisional -- Portability :  non-portable (requires POSIX)@@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -module System.Unix.Crypt +module System.Unix.Crypt     ( crypt     )     where@@ -23,7 +23,7 @@ foreign import ccall unsafe "unistd.h crypt"   c_crypt :: CString -> CString -> IO CString --- | calls crypt(3) +-- | calls crypt(3) crypt :: String -- ^ key       -> String -- ^ salt       -> IO String -- ^ encrypted password
System/Unix/Directory.hs view
@@ -12,7 +12,7 @@  import Control.Exception import Data.List (isSuffixOf)-import System.Cmd+import System.Process import System.Directory import System.Exit import System.FilePath@@ -28,7 +28,7 @@     do       status <- getSymbolicLinkStatus path       case isDirectory status of-        True -> +        True ->             do               subs <- getDirectoryContents path >>=                       return . map (path </>) . filter (not . flip elem [".", ".."]) >>=@@ -84,7 +84,7 @@ --	when you are inside a chroot. removeRecursiveSafely :: FilePath -> IO () removeRecursiveSafely path =-    traverse path removeFile removeDirectory umount+    System.Unix.Directory.traverse path removeFile removeDirectory umount     where       umount path =           do@@ -102,7 +102,7 @@ -- unmounts anything it finds mounted.  Note that this can be much -- slower than Mount.umountBelow, use that instead. unmountRecursiveSafely path =-    traverse path noOp noOp umount+    System.Unix.Directory.traverse path noOp noOp umount     where       noOp _ = return ()       umount path =@@ -134,7 +134,7 @@  -- |temporarily change the working directory to |dir| while running |action| withWorkingDirectory :: FilePath -> IO a -> IO a-withWorkingDirectory dir action = +withWorkingDirectory dir action =     bracket getCurrentDirectory setCurrentDirectory (\ _ -> setCurrentDirectory dir >> action)  -- |create a temporary directory, run the action, remove the temporary directory@@ -153,7 +153,7 @@   c_mkdtemp :: CString -> IO CString  mkdtemp :: FilePath -> IO FilePath-mkdtemp template = +mkdtemp template =       withCString (if "XXXXXX" `isSuffixOf` template then template else (template ++ "XXXXXX")) $ \ ptr -> do         cname <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr)         name <- peekCString cname
System/Unix/FilePath.hsc view
@@ -3,7 +3,7 @@ -- | The function splitFileName is taken from missingh, at the moment -- missingh will not build under sid. -module System.Unix.FilePath +module System.Unix.FilePath     (dirName,      baseName,      realpath,
System/Unix/Files.hs view
@@ -1,14 +1,16 @@ 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. forceSymbolicLink :: FilePath -> FilePath -> IO () forceSymbolicLink target linkName =     createSymbolicLink target linkName `catch`-      (\e -> if isAlreadyExistsError e +      (\e -> if isAlreadyExistsError e              then do removeLink linkName                      createSymbolicLink target linkName              else ioError e)
+ System/Unix/KillByCwd.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |A place to collect and hopefully retire all the random ways of+-- running shell commands that have accumulated over the years.+module System.Unix.KillByCwd+    ( killByCwd+    ) where++import Control.Exception (catch)+import Control.Monad (liftM, filterM)+import Data.Char (isDigit)+import Data.List (isPrefixOf)+import Prelude hiding (catch)+import System.Directory (getDirectoryContents)+import System.Posix.Files (readSymbolicLink)+import System.Posix.Signals (signalProcess, sigTERM)++{-+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+  similarly 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 =+          (liftM (isPrefixOf cwd) (readSymbolicLink ("/proc/" ++ pid ++"/cwd"))) `catch` (\ (_ :: IOError) -> return False)+      exePath :: String -> IO (Maybe String)+      exePath pid = (readSymbolicLink ("/proc/" ++ pid ++"/exe") >>= return . Just) `catch` (\ (_ :: IOError) -> return Nothing)+      kill :: String -> IO ()+      kill pidStr = signalProcess sigTERM (read pidStr)
System/Unix/Misc.hs view
@@ -7,18 +7,22 @@     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.Process import System.Directory import System.Exit import System.IO import System.Posix.Files import System.Process-import System.Unix.Process +-- | Deprecated: Use @Data.ByteString.Lazy.Char8.readFile path >>= return . show . Data.Digest.Pure.MD5.md5@+{-# 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,16 @@               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: Use @Data.ByteString.Lazy.Char8.readFile path >>= Data.ByteString.Lazy.Char8.writeFile (path ++ \".gz\")@+{-# 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)+-}
System/Unix/Mount.hs view
@@ -1,10 +1,16 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-} -- |functions for mounting, umounting, parsing \/proc\/mounts, etc-module System.Unix.Mount -    (umountBelow,	-- FilePath -> IO [(FilePath, (String, String, ExitCode))]-     umount,		-- [String] -> IO (String, String, ExitCode)-     isMountPoint)	-- FilePath -> IO Bool-    where+module System.Unix.Mount+    ( umountBelow       -- FilePath -> IO [(FilePath, (String, String, ExitCode))]+    , umount            -- [String] -> IO (String, String, ExitCode)+    , isMountPoint      -- FilePath -> IO Bool +    , withMount+    , WithProcAndSys(runWithProcAndSys)+    , withProcAndSys+    , withTmp+    ) where+ -- Standard GHC modules  import Control.Monad@@ -12,15 +18,29 @@ import Data.List import System.Directory import System.Exit+import System.IO (readFile, hPutStrLn, stderr) import System.Posix.Files-import System.Unix.Process+import System.Process (readProcessWithExitCode) --- Local Modules+import Control.Applicative (Applicative)+import Control.Exception (catch)+import Control.Monad.Catch (bracket, MonadCatch, MonadMask)+import Control.Monad.Trans (MonadTrans, lift, liftIO, MonadIO)+-- import Control.Monad.Trans.Except ({- ExceptT instances -})+import Data.ByteString.Lazy as L (ByteString, empty)+import GHC.IO.Exception (IOErrorType(OtherError))+import System.Directory (createDirectoryIfMissing)+import System.Exit (ExitCode(ExitFailure, ExitSuccess))+import System.FilePath ((</>))+import System.IO (hPutStrLn, stderr)+import System.IO.Error+import System.Process (CreateProcess, proc)+import System.Process.ListLike (readCreateProcess, showCreateProcessForUser) -import System.Unix.Process+-- Local Modules  -- 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 +64,26 @@ -- in \/proc\/mounts, which means we need to run "umount \/proc\/bus\/usb". -- -- See also: 'umountSucceeded'-umountBelow :: 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 :: Bool     -- ^ Lazy (umount -l flag) if true+            -> FilePath -- ^ canonicalised, absolute path+            -> 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-       result <- mapM (\path -> umount [path,"-f","-l"] >>= 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') -> 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' <- 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, (ExitFailure 1, "", err)) | 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@@ -74,7 +99,7 @@ unescape ('\\':'1':'3':'4':rest) = '\\' : (unescape rest) unescape (c:rest) = c : (unescape rest) --- |'escape' - \/proc\/mount stytle string escaper+-- |'escape' - \/proc\/mount style string escaper escape :: String -> String escape [] = [] escape (' ':rest)  = ('\\':'0':'4':'0':escape rest)@@ -88,8 +113,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@@ -111,3 +136,57 @@             -- It is hard to know what is going on if . or .. don't exist.             -- Assume we are seeing some sort of mount point.             return True++readProcess :: CreateProcess -> L.ByteString -> IO L.ByteString+readProcess p input = do+  (code, out, _err) <- readCreateProcess p input :: IO (ExitCode, L.ByteString, L.ByteString)+  case code of+    ExitFailure n -> ioError (mkIOError OtherError (showCreateProcessForUser p ++ " -> " ++ show n) Nothing Nothing)+    ExitSuccess -> return out++-- | Do an IO task with a file system remounted using mount --bind.+-- This was written to set up a build environment.+withMount :: (MonadIO m, MonadMask m) => FilePath -> FilePath -> m a -> m a+withMount directory mountpoint task =+    bracket pre (\ _ -> post) (\ _ -> task)+    where+      mount = proc "mount" ["--bind", directory, mountpoint]+      umount = proc "umount" [mountpoint]+      umountLazy = proc "umount" ["-l", mountpoint]++      pre = liftIO $ do -- hPutStrLn stderr $ "mounting /proc at " ++ show mountpoint+                        createDirectoryIfMissing True mountpoint+                        readProcess mount L.empty++      post = liftIO $ do -- hPutStrLn stderr $ "unmounting /proc at " ++ show mountpoint+                         readProcess umount L.empty+                           `catch` (\ (e :: IOError) ->+                                        do hPutStrLn stderr ("Exception unmounting " ++ mountpoint ++ ", trying -l: " ++ show e)+                                           readProcess umountLazy L.empty)++-- | Monad transformer to ensure that /proc and /sys are mounted+-- during a computation.+newtype WithProcAndSys m a = WithProcAndSys { runWithProcAndSys :: m a } deriving (Functor, Monad, Applicative)++instance MonadTrans WithProcAndSys where+    lift = WithProcAndSys++instance MonadIO m => MonadIO (WithProcAndSys m) where+    liftIO task = WithProcAndSys (liftIO task)++-- | Mount /proc and /sys in the specified build root and execute a+-- task.  Typically, the task would start with a chroot into the build+-- root.  If the build root given is "/" it is assumed that the file+-- systems are already mounted, no mounting or unmounting is done.+withProcAndSys :: (MonadIO m, MonadMask m) => FilePath -> WithProcAndSys m a -> m a+withProcAndSys "/" task = runWithProcAndSys task+withProcAndSys root task = do+  exists <- liftIO $ doesDirectoryExist root+  case exists of+    True -> withMount "/proc" (root </> "proc") $ withMount "/sys" (root </> "sys") $ runWithProcAndSys task+    False -> liftIO $ ioError $ mkIOError doesNotExistErrorType "chroot directory does not exist" Nothing (Just root)++-- | Do an IO task with /tmp remounted.  This could be used+-- to share /tmp with a build root.+withTmp :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a+withTmp root task = withMount "/tmp" (root </> "tmp") task
− System/Unix/OldProgress.hs 
@@ -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
− System/Unix/Process.hs 
@@ -1,367 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures -Werror #-}--- |functions for killing processes, running processes, etc-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)]-    ) where--import Control.Concurrent (threadDelay)-import Control.Monad (liftM, filterM)-import Control.Monad.Trans (MonadIO(liftIO))---import Control.Exception hiding (catch)---import Control.Parallel.Strategies (rnf)-import Data.Char (isDigit)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Char8 as C-import Data.ByteString.Internal(toForeignPtr)	-- for hPutNonBlocking only-import Data.List (isPrefixOf, 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 [] = []---- | 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"---- | 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---- 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)---checkResult :: (Int -> a) -> a -> Outputs -> a-checkResult _ _ [] = error $ "*** FAILURE: Missing exit code"-checkResult _ onSuccess (Result ExitSuccess : _) = onSuccess-checkResult onFailure _ (Result (ExitFailure n) : _) = onFailure n-checkResult onFailure onSuccess (_ : more) = checkResult onFailure onSuccess more--discardStdout :: Outputs -> Outputs-discardStdout (Stdout _ : more) = discardStdout more-discardStdout (x : more) = x : discardStdout more-discardStdout [] = []--discardStderr :: Outputs -> Outputs-discardStderr (Stderr _ : more) = discardStderr more-discardStderr (x : more) = x : discardStderr more-discardStderr [] = []--discardOutput :: Outputs -> Outputs-discardOutput = discardStdout . discardStderr---- |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---- |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---- |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)---- |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)---- |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)---- |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)---- |Partition the exit code from the outputs.-collectResult :: Outputs -> (ExitCode, Outputs)-collectResult output =-    unResult (partition isResult output)-    where-      isResult (Result _) = True-      isResult _ = False-      unResult ([Result x], out) = (x, out)-      unResult _ = error $ "Internal error - wrong number of results"
− System/Unix/ProcessExtra.hs 
@@ -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
− System/Unix/ProcessStrict.hs 
@@ -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
− System/Unix/Progress.hs 
@@ -1,379 +0,0 @@-{-# LANGUAGE FlexibleContexts, PackageImports, RankNTypes, ScopedTypeVariables #-}-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}--- |Control the progress reporting and output of subprocesses.-module System.Unix.Progress-    ( -- * The Progress Monad-      Progress-    , ProgressFlag(..)-    , quietnessLevels-    , runProgress-    -- * Process launching-    , lazyCommandP-    , lazyProcessP-    -- * Quietness control-    , defaultQuietness-    , modQuietness-    , quieter-    -- * Output stream processing-    -- , prefixes-    -- , printOutput-    -- , dotOutput-    , timeTask-    , showElapsed-    , ePutStr-    , ePutStrLn-    , qPutStr-    , qPutStrLn-    , eMessage-    , eMessageLn-    , qMessage-    , qMessageLn-    -- * Unit tests-    , tests-    -- * A set of lazyCommand functions for an example set of verbosity levels-    , defaultLevels-    , lazyCommandV -- Print everything-    , lazyProcessV-    , lazyCommandF -- Like V, but throws exception on failure-    , lazyProcessF-    , lazyCommandE -- Print everything on failure-    , lazyProcessE-    , lazyCommandEF -- E and F combo-    , lazyProcessEF-    , lazyCommandD -- Dots-    , lazyCommandQ -- Quiet-    , lazyCommandS -- Silent-    , lazyCommandSF-    ) where--import Control.Exception (evaluate, try, SomeException)-import Control.Monad (when)-import Control.Monad.State (StateT, get, evalStateT)-import "mtl" Control.Monad.Trans ( MonadIO, liftIO, lift )-import Data.Array ((!), array, bounds)-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as L-import Data.List (intercalate)-import qualified Data.Set as Set-import Data.Time (NominalDiffTime, getCurrentTime, diffUTCTime)-import System.Environment (getArgs, getEnv)-import System.Exit (ExitCode(..))-import System.IO (hPutStrLn, stderr, hPutStr)-import System.Posix.Env (setEnv)-import System.Unix.Process (lazyProcess, lazyCommand, Output(Stdout, Stderr),-                            exitCodeOnly, stdoutOnly, mergeToStdout)-import Test.HUnit--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@.-data ProgressFlag-    = Echo-    | Dots-    | All-    | Errors-    | Result-    | EchoOnFail-    | AllOnFail-    | ErrorsOnFail-    | ResultOnFail-    | ExceptionOnFail-    deriving (Ord, Eq)---- |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---- |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---- |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---- |Inject a command's output into the Progress monad, handling command echoing,--- output formatting, result code reporting, and exception on failure.-doProgress :: MonadIO m => String -> [Output] -> Progress m [Output]-doProgress cmd output =-    get >>= \ s ->-    doEcho s output >>= doOutput s >>= doResult s >>= doFail s-    where-      doEcho s output-          | Set.member Echo s || (Set.member EchoOnFail s && exitCodeOnly output /= ExitSuccess) =-              liftIO (ePutStrLn ("-> " ++ cmd)) >> return output-          | True = return output-      doOutput s output-          | Set.member All s || (Set.member AllOnFail s && exitCodeOnly output /= ExitSuccess) =-              liftIO (printOutput (prefixes opre epre output))-          | Set.member Dots s =-              liftIO (dotOutput 128 output)-          | Set.member Errors s || (Set.member ErrorsOnFail s && exitCodeOnly output /= ExitSuccess) =-              liftIO (printErrors (prefixes opre epre output))-          | True = return output-      doResult s output-          | Set.member Result s || (Set.member ResultOnFail s && exitCodeOnly output /= ExitSuccess) =-              liftIO (ePutStrLn ("<- " ++ show (exitCodeOnly output))) >> return output-          | True = return output-      doFail :: MonadIO m => ProgressState -> [Output] -> Progress m [Output]-      doFail s output-          | Set.member ExceptionOnFail s =-              case exitCodeOnly output of-                ExitSuccess -> return output-                result -> fail ("*** FAILURE: " ++ cmd ++ " -> " ++ show result)-          | True = return output-      opre = B.pack " 1> "-      epre = B.pack " 2> "---- |Print one dot to stderr for every COUNT characters of output.-dotOutput :: MonadIO m => Int -> [Output] -> m [Output]-dotOutput groupSize output =-    mapM (\ (count, elem) -> ePutStr (replicate count '.') >> return elem) pairs >>= eMessageLn ""-    where-      pairs = zip (dots 0 (map length output)) output-      dots _ [] = []-      dots rem (count : more) =-          let (count', rem') = divMod (count + rem) groupSize in-          count' : dots rem' more-      length (Stdout s) = B.length s-      length (Stderr s) = B.length s-      length _ = 0---- |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) = 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-       ePutStr (label ++ formatTime' time)-       return result--formatTime' :: NominalDiffTime -> String-formatTime' diff = show diff-{--    case () of-      _ | isPrefixOf "00:00:0" hms -> drop 7 hms ++ printf ".%03d" ms ++ " s."-      _ | isPrefixOf "00:00:" hms -> drop 6 hms ++ printf ".%03d" ms ++ " s."-      _ | isPrefixOf "00:" hms -> drop 3 hms-      _ -> hms-    where-      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)--}---- |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 =-    [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---- 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
− System/Unix/Shadow.hsc 
@@ -1,108 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--------------------------------------------------------------------------------- |--- Module      :  System.Unix.Shadow--- Copyright   :  (c) 2010 Jeremy Shaw, The University of Glasgow--- License     :  BSD3--- --- Maintainer  :  jeremy@seereason.com--- Stability   :  provisional--- Portability :  non-portable (requires POSIX)------ support for /etc/shadow------ TODO: This module is modelled after System.Posix.User but lacks many --- of the #ifdefs. Those are probably important.-------------------------------------------------------------------------------module System.Unix.Shadow -    ( SUserEntry(..)-    , getSUserEntryForName-    ) where--import Control.Exception-import Control.Monad-import Foreign-import Foreign.C-import System.Posix.Types-import System.IO.Error--#include "shadow.h"--type CSpwd = ()---- | Entry returned by 'getSUserEntryForName'------ TODO: add other fields-data SUserEntry =- SUserEntry {-   sUserName      :: String,     -- ^ Textual name of this user (pw_name)-   sUserPassword  :: String      -- ^ Password -- may be empty or fake if shadow is in use (pw_passwd)- } deriving (Show, Read, Eq)------ | @getSUserEntryForName name@ calls @getspnam@ to obtain---   the @SUserEntry@ information associated with the user login---   @name@.p-getSUserEntryForName :: String -> IO SUserEntry--- #if HAVE_GETPWNAM_R-getSUserEntryForName name = do-  allocaBytes (#const sizeof(struct spwd)) $ \ppw ->-    alloca $ \ pppw ->-      withCString name $ \ pstr -> do-	throwErrorIfNonZero_ "getsUserEntryForName" $-	  doubleAllocWhile isERANGE pwBufSize $ \s b ->-	    c_getspnam_r pstr ppw b (fromIntegral s) pppw-	r <- peekElemOff pppw 0-	when (r == nullPtr) $-	  ioError $ flip ioeSetErrorString "no user name"-		  $ mkIOError doesNotExistErrorType-			      "getUserEntryForName"-			      Nothing-			      (Just name)-	unpackSUserEntry ppw--foreign import ccall unsafe "getspnam_r"-  c_getspnam_r :: CString -> Ptr CSpwd-               -> CString -> CSize -> Ptr (Ptr CSpwd) -> IO CInt-{--#elif HAVE_GETPWNAM-getUserEntryForName name = do-  withCString name $ \ pstr -> do-    withMVar lock $ \_ -> do-      ppw <- throwErrnoIfNull "getUserEntryForName" $ c_getpwnam pstr-      unpackUserEntry ppw--foreign import ccall unsafe "getpwnam" -  c_getpwnam :: CString -> IO (Ptr CPasswd)-#else-getUserEntryForName = error "System.Posix.User.getUserEntryForName: not supported"-#endif--}--unpackSUserEntry :: Ptr CSpwd -> IO SUserEntry-unpackSUserEntry ptr = do-   name   <- (#peek struct spwd, sp_namp)   ptr >>= peekCString-   passwd <- (#peek struct spwd, sp_pwdp)   ptr >>= peekCString-   return (SUserEntry name passwd)--isERANGE :: Integral a => a -> Bool-isERANGE = (== eRANGE) . Errno . fromIntegral--doubleAllocWhile :: (a -> Bool) -> Int -> (Int -> Ptr b -> IO a) -> IO a-doubleAllocWhile p s m = do-  r <- allocaBytes s (m s)-  if p r then doubleAllocWhile p (2 * s) m else return r---pwBufSize :: Int-pwBufSize = 1024---- Used when calling re-entrant system calls that signal their 'errno' --- directly through the return value.-throwErrorIfNonZero_ :: String -> IO CInt -> IO ()-throwErrorIfNonZero_ loc act = do-    rc <- act-    if (rc == 0) -     then return ()-     else ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
System/Unix/SpecialDevice.hs view
@@ -2,30 +2,30 @@ -- | Construct an ADT representing block and character devices -- (but mostly block devices) by interpreting the contents of -- the Linux sysfs filesystem.-module System.Unix.SpecialDevice +module System.Unix.SpecialDevice     (SpecialDevice,-     sysMountPoint,	-- IO String-     ofNode,		-- FilePath -> IO (Maybe SpecialDevice)-     ofNodeStatus,	-- FileStatus -> Maybe SpecialDevice-     ofPath,		-- FilePath -> IO (Maybe SpecialDevice)-     rootPart,		-- IO (Maybe SpecialDevice)-     ofDevNo,		-- (DeviceID -> SpecialDevice) -> Int -> SpecialDevice-     ofSysName,		-- String -> IO (Maybe SpecialDevice)-     ofSysPath,		-- (DeviceID -> SpecialDevice) -> FilePath -> IO (Maybe SpecialDevice)-     toDevno,		-- SpecialDevice -> Int-     --major,		-- SpecialDevice -> Int-     --minor,		-- SpecialDevice -> Int-     ofMajorMinor,	-- (DeviceID -> SpecialDevice) -> Int -> Int -> SpecialDevice-     node,		-- SpecialDevice -> IO (Maybe FilePath)-     nodes,		-- SpecialDevice -> IO [FilePath]-     sysName,		-- SpecialDevice -> IO (Maybe String)-     splitPart,		-- String -> (String, Int)-     sysDir,		-- SpecialDevice -> IO (Maybe FilePath)-     diskOfPart,	-- SpecialDevice -> IO (Maybe SpecialDevice)-     getAllDisks,	-- IO [SpecialDevice]-     getAllPartitions,	-- IO [SpecialDevice]-     getAllCdroms,	-- IO [SpecialDevice]-     getAllRemovable,	-- IO [SpecialDevice]+     sysMountPoint,     -- IO String+     ofNode,            -- FilePath -> IO (Maybe SpecialDevice)+     ofNodeStatus,      -- FileStatus -> Maybe SpecialDevice+     ofPath,            -- FilePath -> IO (Maybe SpecialDevice)+     rootPart,          -- IO (Maybe SpecialDevice)+     ofDevNo,           -- (DeviceID -> SpecialDevice) -> Int -> SpecialDevice+     ofSysName,         -- String -> IO (Maybe SpecialDevice)+     ofSysPath,         -- (DeviceID -> SpecialDevice) -> FilePath -> IO (Maybe SpecialDevice)+     toDevno,           -- SpecialDevice -> Int+     --major,           -- SpecialDevice -> Int+     --minor,           -- SpecialDevice -> Int+     ofMajorMinor,      -- (DeviceID -> SpecialDevice) -> Int -> Int -> SpecialDevice+     node,              -- SpecialDevice -> IO (Maybe FilePath)+     nodes,             -- SpecialDevice -> IO [FilePath]+     sysName,           -- SpecialDevice -> IO (Maybe String)+     splitPart,         -- String -> (String, Int)+     sysDir,            -- SpecialDevice -> IO (Maybe FilePath)+     diskOfPart,        -- SpecialDevice -> IO (Maybe SpecialDevice)+     getAllDisks,       -- IO [SpecialDevice]+     getAllPartitions,  -- IO [SpecialDevice]+     getAllCdroms,      -- IO [SpecialDevice]+     getAllRemovable,   -- IO [SpecialDevice] --     toDevName, --     getBlkidAlist, --     getBlkidInfo,@@ -78,7 +78,7 @@         (Just . BlockDevice . specialDeviceID $ status) else         if isCharacterDevice status then             (Just . CharacterDevice . specialDeviceID $ status) else-            Nothing    +            Nothing  ofSysName :: String -> IO (Maybe SpecialDevice) ofSysName name =@@ -144,7 +144,7 @@ sysName dev = sysDir dev >>= return . maybe Nothing (Just . basename)  sysDir :: SpecialDevice -> IO (Maybe FilePath)-sysDir dev@(BlockDevice _) = +sysDir dev@(BlockDevice _) =     do       (pairs' :: [(FilePath, FileStatus)]) <- directory_find False (sysMountPoint ++ "/block")       let (paths :: [FilePath]) = map fst . filter isDev $ pairs'@@ -194,10 +194,10 @@       x -> True  getAllCdroms :: IO [SpecialDevice]-getAllCdroms = cdromGroup >>= getDisksInGroup +getAllCdroms = cdromGroup >>= getDisksInGroup  getAllRemovable :: IO [SpecialDevice]-getAllRemovable = floppyGroup >>= getDisksInGroup +getAllRemovable = floppyGroup >>= getDisksInGroup  -- ofNode "/dev/sda1" >>= maybe (return Nothing) sysDir >>= putStrLn . show -- -> Just "/sys/block/sda/sda1/dev"
Unixutils.cabal view
@@ -1,23 +1,42 @@ Name:           Unixutils-Version:        1.36+Version:        1.54.3 License:        BSD3 License-File:	COPYING Author:         Jeremy Shaw, David Fox-Homepage:       http://src.seereason.com/haskell-unixutils+Homepage:       https://github.com/seereason/haskell-unixutils.git Category:	System-Build-Depends:  array, base >= 4 && <5, containers, mtl, HUnit, unix, regex-tdfa, process < 3, bytestring, directory, time, old-time, parallel >= 2, filepath Synopsis:       A crude interface between Haskell and Unix-like operating systems-Maintainer:     jeremy@n-heptane.com+Maintainer:     David Fox <ddssff@gmail.com> Description:  A collection of useful and mildly useful functions that you might  expect to find in System.* which a heavy bias towards Unix-type operating systems. 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-Extra-libraries: crypt+Cabal-Version: >= 1.10 --- For more complex build options see:--- http://www.haskell.org/ghc/docs/latest/html/Cabal/+Library+    Default-Language: Haskell2010+    Build-Depends:+      base >= 4.6 && <5,+      bytestring,+      directory,+      exceptions,+      filepath,+      mtl,+      process,+      process-extras >= 0.3,+      pureMD5,+      regex-tdfa,+      unix,+      zlib+    Exposed-modules:+        System.Unix.Chroot,+        System.Unix.Crypt,+        System.Unix.Directory,+        System.Unix.FilePath,+        System.Unix.KillByCwd,+        System.Unix.Misc,+        System.Unix.Mount,+        System.Unix.SpecialDevice,+        System.Unix.Files+    if !os(darwin)+        Extra-libraries: crypt