packages feed

Unixutils 1.22 → 1.27

raw patch · 8 files changed

+117/−96 lines, 8 filesdep +mtldep +regex-tdfadep −regex-compatdep ~basedep ~parallelsetup-changed

Dependencies added: mtl, regex-tdfa

Dependencies removed: regex-compat

Dependency ranges changed: base, parallel

Files

Setup.hs view
@@ -2,4 +2,4 @@  import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks+main = defaultMainWithHooks simpleUserHooks
System/Unix/Directory.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-} module System.Unix.Directory     ( find     , removeRecursiveSafely@@ -49,7 +49,7 @@ traverse path f d m =     do       result <- try $ getSymbolicLinkStatus path-      either (\ _ -> return ()) (doPath path) result+      either (\ (_ :: SomeException) -> return ()) (doPath path) result     where       doPath path status =           if isDirectory status then
System/Unix/FilePath.hsc view
@@ -12,7 +12,7 @@  import Data.List import System.FilePath (makeRelative, (</>), takeFileName, dropFileName)-import Text.Regex+--import Text.Regex import Foreign.C import Foreign.Marshal.Array
System/Unix/Process.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures -Werror #-} -- |functions for killing processes, running processes, etc module System.Unix.Process     (@@ -36,29 +37,26 @@     , killByCwd		-- FilePath -> IO [(String, Maybe String)]     ) where -import Control.Monad+import Control.Concurrent (threadDelay)+import Control.Monad (liftM, filterM) import Control.Exception hiding (catch)-import Control.Parallel.Strategies-import Data.Char+import Control.Parallel.Strategies (rnf)+import Data.Char (isDigit) import qualified Data.ByteString as B---import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Char8 as C-import qualified Data.ByteString.Lazy.Char8 as L---import qualified Data.ByteString.Internal as I+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-import Data.Word-import Data.Int-import System.Process-import System.IO-import System.IO.Unsafe-import System.Directory-import System.Exit-import System.Posix.Files-import System.Posix.Signals-import System.Posix.Unistd (usleep)-import Foreign.Marshal.Alloc (allocaBytes)-import Foreign.Marshal.Array (peekArray, pokeArray)+import Data.List (isPrefixOf)+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 @@ -102,6 +100,8 @@ 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@@ -167,42 +167,10 @@     | Result ExitCode       deriving Show --- | Display up to thirty characters of a ByteString followed by an--- ellipsis if some of it was omitted.-showBrief :: B.ByteString -> String-showBrief s = -    let l = B.length s in-    show (B.take (min 30 l) s) ++-         if l > 30 then " ... (" ++ show (l - 30) ++ " additional bytes)" else ""--{--instance Show Output where-    show (Stdout s) =-        let l = B.length s in-        "Stdout: " ++ showBrief s-    show (Stderr s) =-        let l = B.length s in-        "Stderr: " ++ showBrief s-    -- show (Sleep n) = "Slept " ++ show n ++ " usec"-    show (Result e) = show e--}- bufSize = 65536		-- maximum chunk size uSecs = 8		-- minimum wait time, doubles each time nothing is ready maxUSecs = 100000	-- maximum wait time (microseconds) ---stringToByteString = B.pack . map (fromInteger . toInteger . ord)---- | Debugging output-ePut :: Int -> String -> IO ()-ePut minv s = if curv >= minv then hPutStr stderr s else return ()-ePut0 = ePut 0-ePut1 = ePut 1-ePut2 = ePut 2---- | Current verbosity level.-curv = 0- -- | Create a process with 'runInteractiveCommand' and run it with 'lazyRun'. lazyCommand :: String -> L.ByteString -> IO [Output] lazyCommand cmd input = runInteractiveCommand cmd >>= lazyRun input@@ -218,6 +186,9 @@ -- the lazy list of 'Output' objects. lazyRun :: L.ByteString -> Process -> IO [Output] lazyRun input (inh, outh, errh, pid) =+    hSetBinaryMode inh True >>+    hSetBinaryMode outh True >>+    hSetBinaryMode errh True >>     elements (L.toChunks input, Just inh, Just outh, Just errh, [])     where       elements :: ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, [Output]) -> IO [Output]@@ -239,7 +210,10 @@ data Readyness = Ready | Unready | EndOfFile  hReady' :: Handle -> IO Readyness-hReady' h = (hReady h >>= (\ flag -> return (if flag then Ready else Unready))) `catch` (\ e -> return EndOfFile)+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@@ -261,7 +235,7 @@         -- Input handle closed and there are no ready output handles,         -- wait a bit         ([], Nothing, Unready, Unready) ->-            do usleep uSecs+            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@@ -273,11 +247,11 @@                 do count' <- hPutNonBlocking handle input >>= return . fromInteger . toInteger                    case count' of                      -- Input buffer is full too, sleep.-                     0 -> do usleep uSecs+                     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)+                     _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@@ -299,7 +273,7 @@         0 -> do hClose handle                 return ([], Nothing)         -- Got some input-        n -> return ([constructor a], Just handle)+        _n -> return ([constructor a], Just handle)  -- | Filter everything except stdout from the output list. stdoutOnly :: [Output] -> L.ByteString@@ -424,4 +398,4 @@ collectOutputUnpacked :: [Output] -> (String, String, [ExitCode]) collectOutputUnpacked =     unpack . collectOutput-    where unpack (out, err, result) = (L.unpack out, L.unpack err, result)+    where unpack (out, err, result) = (C.unpack out, C.unpack err, result)
+ System/Unix/ProcessExtra.hs view
@@ -0,0 +1,49 @@+-- |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/Progress.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} -- |Run shell commands with various types of progress reporting. -- -- Author: David Fox@@ -133,8 +134,9 @@       finish <- getClockTime       let elapsed = diffClockTimes finish start       case result of-        Left e -> do errorMessage style (show e)-                     error (show e)+        Left (e :: SomeException) ->+            do errorMessage style (show e)+               error (show e)         Right a ->             do finishMessage style elapsed                return a
System/Unix/SpecialDevice.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSignatures #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeSynonymInstances #-} -- | Construct an ADT representing block and character devices -- (but mostly block devices) by interpreting the contents of -- the Linux sysfs filesystem.@@ -46,7 +46,7 @@ import System.Posix.Types import System.Posix.Files import System.Posix.User-import Text.Regex+import Text.Regex.TDFA  data SpecialDevice =     BlockDevice DeviceID | CharacterDevice DeviceID@@ -60,7 +60,7 @@ ofPath path =     -- Catch the exception thrown on an invalid symlink     (try $ getFileStatus path) >>=-    return . either (const Nothing) (Just . BlockDevice . deviceID)+    return . either (\ (_ :: SomeException) -> Nothing) (Just . BlockDevice . deviceID)  rootPart :: IO (Maybe SpecialDevice) rootPart = ofPath "/"@@ -70,7 +70,7 @@ -- if the node turns out not to be a special device. ofNode :: FilePath -> IO (Maybe SpecialDevice) ofNode "/dev/root" = ofPath "/"-ofNode node = (try $ getFileStatus node) >>= return . either (const Nothing) ofNodeStatus+ofNode node = (try $ getFileStatus node) >>= return . either (\ (_ :: SomeException) -> Nothing) ofNodeStatus  ofNodeStatus :: FileStatus -> Maybe SpecialDevice ofNodeStatus status =@@ -182,14 +182,17 @@       return (catMaybes devs)     where       inGroup group (_, status) = fileGroup status == group-      isPart (path, _) = maybe False (const True) (matchRegex (mkRegex "-part[0-9]+$") path)  getAllPartitions :: IO [SpecialDevice] getAllPartitions =     directory_find True "/dev/disk/by-path" >>= return . filter isPart >>= return . catMaybes . map (ofNodeStatus . snd)-    where-      isPart (path, _) = maybe False (const True) (matchRegex (mkRegex "-part[0-9]+$") path) +isPart :: (FilePath, FileStatus) -> Bool+isPart (path, _) =+    case path =~ "-part[0-9]+$" of+      x | mrMatch x == "" -> False+      x -> True+ getAllCdroms :: IO [SpecialDevice] getAllCdroms = cdromGroup >>= getDisksInGroup  @@ -203,27 +206,20 @@ -- fileStatus) pairs. directory_find :: Bool -> FilePath -> IO [(FilePath, FileStatus)] directory_find follow path =-    do-      maybeStatus <- -          if follow then-              -- Catch the exception exception thrown on an invalid symlink-              try . getFileStatus $ path else-              getSymbolicLinkStatus path >>= return . Right-      case maybeStatus of-        Left _ -> return []-        Right status ->-            case isDirectory status of-              True -> -                  do-                    -- Catch the exception thrown if we lack read permission-                    subs <- (try $ getDirectoryContents path) >>=-                            return . either (const []) id >>=-                            return . map (path </>) . filter (not . flip elem [".", ".."]) >>=-                            mapM (directory_find follow) >>=-                            return . concat-                    return $ (path, status) : subs-              False ->-                  return [(path, status)]+    if follow then fileStatus else linkStatus+    where+      fileStatus = try (getFileStatus path) >>= either (\ (_ :: SomeException) -> return []) useStatus+      linkStatus = getSymbolicLinkStatus path >>= useStatus+      useStatus status+          | isDirectory status =+              do -- Catch the exception thrown if we lack read permission+                 subs <- (try $ getDirectoryContents path) >>=+                         return . either (\ (_ :: SomeException) -> []) id >>=+                         return . map (path </>) . filter (not . flip elem [".", ".."]) >>=+                         mapM (directory_find follow) >>=+                         return . concat+                 return $ (path, status) : subs+          | True = return [(path, status)]  dirname path = reverse . tail . snd . break (== '/') . reverse $ path basename path = reverse . fst . break (== '/') . reverse $ path
Unixutils.cabal view
@@ -1,11 +1,11 @@ Name:           Unixutils-Version:        1.22+Version:        1.27 License:        BSD3 License-File:	COPYING Author:         Jeremy Shaw Homepage:       http://src.seereason.com/haskell-unixutils Category:	System-Build-Depends:  base >= 3 && < 4, unix, regex-compat, process, bytestring, directory, old-time, parallel, filepath+Build-Depends:  base >= 4 && <5, mtl, unix, regex-tdfa, process, bytestring, directory, old-time, parallel, filepath Synopsis:       A crude interface between Haskell and Unix-like operating systems Maintainer:     jeremy@n-heptane.com Description:@@ -15,7 +15,7 @@ ghc-options:	-O2 Exposed-modules:         System.Unix.Directory, System.Unix.FilePath, System.Unix.List,-	System.Unix.Misc, System.Unix.Mount, System.Unix.Process,+	System.Unix.Misc, System.Unix.Mount, System.Unix.Process, System.Unix.ProcessExtra, 	System.Unix.Progress, System.Unix.SpecialDevice, System.Unix.Files  -- For more complex build options see: