summaryrefslogtreecommitdiff
path: root/src/Utility/Process
diff options
context:
space:
mode:
authorJoey Hess2018-12-30 15:08:55 -0400
committerJoey Hess2018-12-30 15:08:55 -0400
commit3328fb83373adad786e57d4ed47e1d801e14260f (patch)
treef1e3502287f2cdd2bc19020f82b5a56ac90d0bbe /src/Utility/Process
parent11b3e6c0017dadf64ea67a7ea8c98e78b0917256 (diff)
Merged Utility changes from git-annex
Last done in May 2017..
Diffstat (limited to 'src/Utility/Process')
-rw-r--r--src/Utility/Process/Shim.hs5
-rw-r--r--src/Utility/Process/Transcript.hs83
2 files changed, 85 insertions, 3 deletions
diff --git a/src/Utility/Process/Shim.hs b/src/Utility/Process/Shim.hs
index 8c9d41d0..09312c7f 100644
--- a/src/Utility/Process/Shim.hs
+++ b/src/Utility/Process/Shim.hs
@@ -1,4 +1,3 @@
-module Utility.Process.Shim (module X, createProcess, waitForProcess) where
+module Utility.Process.Shim (module X) where
-import System.Process as X hiding (createProcess, waitForProcess)
-import System.Process.Concurrent
+import System.Process as X
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 ()