1{-# LANGUAGE CPP #-} 2{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE FunctionalDependencies #-} 4{-# LANGUAGE MultiParamTypeClasses #-} 5{-# LANGUAGE RankNTypes #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7{-# LANGUAGE UndecidableInstances #-} 8{-# OPTIONS_GHC -fno-warn-orphans #-} 9module System.Process.Common 10 ( ProcessMaker(process, showProcessMakerForUser) 11 , ListLikeProcessIO(forceOutput, readChunks) 12 , ProcessText 13 , ProcessResult(pidf, outf, errf, intf, codef) 14 , readProcessWithExitCode 15 , readCreateProcessWithExitCode 16 , readCreateProcessStrict 17 , readCreateProcessLazy 18 , showCmdSpecForUser 19 , showCreateProcessForUser 20 ) where 21 22import Control.Concurrent 23import Control.Exception as E (SomeException, onException, catch, mask, throw) 24import Control.Monad 25import Data.ListLike as ListLike (ListLike, null) 26import Data.ListLike.IO (ListLikeIO, hGetContents, hPutStr) 27import Data.Monoid ((<>)) 28import Data.String (IsString) 29import Generics.Deriving.Instances () 30import GHC.IO.Exception (IOErrorType(ResourceVanished), IOException(ioe_type)) 31import Prelude hiding (null) 32import System.Exit (ExitCode(..)) 33import System.IO (Handle, hClose, hFlush, BufferMode, hSetBuffering) 34import System.IO.Unsafe (unsafeInterleaveIO) 35import System.Process (CmdSpec(..), CreateProcess(cmdspec, cwd, std_err, std_in, std_out), StdStream(CreatePipe), ProcessHandle, createProcess, proc, showCommandForUser, waitForProcess, terminateProcess) 36import Utils (forkWait) 37 38#if __GLASGOW_HASKELL__ <= 709 39import Control.Applicative ((<$>), (<*>)) 40import Data.Monoid (Monoid(mempty, mappend)) 41#endif 42 43#if !MIN_VERSION_deepseq(1,4,2) 44import Control.DeepSeq (NFData) 45-- | This instance lets us use DeepSeq's force function on a stream of Chunks. 46instance NFData ExitCode 47#endif 48 49class ProcessMaker a where 50 process :: a -> IO (Handle, Handle, Handle, ProcessHandle) 51 showProcessMakerForUser :: a -> String 52 53-- | This is the usual maker argument to 'readCreateProcessLazy'. 54instance ProcessMaker CreateProcess where 55 process p = do 56 (Just inh, Just outh, Just errh, pid) <- createProcess p { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } 57 return (inh, outh, errh, pid) 58 showProcessMakerForUser = showCreateProcessForUser 59 60-- | Passing this to 'readCreateProcessLazy' as the maker argument allows 61-- you to set the buffer mode of the process stdout and stderr handles 62-- just after the handles are created. These are set to 63-- BlockBuffering by default, but for running console commands 64-- LineBuffering is probably what you want. 65instance ProcessMaker (CreateProcess, BufferMode, BufferMode) where 66 process (p, outmode, errmode) = do 67 (Just inh, Just outh, Just errh, pid) <- createProcess p { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } 68 hSetBuffering outh outmode 69 hSetBuffering errh errmode 70 return (inh, outh, errh, pid) 71 showProcessMakerForUser (p, outmode, errmode) = 72 showCreateProcessForUser p ++ " outmode=" ++ show outmode ++ ", errmode=" ++ show errmode 73 74class (IsString text, Monoid text, ListLike text char) => ProcessText text char 75 76class Monoid result => ProcessResult text result | result -> text where 77 pidf :: ProcessHandle -> result 78 outf :: text -> result 79 errf :: text -> result 80 intf :: SomeException -> result 81 codef :: ExitCode -> result 82 83instance ListLikeProcessIO text char => ProcessResult text (ExitCode, text, text) where 84 pidf _ = mempty 85 codef c = (c, mempty, mempty) 86 outf x = (mempty, x, mempty) 87 errf x = (mempty, mempty, x) 88 intf e = throw e 89 90-- | A process usually has one 'ExitCode' at the end of its output, this 'Monoid' 91-- instance lets us build the type returned by 'System.Process.readProcessWithExitCode'. 92instance Monoid ExitCode where 93 mempty = ExitFailure 0 94 mappend x (ExitFailure 0) = x 95 mappend _ x = x 96 97#if MIN_VERSION_base(4,11,0) 98instance Semigroup ExitCode where 99 (<>) = mappend 100#endif 101 102-- | Process IO is based on the 'ListLikeIO' class from the ListLike 103-- package 104class ListLikeIO text char => ListLikeProcessIO text char where 105 forceOutput :: text -> IO text 106 readChunks :: Handle -> IO [text] 107 -- ^ Read from a handle, returning a lazy list of the monoid a. 108 109-- | Like 'System.Process.readProcessWithExitCode', but with 110-- generalized input and output type. Aside from the usual text-like 111-- types, the output can be a list of Chunk a. This lets you process 112-- the chunks received from stdout and stderr lazil, in the order they 113-- are received, as well as the exit code. Utilities to handle Chunks 114-- are provided in System.Process.ListLike. 115readProcessWithExitCode 116 :: ListLikeProcessIO text char => 117 FilePath -- ^ command to run 118 -> [String] -- ^ any arguments 119 -> text -- ^ standard input 120 -> IO (ExitCode, text, text) -- ^ exitcode, stdout, stderr 121readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input 122 123readCreateProcessWithExitCode 124 :: (ProcessMaker maker, ListLikeProcessIO text char) => 125 maker -- ^ command and arguments to run 126 -> text -- ^ standard input 127 -> IO (ExitCode, text, text) -- ^ exitcode, stdout, stderr 128readCreateProcessWithExitCode = readCreateProcessStrict 129 130readCreateProcessStrict :: (ProcessMaker maker, ProcessResult text result, ListLikeProcessIO text char) => 131 maker -> text -> IO result 132readCreateProcessStrict maker input = mask $ \restore -> do 133 (inh, outh, errh, pid) <- process maker 134 flip onException 135 (do terminateProcess pid; hClose inh; hClose outh; hClose errh; 136 waitForProcess pid) $ restore $ do 137 138 -- fork off a thread to start consuming stdout 139 waitOut <- forkWait $ outf <$> (hGetContents outh >>= forceOutput) 140 141 -- fork off a thread to start consuming stderr 142 waitErr <- forkWait $ errf <$> (hGetContents errh >>= forceOutput) 143 144 -- now write and flush any input. 145 writeInput inh input 146 147 -- wait on the output 148 out <- waitOut 149 err <- waitErr 150 151 hClose outh 152 hClose errh 153 154 -- wait on the process 155 ex <- codef <$> waitForProcess pid 156 157 return $ out <> err <> ex 158 159-- | Like readCreateProcessStrict, but the output is read lazily. 160readCreateProcessLazy :: (ProcessMaker maker, ProcessResult a b, ListLikeProcessIO a c) => maker -> a -> IO b 161readCreateProcessLazy maker input = mask $ \restore -> do 162 (inh, outh, errh, pid) <- process maker 163 onException 164 (restore $ 165 do -- fork off a thread to start consuming stdout 166 -- Without unsafeIntereleaveIO the pid messsage gets stuck 167 -- until some additional output arrives from the process. 168 waitOut <- forkWait $ (<>) <$> return (pidf pid) 169 <*> unsafeInterleaveIO (readInterleaved [(outf, outh), (errf, errh)] (codef <$> waitForProcess pid)) 170 writeInput inh input 171 waitOut) 172 (do terminateProcess pid; hClose inh; hClose outh; hClose errh; 173 waitForProcess pid) 174 175-- | Helper function for readCreateProcessLazy. 176readInterleaved :: (ListLikeProcessIO a c, ProcessResult a b) => 177 [(a -> b, Handle)] -> IO b -> IO b 178readInterleaved pairs finish = newEmptyMVar >>= readInterleaved' pairs finish 179 180readInterleaved' :: forall a b c. (ListLikeProcessIO a c, ProcessResult a b) => 181 [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b 182readInterleaved' pairs finish res = do 183 mapM_ (forkIO . uncurry readHandle) pairs 184 takeChunks (length pairs) 185 where 186 -- Forked thread to read the input and send it to takeChunks via 187 -- the MVar. 188 readHandle :: (a -> b) -> Handle -> IO () 189 readHandle f h = do 190 cs <- readChunks h 191 -- If the type returned as stdout and stderr is lazy we need 192 -- to force it here in the producer thread - I'm not exactly 193 -- sure why. And why is String lazy? 194 -- when (lazy (undefined :: a)) (void cs) 195 mapM_ (\ c -> putMVar res (Right (f c))) cs 196 hClose h 197 putMVar res (Left h) 198 takeChunks :: Int -> IO b 199 takeChunks 0 = finish 200 takeChunks openCount = takeChunk >>= takeMore openCount 201 takeMore :: Int -> Either Handle b -> IO b 202 takeMore openCount (Left h) = hClose h >> takeChunks (openCount - 1) 203 takeMore openCount (Right x) = 204 do xs <- unsafeInterleaveIO $ takeChunks openCount 205 return (x <> xs) 206 takeChunk = takeMVar res `E.catch` (\ (e :: SomeException) -> return $ Right $ intf e) 207 208-- | Write and flush process input, closing the handle when done. 209-- Catch and ignore Resource Vanished exceptions, they just mean the 210-- process exited before all of its output was read. 211writeInput :: ListLikeProcessIO a c => Handle -> a -> IO () 212writeInput inh input = 213 ignoreResourceVanished $ do 214 unless (ListLike.null input) $ do 215 hPutStr inh input 216 hFlush inh 217 hClose inh -- stdin has been fully written 218 219-- | Wrapper for a process that provides a handler for the 220-- ResourceVanished exception. This is frequently an exception we 221-- wish to ignore, because many processes will deliberately exit 222-- before they have read all of their input. 223ignoreResourceVanished :: IO () -> IO () 224ignoreResourceVanished action = 225 action `E.catch` (\e -> if ioe_type e == ResourceVanished then return () else ioError e) 226 227-- | System.Process utility functions. 228showCreateProcessForUser :: CreateProcess -> String 229showCreateProcessForUser p = 230 showCmdSpecForUser (cmdspec p) ++ maybe "" (\ d -> " (in " ++ d ++ ")") (cwd p) 231 232showCmdSpecForUser :: CmdSpec -> String 233showCmdSpecForUser (ShellCommand s) = s 234showCmdSpecForUser (RawCommand p args) = showCommandForUser p args 235