diff options
| -rw-r--r-- | Utility/Process.hs | 10 | ||||
| -rw-r--r-- | Utility/Rsync.hs | 3 | ||||
| -rw-r--r-- | Utility/ThreadScheduler.hs | 7 |
3 files changed, 15 insertions, 5 deletions
diff --git a/Utility/Process.hs b/Utility/Process.hs index 398e8a3..03cbe95 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -22,6 +22,7 @@ module Utility.Process ( createProcessChecked, createBackgroundProcess, processTranscript, + processTranscript', withHandle, withBothHandles, withQuietOutput, @@ -162,10 +163,13 @@ createBackgroundProcess p a = a =<< createProcess p - 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 input = processTranscript' cmd opts Nothing input + +processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool) #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} -processTranscript cmd opts input = do +processTranscript' cmd opts environ input = do (readf, writef) <- createPipe readh <- fdToHandle readf writeh <- fdToHandle writef @@ -174,6 +178,7 @@ processTranscript cmd opts input = do { std_in = if isJust input then CreatePipe else Inherit , std_out = UseHandle writeh , std_err = UseHandle writeh + , env = environ } hClose writeh @@ -195,12 +200,13 @@ processTranscript cmd opts input = do return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} -processTranscript cmd opts input = do +processTranscript' cmd opts environ input = do p@(_, _, _, pid) <- createProcess $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit , std_out = CreatePipe , std_err = CreatePipe + , env = environ } getout <- mkreader (stdoutHandle p) diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index 5f322a0..2c5e39b 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -67,7 +67,8 @@ rsyncParamsFixup = map fixup -} rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool rsyncProgress meterupdate params = do - r <- withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) + r <- catchBoolIO $ + withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) {- For an unknown reason, piping rsync's output like this does - causes it to run a second ssh process, which it neglects to wait - on. Reap the resulting zombie. -} diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index c3e871c..dbb6cb3 100644 --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -53,8 +53,11 @@ unboundDelay time = do {- Pauses the main thread, letting children run until program termination. -} waitForTermination :: IO () waitForTermination = do +#ifdef mingw32_HOST_OS + runEvery (Seconds 600) $ + void getLine +#else lock <- newEmptyMVar -#ifndef mingw32_HOST_OS let check sig = void $ installHandler sig (CatchOnce $ putMVar lock ()) Nothing check softwareTermination @@ -62,8 +65,8 @@ waitForTermination = do whenM (queryTerminal stdInput) $ check keyboardSignal #endif -#endif takeMVar lock +#endif oneSecond :: Microseconds oneSecond = 1000000 |