process-listlike 0.8 → 0.9
raw patch · 13 files changed
+463/−136 lines, 13 filesdep +mtldep ~bytestringdep ~processsetup-changednew-component:exe:process-listlike-tests
Dependencies added: mtl
Dependency ranges changed: bytestring, process
Files
- Setup.hs +1/−1
- System/Process/ByteString.hs +2/−0
- System/Process/ByteString/Lazy.hs +2/−0
- System/Process/Chunks.hs +149/−0
- System/Process/Lazy.hs +34/−0
- System/Process/ListLike.hs +85/−123
- System/Process/Strict.hs +22/−0
- System/Process/String.hs +2/−0
- System/Process/Text.hs +2/−0
- System/Process/Text/Lazy.hs +2/−0
- Tests/Main.hs +146/−10
- changelog +9/−0
- process-listlike.cabal +7/−2
Setup.hs view
@@ -16,5 +16,5 @@ } runTestScript lbi =- system (buildDir lbi ++ "/tests/tests") >>= \ code ->+ system (buildDir lbi ++ "/process-listlike-tests/process-listlike-tests") >>= \ code -> if code == ExitSuccess then return () else error "unit test failure"
System/Process/ByteString.hs view
@@ -1,3 +1,4 @@+-- | "System.Process.ListLike" functions restricted to type 'Data.ByteString.Char8.ByteString'. {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module System.Process.ByteString@@ -11,6 +12,7 @@ import System.Exit (ExitCode) import System.Process (CreateProcess) import qualified System.Process.ListLike as R+import System.Process.Strict () readProcess :: (a ~ ByteString) => FilePath -> [String] -> a -> IO a readProcess = R.readProcess
System/Process/ByteString/Lazy.hs view
@@ -1,3 +1,4 @@+-- | "System.Process.ListLike" functions restricted to the lazy 'Data.ByteString.Lazy.Char8.ByteString' type. {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module System.Process.ByteString.Lazy@@ -11,6 +12,7 @@ import System.Exit (ExitCode) import System.Process (CreateProcess) import qualified System.Process.ListLike as R+import System.Process.Lazy () readProcess ::(a ~ ByteString) => FilePath -> [String] -> a -> IO a readProcess = R.readProcess
+ System/Process/Chunks.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}+module System.Process.Chunks+ ( Chunk(..)+ , readProcessChunks+ -- * Control+ , foldChunk+ , foldChunks+ , putChunk+ -- * Canonical+ , canonicalChunks+ -- * Indent+ , indentChunks+ , putIndented+ -- * Dotify+ , dotifyChunk+ , dotifyChunks+ , putDots+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.DeepSeq (NFData)+import Control.Monad.State (StateT, evalStateT, evalState, get, put)+import Control.Monad.Trans (lift)+import Data.List (foldl')+import Data.ListLike (ListLike(..), ListLikeIO(..))+import Data.Monoid ((<>))+import Prelude hiding (mapM, putStr, null, tail, break, sequence, length, replicate, rem)+import System.Exit (ExitCode)+import System.IO (stderr)+import System.Process (ProcessHandle, CreateProcess)+import System.Process.ListLike (ListLikePlus, readProcessInterleaved)++-- | This lets us use DeepSeq's 'Control.DeepSeq.force' on the stream+-- of data returned by 'readProcessChunks'.+instance NFData ExitCode++-- | The output stream of a process returned by 'readProcessChunks'.+data Chunk a+ = ProcessHandle ProcessHandle -- ^ This will always come first+ | Stdout a+ | Stderr a+ | Exception IOError+ | Result ExitCode+ deriving Show++-- Is this rude? It will collide with any other bogus Show+-- ProcessHandle instances created elsewhere.+instance Show ProcessHandle where+ show _ = "<processhandle>"++-- | A concrete use of 'readProcessInterleaved' - build a list+-- containing chunks of process output, any exceptions that get thrown+-- (unimplemented), and finally an exit code.+readProcessChunks :: (ListLikePlus a c) => CreateProcess -> a -> IO [Chunk a]+readProcessChunks p input =+ readProcessInterleaved (\ h -> [ProcessHandle h]) (\ x -> [Result x]) (\ x -> [Stdout x]) (\ x -> [Stderr x]) p input++foldChunk :: (ProcessHandle -> b) -> (a -> b) -> (a -> b) -> (IOError -> b) -> (ExitCode -> b) -> Chunk a -> b+foldChunk pidf _ _ _ _ (ProcessHandle x) = pidf x+foldChunk _ outf _ _ _ (Stdout x) = outf x+foldChunk _ _ errf _ _ (Stderr x) = errf x+foldChunk _ _ _ exnf _ (Exception x) = exnf x+foldChunk _ _ _ _ exitf (Result x) = exitf x++-- | Build a value from a chunk stream.+foldChunks :: (r -> Chunk a -> r) -> r -> [Chunk a] -> r+foldChunks f r0 xs = foldl' f r0 xs++-- | Write the Stdout chunks to stdout and the Stderr chunks to stderr.+putChunk :: ListLikePlus a c => Chunk a -> IO ()+putChunk (Stdout x) = putStr x+putChunk (Stderr x) = hPutStr stderr x+putChunk _ = return ()++-- | Merge adjacent Stdout or Stderr chunks.+canonicalChunks :: ListLikePlus a c => [Chunk a] -> [Chunk a]+canonicalChunks [] = []+canonicalChunks (Stdout a : Stdout b : more) = canonicalChunks (Stdout (a <> b) : more)+canonicalChunks (Stderr a : Stderr b : more) = canonicalChunks (Stderr (a <> b) : more)+canonicalChunks (Stdout a : more) | null a = canonicalChunks more+canonicalChunks (Stderr a : more) | null a = canonicalChunks more+canonicalChunks (a : more) = a : canonicalChunks more++-- | The monad state, are we at the beginning of a line or the middle?+data BOL = BOL | MOL deriving (Eq)++-- | Indent the text of a chunk with the prefixes given for stdout and+-- stderr. The state monad keeps track of whether we are at the+-- beginning of a line - when we are and more text comes we insert one+-- of the prefixes.+indentChunk :: forall a c m. (Monad m, Functor m, ListLikePlus a c, Eq c) => c -> a -> a -> Chunk a -> StateT BOL m [Chunk a]+indentChunk nl outp errp chunk =+ case chunk of+ Stdout x -> doText Stdout outp x+ Stderr x -> doText Stderr errp x+ _ -> return [chunk]+ where+ doText :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]+ doText con pre x = do+ let (hd, tl) = break (== nl) x+ (<>) <$> doHead con pre hd <*> doTail con pre tl+ doHead :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]+ doHead _ _ x | null x = return []+ doHead con pre x = do+ bol <- get+ case bol of+ BOL -> put MOL >> return [con (pre <> x)]+ MOL -> return [con x]+ doTail :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]+ doTail _ _ x | null x = return []+ doTail con pre x = do+ bol <- get+ put BOL+ tl <- doText con pre (tail x)+ return $ (if bol == BOL then [con pre] else []) <> [con (singleton nl)] <> tl++-- | Pure function to indent the text of a chunk list.+indentChunks :: (ListLikePlus a c, Eq c) => c -> a -> a -> [Chunk a] -> [Chunk a]+indentChunks nl outp errp chunks =+ evalState (Prelude.concat <$> mapM (indentChunk nl outp errp) chunks) BOL++-- | Output the indented text of a chunk list, but return the original+-- unindented list.+putIndented :: (ListLikePlus a c, Eq c) => c -> a -> a -> [Chunk a] -> IO [Chunk a]+putIndented nl outp errp chunks =+ evalStateT (mapM (\ x -> indentChunk nl outp errp x >>= mapM_ (lift . putChunk) >> return x) chunks) BOL++dotifyChunk :: forall a c m. (Monad m, Functor m, ListLikePlus a c) => Int -> c -> Chunk a -> StateT Int m [Chunk a]+dotifyChunk charsPerDot dot chunk =+ case chunk of+ Stdout x -> doChars (length x)+ Stderr x -> doChars (length x)+ _ -> return [chunk]+ where+ doChars count = do+ rem <- get+ let (count', rem') = divMod (rem + count) (fromIntegral charsPerDot)+ put rem'+ if (count' > 0) then return [Stderr (replicate count' dot)] else return []++dotifyChunks :: forall a c. (ListLikePlus a c) => Int -> c -> [Chunk a] -> [Chunk a]+dotifyChunks charsPerDot dot chunks =+ evalState (Prelude.concat <$> mapM (dotifyChunk charsPerDot dot) chunks) 0++-- | Output the dotified text of a chunk list, but return the original+-- unindented list.+putDots :: (ListLikePlus a c) => Int -> c -> [Chunk a] -> IO [Chunk a]+putDots charsPerDot dot chunks =+ evalStateT (mapM (\ x -> dotifyChunk charsPerDot dot x >>= mapM_ (lift . putChunk) >> return x) chunks) 0
+ System/Process/Lazy.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module System.Process.Lazy where++import Control.Exception as E (evaluate)+import Control.Monad+import qualified Data.ByteString.Lazy as L+import Data.List as List (map, concat)+import Data.ListLike (ListLikeIO(..))+import Data.ListLike.Text.Text ()+import Data.ListLike.Text.TextLazy ()+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Word (Word8)+import Prelude hiding (null, length, rem)+import System.IO hiding (hPutStr, hGetContents)+import System.Process.ListLike (ListLikePlus(..))++instance ListLikePlus L.ByteString Word8 where+ setModes _ (inh, outh, errh, _) = f inh >> f outh >> f errh where f mh = maybe (return ()) (\ h -> hSetBinaryMode h True) mh+ readChunks h = hGetContents h >>= evaluate . Prelude.map (L.fromChunks . (: [])) . L.toChunks++instance ListLikePlus LT.Text Char where+ setModes _ _ = return ()+ readChunks h = hGetContents h >>= evaluate . Prelude.map (LT.fromChunks . (: [])) . LT.toChunks++-- | This String instance is implemented using the Lazy Text instance.+-- Otherwise (without some serious coding) String would be a strict+-- instance . Note that the 'System.Process.readProcess' in the+-- process library is strict, while our equivalent is not - see test4+-- in Tests/Dots.hs.+instance ListLikePlus String Char where+ setModes _ _ = return ()+ readChunks h = readChunks h >>= return . List.map T.unpack . List.concat . List.map LT.toChunks
System/Process/ListLike.hs view
@@ -1,4 +1,6 @@--- | Versions of the functions in module 'System.Process.Read' specialized for type ByteString.+-- | Generalized versions of the functions+-- 'System.Process.readProcess', and+-- 'System.Process.readProcessWithExitCode'. {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-} module System.Process.ListLike ( ListLikePlus(..),@@ -8,85 +10,82 @@ readCreateProcess, readProcessWithExitCode, readProcess,- Output(..),- readProcessChunks+ showCmdSpecForUser ) where import Control.Concurrent-import Control.DeepSeq (NFData)-import Control.Exception as E (SomeException, onException, evaluate, catch, try, throwIO, mask, throw)+import Control.Exception as E (SomeException, onException, catch, try, throwIO, mask, throw) import Control.Monad-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Int (Int64)-import Data.List as List (map) import Data.ListLike (ListLike(..), ListLikeIO(..)) import Data.ListLike.Text.Text () import Data.ListLike.Text.TextLazy () import Data.Monoid (Monoid(mempty, mappend), (<>))-import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import Data.Word (Word8) import GHC.IO.Exception (IOErrorType(OtherError, ResourceVanished), IOException(ioe_type)) import Prelude hiding (null, length, rem) import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import System.IO hiding (hPutStr, hGetContents) import qualified System.IO.Error as IO import System.IO.Unsafe (unsafeInterleaveIO)-import System.Process (CreateProcess(..), StdStream(CreatePipe, Inherit), proc,+import System.Process (ProcessHandle, CreateProcess(..), StdStream(CreatePipe, Inherit), proc, CmdSpec(RawCommand, ShellCommand), showCommandForUser, createProcess, waitForProcess, terminateProcess) --- | Class of types which can be used as the input and outputs of the process functions.-class (Integral (LengthType a), ListLikeIO a c) => ListLikePlus a c where- type LengthType a- binary :: a -> [Handle] -> IO ()- -- ^ This should call 'hSetBinaryMode' on each handle if a is a- -- ByteString type, so that it doesn't attempt to decode the text- -- using the current locale.- lazy :: a -> Bool- length' :: a -> LengthType a- toChunks :: a -> [a]+-- | Class of types which can be used as the input and outputs of+-- these process functions.+class ListLikeIO a c => ListLikePlus a c where+ setModes :: a -> (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()+ -- ^ Perform initialization on the handles returned by createProcess+ -- based on this ListLikePlus instance - typically setting binary+ -- mode on all the file descriptors if the element type is Word8.+ -- If this is not done, reading something other than text (such as a+ -- .jpg or .pdf file) will usually fail with a decoding error.+ readChunks :: Handle -> IO [a]+ -- ^ Read the list of chunks from this handle. For lazy types this+ -- is just a call to hGetContents followed by toChunks. For strict+ -- types it might return a singleton list. Strings are trickier. --- | A test version of readProcessC--- Pipes code here: http://hpaste.org/76631+-- | Read the output of a process and use the argument functions to+-- convert it into a Monoid, preserving the order of appearance of the+-- different chunks of output from standard output and standard error. readProcessInterleaved :: (ListLikePlus a c, Monoid b) =>- (ExitCode -> b) -> (a -> b) -> (a -> b)+ (ProcessHandle -> b) -> (ExitCode -> b) -> (a -> b) -> (a -> b) -> CreateProcess -> a -> IO b-readProcessInterleaved codef outf errf p input = mask $ \ restore -> do- (Just inh, Just outh, Just errh, pid) <-+readProcessInterleaved pidf codef outf errf p input = mask $ \ restore -> do+ hs@(Just inh, Just outh, Just errh, pid) <- createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }) - binary input [inh, outh, errh]+ setModes input hs flip onException (do hClose inh; hClose outh; hClose errh; terminateProcess pid; waitForProcess pid) $ restore $ do- waitOut <- forkWait $ readInterleaved [(outf, outh), (errf, errh)] $ waitForProcess pid >>= return . codef+ waitOut <- forkWait $ readInterleaved (pidf pid) [(outf, outh), (errf, errh)] $ waitForProcess pid >>= return . codef writeInput inh input waitOut --- | Simultaneously read the output from all the handles, using the--- associated functions to add them to the Monoid b in the order they--- appear. Close each handle on EOF (even though they were open when--- we received them.) I can't think of anything else to do with a--- handle that has reached EOF.-readInterleaved :: forall a b c. (ListLikePlus a c, Monoid b) => [(a -> b, Handle)] -> IO b -> IO b-readInterleaved pairs finish = newEmptyMVar >>= readInterleaved' pairs finish+-- | Simultaneously read the output from several file handles, using+-- the associated functions to add them to a Monoid b in the order+-- they appear. This closes each handle on EOF, because AFAIK it is+-- the only useful thing to do with a file handle that has reached+-- EOF.+readInterleaved :: forall a b c. (ListLikePlus a c, Monoid b) => b -> [(a -> b, Handle)] -> IO b -> IO b+readInterleaved start pairs finish = newEmptyMVar >>= readInterleaved' start pairs finish readInterleaved' :: forall a b c. (ListLikePlus a c, Monoid b) =>- [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b-readInterleaved' pairs finish res = do+ b -> [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b+readInterleaved' start pairs finish res = do mapM_ (forkIO . uncurry readHandle) pairs- takeChunks (length pairs)+ r <- takeChunks (length pairs)+ return $ start <> r where+ readHandle :: (a -> b) -> Handle -> IO () readHandle f h = do- cs <- hGetContents h+ cs <- readChunks h -- If the type returned as stdout and stderr is lazy we need -- to force it here in the producer thread - I'm not exactly -- sure why. And why is String lazy?- when (lazy (undefined :: a)) (void $ force' cs)- mapM_ (\ c -> putMVar res (Right (f c))) (toChunks cs)+ -- when (lazy (undefined :: a)) (void cs)+ mapM_ (\ c -> putMVar res (Right (f c))) cs hClose h putMVar res (Left h) takeChunks :: Int -> IO b@@ -98,15 +97,12 @@ do xs <- unsafeInterleaveIO $ takeChunks openCount return (x <> xs) --- | A polymorphic implementation of--- 'System.Process.readProcessWithExitCode' with a few--- generalizations:------ 1. The input and outputs can be any instance of 'ListLikePlus'.------ 2. Allows you to modify the 'CreateProcess' record before the process starts------ 3. Takes a 'CmdSpec', so you can launch either a 'RawCommand' or a 'ShellCommand'.+-- | An implementation of 'System.Process.readProcessWithExitCode'+-- with a two generalizations: (1) The input and outputs can be any+-- instance of 'ListLikePlus', and (2) The CreateProcess is passes an+-- argument, so you can use either 'System.Process.proc' or+-- 'System.Process.rawSystem' and you can modify its fields such as+-- 'System.Process.cwd' before the process starts readCreateProcessWithExitCode :: forall a c. ListLikePlus a c =>@@ -114,14 +110,15 @@ -> a -- ^ standard input -> IO (ExitCode, a, a) -- ^ exitcode, stdout, stderr, exception readCreateProcessWithExitCode p input =- readProcessInterleaved (\ c -> (c, mempty, mempty))+ readProcessInterleaved (\ _ -> mempty)+ (\ c -> (c, mempty, mempty)) (\ x -> (mempty, x, mempty)) (\ x -> (mempty, mempty, x)) p input --- | A polymorphic implementation of--- 'System.Process.readProcessWithExitCode' in terms of--- 'readCreateProcessWithExitCode'.+-- | A version of 'System.Process.readProcessWithExitCode' that uses+-- any instance of 'ListLikePlus' instead of 'String', implemented+-- using 'readCreateProcessWithExitCode'. readProcessWithExitCode :: ListLikePlus a c => FilePath -- ^ command to run@@ -130,7 +127,8 @@ -> IO (ExitCode, a, a) -- ^ exitcode, stdout, stderr readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input --- | Implementation of 'System.Process.readProcess' in terms of+-- | Implementation of 'System.Process.readProcess' that uses any+-- instance of 'ListLikePlus' instead of 'String', implemented using -- 'readCreateProcess'. readProcess :: ListLikePlus a c =>@@ -140,31 +138,34 @@ -> IO a -- ^ stdout readProcess cmd args = readCreateProcess (proc cmd args) --- | A polymorphic implementation of 'System.Process.readProcess' with a few generalizations:------ 1. The input and outputs can be any instance of 'ListLikePlus'.------ 2. Allows you to modify the 'CreateProcess' record before the process starts+-- | An implementation of 'System.Process.readProcess' with a two+-- generalizations: (1) The input and outputs can be any instance of+-- 'ListLikePlus', and (2) The CreateProcess is passes an argument, so+-- you can use either 'System.Process.proc' or+-- 'System.Process.rawSystem' and you can modify its fields such as+-- 'System.Process.cwd' before the process starts ----- 3. Takes a 'CmdSpec', so you can launch either a 'RawCommand' or a 'ShellCommand'.+-- This can't be implemented by calling readProcessInterleaved because+-- the std_err field needs to be set to Inherit, which means that+-- 'createProcess' returns no stderr handle. Instead, we have a+-- nearly identical copy of the 'readProcessInterleaved' code which+-- only passes one pair 'readInterleaved'. REMEMBER to keep these two+-- in sync if there are future changes! readCreateProcess :: ListLikePlus a c => CreateProcess -- ^ process to run -> a -- ^ standard input -> IO a -- ^ stdout readCreateProcess p input = mask $ \restore -> do- -- Same code as readProcessInterleaved except that std_err is set- -- to Inherit, so no errh handle is created. Thus, only one pair- -- exists to pass to readInterleaved.- (Just inh, Just outh, _, pid) <-+ hs@(Just inh, Just outh, _, pid) <- createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit }) - binary input [inh, outh]+ setModes input hs flip onException (do hClose inh; hClose outh; terminateProcess pid; waitForProcess pid) $ restore $ do- waitOut <- forkWait $ readInterleaved [(id, outh)] $ waitForProcess pid >>= codef+ waitOut <- forkWait $ readInterleaved mempty [(id, outh)] $ waitForProcess pid >>= codef writeInput inh input waitOut @@ -173,18 +174,14 @@ codef (ExitFailure r) = throw (mkError "readCreateProcess: " (cmdspec p) r) codef ExitSuccess = return mempty --- | Write and flush process input+-- | Write and flush process input, closing the handle when done.+-- Catch and ignore Resource Vanished exceptions, they just mean the+-- process exited before all of its output was read. writeInput :: ListLikePlus a c => Handle -> a -> IO () writeInput inh input = do (do unless (null input) (hPutStr inh input >> hFlush inh) hClose inh) `E.catch` resourceVanished (\ _ -> return ()) -forkWait :: IO a -> IO (IO a)-forkWait a = do- res <- newEmptyMVar- _ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res- return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return)- -- | Wrapper for a process that provides a handler for the -- ResourceVanished exception. This is frequently an exception we -- wish to ignore, because many processes will deliberately exit@@ -192,6 +189,13 @@ resourceVanished :: (IOError -> IO a) -> IOError -> IO a resourceVanished epipe e = if ioe_type e == ResourceVanished then epipe e else ioError e +-- | Fork a thread to read from a handle.+forkWait :: IO a -> IO (IO a)+forkWait a = do+ res <- newEmptyMVar+ _ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res+ return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return)+ -- | Create an exception for a process that exited abnormally. mkError :: String -> CmdSpec -> Int -> IOError mkError prefix (RawCommand cmd args) r =@@ -201,55 +205,13 @@ IO.mkIOError OtherError (prefix ++ cmd ++ " (exit " ++ show r ++ ")") Nothing Nothing -force' :: forall a c. ListLikePlus a c => a -> IO (LengthType a)-force' x = evaluate $ length' $ x--instance ListLikePlus String Char where- type LengthType String = Int- binary _ = mapM_ (\ h -> hSetBinaryMode h True) -- Prevent decoding errors when reading handles (because internally this uses lazy bytestrings)- lazy _ = True -- Why True? toChunks returns a singleton?- length' = length- toChunks = (: [])--instance ListLikePlus B.ByteString Word8 where- type LengthType B.ByteString = Int- binary _ = mapM_ (\ h -> hSetBinaryMode h True) -- Prevent decoding errors when reading handles- lazy _ = False- length' = B.length- toChunks = (: [])--instance ListLikePlus L.ByteString Word8 where- type LengthType L.ByteString = Int64- binary _ = mapM_ (\ h -> hSetBinaryMode h True) -- Prevent decoding errors when reading handles- lazy _ = True- length' = L.length- toChunks = List.map (L.fromChunks . (: [])) . L.toChunks--instance ListLikePlus T.Text Char where- type LengthType T.Text = Int- binary _ _ = return ()- lazy _ = False- length' = T.length- toChunks = (: [])--instance ListLikePlus LT.Text Char where- type LengthType LT.Text = Int64- binary _ _ = return ()- lazy _ = True- length' = LT.length- toChunks = List.map (LT.fromChunks . (: [])) . LT.toChunks-+-- | A chunk stream should have an 'ExitCode' at the end, this monoid lets+-- us build a monoid for the type returned by readProcessWithExitCode. instance Monoid ExitCode where mempty = ExitFailure 0 mappend x (ExitFailure 0) = x mappend _ x = x --- | This lets us use deepseq's force on the stream of data returned--- by readProcessChunks.-instance NFData ExitCode--data Output a = Stdout a | Stderr a | Result ExitCode | Exception IOError deriving (Eq, Show)--readProcessChunks :: (ListLikePlus a c) => CreateProcess -> a -> IO [Output a]-readProcessChunks p input =- readProcessInterleaved (\ x -> [Result x]) (\ x -> [Stdout x]) (\ x -> [Stderr x]) p input+showCmdSpecForUser :: CmdSpec -> String+showCmdSpecForUser (ShellCommand s) = s+showCmdSpecForUser (RawCommand p args) = showCommandForUser p args
+ System/Process/Strict.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeSynonymInstances #-}+-- | ListLikePlus instances for strict types - these are more+-- dangerous, if you start a long running process with them they will+-- block until the process finishes. Why not try a lazy type?+{-# OPTIONS_GHC -fno-warn-orphans #-}+module System.Process.Strict where++import Control.DeepSeq (force)+import Data.ByteString.Char8 as B (ByteString)+import Data.ListLike.IO (hGetContents)+import Data.Text as T (Text)+import Data.Word (Word8)+import System.IO (hSetBinaryMode)+import System.Process.ListLike (ListLikePlus(..))++instance ListLikePlus B.ByteString Word8 where+ setModes _ (inh, outh, errh, _) = f inh >> f outh >> f errh where f mh = maybe (return ()) (\ h -> hSetBinaryMode h True) mh+ readChunks h = hGetContents h >>= return . force . (: [])++instance ListLikePlus T.Text Char where+ setModes _ _ = return ()+ readChunks h = hGetContents h >>= return . force . (: [])
System/Process/String.hs view
@@ -1,3 +1,4 @@+-- | "System.Process.ListLike" functions restricted to type 'String'. {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module System.Process.String@@ -10,6 +11,7 @@ import System.Exit (ExitCode) import System.Process (CreateProcess) import qualified System.Process.ListLike as R+import System.Process.Lazy () readProcess :: (a ~ String) => FilePath -> [String] -> a -> IO a readProcess = R.readProcess
System/Process/Text.hs view
@@ -1,3 +1,4 @@+-- | "System.Process.ListLike" functions restricted to type 'Data.Text.Text'. {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module System.Process.Text@@ -11,6 +12,7 @@ import System.Exit (ExitCode) import System.Process (CreateProcess) import qualified System.Process.ListLike as R+import System.Process.Strict () readProcess :: (a ~ Text) => FilePath -> [String] -> a -> IO a readProcess = R.readProcess
System/Process/Text/Lazy.hs view
@@ -1,3 +1,4 @@+-- | "System.Process.ListLike" functions restricted to the lazy 'Data.Text.Lazy.Text' type. {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module System.Process.Text.Lazy@@ -11,6 +12,7 @@ import System.Exit (ExitCode) import System.Process (CreateProcess) import qualified System.Process.ListLike as R+import System.Process.Lazy () readProcess :: (a ~ Text) => FilePath -> [String] -> a -> IO a readProcess = R.readProcess
Tests/Main.hs view
@@ -1,16 +1,23 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings, RankNTypes #-} module Main where import Codec.Binary.UTF8.String (encode) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import Data.ListLike (ListLike(..))+import Data.ListLike as ListLike (ListLike(..))+import Data.Maybe (mapMaybe)+import Data.Monoid (Monoid(..)) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Prelude hiding (length, concat)+import GHC.IO.Exception import System.Exit import System.Posix.Files (getFileStatus, fileMode, setFileMode, unionFileModes, ownerExecuteMode, groupExecuteMode, otherExecuteMode) import System.Process (proc)+import System.Process.Chunks (Chunk(..), readProcessChunks, canonicalChunks)+import System.Process.Lazy () import System.Process.ListLike (readProcessWithExitCode, readCreateProcessWithExitCode, readCreateProcess, ListLikePlus(..))+import System.Process.Strict () import Test.HUnit hiding (path) fromString :: String -> B.ByteString@@ -19,6 +26,45 @@ lazyFromString :: String -> L.ByteString lazyFromString = L.fromChunks . (: []) . fromString +instance Monoid Test where+ mempty = TestList []+ mappend (TestList a) (TestList b) = TestList (a ++ b)+ mappend (TestList a) b = TestList (a ++ [b])+ mappend a (TestList b) = TestList ([a] ++ b)+ mappend a b = TestList [a, b]++testInstances :: (forall a c. (Show a, ListLikePlus a c) => a -> Test) -> Test+testInstances mkTest = mappend (testCharInstances mkTest) (testWord8Instances mkTest)++testStrictInstances :: (forall a c. (Show a, ListLikePlus a c) => a -> Test) -> Test+testStrictInstances mkTest = mappend (testStrictCharInstances mkTest) (testStrictWord8Instances mkTest)++testLazyInstances :: (forall a c. (Show a, ListLikePlus a c) => a -> Test) -> Test+testLazyInstances mkTest = mappend (testLazyCharInstances mkTest) (testLazyWord8Instances mkTest)++testCharInstances :: (forall a c. (Show a, ListLikePlus a c) => a -> Test) -> Test+testCharInstances mkTest = mappend (testLazyCharInstances mkTest) (testStrictCharInstances mkTest)++testLazyCharInstances :: (forall a c. (Show a, ListLikePlus a c) => a -> Test) -> Test+testLazyCharInstances mkTest =+ TestList [ TestLabel "Lazy Text" $ mkTest LT.empty+ , TestLabel "String" $ mkTest ("" :: String) ]++testStrictCharInstances :: (forall a c. (Show a, ListLikePlus a c) => a -> Test) -> Test+testStrictCharInstances mkTest =+ TestList [ TestLabel "Strict Text" $ mkTest T.empty ]++testWord8Instances :: (forall a c. (Show a, ListLikePlus a c) => a -> Test) -> Test+testWord8Instances mkTest = mappend (testLazyWord8Instances mkTest) (testStrictWord8Instances mkTest)++testLazyWord8Instances :: (forall a c. (Show a, ListLikePlus a c) => a -> Test) -> Test+testLazyWord8Instances mkTest =+ TestList [ TestLabel "Lazy ByteString" $ mkTest L.empty ]++testStrictWord8Instances :: (forall a c. (Show a, ListLikePlus a c) => a -> Test) -> Test+testStrictWord8Instances mkTest =+ TestList [ TestLabel "Strict ByteString" $ mkTest B.empty ]+ main :: IO () main = do chmod "Tests/Test1.hs"@@ -39,41 +85,131 @@ test1 = TestLabel "test1" (TestList- [ TestLabel "ByteString" $+ [ TestLabel "[Output]" $+ TestList+ [ testCharInstances+ (\ i -> TestCase (do b <- readProcessChunks (proc "cat" ["Tests/text"]) i+ assertEqual+ "UTF8"+ ["ProcessHandle <processhandle>",+ -- For Text, assuming your locale is set to utf8, the result is unicode.+ "Stdout \"Signed: Baishi laoren \\30333\\30707\\32769\\20154, painted in the artist\\8217s 87th year.\\n\"",+ "Result ExitSuccess"] (ListLike.map show (canonicalChunks b))))+ , testWord8Instances+ (\ i -> TestCase (do b <- readProcessChunks (proc "cat" ["Tests/text"]) i+ assertEqual+ "UTF8"+ ["ProcessHandle <processhandle>",+ -- For ByteString we get utf8 encoded text+ "Stdout \"Signed: Baishi laoren \\231\\153\\189\\231\\159\\179\\232\\128\\129\\228\\186\\186, painted in the artist\\226\\128\\153s 87th year.\\n\"",+ "Result ExitSuccess"] (ListLike.map show (canonicalChunks b))))+ , testInstances+ (\ i -> TestCase (do b <- readProcessChunks (proc "Tests/Test1.hs" []) i+ assertEqual+ "[Chunk]"+ ["ProcessHandle <processhandle>",+ "Stderr \"This is an error message.\\n\"",+ "Result (ExitFailure 123)"]+ (ListLike.map show (canonicalChunks b))))+ ]+ -- This gets "hGetContents: invalid argument (invalid byte sequence)" if we don't call+ -- binary on the file handles in readProcessInterleaved.++ , TestLabel "JPG" $+ TestList+ [ {- TestCase (do b <- readProcessChunks (proc "cat" ["Tests/houseisclean.jpg"]) B.empty >>=+ return . mapMaybe (\ x -> case x of+ Stdout s -> Just (length' s)+ Stderr s -> Just (length' s)+ _ -> Nothing)+ assertEqual "ByteString Chunk Size"+ [68668,0]+ b+ -- If we could read a jpg file into a string the chunks would look something like this:+ -- [2048,2048,2048,1952,2048,2048,2048,1952,2048,2048,2048,1952,2048,2048,2048,1952,2048,2048,2048,1952,2048,2048,2048,1952,2048,2048,2048,1952,2048,2048,2048,1952,2048,1852]+ )+ , -}+ testLazyWord8Instances+ ( \ i -> TestCase (do b <- readProcessChunks (proc "cat" ["Tests/houseisclean.jpg"]) i >>=+ return . mapMaybe (\ x -> case x of+ Stdout s -> Just (length s)+ Stderr s -> Just (length s)+ _ -> Nothing)+ assertEqual "Chunk Size" [32752,32752,3164] b))+ , testStrictWord8Instances+ ( \ i -> TestCase (do b <- readProcessChunks (proc "cat" ["Tests/houseisclean.jpg"]) i >>=+ return . mapMaybe (\ x -> case x of+ Stdout s -> Just (length s)+ Stderr s -> Just (length s)+ _ -> Nothing)+ assertEqual "Chunk Size" [68668,0] b))+{- -- We don't seem to get an InvalidArgument exception back.+ , TestCase (do b <- tryIOError (readProcessChunks (proc "cat" ["Tests/houseisclean.jpg"]) "") >>= return . either Left (Right . show)+ assertEqual "String decoding exception" (Left (IOError { ioe_handle = Nothing+ , ioe_type = InvalidArgument+ , ioe_location = "recoverDecode"+ , ioe_description = "invalid byte sequence"+ , ioe_errno = Nothing+ , ioe_filename = Nothing })) b)++Related to https://ghc.haskell.org/trac/ghc/ticket/9236. Try this:++ import System.IO+ import System.IO.Error++ main = do+ h <- openFile "Tests/houseisclean.jpg" ReadMode+ r <- try (hGetContents h) >>= either exn str+ hClose h+ where+ exn (e :: IOError) = putStrLn ("exn=" ++ show (ioe_handle e, ioe_type e, ioe_location e, ioe_description e, ioe_errno e, ioe_filename e))+ str s = putStrLn ("s=" ++ show s)++The exception gets thrown and caught after the string result starts+being printed. You can see the open quote.+-}+ ]+{-+ , TestLabel "ByteString" $ TestCase (do b <- readProcessWithExitCode "Tests/Test1.hs" [] B.empty assertEqual "ByteString" (ExitFailure 123, fromString "", fromString "This is an error message.\n") b)+-} , TestLabel "Lazy" $ TestCase (do l <- readProcessWithExitCode "Tests/Test1.hs" [] L.empty assertEqual "Lazy ByteString" (ExitFailure 123, lazyFromString "", lazyFromString "This is an error message.\n") l)+{- , TestLabel "Text" $ TestCase (do t <- readProcessWithExitCode "Tests/Test1.hs" [] T.empty assertEqual "Text" (ExitFailure 123, T.pack "", T.pack "This is an error message.\n") t)+-} , TestLabel "LazyText" $ TestCase (do lt <- readProcessWithExitCode "Tests/Test1.hs" [] LT.empty assertEqual "LazyText" (ExitFailure 123, LT.pack "", LT.pack "This is an error message.\n") lt)+{- , TestLabel "String" $ TestCase (do s <- readProcessWithExitCode "Tests/Test1.hs" [] "" assertEqual "String" (ExitFailure 123, "", "This is an error message.\n") s)+-} , TestLabel "pnmfile" $- TestCase (do out <- B.readFile "Tests/penguin.jpg" >>=+ TestCase (do out <- L.readFile "Tests/penguin.jpg" >>= readCreateProcess (proc "djpeg" []) >>= readCreateProcess (proc "pnmfile" [])- assertEqual "pnmfile" (fromString "stdin:\tPPM raw, 96 by 96 maxval 255\n") out)+ assertEqual "pnmfile" (lazyFromString "stdin:\tPPM raw, 96 by 96 maxval 255\n") out) , TestLabel "pnmfile2" $- TestCase (do jpg <- B.readFile "Tests/penguin.jpg"+ TestCase (do jpg <- L.readFile "Tests/penguin.jpg" (code1, pnm, err1) <- readCreateProcessWithExitCode (proc "djpeg" []) jpg out2 <- readCreateProcess (proc "pnmfile" []) pnm- assertEqual "pnmfile2" (ExitSuccess, empty, 2192, 27661, fromString "stdin:\tPPM raw, 96 by 96 maxval 255\n") (code1, err1, length' jpg, length' pnm, out2))+ assertEqual "pnmfile2" (ExitSuccess, empty, 2192, 27661, lazyFromString "stdin:\tPPM raw, 96 by 96 maxval 255\n") (code1, err1, length jpg, length pnm, out2)) , TestLabel "file closed 1" $- TestCase (do result <- readCreateProcessWithExitCode (proc "Tests/Test4.hs" []) (fromString "a" :: B.ByteString)- assertEqual "file closed 1" (ExitSuccess, (fromString "a"), (fromString "Read one character: 'a'\n")) result)+ TestCase (do result <- readCreateProcessWithExitCode (proc "Tests/Test4.hs" []) (lazyFromString "a" :: L.ByteString)+ assertEqual "file closed 1" (ExitSuccess, (lazyFromString "a"), (lazyFromString "Read one character: 'a'\n")) result) , TestLabel "file closed 2" $ TestCase (do result <- readCreateProcessWithExitCode (proc "Tests/Test4.hs" []) (lazyFromString "" :: L.ByteString) assertEqual "file closed 2" (ExitFailure 1, empty, (lazyFromString "Test4.hs: <stdin>: hGetChar: end of file\n")) result) , TestLabel "file closed 3" $- TestCase (do result <- readCreateProcessWithExitCode (proc "Tests/Test4.hs" []) "abcde"+ TestCase (do result <- readCreateProcessWithExitCode (proc "Tests/Test4.hs" []) ("abcde" :: LT.Text) assertEqual "file closed 3" (ExitSuccess, "a", "Read one character: 'a'\n") result) , TestLabel "file closed 4" $- TestCase (do result <- readCreateProcessWithExitCode (proc "Tests/Test4.hs" []) "abcde"+ TestCase (do result <- readCreateProcessWithExitCode (proc "Tests/Test4.hs" []) ("abcde" :: LT.Text) assertEqual "file closed 4" (ExitSuccess, "a", "Read one character: 'a'\n") result) ])
changelog view
@@ -1,3 +1,12 @@+haskell-process-listlike (0.9) unstable; urgency=low++ * Add an argument to readProcessInterleaved that receives the+ ProcessHandle as the process starts. Add a corresponding constructor+ to the Output type to insert the ProcessHandle into the list+ returned by readProcessChunks.++ -- David Fox <dsf@seereason.com> Sun, 31 Aug 2014 07:15:28 -0700+ haskell-process-listlike (0.8) unstable; urgency=low * Replace the implementation of readCreateProcessWithExitCode
process-listlike.cabal view
@@ -1,5 +1,5 @@ Name: process-listlike-Version: 0.8+Version: 0.9 Synopsis: Enhanced version of process-extras Description: Extra functionality for the Process library <http://hackage.haskell.org/package/process>. This is a drop-in replacement for <http://hackage.haskell.org/package/process-extras>,@@ -23,9 +23,12 @@ ghc-options: -Wall -O2 Exposed-modules:+ System.Process.Chunks+ System.Process.Lazy System.Process.ListLike System.Process.ByteString System.Process.ByteString.Lazy+ System.Process.Strict System.Process.String System.Process.Text System.Process.Text.Lazy@@ -36,11 +39,12 @@ deepseq, HUnit, ListLike >= 4.0,+ mtl, process, text, utf8-string -Executable tests+Executable process-listlike-tests Main-Is: Tests/Main.hs GHC-Options: -Wall -O2 -threaded -rtsopts Build-Depends:@@ -49,6 +53,7 @@ deepseq, HUnit, ListLike,+ mtl, process, process-listlike, text,