From 3328fb83373adad786e57d4ed47e1d801e14260f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 30 Dec 2018 15:08:55 -0400 Subject: Merged Utility changes from git-annex Last done in May 2017.. --- src/Utility/Process/Shim.hs | 5 +-- src/Utility/Process/Transcript.hs | 83 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 85 insertions(+), 3 deletions(-) create mode 100644 src/Utility/Process/Transcript.hs (limited to 'src/Utility/Process') 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 + - + - 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 () -- cgit v1.2.3