diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -2,4 +2,4 @@ import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks simpleUserHooks diff --git a/System/Unix/Directory.hs b/System/Unix/Directory.hs --- a/System/Unix/Directory.hs +++ b/System/Unix/Directory.hs @@ -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 diff --git a/System/Unix/FilePath.hsc b/System/Unix/FilePath.hsc --- a/System/Unix/FilePath.hsc +++ b/System/Unix/FilePath.hsc @@ -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 diff --git a/System/Unix/Process.hs b/System/Unix/Process.hs --- a/System/Unix/Process.hs +++ b/System/Unix/Process.hs @@ -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) diff --git a/System/Unix/ProcessExtra.hs b/System/Unix/ProcessExtra.hs new file mode 100644 --- /dev/null +++ b/System/Unix/ProcessExtra.hs @@ -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 diff --git a/System/Unix/Progress.hs b/System/Unix/Progress.hs --- a/System/Unix/Progress.hs +++ b/System/Unix/Progress.hs @@ -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 diff --git a/System/Unix/SpecialDevice.hs b/System/Unix/SpecialDevice.hs --- a/System/Unix/SpecialDevice.hs +++ b/System/Unix/SpecialDevice.hs @@ -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 diff --git a/Unixutils.cabal b/Unixutils.cabal --- a/Unixutils.cabal +++ b/Unixutils.cabal @@ -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: