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