summaryrefslogtreecommitdiff
path: root/src/Utility/Process/Transcript.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Utility/Process/Transcript.hs')
-rw-r--r--src/Utility/Process/Transcript.hs83
1 files changed, 83 insertions, 0 deletions
diff --git a/src/Utility/Process/Transcript.hs b/src/Utility/Process/Transcript.hs
new file mode 100644
index 00000000..68fb2223
--- /dev/null
+++ b/src/Utility/Process/Transcript.hs
@@ -0,0 +1,83 @@
+{- Process transcript
+ -
+ - Copyright 2012-2018 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Process.Transcript where
+
+import Utility.Process
+import Utility.Misc
+
+import System.IO
+import System.Exit
+import Control.Concurrent.Async
+import Control.Monad
+#ifndef mingw32_HOST_OS
+import qualified System.Posix.IO
+#else
+import Control.Applicative
+#endif
+import Data.Maybe
+import Prelude
+
+-- | Runs a process and returns a transcript combining its stdout and
+-- stderr, and whether it succeeded or failed.
+processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
+processTranscript cmd opts = processTranscript' (proc cmd opts)
+
+-- | Also feeds the process some input.
+processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
+processTranscript' cp input = do
+ (t, c) <- processTranscript'' cp input
+ return (t, c == ExitSuccess)
+
+processTranscript'' :: CreateProcess -> Maybe String -> IO (String, ExitCode)
+processTranscript'' cp input = do
+#ifndef mingw32_HOST_OS
+{- This implementation interleves stdout and stderr in exactly the order
+ - the process writes them. -}
+ (readf, writef) <- System.Posix.IO.createPipe
+ System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True
+ System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True
+ readh <- System.Posix.IO.fdToHandle readf
+ writeh <- System.Posix.IO.fdToHandle writef
+ p@(_, _, _, pid) <- createProcess $ cp
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = UseHandle writeh
+ , std_err = UseHandle writeh
+ }
+ hClose writeh
+
+ get <- asyncreader readh
+ writeinput input p
+ transcript <- wait get
+#else
+{- This implementation for Windows puts stderr after stdout. -}
+ p@(_, _, _, pid) <- createProcess $ cp
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+
+ getout <- asyncreader (stdoutHandle p)
+ geterr <- asyncreader (stderrHandle p)
+ writeinput input p
+ transcript <- (++) <$> wait getout <*> wait geterr
+#endif
+ code <- waitForProcess pid
+ return (transcript, code)
+ where
+ asyncreader = async . hGetContentsStrict
+
+ writeinput (Just s) p = do
+ let inh = stdinHandle p
+ unless (null s) $ do
+ hPutStr inh s
+ hFlush inh
+ hClose inh
+ writeinput Nothing _ = return ()