From 6179ad56d9537e0aa972dfa3e60b01b5cfc71c1b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 13:13:38 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 23 +++-------------------- 1 file changed, 3 insertions(+), 20 deletions(-) (limited to 'src/Utility/ConcurrentOutput.hs') diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index faef2d00..20e39832 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -74,27 +74,16 @@ takeOutputLock' block = do lcker <- outputLockedBy <$> getOutputHandle v' <- tryTakeMVar lcker case v' of - Just orig@(ProcessLock h _) -> do - hPutStrLn stderr $ show ("CHECK STALE") - hFlush stderr + Just orig@(ProcessLock h _) -> -- if process has exited, lock is stale ifM (isJust <$> P.getProcessExitCode h) - ( do - hPutStrLn stderr $ show ("WAS STALE") - hFlush stderr - havelock + ( havelock , if block then do - hPutStrLn stderr $ show ("WAIT FOR PROCESS") - hFlush stderr void $ P.waitForProcess h havelock else do - hPutStrLn stderr $ show ("RESTORE") - hFlush stderr putMVar lcker orig - hPutStrLn stderr $ show ("RESTORE DONE") - hFlush stderr return False ) Just GeneralLock -> do @@ -126,11 +115,7 @@ updateOutputLocker :: Locker -> IO () updateOutputLocker l = do lcker <- outputLockedBy <$> getOutputHandle void $ tryTakeMVar lcker - hPutStrLn stderr $ show ("SETTING LOCKER") - hFlush stderr putMVar lcker l - hPutStrLn stderr $ show ("SETTING LOCKER DONE") - hFlush stderr -- | Use this around any IO actions that use `outputConcurrent` -- or `createProcessConcurrent` @@ -176,9 +161,7 @@ outputConcurrent s = do -- as the output lock becomes free. createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) createProcessConcurrent p - | willoutput (P.std_out p) || willoutput (P.std_err p) = do - hPutStrLn stderr $ show ("CHECK CONCURRENT", cmd) - hFlush stderr + | willoutput (P.std_out p) || willoutput (P.std_err p) = ifM tryTakeOutputLock ( do hPutStrLn stderr $ show ("NOT CONCURRENT", cmd) -- cgit v1.2.3