diff options
author | Joey Hess <joeyh@joeyh.name> | 2020-01-02 12:34:10 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2020-01-02 12:42:57 -0400 |
commit | 9df8a6eb9405dde4464d27133c04f5ee539a85de (patch) | |
tree | 8a7ac5f52be8679f8a2525515a0b2c1b715c99ad /Utility/Process.hs | |
parent | 16022a8b98f4bc134542e78a42538364d2f97d92 (diff) | |
download | git-repair-9df8a6eb9405dde4464d27133c04f5ee539a85de.tar.gz |
merge from git-annex and relicense accordingly
Merge git library and utility from git-annex. The former is now relicensed
AGPL, so git-repair as a whole becomes AGPL.
For simplicity, I am relicensing the remainder of the code in git-repair
AGPL as well, per the header changes in this commit. While that code is
also technically available under the GPL license, as it's been released
under that license before, changes going forward will be only released by
me under the AGPL.
Diffstat (limited to 'Utility/Process.hs')
-rw-r--r-- | Utility/Process.hs | 91 |
1 files changed, 11 insertions, 80 deletions
diff --git a/Utility/Process.hs b/Utility/Process.hs index 6d981cb..af3a5f4 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -24,11 +24,10 @@ module Utility.Process ( createProcessSuccess, createProcessChecked, createBackgroundProcess, - processTranscript, - processTranscript', withHandle, withIOHandles, withOEHandles, + withNullHandle, withQuietOutput, feedWithQuietOutput, createProcess, @@ -54,13 +53,6 @@ import System.Log.Logger import Control.Concurrent import qualified Control.Exception as E import Control.Monad -#ifndef mingw32_HOST_OS -import qualified System.Posix.IO -#else -import Control.Applicative -#endif -import Data.Maybe -import Prelude type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -170,68 +162,6 @@ createProcessChecked checker p a = do createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p --- | Runs a process, optionally feeding it some input, 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) - -processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool) -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 - 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 <- mkreader readh - writeinput input p - transcript <- get - - ok <- checkSuccessProcess pid - return (transcript, ok) -#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 <- mkreader (stdoutHandle p) - geterr <- mkreader (stderrHandle p) - writeinput input p - transcript <- (++) <$> getout <*> geterr - - ok <- checkSuccessProcess pid - return (transcript, ok) -#endif - where - mkreader h = do - s <- hGetContents h - v <- newEmptyMVar - void $ forkIO $ do - void $ E.evaluate (length s) - putMVar v () - return $ do - takeMVar v - return s - - writeinput (Just s) p = do - let inh = stdinHandle p - unless (null s) $ do - hPutStr inh s - hFlush inh - hClose inh - writeinput Nothing _ = return () - -- | Runs a CreateProcessRunner, on a CreateProcess structure, that -- is adjusted to pipe only from/to a single StdHandle, and passes -- the resulting Handle to an action. @@ -248,13 +178,10 @@ withHandle h creator p a = creator p' $ a . select , std_out = Inherit , std_err = Inherit } - (select, p') - | h == StdinHandle = - (stdinHandle, base { std_in = CreatePipe }) - | h == StdoutHandle = - (stdoutHandle, base { std_out = CreatePipe }) - | h == StderrHandle = - (stderrHandle, base { std_err = CreatePipe }) + (select, p') = case h of + StdinHandle -> (stdinHandle, base { std_in = CreatePipe }) + StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe }) + StderrHandle -> (stderrHandle, base { std_err = CreatePipe }) -- | Like withHandle, but passes (stdin, stdout) handles to the action. withIOHandles @@ -284,13 +211,16 @@ withOEHandles creator p a = creator p' $ a . oeHandles , std_err = CreatePipe } +withNullHandle :: (Handle -> IO a) -> IO a +withNullHandle = withFile devNull WriteMode + -- | Forces the CreateProcessRunner to run quietly; -- both stdout and stderr are discarded. withQuietOutput :: CreateProcessRunner -> CreateProcess -> IO () -withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do +withQuietOutput creator p = withNullHandle $ \nullh -> do let p' = p { std_out = UseHandle nullh , std_err = UseHandle nullh @@ -316,7 +246,8 @@ devNull :: FilePath #ifndef mingw32_HOST_OS devNull = "/dev/null" #else -devNull = "NUL" +-- Use device namespace to prevent GHC from rewriting path +devNull = "\\\\.\\NUL" #endif -- | Extract a desired handle from createProcess's tuple. |