From 548e627789ffd07f8720275eab6ad3ec5dd9ac42 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 12:46:07 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) (limited to 'src/Utility') diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index c6550b84..8cb81c61 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -31,7 +31,11 @@ data OutputHandle = OutputHandle data Locker = GeneralLock - | ProcessLock P.ProcessHandle + | ProcessLock P.ProcessHandle String + +instance Show Locker where + show GeneralLock = "GeneralLock" + show (ProcessLock _ cmd) = "ProcessLock " ++ cmd -- | A shared global variable for the OutputHandle. {-# NOINLINE globalOutputHandle #-} @@ -70,7 +74,7 @@ takeOutputLock' block = do lcker <- outputLockedBy <$> getOutputHandle v' <- tryTakeMVar lcker case v' of - Just (ProcessLock h) -> + Just orig@(ProcessLock h _) -> -- if process has exited, lock is stale ifM (isJust <$> P.getProcessExitCode h) ( havelock @@ -79,7 +83,7 @@ takeOutputLock' block = do void $ P.waitForProcess h havelock else do - putMVar lcker (ProcessLock h) + putMVar lcker orig return False ) Just GeneralLock -> do @@ -164,7 +168,9 @@ createProcessConcurrent p hPutStrLn stderr "IS NOT CONCURRENT" firstprocess , do - hPutStrLn stderr "IS CONCURRENT" + lcker <- outputLockedBy <$> getOutputHandle + l <- readMVar lcker + hPutStrLn stderr $ show ("IS CONCURRENT", l) concurrentprocess ) | otherwise = P.createProcess p @@ -176,10 +182,14 @@ createProcessConcurrent p | willoutput str = P.UseHandle h | otherwise = str + cmd = case P.cmdspec p of + P.ShellCommand s -> s + P.RawCommand c ps -> unwords (c:ps) + firstprocess = do r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock - updateOutputLocker (ProcessLock h) + updateOutputLocker (ProcessLock h cmd) -- Output lock is still held as we return; the process -- is running now, and once it exits the output lock will -- be stale and can then be taken by something else. -- cgit v1.2.3