diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# About + +Extra functionality for the [Process library](http://hackage.haskell.org/package/process). + +# Contributing + +This project is available on [GitHub](https://github.com/davidlazar/process-extras) and [Bitbucket](https://bitbucket.org/davidlazar/process-extras/). You may contribute changes using either. + +Please report bugs and feature requests using the [GitHub issue tracker](https://github.com/davidlazar/process-extras/issues). diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,20 +1,2 @@ import Distribution.Simple -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir)) -import Distribution.Simple.Program -import System.Directory -import System.Exit -import System.Process - -main = copyFile "debian/changelog" "changelog" >> - defaultMainWithHooks simpleUserHooks { - postBuild = - \ _ _ _ lbi -> - case buildDir lbi of - "dist-ghc/build" -> return () - _ -> runTestScript lbi - , runTests = \ _ _ _ lbi -> runTestScript lbi - } - -runTestScript lbi = - system (buildDir lbi ++ "/process-listlike-tests/process-listlike-tests") >>= \ code -> - if code == ExitSuccess then return () else error "unit test failure" +main = defaultMain diff --git a/System/Process/ByteString.hs b/System/Process/ByteString.hs deleted file mode 100644 --- a/System/Process/ByteString.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | "System.Process.ListLike" functions restricted to type 'Data.ByteString.Char8.ByteString'. -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module System.Process.ByteString - ( readProcess - , readProcessWithExitCode - , readCreateProcess - , readCreateProcessWithExitCode - ) where - -import Data.ByteString.Char8 (ByteString) -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 -readProcessWithExitCode :: (a ~ ByteString) => FilePath -> [String] -> a -> IO (ExitCode, a, a) -readProcessWithExitCode = R.readProcessWithExitCode -readCreateProcess :: (a ~ ByteString) => CreateProcess -> a -> IO a -readCreateProcess = R.readCreateProcess -readCreateProcessWithExitCode :: (a ~ ByteString) => CreateProcess -> a -> IO (ExitCode, a, a) -readCreateProcessWithExitCode = R.readCreateProcessWithExitCode diff --git a/System/Process/ByteString/Lazy.hs b/System/Process/ByteString/Lazy.hs deleted file mode 100644 --- a/System/Process/ByteString/Lazy.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | "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 - ( readProcess - , readProcessWithExitCode - , readCreateProcess - , readCreateProcessWithExitCode - ) where - -import Data.ByteString.Lazy.Char8 (ByteString) -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 -readProcessWithExitCode ::(a ~ ByteString) => FilePath -> [String] -> a -> IO (ExitCode, a, a) -readProcessWithExitCode = R.readProcessWithExitCode -readCreateProcess ::(a ~ ByteString) => CreateProcess -> a -> IO a -readCreateProcess = R.readCreateProcess -readCreateProcessWithExitCode ::(a ~ ByteString) => CreateProcess -> a -> IO (ExitCode, a, a) -readCreateProcessWithExitCode = R.readCreateProcessWithExitCode diff --git a/System/Process/Chunks.hs b/System/Process/Chunks.hs deleted file mode 100644 --- a/System/Process/Chunks.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# 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 _ = "" - --- | 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 diff --git a/System/Process/Lazy.hs b/System/Process/Lazy.hs deleted file mode 100644 --- a/System/Process/Lazy.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# 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 diff --git a/System/Process/ListLike.hs b/System/Process/ListLike.hs deleted file mode 100644 --- a/System/Process/ListLike.hs +++ /dev/null @@ -1,217 +0,0 @@ --- | Generalized versions of the functions --- 'System.Process.readProcess', and --- 'System.Process.readProcessWithExitCode'. -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies #-} -module System.Process.ListLike ( - ListLikePlus(..), - readProcessInterleaved, - readInterleaved, - readCreateProcessWithExitCode, - readCreateProcess, - readProcessWithExitCode, - readProcess, - showCmdSpecForUser - ) where - -import Control.Concurrent -import Control.Exception as E (SomeException, onException, catch, try, throwIO, mask, throw) -import Control.Monad -import Data.ListLike (ListLike(..), ListLikeIO(..)) -import Data.ListLike.Text.Text () -import Data.ListLike.Text.TextLazy () -import Data.Monoid (Monoid(mempty, mappend), (<>)) -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 (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 --- 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. - --- | 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) => - (ProcessHandle -> b) -> (ExitCode -> b) -> (a -> b) -> (a -> b) - -> CreateProcess -> a -> IO b -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 }) - - setModes input hs - - flip onException - (do hClose inh; hClose outh; hClose errh; - terminateProcess pid; waitForProcess pid) $ restore $ do - waitOut <- forkWait $ readInterleaved (pidf pid) [(outf, outh), (errf, errh)] $ waitForProcess pid >>= return . codef - writeInput inh input - waitOut - --- | 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) => - b -> [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b -readInterleaved' start pairs finish res = do - mapM_ (forkIO . uncurry readHandle) pairs - r <- takeChunks (length pairs) - return $ start <> r - where - readHandle :: (a -> b) -> Handle -> IO () - readHandle f h = do - 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 cs) - mapM_ (\ c -> putMVar res (Right (f c))) cs - hClose h - putMVar res (Left h) - takeChunks :: Int -> IO b - takeChunks 0 = finish - takeChunks openCount = takeMVar res >>= takeChunk openCount - takeChunk :: Int -> Either Handle b -> IO b - takeChunk openCount (Left h) = hClose h >> takeChunks (openCount - 1) - takeChunk openCount (Right x) = - do xs <- unsafeInterleaveIO $ takeChunks openCount - return (x <> xs) - --- | 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 => - CreateProcess -- ^ process to run - -> a -- ^ standard input - -> IO (ExitCode, a, a) -- ^ exitcode, stdout, stderr, exception -readCreateProcessWithExitCode p input = - readProcessInterleaved (\ _ -> mempty) - (\ c -> (c, mempty, mempty)) - (\ x -> (mempty, x, mempty)) - (\ x -> (mempty, mempty, x)) - p input - --- | 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 - -> [String] -- ^ any arguments - -> a -- ^ standard input - -> IO (ExitCode, a, a) -- ^ exitcode, stdout, stderr -readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input - --- | Implementation of 'System.Process.readProcess' that uses any --- instance of 'ListLikePlus' instead of 'String', implemented using --- 'readCreateProcess'. -readProcess - :: ListLikePlus a c => - FilePath -- ^ command to run - -> [String] -- ^ any arguments - -> a -- ^ standard input - -> IO a -- ^ stdout -readProcess cmd args = readCreateProcess (proc cmd args) - --- | 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 --- --- 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 - hs@(Just inh, Just outh, _, pid) <- - createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit }) - - setModes input hs - - flip onException - (do hClose inh; hClose outh; - terminateProcess pid; waitForProcess pid) $ restore $ do - waitOut <- forkWait $ readInterleaved mempty [(id, outh)] $ waitForProcess pid >>= codef - writeInput inh input - waitOut - - where - -- Throw an IO error on ExitFailure - codef (ExitFailure r) = throw (mkError "readCreateProcess: " (cmdspec p) r) - codef ExitSuccess = return mempty - --- | 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 ()) - --- | 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 --- before they have read all of their input. -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 = - IO.mkIOError OtherError (prefix ++ showCommandForUser cmd args ++ " (exit " ++ show r ++ ")") - Nothing Nothing -mkError prefix (ShellCommand cmd) r = - IO.mkIOError OtherError (prefix ++ cmd ++ " (exit " ++ show r ++ ")") - Nothing Nothing - --- | 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 - -showCmdSpecForUser :: CmdSpec -> String -showCmdSpecForUser (ShellCommand s) = s -showCmdSpecForUser (RawCommand p args) = showCommandForUser p args diff --git a/System/Process/Strict.hs b/System/Process/Strict.hs deleted file mode 100644 --- a/System/Process/Strict.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# 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 . (: []) diff --git a/System/Process/String.hs b/System/Process/String.hs deleted file mode 100644 --- a/System/Process/String.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | "System.Process.ListLike" functions restricted to type 'String'. -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module System.Process.String - ( readProcess - , readProcessWithExitCode - , readCreateProcess - , readCreateProcessWithExitCode - ) where - -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 -readProcessWithExitCode :: (a ~ String) => FilePath -> [String] -> a -> IO (ExitCode, a, a) -readProcessWithExitCode = R.readProcessWithExitCode -readCreateProcess :: (a ~ String) => CreateProcess -> a -> IO a -readCreateProcess = R.readCreateProcess -readCreateProcessWithExitCode :: (a ~ String) => CreateProcess -> a -> IO (ExitCode, a, a) -readCreateProcessWithExitCode = R.readCreateProcessWithExitCode diff --git a/System/Process/Text.hs b/System/Process/Text.hs deleted file mode 100644 --- a/System/Process/Text.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | "System.Process.ListLike" functions restricted to type 'Data.Text.Text'. -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module System.Process.Text - ( readProcess - , readProcessWithExitCode - , readCreateProcess - , readCreateProcessWithExitCode - ) where - -import Data.Text (Text) -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 -readProcessWithExitCode :: (a ~ Text) => FilePath -> [String] -> a -> IO (ExitCode, a, a) -readProcessWithExitCode = R.readProcessWithExitCode -readCreateProcess :: (a ~ Text) => CreateProcess -> a -> IO a -readCreateProcess = R.readCreateProcess -readCreateProcessWithExitCode :: (a ~ Text) => CreateProcess -> a -> IO (ExitCode, a, a) -readCreateProcessWithExitCode = R.readCreateProcessWithExitCode diff --git a/System/Process/Text/Lazy.hs b/System/Process/Text/Lazy.hs deleted file mode 100644 --- a/System/Process/Text/Lazy.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | "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 - ( readProcess - , readProcessWithExitCode - , readCreateProcess - , readCreateProcessWithExitCode - ) where - -import Data.Text.Lazy (Text) -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 -readProcessWithExitCode :: (a ~ Text) => FilePath -> [String] -> a -> IO (ExitCode, a, a) -readProcessWithExitCode = R.readProcessWithExitCode -readCreateProcess :: (a ~ Text) => CreateProcess -> a -> IO a -readCreateProcess = R.readCreateProcess -readCreateProcessWithExitCode :: (a ~ Text) => CreateProcess -> a -> IO (ExitCode, a, a) -readCreateProcessWithExitCode = R.readCreateProcessWithExitCode diff --git a/Tests/Main.hs b/Tests/Main.hs deleted file mode 100644 --- a/Tests/Main.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# 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 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 -fromString = fromList . encode - -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" - chmod "Tests/Test2.hs" - chmod "Tests/Test4.hs" - (c,st) <- runTestText putTextToShowS test1 -- (TestList (versionTests ++ sourcesListTests ++ dependencyTests ++ changesTests)) - putStrLn (st "") - case (failures c) + (errors c) of - 0 -> return () - _ -> exitFailure - -chmod :: FilePath -> IO () -chmod path = - getFileStatus "Tests/Test1.hs" >>= \ status -> - setFileMode path (foldr unionFileModes (fileMode status) [ownerExecuteMode, groupExecuteMode, otherExecuteMode]) - -test1 :: Test -test1 = - TestLabel "test1" - (TestList - [ TestLabel "[Output]" $ - TestList - [ testCharInstances - (\ i -> TestCase (do b <- readProcessChunks (proc "cat" ["Tests/text"]) i - assertEqual - "UTF8" - ["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 ", - -- 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 ", - "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 <- L.readFile "Tests/penguin.jpg" >>= - readCreateProcess (proc "djpeg" []) >>= - readCreateProcess (proc "pnmfile" []) - assertEqual "pnmfile" (lazyFromString "stdin:\tPPM raw, 96 by 96 maxval 255\n") out) - , TestLabel "pnmfile2" $ - 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, 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" []) (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: : hGetChar: end of file\n")) result) - , TestLabel "file closed 3" $ - 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" :: LT.Text) - assertEqual "file closed 4" (ExitSuccess, "a", "Read one character: 'a'\n") result) - ]) diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,135 +0,0 @@ -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 Sun, 31 Aug 2014 07:15:28 -0700 - -haskell-process-listlike (0.8) unstable; urgency=low - - * Replace the implementation of readCreateProcessWithExitCode - with a call to readProcessInterleaved. Almost did the same - with readCreateProcess, but it was simpler to make it a near - copy of readProcessInterleaved. - - -- David Fox Sat, 30 Aug 2014 13:08:47 -0700 - -haskell-process-listlike (0.7) unstable; urgency=low - - * Add module System.Process.Read.Interleaved (from process-progress) - * Add module System.Process.Read.Chunks (from process-progress) - * Rename module System.Process.Read.Chars -> System.Process.Read.ListLike - - -- David Fox Tue, 26 Aug 2014 11:16:13 -0700 - -haskell-process-listlike (0.6.2) unstable; urgency=low - - * Make changelog visible in hackage. - - -- David Fox Tue, 15 Oct 2013 07:40:46 -0700 - -haskell-process-listlike (0.6.1) unstable; urgency=low - - * Add System.Process.String. - - -- David Fox Wed, 22 May 2013 11:22:06 -0700 - -haskell-process-listlike (0.6) unstable; urgency=low - - * Use the ListLike and ListLikeIO classes as the basis of the - class of types the readProcess functions use. - * Move the Chunk code to the process-progress package. - - -- David Fox Wed, 28 Nov 2012 08:17:47 -0800 - -haskell-process-extras (0.5) unstable; urgency=low - - * Modify the signature of the readModifiedProcess* functions - to take a CreateProcess rather than a function to modify a - CreateProcess. - - -- David Fox Mon, 12 Nov 2012 18:37:40 -0800 - -haskell-process-extras (0.4.7) unstable; urgency=low - - * Add compatibility modules for the original process-extras. - - -- David Fox Wed, 24 Oct 2012 14:46:59 -0700 - -haskell-process-extras (0.4.6) unstable; urgency=low - - * Forked off process-progress. - - -- David Fox Wed, 24 Oct 2012 11:31:34 -0700 - -haskell-process-extras (0.4.5) unstable; urgency=low - - * Add Verbosity module - * Print newline after last dot - - -- David Fox Tue, 23 Oct 2012 10:33:25 -0700 - -haskell-process-extras (0.4.4) unstable; urgency=low - - * Replace all the lazyCommand*/lazyProcess* functions with runProcess*. - - -- David Fox Tue, 23 Oct 2012 08:07:37 -0700 - -haskell-process-extras (0.4.3) unstable; urgency=low - - * More cleanups in readProcessChunks - * Unit tests - * Start of thread based version of readProcessChunks - * Start of pipes based version of readProcessChunks - - -- David Fox Mon, 22 Oct 2012 16:15:14 -0700 - -haskell-process-extras (0.4.1) unstable; urgency=low - - * Redo and simplify readProcessChunks so it works on infinite streams without - hanging or leaking memory. - * Add some tests (though not in a formal framework yet.) - - -- David Fox Sat, 20 Oct 2012 15:24:15 -0700 - -haskell-process-extras (0.4) unstable; urgency=low - - * Re-arrange the modules so that we can generally just import - System.Process.Read. - * Rename readProcessChunksWithExitCode -> readProcessChunks - * Rename class Strng -> class Chars - * Rename class Strng2 -> class NonBlocking - - -- David Fox Thu, 18 Oct 2012 08:13:36 -0700 - -haskell-process-extras (0.3.8) unstable; urgency=low - - * No, we still need to catch ResourceVanished. Ingoring it seems to - be sufficient, don't change the signatures back to indicate when it - happens. - - -- David Fox Wed, 17 Oct 2012 23:52:21 -0700 - -haskell-process-extras (0.3.7) unstable; urgency=low - - * The code that catches ResourceVanished seems to be unnecessary now, - remove it. - - -- David Fox Wed, 17 Oct 2012 15:30:52 -0700 - -haskell-process-extras (0.3.6) unstable; urgency=low - - * Call hSetBinaryMode in all the ByteString instances of Strng - * Fix a bug which prevented stderr from being forced - * Change to emulate behavior of System.Process for input handle - - -- David Fox Wed, 17 Oct 2012 15:02:09 -0700 - -haskell-process-extras (0.3.5) unstable; urgency=low - - * Add instances and implementations for the String type. - - -- David Fox Wed, 17 Oct 2012 09:41:03 -0700 - diff --git a/process-listlike.cabal b/process-listlike.cabal --- a/process-listlike.cabal +++ b/process-listlike.cabal @@ -1,61 +1,60 @@ Name: process-listlike -Version: 0.9 -Synopsis: Enhanced version of process-extras -Description: Extra functionality for the Process library . - This is a drop-in replacement for , - which adds support for creating processes from a CreateProcess, more access to the - internals, and completes support for the String type. -Homepage: http://src.seereason.com/process-listlike +Version: 0.10 +Synopsis: Process extras +Description: Extra functionality for the Process library + . +Homepage: https://github.com/ddssff/process-listlike License: MIT License-file: LICENSE -Author: David Lazar, Bas van Dijk, David Fox -Maintainer: David Fox +Author: David Lazar, Bas van Dijk +Maintainer: David Lazar Category: System Build-type: Simple -Cabal-version: >=1.8 -Extra-Source-Files: changelog +Cabal-version: >= 1.8 +Extra-source-files: + README.md source-repository head - Type: darcs - Location: https://github.com/ddssff/process-listlike.git + Type: git + Location: https://github.com/ddssff/process-listlike Library - ghc-options: -Wall -O2 + ghc-options: -Wall + Hs-source-dirs: src + Exposed-modules: - System.Process.Chunks - System.Process.Lazy - System.Process.ListLike System.Process.ByteString System.Process.ByteString.Lazy - System.Process.Strict + System.Process.Chunks + System.Process.ListLike + System.Process.ListLike.Classes + System.Process.ListLike.Instances + System.Process.ListLike.LazyString + System.Process.ListLike.Read + System.Process.ListLike.ReadNoThreads + System.Process.ListLike.StrictString System.Process.String System.Process.Text System.Process.Text.Lazy + Other-modules: + Utils + Build-depends: base >= 4 && < 5, + process, bytestring, - deepseq, - HUnit, - ListLike >= 4.0, + ListLike >= 4, mtl, - process, text, - utf8-string + deepseq Executable process-listlike-tests - Main-Is: Tests/Main.hs + Main-Is: tests/Main.hs + Build-depends: base >= 4, bytestring, deepseq, process, process-listlike, utf8-string, unix, text, HUnit, ListLike, regex-posix + +Executable process-listlike-interactive-tests + Main-Is: tests/Interactive.hs GHC-Options: -Wall -O2 -threaded -rtsopts - Build-Depends: - base >= 4 && < 5, - bytestring, - deepseq, - HUnit, - ListLike, - mtl, - process, - process-listlike, - text, - utf8-string, - unix + Build-Depends: base >= 4, bytestring, deepseq, HUnit, ListLike, mtl, process, process-listlike, text, utf8-string, unix diff --git a/src/System/Process/ByteString.hs b/src/System/Process/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/ByteString.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleContexts #-} +module System.Process.ByteString where + +import Data.ByteString (ByteString) +import System.Process +import System.Process.ListLike.Classes (ProcessOutput) +import qualified System.Process.ListLike.Read as LL (readCreateProcess, readProcess) +import System.Exit (ExitCode) + +readCreateProcess :: ProcessOutput ByteString b => CreateProcess -> ByteString -> IO b +readCreateProcess = LL.readCreateProcess + +-- | Like 'System.Process.readProcessWithExitCode', but takes a +-- CreateProcess instead of a command and argument list, and reads and +-- writes type 'ByteString' +readCreateProcessWithExitCode + :: CreateProcess -- ^ command to run + -> ByteString -- ^ standard input + -> IO (ExitCode, ByteString, ByteString) -- ^ exitcode, stdout, stderr +readCreateProcessWithExitCode = LL.readCreateProcess + +-- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString' +readProcessWithExitCode :: FilePath -> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString) +readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input + +-- | Like 'System.Process.readProcess', but using 'ByteString' +readProcess :: FilePath -> [String] -> ByteString -> IO ByteString +readProcess = LL.readProcess diff --git a/src/System/Process/ByteString/Lazy.hs b/src/System/Process/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/ByteString/Lazy.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleContexts #-} +module System.Process.ByteString.Lazy where + +import Data.ByteString.Lazy (ByteString) +import System.Exit (ExitCode) +import System.Process +import qualified System.Process.ListLike.Read as LL (readCreateProcess, readProcess) +import System.Process.ListLike.Classes (ProcessOutput) + +readCreateProcess :: ProcessOutput ByteString b => CreateProcess -> ByteString -> IO b +readCreateProcess = LL.readCreateProcess + +-- | Like 'System.Process.readProcessWithExitCode', but takes a +-- CreateProcess instead of a command and argument list, and reads and +-- writes type 'ByteString' +readCreateProcessWithExitCode + :: CreateProcess -- ^ command to run + -> ByteString -- ^ standard input + -> IO (ExitCode, ByteString, ByteString) -- ^ exitcode, stdout, stderr +readCreateProcessWithExitCode = LL.readCreateProcess + +-- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString' +readProcessWithExitCode :: FilePath -> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString) +readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input + +-- | Like 'System.Process.readProcess', but using 'ByteString' +readProcess :: FilePath -> [String] -> ByteString -> IO ByteString +readProcess = LL.readProcess diff --git a/src/System/Process/Chunks.hs b/src/System/Process/Chunks.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Chunks.hs @@ -0,0 +1,230 @@ +-- | Support for using the 'Chunk' list returned by 'readProcessChunks'. +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} +module System.Process.Chunks + ( Chunk(..) + , readCreateProcessChunks + , discardEmptyChunks + , fuseChunks + , collectProcessTriple + , collectProcessResult + , collectProcessOutput + , indentChunks + , dotifyChunks + , putChunk + , putMappedChunks + , putIndented + , putIndentedShowCommand + , putDots + , putDotsLn + , insertCommandStart + , insertCommandResult + , insertCommandDisplay + , showCreateProcessForUser + , showCmdSpecForUser + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.DeepSeq (NFData) +import Control.Exception (SomeException) +import Control.Monad.State (StateT, evalState, evalStateT, get, put) +import Control.Monad.Trans (lift) +import Data.ListLike (ListLike(..), ListLikeIO(hPutStr, putStr)) +import Data.Monoid (Monoid, (<>), mempty) +import Data.String (IsString(fromString)) +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(cmdspec, cwd), CmdSpec(..), showCommandForUser) +import System.Process.ListLike.Classes (ListLikeLazyIO, ProcessOutput(pidf, outf, errf, intf, codef)) +import System.Process.ListLike.Read (readCreateProcess) + +-- | A concrete representation of the methods in ProcessOutput. +data Chunk a + = ProcessHandle ProcessHandle -- ^ This will always come first + | Stdout a + | Stderr a + | Exception SomeException + | Result ExitCode + +instance ListLikeLazyIO a c => ProcessOutput a [Chunk a] where + pidf p = [ProcessHandle p] + outf x = [Stdout x] + errf x = [Stderr x] + intf e = [Exception e] + codef c = [Result c] + +instance ListLikeLazyIO a c => ProcessOutput a (ExitCode, [Chunk a]) where + pidf p = (mempty, [ProcessHandle p]) + codef c = (c, mempty) + outf x = (mempty, [Stdout x]) + errf x = (mempty, [Stderr x]) + intf e = (mempty, [Exception e]) + +-- | This lets us use DeepSeq's 'Control.DeepSeq.force' on a stream +-- of Chunks. +instance NFData ExitCode + +-- | A concrete use of 'readCreateProcess' - build a list containing +-- chunks of process output, any exceptions that get thrown, and +-- finally an exit code. If a is a lazy type the returned list will +-- be lazy. +readCreateProcessChunks :: (ListLikeLazyIO a c) => CreateProcess -> a -> IO [Chunk a] +readCreateProcessChunks = readCreateProcess + +-- | Eliminate empty Stdout or Stderr chunks. +discardEmptyChunks :: ListLikeLazyIO a c => [Chunk a] -> [Chunk a] +discardEmptyChunks [] = [] +discardEmptyChunks (Stdout a : more) | null a = discardEmptyChunks more +discardEmptyChunks (Stderr a : more) | null a = discardEmptyChunks more +discardEmptyChunks (a : more) = a : discardEmptyChunks more + +-- | Merge adjacent Stdout or Stderr chunks. This may be undesirable +-- if you want to get your input as soon as it becomes available, it +-- has the effect of making the result "less lazy". +fuseChunks :: ListLikeLazyIO a c => [Chunk a] -> [Chunk a] +fuseChunks [] = [] +fuseChunks (Stdout a : Stdout b : more) = fuseChunks (Stdout (a <> b) : more) +fuseChunks (Stderr a : Stderr b : more) = fuseChunks (Stderr (a <> b) : more) +fuseChunks (Stdout a : more) | null a = fuseChunks more +fuseChunks (Stderr a : more) | null a = fuseChunks more +fuseChunks (a : more) = a : fuseChunks more + +collectProcessTriple :: Monoid a => [Chunk a] -> (ExitCode, a, a) +collectProcessTriple [] = mempty +collectProcessTriple (Result x : xs) = (x, mempty, mempty) <> collectProcessTriple xs +collectProcessTriple (Stdout x : xs) = (mempty, x, mempty) <> collectProcessTriple xs +collectProcessTriple (Stderr x : xs) = (mempty, mempty, x) <> collectProcessTriple xs +collectProcessTriple (_ : xs) = collectProcessTriple xs + +collectProcessResult :: Monoid a => [Chunk a] -> (ExitCode, [Chunk a]) +collectProcessResult [] = mempty +collectProcessResult (Result x : xs) = (x, mempty) <> collectProcessResult xs +collectProcessResult (x : xs) = (mempty, [x]) <> collectProcessResult xs + +collectProcessOutput :: Monoid a => [Chunk a] -> (ExitCode, a) +collectProcessOutput [] = mempty +collectProcessOutput (Result x : xs) = (x, mempty) <> collectProcessOutput xs +collectProcessOutput (Stdout x : xs) = (mempty, x) <> collectProcessOutput xs +collectProcessOutput (Stderr x : xs) = (mempty, x) <> collectProcessOutput xs +collectProcessOutput (_ : xs) = mempty <> collectProcessOutput xs + +-- | Pure function to indent the text of a chunk list. +indentChunks :: forall a c. (ListLikeLazyIO a c, Eq c, IsString a) => String -> String -> [Chunk a] -> [Chunk a] +indentChunks outp errp chunks = + evalState (Prelude.concat <$> mapM (indentChunk nl (fromString outp) (fromString errp)) chunks) BOL + where + nl :: c + nl = Data.ListLike.head (fromString "\n" :: a) + +-- | 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, ListLikeLazyIO 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 + +dotifyChunks :: forall a c. (ListLikeLazyIO a c) => Int -> c -> [Chunk a] -> [Chunk a] +dotifyChunks charsPerDot dot chunks = + evalState (Prelude.concat <$> mapM (dotifyChunk charsPerDot dot) chunks) 0 + +-- | dotifyChunk charsPerDot dot chunk - Replaces every charsPerDot +-- characters in the Stdout and Stderr chunks with one dot. Runs in +-- the state monad to keep track of how many characters had been seen +-- when the previous chunk finished. chunks. +dotifyChunk :: forall a c m. (Monad m, Functor m, ListLikeLazyIO 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 [] + +-- | Write the Stdout chunks to stdout and the Stderr chunks to stderr. +putChunk :: ListLikeLazyIO a c => Chunk a -> IO () +putChunk (Stdout x) = putStr x +putChunk (Stderr x) = hPutStr stderr x +putChunk _ = return () + +-- | Apply a function to the chunk list and output the result, +-- return the original (unmodified) chunk list. +putMappedChunks :: ListLikeLazyIO a c => ([Chunk a] -> [Chunk a]) -> [Chunk a] -> IO [Chunk a] +putMappedChunks f chunks = mapM_ putChunk (f chunks) >> return chunks + +-- | Output the indented text of a chunk list, but return the original +-- unindented list. +putIndented :: (ListLikeLazyIO a c, Eq c, IsString a) => String -> String -> [Chunk a] -> IO [Chunk a] +putIndented outp errp chunks = putMappedChunks (indentChunks outp errp) chunks + +putIndentedShowCommand :: (ListLikeLazyIO a c, Eq c, IsString a) => + CreateProcess -> String -> String -> [Chunk a] -> IO [Chunk a] +putIndentedShowCommand p outp errp chunks = + putMappedChunks (insertCommandDisplay p . indentChunks outp errp) chunks + +-- | Output the dotified text of a chunk list. Returns the original +-- (undotified) list. +putDots :: (ListLikeLazyIO 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 + +-- | Output the dotified text of a chunk list with a newline at EOF. +-- Returns the original list. +putDotsLn :: forall a c. (IsString a, ListLikeLazyIO a c) => Int -> c -> [Chunk a] -> IO [Chunk a] +putDotsLn cpd dot chunks = putDots cpd dot chunks >>= \ r -> hPutStr stderr (fromString "\n" :: a) >> return r + +-- | Insert a chunk displaying the command and its arguments at the +-- beginning of the chunk list. +insertCommandStart :: (IsString a, ListLikeLazyIO a c, Eq c) => + CreateProcess -> [Chunk a] -> [Chunk a] +insertCommandStart p chunks = [Stderr (fromString (" -> " ++ showCreateProcessForUser p ++ "\n"))] <> chunks + +-- | Insert a chunk displaying the command and the result code. +insertCommandResult :: (IsString a, ListLikeLazyIO a c, Eq c) => + CreateProcess -> [Chunk a] -> [Chunk a] +insertCommandResult _ [] = [] +insertCommandResult p (Result code : xs) = + Stderr (fromString (" <- " ++ show code ++ " <- " ++ showCmdSpecForUser (cmdspec p) ++ "\n")) : + Result code : + xs +insertCommandResult p (x : xs) = x : insertCommandResult p xs + +insertCommandDisplay :: (IsString a, ListLikeLazyIO a c, Eq c) => CreateProcess -> [Chunk a] -> [Chunk a] +insertCommandDisplay p = insertCommandResult p . insertCommandStart p + +showCreateProcessForUser :: CreateProcess -> String +showCreateProcessForUser p = + showCmdSpecForUser (cmdspec p) ++ maybe "" (\ d -> " (in " ++ d ++ ")") (cwd p) + +showCmdSpecForUser :: CmdSpec -> String +showCmdSpecForUser (ShellCommand s) = s +showCmdSpecForUser (RawCommand p args) = showCommandForUser p args diff --git a/src/System/Process/ListLike.hs b/src/System/Process/ListLike.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/ListLike.hs @@ -0,0 +1,8 @@ +module System.Process.ListLike + ( module System.Process.ListLike.Classes + , module System.Process.ListLike.Read + ) where + +import System.Process.ListLike.Classes +import System.Process.ListLike.Instances () +import System.Process.ListLike.Read diff --git a/src/System/Process/ListLike/Classes.hs b/src/System/Process/ListLike/Classes.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/ListLike/Classes.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-} +module System.Process.ListLike.Classes + ( ListLikeLazyIO(..) + , ProcessOutput(..) + ) where + +import Control.Exception (SomeException) +import Data.ListLike (ListLikeIO(..)) +import Data.ListLike.Text.Text () +import Data.ListLike.Text.TextLazy () +import Data.Monoid (Monoid(mempty, mappend)) +import Prelude hiding (null, length, rem) +import System.Exit (ExitCode(ExitFailure)) +import System.IO hiding (hPutStr, hGetContents) +import System.Process (ProcessHandle) + +-- | Methods for turning the output of a process into a monoid. +class Monoid b => ProcessOutput a b | b -> a where + pidf :: ProcessHandle -> b + outf :: a -> b + errf :: a -> b + intf :: SomeException -> b + codef :: ExitCode -> b + +-- | A process usually has one 'ExitCode' at the end of its output, this 'Monoid' +-- instance lets us build the type returned by 'System.Process.readProcessWithExitCode'. +instance Monoid ExitCode where + mempty = ExitFailure 0 + mappend x (ExitFailure 0) = x + mappend _ x = x + +-- | Class of types which can be used as the input and outputs of +-- these process functions. +class ListLikeIO a c => ListLikeLazyIO a c where + 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. diff --git a/src/System/Process/ListLike/Instances.hs b/src/System/Process/ListLike/Instances.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/ListLike/Instances.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} + +-- | ListLikeLazyIO instances for strict and lazy types. If you start a +-- long running process with a strict type it will block until the +-- process finishes. Why not try a lazy type? + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module System.Process.ListLike.Instances where + +import Control.DeepSeq (force) +import Control.Exception as E (evaluate, throw) +import Data.ByteString.Char8 as B (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.ListLike.IO (hGetContents) +import Data.Monoid (mempty) +import Data.Text as T (Text) +import qualified Data.Text.Lazy as LT +import Data.Word (Word8) +import System.Exit (ExitCode) +import System.Process.ListLike.Classes (ListLikeLazyIO(..), ProcessOutput(..)) + +instance ListLikeLazyIO B.ByteString Word8 where + --setModes _ (inh, outh, errh, _) = f inh >> f outh >> f errh where f = maybe (return ()) (\ h -> hSetBinaryMode h True) + readChunks h = hGetContents h >>= return . force . (: []) + +instance ListLikeLazyIO T.Text Char where + --setModes _ _ = return () + readChunks h = hGetContents h >>= return . force . (: []) + +instance ListLikeLazyIO L.ByteString Word8 where + --setModes _ (inh, outh, errh, _) = f inh >> f outh >> f errh where f = maybe (return ()) (\ h -> hSetBinaryMode h True) + readChunks h = hGetContents h >>= evaluate . Prelude.map (L.fromChunks . (: [])) . L.toChunks + +instance ListLikeLazyIO LT.Text Char where + --setModes _ _ = return () + readChunks h = hGetContents h >>= evaluate . Prelude.map (LT.fromChunks . (: [])) . LT.toChunks + +instance ListLikeLazyIO a c => ProcessOutput a (ExitCode, a, a) where + pidf _ = mempty + codef c = (c, mempty, mempty) + outf x = (mempty, x, mempty) + errf x = (mempty, mempty, x) + intf e = throw e diff --git a/src/System/Process/ListLike/LazyString.hs b/src/System/Process/ListLike/LazyString.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/ListLike/LazyString.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} +module System.Process.ListLike.LazyString where + +import Data.Text as T (unpack) +import Data.Text.Lazy as LT (toChunks) +import System.Process.ListLike.Classes (ListLikeLazyIO(readChunks)) +import System.Process.ListLike.Instances () + +-- | 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 ListLikeLazyIO String Char where + readChunks h = readChunks h >>= return . map T.unpack . concat . map LT.toChunks diff --git a/src/System/Process/ListLike/Read.hs b/src/System/Process/ListLike/Read.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/ListLike/Read.hs @@ -0,0 +1,165 @@ +-- | Generalized versions of the functions +-- 'System.Process.readProcess', and +-- 'System.Process.readProcessWithExitCode'. +{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, ScopedTypeVariables, TupleSections, TypeFamilies, UndecidableInstances #-} +module System.Process.ListLike.Read + ( readCreateProcess, + readCreateProcess', + readInterleaved, + readCreateProcessWithExitCode, + readProcessWithExitCode, + StdoutWrapper(..), + readProcess + ) where + +import Control.Applicative ((<$>), (<*>), pure) +import Control.Concurrent +import Control.Exception as E (SomeException, onException, catch, mask, throw) +import Control.Monad +import Data.ListLike (ListLike(..), ListLikeIO(..)) +import Data.ListLike.Text.Text () +import Data.ListLike.Text.TextLazy () +import Data.Maybe (maybeToList) +import Data.Monoid (Monoid(mempty, mappend), (<>)) +import GHC.IO.Exception (IOErrorType(OtherError, ResourceVanished), IOException(ioe_type)) +import Prelude hiding (null, length, rem) +import System.Exit (ExitCode(ExitSuccess)) +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, + createProcess, waitForProcess, terminateProcess) +import System.Process.ListLike.Classes (ListLikeLazyIO(..), ProcessOutput(..)) +import System.Process.ListLike.Instances () +import Utils (forkWait) + +-- | 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. +readCreateProcess :: (ListLikeLazyIO a c, ProcessOutput a b) => CreateProcess -> a -> IO b +readCreateProcess p input = + readCreateProcess' (p {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }) input + +readCreateProcess' :: (ListLikeLazyIO a c, ProcessOutput a b) => CreateProcess -> a -> IO b +readCreateProcess' p input = mask $ \ restore -> do + (Just inh, maybe_outh, maybe_errh, pid) <- createProcess p + + onException + (restore $ + do -- Without unsafeIntereleaveIO the pid messsage gets stuck + -- until some additional output arrives from the process. + waitOut <- forkWait $ (<>) <$> pure (pidf pid) + <*> unsafeInterleaveIO (readInterleaved (maybeToList (fmap (outf,) maybe_outh) <> maybeToList (fmap (errf,) maybe_errh)) + (codef <$> waitForProcess pid)) + writeInput inh input + waitOut) + (do terminateProcess pid + hClose inh + maybe (return ()) hClose maybe_outh + maybe (return ()) hClose maybe_errh + waitForProcess pid) + +-- | 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. (ListLikeLazyIO a c, ProcessOutput a b) => + [(a -> b, Handle)] -> IO b -> IO b +readInterleaved pairs finish = newEmptyMVar >>= readInterleaved' pairs finish + +readInterleaved' :: forall a b c. (ListLikeLazyIO a c, ProcessOutput a b) => + [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b +readInterleaved' pairs finish res = do + mapM_ (forkIO . uncurry readHandle) pairs + takeChunks (length pairs) + where + -- Forked thread to read the input and send it to takeChunks via + -- the MVar. + readHandle :: (a -> b) -> Handle -> IO () + readHandle f h = do + 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 cs) + mapM_ (\ c -> putMVar res (Right (f c))) cs + hClose h + putMVar res (Left h) + takeChunks :: Int -> IO b + takeChunks 0 = finish + takeChunks openCount = takeChunk >>= takeMore openCount + takeMore :: Int -> Either Handle b -> IO b + takeMore openCount (Left h) = hClose h >> takeChunks (openCount - 1) + takeMore openCount (Right x) = + do xs <- unsafeInterleaveIO $ takeChunks openCount + return (x <> xs) + takeChunk = takeMVar res `catch` (\ (e :: SomeException) -> return $ Right $ intf e) + +-- | An implementation of 'System.Process.readProcessWithExitCode' +-- with a two generalizations: (1) The input and outputs can be any +-- instance of 'ListLikeLazyIO', 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 :: ListLikeLazyIO a c => + CreateProcess -- ^ process to run + -> a -- ^ standard input + -> IO (ExitCode, a, a) -- ^ exitcode, stdout, stderr +readCreateProcessWithExitCode p input = readCreateProcess p input + +-- | A version of 'System.Process.readProcessWithExitCode' that uses +-- any instance of 'ListLikeLazyIO' instead of 'String', implemented +-- using 'readCreateProcessWithExitCode'. +readProcessWithExitCode :: ListLikeLazyIO a c => + FilePath -- ^ command to run + -> [String] -- ^ any arguments + -> a -- ^ standard input + -> IO (ExitCode, a, a) -- ^ exitcode, stdout, stderr +readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input + +-- | Implementation of 'System.Process.readProcess' that uses any +-- instance of 'ListLikeLazyIO' instead of 'String', implemented using +-- 'readCreateProcess'. As with 'System.Process.readProcess', Stderr +-- goes directly to the console, only stdout is returned. Also like +-- 'System.Process.readProcess', an IO error of type OtherError is +-- thrown when the result code is not ExitSuccess. +readProcess :: ListLikeLazyIO a c => + FilePath -- ^ command to run + -> [String] -- ^ any arguments + -> a -- ^ standard input + -> IO a -- ^ stdout +readProcess cmd args input = + unStdoutWrapper <$> readCreateProcess' ((proc cmd args) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit}) input + +-- | For the 'readProcess' function, we need to wrap a newtype around +-- the output type so we can build a ProcessOutput instance for it. +-- Otherwise it would overlap everything. +newtype StdoutWrapper a = StdoutWrapper {unStdoutWrapper :: a} + +instance Monoid a => Monoid (StdoutWrapper a) where + mempty = StdoutWrapper mempty + mappend (StdoutWrapper a) (StdoutWrapper b) = StdoutWrapper (a <> b) + +instance (ListLikeLazyIO a c, Monoid a) => ProcessOutput a (StdoutWrapper a) where + pidf _ = mempty + codef ExitSuccess = mempty + codef failure = throw $ IO.mkIOError OtherError ("Process exited with " ++ show failure) Nothing Nothing + outf x = StdoutWrapper x + errf _ = mempty + intf e = throw e + +-- | 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 :: ListLikeLazyIO a c => Handle -> a -> IO () +writeInput inh input = do + (do unless (null input) (hPutStr inh input >> hFlush inh) + hClose inh) `E.catch` resourceVanished (\ _ -> 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 +-- before they have read all of their input. +resourceVanished :: (IOError -> IO a) -> IOError -> IO a +resourceVanished epipe e = if ioe_type e == ResourceVanished then epipe e else ioError e diff --git a/src/System/Process/ListLike/ReadNoThreads.hs b/src/System/Process/ListLike/ReadNoThreads.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/ListLike/ReadNoThreads.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE MultiParamTypeClasses, PackageImports, ScopedTypeVariables #-} +{-# OPTIONS -Wwarn -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures #-} + +-- | This is an alternative version of the module +-- "System.Process.ListLike.Read" that doesn't use forkIO. I don't +-- know of any advantages, I'm just including it because it is derived +-- from old code I had developed, it is kinda badass, and maybe +-- someone has a use for it. +-- +-- Function 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. +module System.Process.ListLike.ReadNoThreads + ( ListLikeIOPlus(..) + , readCreateProcess + , readCreateProcessWithExitCode + , readProcessWithExitCode + ) where + +import Control.Applicative ((<$>), (<*>), pure) +import Control.Concurrent (threadDelay) +import Control.Exception (catch, mask, onException, try) +import Data.ListLike (ListLike(length, null), ListLikeIO(hGetNonBlocking)) +import Data.Maybe (mapMaybe) +import Data.Monoid (Monoid(mempty), (<>), mconcat) +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified GHC.IO.Exception as E +import Prelude hiding (length, null) +import System.Exit (ExitCode) +import System.Process (ProcessHandle, CreateProcess(..), waitForProcess, proc, createProcess, StdStream(CreatePipe), terminateProcess) +import System.IO (Handle, hReady, hClose) +import System.IO.Unsafe (unsafeInterleaveIO) +import System.Process.ListLike.Classes (ProcessOutput(..), ListLikeLazyIO(..)) +import System.Process.ListLike.Instances () + +-- For the ListLikeIOPlus instance +import qualified Data.ByteString.Lazy as L +import Data.Word (Word8) + +-- | For the unthreaded implementation we need a more powerful +-- ListLikeLazyIO class. +class ListLikeLazyIO a c => ListLikeIOPlus a c where + hPutNonBlocking :: Handle -> a -> IO a + chunks :: a -> [a] + +instance ListLikeIOPlus L.ByteString Word8 where + hPutNonBlocking = L.hPutNonBlocking + chunks = Prelude.map (L.fromChunks . (: [])) . L.toChunks + +instance ListLikeIOPlus LT.Text Char where + hPutNonBlocking h text = L.hPutNonBlocking h (encodeUtf8 text) >> return text + chunks = map (LT.fromChunks . (: [])) . LT.toChunks + +bufSize = 65536 -- maximum chunk size +uSecs = 8 -- minimum wait time, doubles each time nothing is ready +maxUSecs = 100000 -- maximum wait time (microseconds) + +readCreateProcess :: forall a b c. (ListLikeIOPlus a c, ProcessOutput a b) => CreateProcess -> a -> IO b +readCreateProcess p input = mask $ \ restore -> do + (Just inh, Just outh, Just errh, pid) <- + createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe}) + + -- setModes input hs + + -- The uses of unsafeInterleaveIO here and below are required to + -- keep the output from blocking waiting for process exit. + onException + (restore $ (<>) <$> pure (pidf pid) + <*> (unsafeInterleaveIO $ elements pid (chunks input, Just inh, [(outf, outh), (errf, errh)], Nothing))) + (do terminateProcess pid; hClose inh; hClose outh; hClose errh; + waitForProcess pid) + where + elements :: ProcessHandle -> ([a], Maybe Handle, [(a -> b, Handle)], Maybe b) -> IO b + -- 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 nowhere else is a Result added. However, the process + -- doing the traversing might die before that end is reached. + elements pid tuple@(_, _, [], elems) = + do result <- try (waitForProcess pid) + case result of + Left exn -> (<>) <$> pure (maybe mempty id elems <> intf exn) <*> elements pid tuple + Right code -> pure (maybe mempty id elems <> codef code) + -- The available output has been processed, send input and read + -- from the ready handles + elements pid tuple@(_, _, _, Nothing) = + do result <- try (ready uSecs tuple) + case result of + Left exn -> (<>) <$> pure (intf exn) <*> elements pid tuple + Right tuple' -> elements pid tuple' + -- Add some output to the result value + elements pid (input, inh, pairs, Just elems) = + (<>) <$> pure elems + <*> (unsafeInterleaveIO $ elements pid (input, inh, pairs, Nothing)) + +-- A quick fix for the issue where hWaitForInput has actually started +-- raising the isEOFError exception in ghc 6.10. +data Readyness = Ready | Unready | EndOfFile deriving Eq + +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 :: (ListLikeIOPlus a c, ProcessOutput a b) => + Int -> ([a], Maybe Handle, [(a -> b, Handle)], Maybe b) + -> IO ([a], Maybe Handle, [(a -> b, Handle)], Maybe b) +ready waitUSecs (input, inh, pairs, elems) = + do + anyReady <- mapM (hReady' . snd) pairs + case (input, inh, anyReady) of + -- Input exhausted, close the input handle. + ([], Just handle, _) | all (== Unready) anyReady -> + do hClose handle + ready waitUSecs ([], Nothing, pairs, elems) + -- Input handle closed and there are no ready output handles, + -- wait a bit + ([], Nothing, _) | all (== Unready) anyReady -> + do threadDelay waitUSecs + --ePut0 ("Slept " ++ show uSecs ++ " microseconds\n") + ready (min maxUSecs (2 * waitUSecs)) (input, inh, pairs, elems) + -- Input is available and there are no ready output handles + (input : etc, Just handle, _) + -- Discard a zero byte input + | all (== Unready) anyReady && null input -> ready waitUSecs (etc, inh, pairs, elems) + -- Send some input to the process + | all (== Unready) anyReady -> + do input' <- hPutNonBlocking handle input + case null input' of + -- Input buffer is full too, sleep. + True -> do threadDelay uSecs + ready (min maxUSecs (2 * waitUSecs)) (input : etc, inh, pairs, elems) + -- We wrote some input, discard it and continue + False -> return (input' : etc, Just handle, pairs, elems) + -- One or both output handles are ready, try to read from them + _ -> + do allOutputs <- mapM (\ ((f, h), r) -> nextOut h r f) (zip pairs anyReady) + let newPairs = mapMaybe (\ ((_, mh), (f, _)) -> maybe Nothing (\ h -> Just (f, h)) mh) (zip allOutputs pairs) + return (input, inh, newPairs, elems <> mconcat (map fst allOutputs)) + +-- | Return the next output element and the updated handle +-- from a handle which is assumed ready. +nextOut :: (ListLikeIO a c, ProcessOutput a b) => Handle -> Readyness -> (a -> b) -> IO (Maybe b, Maybe Handle) +nextOut _ EndOfFile _ = return (Nothing, Nothing) -- Handle is closed +nextOut handle Unready _ = return (Nothing, Just handle) -- Handle is not ready +nextOut handle Ready constructor = -- Perform a read + do + a <- hGetNonBlocking handle bufSize + case length a of + -- A zero length read, unlike a zero length write, always + -- means EOF. + 0 -> do hClose handle + return (Nothing, Nothing) + -- Got some input + _n -> return (Just (constructor a), Just handle) + +readCreateProcessWithExitCode :: (ListLikeIOPlus a c) => CreateProcess -> a -> IO (ExitCode, a, a) +readCreateProcessWithExitCode p input = readCreateProcess p input + +readProcessWithExitCode :: (ListLikeIOPlus a c) => FilePath -> [String] -> a -> IO (ExitCode, a, a) +readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input diff --git a/src/System/Process/ListLike/StrictString.hs b/src/System/Process/ListLike/StrictString.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/ListLike/StrictString.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} +module System.Process.ListLike.StrictString where + +import Control.DeepSeq (force) +import Data.ListLike (hGetContents) +import System.Process.ListLike.Classes (ListLikeLazyIO(readChunks)) + +instance ListLikeLazyIO String Char where + readChunks h = hGetContents h >>= return . force . (: []) diff --git a/src/System/Process/String.hs b/src/System/Process/String.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/String.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleContexts #-} +module System.Process.String where + +import System.Exit (ExitCode) +import System.Process (CreateProcess(..), CmdSpec(..), readProcessWithExitCode) +import System.Process.ListLike.Classes (ProcessOutput, ListLikeLazyIO) +import System.Process.ListLike.Read as LL (readCreateProcess) + +-- No ListLikeLazyIO instance is imported here because we have two and +-- naturally they conflict. +readCreateProcess :: (ListLikeLazyIO String Char, ProcessOutput String b) => CreateProcess -> String -> IO b +readCreateProcess = LL.readCreateProcess + +readCreateProcessWithExitCode + :: ListLikeLazyIO String Char => + CreateProcess -- ^ command to run + -> String -- ^ standard input + -> IO (ExitCode, String, String) -- ^ exitcode, stdout, stderr +readCreateProcessWithExitCode = LL.readCreateProcess diff --git a/src/System/Process/Text.hs b/src/System/Process/Text.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Text.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleContexts #-} +module System.Process.Text where + +import Data.Text (Text) +import System.Process +import System.Process.ListLike.Classes (ProcessOutput) +import qualified System.Process.ListLike.Read as LL (readCreateProcess, readProcess) +import System.Exit (ExitCode) + +readCreateProcess :: ProcessOutput Text b => CreateProcess -> Text -> IO b +readCreateProcess = LL.readCreateProcess + +-- | Like 'System.Process.readProcessWithExitCode', but takes a +-- CreateProcess instead of a command and argument list, and reads and +-- writes type 'ByteString' +readCreateProcessWithExitCode + :: CreateProcess -- ^ command to run + -> Text -- ^ standard input + -> IO (ExitCode, Text, Text) -- ^ exitcode, stdout, stderr +readCreateProcessWithExitCode = LL.readCreateProcess + +-- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString' +readProcessWithExitCode :: FilePath -> [String] -> Text -> IO (ExitCode, Text, Text) +readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input + +-- | Like 'System.Process.readProcess', but using 'Text' +readProcess :: FilePath -> [String] -> Text -> IO Text +readProcess = LL.readProcess diff --git a/src/System/Process/Text/Lazy.hs b/src/System/Process/Text/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Text/Lazy.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} +module System.Process.Text.Lazy where + +import Data.Text.Lazy (Text) +import System.Exit (ExitCode) +import System.Process +import System.Process.ListLike.Classes (ProcessOutput) +import qualified System.Process.ListLike.Read as LL (readCreateProcess, readProcess) + +readCreateProcess :: ProcessOutput Text b => CreateProcess -> Text -> IO b +readCreateProcess = LL.readCreateProcess + +-- | Like 'System.Process.readProcessWithExitCode', but using 'Text' +readCreateProcessWithExitCode + :: CreateProcess -- ^ command to run + -> Text -- ^ standard input + -> IO (ExitCode, Text, Text) -- ^ exitcode, stdout, stderr +readCreateProcessWithExitCode = LL.readCreateProcess + +-- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString' +readProcessWithExitCode :: FilePath -> [String] -> Text -> IO (ExitCode, Text, Text) +readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input + +-- | Like 'System.Process.readProcess', but using 'Text' +readProcess :: FilePath -> [String] -> Text -> IO Text +readProcess = LL.readProcess diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,10 @@ +module Utils where + +import Control.Concurrent +import Control.Exception + +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) diff --git a/tests/Interactive.hs b/tests/Interactive.hs new file mode 100644 --- /dev/null +++ b/tests/Interactive.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving #-} +-- | Tests that require a user to send a keyboard interrupt. +module Main where + +import Control.Exception (SomeException) +import qualified Data.Text.Lazy +import qualified Data.ByteString.Lazy +import Data.Monoid +import System.Process +import System.Process.Chunks (Chunk(..)) +import System.Process.ListLike.Instances () +import qualified System.Process.ListLike.ReadNoThreads as NoThreads +import qualified System.Process.ListLike.Read as Threads +import System.Environment +import System.IO +import Text.Read (readMaybe) + +instance Show ProcessHandle where + show _ = "" + +instance Eq ProcessHandle where + _ == _ = False + +instance Eq SomeException where + _ == _ = False + +deriving instance Show a => Show (Chunk a) + +deriving instance Eq a => Eq (Chunk a) + +main :: IO () +main = do + args <- getArgs + case readArgs args of + Nothing -> + hPutStrLn stderr $ + unlines ([ "usage: interactive-tests test# runner#" + , "tests: " ] ++ + map (\ (n, test) -> " " ++ show n ++ ". " ++ test) (zip ([1..] :: [Int]) tests) ++ + [ "runners: " ] ++ + map (\ (n, (runner, _)) -> " " ++ show n ++ ". " ++ runner) (zip ([1..] :: [Int]) runners)) + Just (test, (s, runner)) -> + do hPutStrLn stderr (test ++ " -> " ++ s) + runner (shell test) + where + readArgs :: [String] -> Maybe (String, (String, CreateProcess -> IO ())) + readArgs [t, r] = + case (readMaybe t, readMaybe r) of + (Just t', Just r') + | t' >= 1 && t' <= length tests && r' >= 1 && r' <= length runners -> + Just (tests !! (t' - 1), runners !! (r' - 1)) + _ -> Nothing + readArgs _ = Nothing + +tests :: [String] +tests = [ "ls -l /tmp" + , "yes | cat -n | while read i; do echo $i; sleep 1; done" + , "oneko" + , "yes | cat -n" ] + +runners :: [(String, CreateProcess -> IO ())] +runners = [ ("NoThreads.readCreateProcess Lazy.Text", + \ p -> NoThreads.readCreateProcess p mempty >>= \ (b :: [Chunk Data.Text.Lazy.Text]) -> + mapM_ (hPutStrLn stderr . show) b) + , ("NoThreads.readCreateProcess Lazy.ByteString", + \ p -> NoThreads.readCreateProcess p mempty >>= \ (b :: [Chunk Data.ByteString.Lazy.ByteString]) -> + mapM_ (hPutStrLn stderr . show) b) + , ("Threads.readCreateProcess Lazy.Text", + \ p -> Threads.readCreateProcess p mempty >>= \ (b :: [Chunk Data.Text.Lazy.Text]) -> + mapM_ (hPutStrLn stderr . show) b) + , ("Threads.readCreateProcess Lazy.ByteString", + \ p -> Threads.readCreateProcess p mempty >>= \ (b :: [Chunk Data.ByteString.Lazy.ByteString]) -> + mapM_ (hPutStrLn stderr . show) b) + ] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE CPP, FlexibleInstances, OverloadedStrings, RankNTypes, ScopedTypeVariables, StandaloneDeriving #-} +module Main where + +import Codec.Binary.UTF8.String (encode) +import Control.Applicative ((<$>)) +import Control.DeepSeq (NFData, force) +import Control.Exception (SomeException, try) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Char (chr, ord) +import Data.List (isSuffixOf) +import Data.ListLike as ListLike (ListLike(length, concat, null, groupBy, head, toList, dropWhile, takeWhile, drop, length), ListLikeIO(readFile)) +import Data.Maybe (mapMaybe) +import Data.Monoid (Monoid(..), (<>)) +import Data.String (IsString(fromString)) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Prelude hiding (length, readFile, head) +import GHC.IO.Exception +import System.Exit +import System.IO (hPutStrLn, stderr) +import System.Posix.Files (getFileStatus, fileMode, setFileMode, unionFileModes, ownerExecuteMode, groupExecuteMode, otherExecuteMode) +import System.Process (CreateProcess, proc, ProcessHandle, shell, readProcessWithExitCode) +import System.Process.ByteString as B +import System.Process.ByteString.Lazy as LB +import System.Process.String as S +import System.Process.Text as T +import System.Process.Text.Lazy as LT +import System.Process.Chunks as Chunks +import System.Process.ListLike.Classes (ListLikeLazyIO, ProcessOutput) +import System.Process.ListLike.Instances +import System.Process.ListLike.StrictString () -- the lazy one is the same as lazy text, the strict one is more interesting to test +import System.Process.ListLike.Read as LL +import System.Timeout +import Test.HUnit hiding (path) +import Text.Regex.Posix ((=~)) +import Text.Printf + +instance Show ProcessHandle where + show _ = "" + +instance Eq ProcessHandle where + _ == _ = False + +instance Eq SomeException where + _ == _ = False + +deriving instance Show a => Show (Chunk a) + +deriving instance Eq a => Eq (Chunk a) + +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] + +type MkTest = forall a c. (Show a, ListLikeLazyIO a c, IsString a, Eq a, Enum c) => String -> a -> Test + +testInstances :: MkTest -> Test +testInstances mkTest = mappend (testCharInstances mkTest) (testWord8Instances mkTest) + +testStrictInstances :: MkTest -> Test +testStrictInstances mkTest = mappend (testStrictCharInstances mkTest) (testStrictWord8Instances mkTest) + +testLazyInstances :: MkTest -> Test +testLazyInstances mkTest = mappend (testLazyCharInstances mkTest) (testLazyWord8Instances mkTest) + +testCharInstances :: MkTest -> Test +testCharInstances mkTest = mappend (testLazyCharInstances mkTest) (testStrictCharInstances mkTest) + +testLazyCharInstances :: MkTest -> Test +testLazyCharInstances mkTest = mkTest "Lazy Text" LT.empty + +testStrictCharInstances :: MkTest -> Test +testStrictCharInstances mkTest = mappend (mkTest "Strict Text" T.empty) (mkTest "String" ("" :: String)) + +testWord8Instances :: MkTest -> Test +testWord8Instances mkTest = mappend (testLazyWord8Instances mkTest) (testStrictWord8Instances mkTest) + +testLazyWord8Instances :: MkTest -> Test +testLazyWord8Instances mkTest = mkTest "Lazy ByteString" LB.empty + +testStrictWord8Instances :: MkTest -> Test +testStrictWord8Instances mkTest = mkTest "Strict ByteString" B.empty + +main :: IO () +main = + do chmod "tests/script1.hs" + chmod "tests/script4.hs" + (c,st) <- runTestText putTextToShowS test1 -- (TestList (versionTests ++ sourcesListTests ++ dependencyTests ++ changesTests)) + putStrLn (st "") + case (failures c) + (errors c) of + 0 -> return () + _ -> exitFailure + +chmod :: FilePath -> IO () +chmod path = + getFileStatus path >>= \ status -> + setFileMode path (foldr unionFileModes (fileMode status) [ownerExecuteMode, groupExecuteMode, otherExecuteMode]) + +cps :: [CreateProcess] +cps = [ proc "true" [] + , proc "false" [] + , shell "foo" + , proc "foo" [] + , shell "yes | cat -n | head 100" + , shell "yes | cat -n" + , proc "cat" ["tests/text"] + , proc "cat" ["tests/houseisclean.jpg"] + , proc "tests/script1.hs" [] + ] + +test1 :: Test +test1 = + TestLabel "test1" + (TestList + [ TestLabel "[Output]" $ + TestList + [ testInstances + (\ s i -> TestLabel s $ TestCase $ do -- We can use a string for the input because the process I/O types + -- are instances of IsString. + result <- LL.readCreateProcessWithExitCode (proc "tests/script4.hs" []) ("a" <> i) + assertEqual "file closed 1" (ExitSuccess, "a", "Read one character: 'a'\n") result) + , testInstances + (\ s i -> TestLabel s $ TestCase $ do + result <- LL.readCreateProcessWithExitCode (proc "tests/script4.hs" []) i + assertEqual "file closed 2" (ExitFailure 1, "", "script4.hs: : hGetChar: end of file\n") result) + , testInstances + (\ s i -> TestLabel s $ TestCase $ do + result <- LL.readCreateProcessWithExitCode (proc "tests/script4.hs" []) ("abcde" <> i) + assertEqual "file closed 3" (ExitSuccess, "a", "Read one character: 'a'\n") result) + , testCharInstances + (\ s i -> TestLabel s $ TestCase $ do + b <- LL.readCreateProcessWithExitCode (proc "cat" ["tests/text"]) i + assertEqual + "Unicode" + (ExitSuccess, + -- For Text, assuming your locale is set to utf8, the result is unicode. + "Signed: Baishi laoren \30333\30707\32769\20154, painted in the artist\8217s 87th year.\n", + "") + b) + , testWord8Instances + (\ s i -> TestLabel s $ TestCase $ do + b <- LL.readCreateProcessWithExitCode (proc "cat" ["tests/text"]) i + assertEqual + "UTF8" + (ExitSuccess, + -- For ByteString we get utf8 encoded text + "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", + "") + b) + , testInstances + (\ s i -> TestLabel s $ TestCase $ do + b <- LL.readCreateProcessWithExitCode (proc "tests/script1.hs" []) i + assertEqual + "ExitFailure" + (ExitFailure 123, + "", + "This is an error message.\n") + b) + , testWord8Instances + (\ s i -> TestLabel s $ TestCase $ do + (ex, out, err) <- LL.readCreateProcessWithExitCode (proc "cat" ["tests/houseisclean.jpg"]) i + assertEqual "Length" (ExitSuccess, 68668, 0) (ex, length out, length err)) + , testInstances + (\ s i -> TestLabel s $ TestCase $ do + l <- LL.readCreateProcessWithExitCode (proc "tests/script1.hs" []) i + assertEqual "Error 123" (ExitFailure 123, "", "This is an error message.\n") l) + , testWord8Instances + (\ s i -> TestLabel s $ TestCase $ do + jpg <- readFile "tests/penguin.jpg" + (code1, pnm, err1) <- LL.readCreateProcessWithExitCode (proc "djpeg" []) (i <> jpg) -- force the return type of readFile to match i + (code2, out2, err2) <- LL.readCreateProcessWithExitCode (proc "pnmfile" []) pnm + assertEqual "pnmfile1" + (ExitSuccess, mempty, 2192, 27661, "stdin:\tPPM raw, 96 by 96 maxval 255\n") + (code1, err1, length jpg, length pnm, out2)) + , testCharInstances + (\ s i -> TestLabel s $ TestCase $ do + Left e <- try $ do jpg <- readFile "tests/penguin.jpg" + (code1, pnm, err1) <- LL.readCreateProcessWithExitCode (proc "djpeg" []) (i <> jpg) + LL.readCreateProcessWithExitCode (proc "pnmfile" []) pnm + assertEqual "pnmfile2" (IOError {ioe_handle = ioe_handle e, + ioe_type = InvalidArgument, + ioe_location = "hGetContents", + ioe_description = "invalid byte sequence", + ioe_errno = Nothing, + ioe_filename = Just "tests/penguin.jpg"}) + (e :: IOError)) + , testInstances + (\ s i -> TestLabel s $ TestCase $ do + let n = case isSuffixOf "ByteString" s of + True -> (50000000 :: Int) + False -> (5000000 :: Int) + l :: Int + l = case isSuffixOf "ByteString" s of + True -> (539000002 :: Int) + False -> (49000001 :: Int) + (ex, out, err) <- LL.readCreateProcessWithExitCode (proc "time" ["bash", "-c", "yes | cat -n | head -n " <> show n]) i + let t = parseTimeOutput err + v = fromInteger (toEnum l) / t + hPutStrLn stderr (printf "%7.2f million chars/second for " (v / 1000000.00) <> s <> " (" <> percentMessage v (expected s) <> ")") + let r = v `about` expected s + assertEqual "5M lines" (ExitSuccess, l, "Within 30% of usual speed") (ex, length out, r)) + -- This demonstrates lazy generation of process output. If + -- you try this with a strict instance the call to + -- readCreateProcessChunks will block indefinitely. + , let expected "Lazy Text" = [Stderr "..",Stderr "..",Stderr "..",Stderr "..",Stderr "..",Stderr "..",Stderr "..",Stderr "..",Stderr ".."] + expected "Lazy ByteString" = [Stderr "................................",Stderr ".................................", + Stderr ".................................",Stderr ".................................", + Stderr "................................",Stderr ".................................", + Stderr ".................................",Stderr ".................................", + Stderr "................................"] + expected _ = error "unexpected" in + testLazyInstances + (\ s i -> TestLabel s $ TestCase $ do + (ProcessHandle _ : chunks) <- LL.readCreateProcess (proc "bash" ["-c", "yes | cat -n"]) i >>= return . take 10 . dotifyChunks 1000 (head (i <> ".")) + assertEqual "ten chunks" (expected s) chunks) + , testInstances + (\ s i -> TestLabel s $ TestCase $ do + hPutStrLn stderr $ "deadlock test for " ++ s + result <- timeout 1000000 $ print =<< LL.readProcessWithExitCode "sleep" ["2h"] i + assertEqual "takano-akio deadlock test" Nothing result) + ] + ]) + +expected :: String -> Double +expected "String" = 23000000.0 +expected "Strict ByteString" = 760000000.0 +expected "Lazy ByteString" = 760000000.0 +expected "Strict Text" = 44000000.0 +expected "Lazy Text" = 47000000.0 +expected s = error $ "Unexpected instance: " <> show s + +percentMessage v expected = + case v / expected of + r | r < 1.0 -> printf "%01.2f pct slower than usual" (100.0 - 100.0 * r) + r -> printf "%01.2f pct faster than usual" (100.0 * r - 100.0) + +about :: Double -> Double -> String +about v expected = + case v / expected of + r | r >= 0.7 && r <= 1.3 -> "Within 30% of usual speed" + _ -> percentMessage v expected + +parseTimeOutput :: forall a c. (ListLike a c, Enum c) => a -> Double +parseTimeOutput a = + case s =~ ("^(.*)system ([0-9]*):([0-9]*).([0-9]*)elapsed(.*)$" :: String) :: (String, String, String, [String]) of + (_, _, _, [_, m, s, h, _]) -> (read m :: Double) * 60.0 + (read s :: Double) + (read ("0." <> h) :: Double) + where + s = map (chr . fromEnum) $ toList a