diff --git a/process-extras.cabal b/process-extras.cabal --- a/process-extras.cabal +++ b/process-extras.cabal @@ -1,13 +1,13 @@ Name: process-extras -Version: 0.2.0 +Version: 0.3.0 Synopsis: Process extras Description: Extra functionality for the Process library . -Homepage: https://github.com/davidlazar/process-extras +Homepage: https://github.com/seereason/process-extras License: MIT License-file: LICENSE -Author: David Lazar, Bas van Dijk -Maintainer: David Lazar +Author: David Lazar, Bas van Dijk, David Fox +Maintainer: David Fox Category: System Build-type: Simple Cabal-version: >=1.6 @@ -16,7 +16,7 @@ source-repository head Type: git - Location: https://github.com/davidlazar/process-extras + Location: https://github.com/seereason/process-extras Library ghc-options: -Wall @@ -26,6 +26,8 @@ Exposed-modules: System.Process.ByteString System.Process.ByteString.Lazy + System.Process.Common + System.Process.ListLike System.Process.Text System.Process.Text.Lazy @@ -34,6 +36,7 @@ Build-depends: base >= 4 && < 5, + ListLike >= 4, process, bytestring, text, diff --git a/src/System/Process/ByteString.hs b/src/System/Process/ByteString.hs --- a/src/System/Process/ByteString.hs +++ b/src/System/Process/ByteString.hs @@ -1,47 +1,25 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module System.Process.ByteString where -import Control.Exception +import Control.Applicative ((<$>)) import Control.Monad import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Data.ListLike.IO (hGetContents) +import Data.Word (Word8) +import Prelude hiding (null) import System.Process +import System.Process.Common import System.Exit (ExitCode) -import System.IO -import Utils (forkWait) -- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString' -readProcessWithExitCode - :: FilePath -- ^ command to run - -> [String] -- ^ any arguments - -> ByteString -- ^ standard input - -> IO (ExitCode, ByteString, ByteString) -- ^ exitcode, stdout, stderr -readProcessWithExitCode cmd args input = mask $ \restore -> do - (Just inh, Just outh, Just errh, pid) <- - createProcess (proc cmd args){ std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe } - flip onException - (do hClose inh; hClose outh; hClose errh; - terminateProcess pid; waitForProcess pid) $ restore $ do - - -- fork off a thread to start consuming stdout - waitOut <- forkWait $ B.hGetContents outh - - -- fork off a thread to start consuming stderr - waitErr <- forkWait $ B.hGetContents errh - - -- now write and flush any input - unless (B.null input) $ do B.hPutStr inh input; hFlush inh - hClose inh -- done with stdin - - -- wait on the output - out <- waitOut - err <- waitErr - - hClose outh - hClose errh +instance ListLikeProcessIO ByteString Word8 where + forceOutput = return + readChunks h = (: []) <$> hGetContents h - -- wait on the process - ex <- waitForProcess pid +-- | Specialized version for backwards compatibility. +readProcessWithExitCode :: FilePath -> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString) +readProcessWithExitCode = System.Process.Common.readProcessWithExitCode - return (ex, out, err) +readCreateProcessWithExitCode :: CreateProcess -> ByteString -> IO (ExitCode, ByteString, ByteString) +readCreateProcessWithExitCode = System.Process.Common.readCreateProcessWithExitCode diff --git a/src/System/Process/ByteString/Lazy.hs b/src/System/Process/ByteString/Lazy.hs --- a/src/System/Process/ByteString/Lazy.hs +++ b/src/System/Process/ByteString/Lazy.hs @@ -1,50 +1,26 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module System.Process.ByteString.Lazy where -import Control.Exception +import Control.Applicative ((<$>)) +import Control.DeepSeq (force) import qualified Control.Exception as C (evaluate) -import Control.Monad -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as B +import Data.ByteString.Lazy (ByteString, toChunks, fromChunks) +import Data.ListLike.IO (hGetContents) +import Data.Word (Word8) +import Prelude hiding (null) import System.Process +import System.Process.Common import System.Exit (ExitCode) -import System.IO -import Utils (forkWait) -- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString' -readProcessWithExitCode - :: FilePath -- ^ command to run - -> [String] -- ^ any arguments - -> ByteString -- ^ standard input - -> IO (ExitCode, ByteString, ByteString) -- ^ exitcode, stdout, stderr -readProcessWithExitCode cmd args input = mask $ \restore -> do - (Just inh, Just outh, Just errh, pid) <- - createProcess (proc cmd args){ std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe } - flip onException - (do hClose inh; hClose outh; hClose errh; - terminateProcess pid; waitForProcess pid) $ restore $ do - - -- fork off a thread to start consuming stdout - out <- B.hGetContents outh - waitOut <- forkWait $ void $ C.evaluate $ B.length out - - -- fork off a thread to start consuming stderr - err <- B.hGetContents errh - waitErr <- forkWait $ void $ C.evaluate $ B.length err - - -- now write and flush any input - unless (B.null input) $ do B.hPutStr inh input; hFlush inh - hClose inh -- done with stdin - - -- wait on the output - waitOut - waitErr - - hClose outh - hClose errh +instance ListLikeProcessIO ByteString Word8 where + forceOutput = C.evaluate . force + readChunks h = (map (fromChunks . (: [])) . toChunks) <$> hGetContents h - -- wait on the process - ex <- waitForProcess pid +-- | Specialized version for backwards compatibility. +readProcessWithExitCode :: FilePath -> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString) +readProcessWithExitCode = System.Process.Common.readProcessWithExitCode - return (ex, out, err) +readCreateProcessWithExitCode :: CreateProcess -> ByteString -> IO (ExitCode, ByteString, ByteString) +readCreateProcessWithExitCode = System.Process.Common.readCreateProcessWithExitCode diff --git a/src/System/Process/Common.hs b/src/System/Process/Common.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Common.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module System.Process.Common where + +import Control.Applicative (pure, (<$>), (<*>)) +import Control.Concurrent +import Control.Exception as E (SomeException, onException, catch, mask, throw) +import Control.Monad +import Data.ListLike (null) +import Data.ListLike.IO (ListLikeIO, hGetContents, hPutStr) +import Data.Monoid (Monoid(mempty, mappend), (<>)) +import GHC.IO.Exception (IOErrorType(ResourceVanished), IOException(ioe_type)) +import Prelude hiding (null) +import System.Exit (ExitCode(ExitFailure)) +import System.IO (Handle, hClose, hFlush) +import System.IO.Unsafe (unsafeInterleaveIO) +import System.Process +import Utils (forkWait) + +class Monoid b => ProcessOutput a b | b -> a where + pidf :: ProcessHandle -> b + outf :: a -> b + errf :: a -> b + intf :: SomeException -> b + codef :: ExitCode -> b + +instance ListLikeProcessIO 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 + +-- | 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 ListLikeIO a c => ListLikeProcessIO a c where + forceOutput :: a -> IO a + readChunks :: Handle -> IO [a] + -- ^ Read from a handle, returning a lazy list of the monoid a. + +-- | Like 'System.Process.readProcessWithExitCode', but with generalized input and output type. +readProcessWithExitCode + :: ListLikeProcessIO 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 + +readCreateProcessWithExitCode + :: ListLikeProcessIO a c => + CreateProcess -- ^ command and arguments to run + -> a -- ^ standard input + -> IO (ExitCode, a, a) -- ^ exitcode, stdout, stderr +readCreateProcessWithExitCode = readCreateProcess + +readCreateProcess :: (ProcessOutput a b, ListLikeProcessIO a c) => 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 } + flip onException + (do terminateProcess pid; hClose inh; hClose outh; hClose errh; + waitForProcess pid) $ restore $ do + + -- fork off a thread to start consuming stdout + waitOut <- forkWait $ outf <$> (hGetContents outh >>= forceOutput) + + -- fork off a thread to start consuming stderr + waitErr <- forkWait $ errf <$> (hGetContents errh >>= forceOutput) + + -- now write and flush any input + unless (null input) $ do hPutStr inh input; hFlush inh + hClose inh -- done with stdin + + -- wait on the output + out <- waitOut + err <- waitErr + + hClose outh + hClose errh + + -- wait on the process + ex <- codef <$> waitForProcess pid + + return $ out <> err <> ex + +-- | Like readCreateProcess, but the output is read lazily. +readCreateProcessLazy :: (ProcessOutput a b, ListLikeProcessIO a c) => CreateProcess -> a -> IO b +readCreateProcessLazy p input = mask $ \restore -> do + (Just inh, Just outh, Just errh, pid) <- + createProcess p{ std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe } + onException + (restore $ + do -- fork off a thread to start consuming stdout + -- Without unsafeIntereleaveIO the pid messsage gets stuck + -- until some additional output arrives from the process. + waitOut <- forkWait $ (<>) <$> pure (pidf pid) + <*> unsafeInterleaveIO (readInterleaved [(outf, outh), (errf, errh)] (codef <$> waitForProcess pid)) + writeInput inh input + waitOut) + (do terminateProcess pid; hClose inh; hClose outh; hClose errh; + waitForProcess pid) + +-- | Helper function for readCreateProcessLazy. +readInterleaved :: (ListLikeProcessIO a c, ProcessOutput a b) => + [(a -> b, Handle)] -> IO b -> IO b +readInterleaved pairs finish = newEmptyMVar >>= readInterleaved' pairs finish + +readInterleaved' :: forall a b c. (ListLikeProcessIO 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) + +-- | 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 :: ListLikeProcessIO 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.hs b/src/System/Process/ListLike.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/ListLike.hs @@ -0,0 +1,86 @@ +-- | Re-export all symbols and instances of the process-extras package. +{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module System.Process.ListLike + ( ListLikeProcessIO(forceOutput) + , ProcessOutput(pidf, outf, errf, codef, intf) + , readCreateProcess + , readCreateProcessLazy + , readCreateProcessWithExitCode + , readProcessWithExitCode + , Chunk(..) + , collectOutput + , showCreateProcessForUser + , showCmdSpecForUser + ) where + +import Control.DeepSeq (force) +import Control.Exception as C (evaluate, SomeException, throw) +import Data.ListLike.IO (hGetContents) +import Data.Monoid (mempty, mconcat) +import Data.Text (unpack) +import Data.Text.Lazy (Text, toChunks) +import System.Exit (ExitCode) +import System.Process (CmdSpec(..), CreateProcess(..), ProcessHandle, showCommandForUser) +import System.Process.ByteString () +import System.Process.ByteString.Lazy () +import System.Process.Common (ListLikeProcessIO(forceOutput, readChunks), ProcessOutput(pidf, outf, errf, codef, intf), + readCreateProcess, readCreateProcessLazy, readCreateProcessWithExitCode, readProcessWithExitCode) +import System.Process.Text () +import System.Process.Text.Lazy () + +-- | System.Process utility functions. +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 + +-- | Like 'System.Process.readProcessWithExitCode' that takes a 'CreateProcess'. +instance ListLikeProcessIO String Char where + -- | This is required because strings are magically lazy. Without it + -- processes get exit status 13 - file read failures. + forceOutput = evaluate . force + -- | Read the handle as lazy text, convert to chunks of strict text, + -- and then unpack into strings. + readChunks h = do + t <- hGetContents h :: IO Text + return $ map unpack $ toChunks t + +-- | This type is a concrete representation of the methods of class +-- ProcessOutput. If you take your process output as this type you +-- could, for example, echo all the output and then use collectOutput +-- below to convert it to any other instance of ProcessOutput. +data Chunk a + = ProcessHandle ProcessHandle + -- ^ This will always come first, before any output or exit code. + | Stdout a + | Stderr a + | Result ExitCode + | Exception SomeException + -- ^ Note that the instances below do not use this constructor. + +instance ListLikeProcessIO a c => ProcessOutput a [Chunk a] where + pidf p = [ProcessHandle p] + outf x = [Stdout x] + errf x = [Stderr x] + intf e = throw e + codef c = [Result c] + +instance ListLikeProcessIO 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 = throw e + +-- | Turn a @[Chunk a]@ into any other instance of 'ProcessOutput'. +collectOutput :: ProcessOutput a b => [Chunk a] -> b +collectOutput xs = mconcat $ map (\ chunk -> case chunk of + ProcessHandle x -> pidf x + Stdout x -> outf x + Stderr x -> errf x + Result x -> codef x + Exception x -> intf x) xs diff --git a/src/System/Process/Text.hs b/src/System/Process/Text.hs --- a/src/System/Process/Text.hs +++ b/src/System/Process/Text.hs @@ -1,48 +1,24 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module System.Process.Text where -import Control.Exception +import Control.Applicative ((<$>)) import Control.Monad +import Data.ListLike.IO (hGetContents) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Prelude hiding (null) import System.Process +import System.Process.Common import System.Exit (ExitCode) -import System.IO -import Utils (forkWait) -- | Like 'System.Process.readProcessWithExitCode', but using 'Text' -readProcessWithExitCode - :: FilePath -- ^ command to run - -> [String] -- ^ any arguments - -> Text -- ^ standard input - -> IO (ExitCode, Text, Text) -- ^ exitcode, stdout, stderr -readProcessWithExitCode cmd args input = mask $ \restore -> do - (Just inh, Just outh, Just errh, pid) <- - createProcess (proc cmd args){ std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe } - flip onException - (do hClose inh; hClose outh; hClose errh; - terminateProcess pid; waitForProcess pid) $ restore $ do - - -- fork off a thread to start consuming stdout - waitOut <- forkWait $ T.hGetContents outh - - -- fork off a thread to start consuming stderr - waitErr <- forkWait $ T.hGetContents errh - - -- now write and flush any input - unless (T.null input) $ do T.hPutStr inh input; hFlush inh - hClose inh -- done with stdin - - -- wait on the output - out <- waitOut - err <- waitErr - - hClose outh - hClose errh +instance ListLikeProcessIO Text Char where + forceOutput = return + readChunks h = (: []) <$> hGetContents h - -- wait on the process - ex <- waitForProcess pid +-- | Specialized version for backwards compatibility. +readProcessWithExitCode :: FilePath -> [String] -> Text -> IO (ExitCode, Text, Text) +readProcessWithExitCode = System.Process.Common.readProcessWithExitCode - return (ex, out, err) +readCreateProcessWithExitCode :: CreateProcess -> Text -> IO (ExitCode, Text, Text) +readCreateProcessWithExitCode = System.Process.Common.readCreateProcessWithExitCode diff --git a/src/System/Process/Text/Lazy.hs b/src/System/Process/Text/Lazy.hs --- a/src/System/Process/Text/Lazy.hs +++ b/src/System/Process/Text/Lazy.hs @@ -1,52 +1,25 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module System.Process.Text.Lazy where -import Control.DeepSeq (rnf) -import Control.Exception +import Control.Applicative ((<$>)) +import Control.DeepSeq (force) import qualified Control.Exception as C (evaluate) -import Control.Monad -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as T +import Data.ListLike.IO (hGetContents) +import Data.Text.Lazy (Text, fromChunks, toChunks) +import Prelude hiding (null) import System.Process +import System.Process.Common import System.Exit (ExitCode) -import System.IO -import Utils (forkWait) -- | Like 'System.Process.readProcessWithExitCode', but using 'Text' -readProcessWithExitCode - :: FilePath -- ^ command to run - -> [String] -- ^ any arguments - -> Text -- ^ standard input - -> IO (ExitCode, Text, Text) -- ^ exitcode, stdout, stderr -readProcessWithExitCode cmd args input = mask $ \restore -> do - (Just inh, Just outh, Just errh, pid) <- - createProcess (proc cmd args){ std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe } - flip onException - (do hClose inh; hClose outh; hClose errh; - terminateProcess pid; waitForProcess pid) $ restore $ do - - -- fork off a thread to start consuming stdout - out <- T.hGetContents outh - waitOut <- forkWait $ C.evaluate $ rnf out - - -- fork off a thread to start consuming stderr - err <- T.hGetContents errh - waitErr <- forkWait $ C.evaluate $ rnf err - - -- now write and flush any input - unless (T.null input) $ do T.hPutStr inh input; hFlush inh - hClose inh -- done with stdin - - -- wait on the output - waitOut - waitErr - - hClose outh - hClose errh +instance ListLikeProcessIO Text Char where + forceOutput = C.evaluate . force + readChunks h = (map (fromChunks . (: [])) . toChunks) <$> hGetContents h - -- wait on the process - ex <- waitForProcess pid +-- | Specialized version for backwards compatibility. +readProcessWithExitCode :: FilePath -> [String] -> Text -> IO (ExitCode, Text, Text) +readProcessWithExitCode = System.Process.Common.readProcessWithExitCode - return (ex, out, err) +readCreateProcessWithExitCode :: CreateProcess -> Text -> IO (ExitCode, Text, Text) +readCreateProcessWithExitCode = System.Process.Common.readCreateProcessWithExitCode