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