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(-) 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 -- cgit v1.2.3 From 42e965e4ebde989cec7ce4c0d1b284cd54a16b64 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 12:51:17 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 8cb81c61..7868ffd4 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -170,7 +170,7 @@ createProcessConcurrent p , do lcker <- outputLockedBy <$> getOutputHandle l <- readMVar lcker - hPutStrLn stderr $ show ("IS CONCURRENT", l) + hPutStrLn stderr $ show ("IS CONCURRENT", cmd, l) concurrentprocess ) | otherwise = P.createProcess p -- cgit v1.2.3 From a02a837afb91dc025cb3862b90c1d62c1562cb23 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 12:54:28 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 7868ffd4..8497b2dc 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -164,13 +164,12 @@ createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Ma createProcessConcurrent p | willoutput (P.std_out p) || willoutput (P.std_err p) = ifM tryTakeOutputLock - ( do - hPutStrLn stderr "IS NOT CONCURRENT" - firstprocess + ( firstprocess , do lcker <- outputLockedBy <$> getOutputHandle l <- readMVar lcker hPutStrLn stderr $ show ("IS CONCURRENT", cmd, l) + hFlush stderr concurrentprocess ) | otherwise = P.createProcess p -- cgit v1.2.3 -- cgit v1.2.3 -- cgit v1.2.3 From 70f2208ed6d855895f22a467c9da80cad7402dda Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 13:00:24 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 8497b2dc..9e6b6a68 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -164,7 +164,10 @@ createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Ma createProcessConcurrent p | willoutput (P.std_out p) || willoutput (P.std_err p) = ifM tryTakeOutputLock - ( firstprocess + ( do + hPutStrLn stderr $ show ("NOT CONCURRENT", cmd) + hFlush stderr + firstprocess , do lcker <- outputLockedBy <$> getOutputHandle l <- readMVar lcker -- cgit v1.2.3 From 63c7d246b206e774baf3767333d170c9c74b63d9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 13:03:58 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 9e6b6a68..a1a8898d 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -162,7 +162,9 @@ 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) = + | willoutput (P.std_out p) || willoutput (P.std_err p) = do + hPutStrLn stderr $ show ("CHECK CONCURRENT", cmd) + hFlush stderr ifM tryTakeOutputLock ( do hPutStrLn stderr $ show ("NOT CONCURRENT", cmd) @@ -175,7 +177,10 @@ createProcessConcurrent p hFlush stderr concurrentprocess ) - | otherwise = P.createProcess p + | otherwise = do + hPutStrLn stderr $ show ("NO OUTPUT", cmd) + hFlush stderr + P.createProcess p where willoutput P.Inherit = True willoutput _ = False -- cgit v1.2.3 From a48d1d2c30c722d77955989d967876e42d5e046d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 13:08:26 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index a1a8898d..a3cc54d2 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -115,8 +115,11 @@ updateOutputLocker :: Locker -> IO () updateOutputLocker l = do lcker <- outputLockedBy <$> getOutputHandle void $ tryTakeMVar lcker + hPutStrLn stderr $ show ("SETTING LOCKER") + hFlush stderr putMVar lcker l - modifyMVar_ lcker (const $ return l) + hPutStrLn stderr $ show ("SETTING LOCKER DONE") + hFlush stderr -- | Use this around any IO actions that use `outputConcurrent` -- or `createProcessConcurrent` -- cgit v1.2.3 -- cgit v1.2.3 From 0372aa05acdf281e27402446e8cdb731a78a848e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 13:11:29 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index a3cc54d2..71055f14 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -74,16 +74,27 @@ takeOutputLock' block = do lcker <- outputLockedBy <$> getOutputHandle v' <- tryTakeMVar lcker case v' of - Just orig@(ProcessLock h _) -> + Just orig@(ProcessLock h _) -> do + hPutStrLn stderr $ show ("CHECK STALE") + hFlush stderr -- if process has exited, lock is stale ifM (isJust <$> P.getProcessExitCode h) - ( havelock + ( do + hPutStrLn stderr $ show ("WAS STALE") + hFlush stderr + 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 -- cgit v1.2.3 From 873f0861240f33bea00adc629adba80c31b79694 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 13:12:39 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 71055f14..faef2d00 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -186,7 +186,7 @@ createProcessConcurrent p firstprocess , do lcker <- outputLockedBy <$> getOutputHandle - l <- readMVar lcker + l <- tryReadMVar lcker hPutStrLn stderr $ show ("IS CONCURRENT", cmd, l) hFlush stderr concurrentprocess -- cgit v1.2.3 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(-) 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 From 8579d5c5c436cffca56506cd6c52f90d64b082ce Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 13:17:39 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 20e39832..279421e2 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -116,6 +116,7 @@ updateOutputLocker l = do lcker <- outputLockedBy <$> getOutputHandle void $ tryTakeMVar lcker putMVar lcker l + modifyMVar_ lcker (const $ return l) -- | Use this around any IO actions that use `outputConcurrent` -- or `createProcessConcurrent` @@ -169,15 +170,11 @@ createProcessConcurrent p firstprocess , do lcker <- outputLockedBy <$> getOutputHandle - l <- tryReadMVar lcker - hPutStrLn stderr $ show ("IS CONCURRENT", cmd, l) + hPutStrLn stderr $ show ("IS CONCURRENT", cmd) hFlush stderr concurrentprocess ) - | otherwise = do - hPutStrLn stderr $ show ("NO OUTPUT", cmd) - hFlush stderr - P.createProcess p + | otherwise = P.createProcess p where willoutput P.Inherit = True willoutput _ = False -- cgit v1.2.3 From 6fcefbca7d55d8d7944ad78f622c9255edc33e00 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 13:19:47 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 279421e2..cbd5a00d 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -128,7 +128,10 @@ withConcurrentOutput a = a `finally` drain where -- Just taking the output lock is enough to ensure that anything -- that was buffering output has had a chance to flush its buffer. - drain = lockOutput (return ()) + drain = do + hPutStrLn stderr "DRAIN" + hFlush stderr + lockOutput (return ()) -- | Displays a string to stdout, and flush output so it's displayed. -- -- cgit v1.2.3 From 0a59e7e9914f7dbd5e7f8fc4bee892a220fe725e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 13:21:07 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index cbd5a00d..b49447cc 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -132,6 +132,8 @@ withConcurrentOutput a = a `finally` drain hPutStrLn stderr "DRAIN" hFlush stderr lockOutput (return ()) + hPutStrLn stderr "DRAIN DONE" + hFlush stderr -- | Displays a string to stdout, and flush output so it's displayed. -- -- cgit v1.2.3 -- cgit v1.2.3 From 99ae20dedef013397d9d9febf3beb71061491f86 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 14:21:25 -0400 Subject: propellor spin --- debian/changelog | 1 + debian/control | 2 + propellor.cabal | 6 +-- src/Propellor/Bootstrap.hs | 3 +- src/Utility/ConcurrentOutput.hs | 101 +++++++++++++++++++++------------------- 5 files changed, 60 insertions(+), 53 deletions(-) diff --git a/debian/changelog b/debian/changelog index 6c154e1a..f3522b7c 100644 --- a/debian/changelog +++ b/debian/changelog @@ -19,6 +19,7 @@ propellor (2.13.0) UNRELEASED; urgency=medium actions are combined (API change). * Added Propellor.Property.Concurrent for concurrent properties. * execProcess and everything built on it is now concurrent output safe. + * Propellor now depends on stm. * Add File.isCopyOf. Thanks, Per Olofsson. -- Joey Hess Sat, 24 Oct 2015 15:16:45 -0400 diff --git a/debian/control b/debian/control index 7f42c916..2956fdaa 100644 --- a/debian/control +++ b/debian/control @@ -17,6 +17,7 @@ Build-Depends: libghc-mtl-dev, libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), + libghc-stm-dev, Maintainer: Gergely Nagy Standards-Version: 3.9.6 Vcs-Git: git://git.joeyh.name/propellor @@ -39,6 +40,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends}, libghc-mtl-dev, libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), + libghc-stm-dev, git, make, Description: property-based host configuration management in haskell diff --git a/propellor.cabal b/propellor.cabal index 20e82407..da43775f 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -39,7 +39,7 @@ Executable propellor Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions (>= 0.6) + exceptions (>= 0.6), stm if (! os(windows)) Build-Depends: unix @@ -51,7 +51,7 @@ Executable propellor-config Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions + exceptions, stm if (! os(windows)) Build-Depends: unix @@ -62,7 +62,7 @@ Library Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions + exceptions, stm if (! os(windows)) Build-Depends: unix diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 6a5d5acb..2318b910 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -65,7 +65,7 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " aptinstall p = "apt-get --no-upgrade --no-install-recommends -y install " ++ p - -- This is the same build deps listed in debian/control. + -- This is the same deps listed in debian/control. debdeps = [ "gnupg" , "ghc" @@ -81,6 +81,7 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " , "libghc-mtl-dev" , "libghc-transformers-dev" , "libghc-exceptions-dev" + , "libghc-stm-dev" , "make" ] diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index b49447cc..301a89bc 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -14,6 +14,7 @@ import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Applicative import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent +import Control.Concurrent.STM import Control.Concurrent.Async import Data.Maybe import Data.List @@ -25,8 +26,7 @@ import Utility.Monad import Utility.Exception data OutputHandle = OutputHandle - { outputLock :: MVar () -- ^ empty when locked - , outputLockedBy :: MVar Locker + { outputLock :: TMVar (Maybe Locker) } data Locker @@ -42,8 +42,7 @@ instance Show Locker where globalOutputHandle :: MVar OutputHandle globalOutputHandle = unsafePerformIO $ newMVar =<< OutputHandle - <$> newMVar () - <*> newEmptyMVar + <$> newTMVarIO Nothing -- | Gets the global OutputHandle. getOutputHandle :: IO OutputHandle @@ -62,61 +61,65 @@ takeOutputLock = void $ takeOutputLock' True tryTakeOutputLock :: IO Bool tryTakeOutputLock = takeOutputLock' False -takeOutputLock' :: Bool -> IO Bool -takeOutputLock' block = do +withLock :: (TMVar (Maybe Locker) -> STM a) -> IO a +withLock a = do lck <- outputLock <$> getOutputHandle - go =<< tryTakeMVar lck + atomically (a lck) + +-- The lock TMVar is kept full normally, even if only with Nothing, +-- so if we take it here, that blocks anyone else from trying +-- to take the lock while we are checking it. +takeOutputLock' :: Bool -> IO Bool +takeOutputLock' block = go =<< withLock tryTakeTMVar where - -- lck was full, and we've emptied it, so we hold the lock now. - go (Just ()) = havelock - -- lck is empty, so someone else is holding the lock. - go Nothing = do - lcker <- outputLockedBy <$> getOutputHandle - v' <- tryTakeMVar lcker - case v' of - Just orig@(ProcessLock h _) -> - -- if process has exited, lock is stale - ifM (isJust <$> P.getProcessExitCode h) - ( havelock - , if block - then do - void $ P.waitForProcess h - havelock - else do - putMVar lcker orig - return False - ) - Just GeneralLock -> do - putMVar lcker GeneralLock - whenblock waitlock - Nothing -> whenblock waitlock + go Nothing = whenblock waitlock + -- Something has the lock. It may be stale, so check it. + -- We must always be sure to fill the TMVar back with Just or Nothing. + go (Just orig) = case orig of + Nothing -> havelock + (Just (ProcessLock h _)) -> + -- when process has exited, lock is stale + ifM (isJust <$> P.getProcessExitCode h) + ( havelock + , if block + then do + void $ P.waitForProcess h + havelock + else do + withLock (`putTMVar` orig) + return False + ) + (Just GeneralLock) -> do + withLock (`putTMVar` orig) + whenblock waitlock havelock = do - updateOutputLocker GeneralLock + withLock (`putTMVar` Just GeneralLock) return True - waitlock = do - -- Wait for current lock holder to relinquish - -- it and take the lock. - lck <- outputLock <$> getOutputHandle - takeMVar lck - havelock + + -- Wait for current lock holder (if any) to relinquish + -- it and take the lock for ourselves. + waitlock = withLock $ \l -> do + v <- tryTakeTMVar l + case v of + Just (Just _) -> retry + _ -> do + putTMVar l (Just GeneralLock) + return True + whenblock a = if block then a else return False -- | Only safe to call after taking the output lock. dropOutputLock :: IO () -dropOutputLock = do - lcker <- outputLockedBy <$> getOutputHandle - lck <- outputLock <$> getOutputHandle - void $ takeMVar lcker - putMVar lck () +dropOutputLock = withLock $ \l -> do + void $ takeTMVar l + putTMVar l Nothing -- | Only safe to call after takeOutputLock; updates the Locker. updateOutputLocker :: Locker -> IO () -updateOutputLocker l = do - lcker <- outputLockedBy <$> getOutputHandle - void $ tryTakeMVar lcker - putMVar lcker l - modifyMVar_ lcker (const $ return l) +updateOutputLocker locker = withLock $ \l -> do + void $ takeTMVar l + putTMVar l (Just locker) -- | Use this around any IO actions that use `outputConcurrent` -- or `createProcessConcurrent` @@ -174,8 +177,8 @@ createProcessConcurrent p hFlush stderr firstprocess , do - lcker <- outputLockedBy <$> getOutputHandle - hPutStrLn stderr $ show ("IS CONCURRENT", cmd) + v <- withLock $ tryReadTMVar + hPutStrLn stderr $ show ("IS CONCURRENT", cmd, v) hFlush stderr concurrentprocess ) -- cgit v1.2.3 From 661870a6438642110b76235622c055bb0c61bcdc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 14:24:01 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 301a89bc..03771bfd 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -83,7 +83,11 @@ takeOutputLock' block = go =<< withLock tryTakeTMVar ( havelock , if block then do + hPutStr stderr "WAITFORPROCESS in lock" + hFlush stderr void $ P.waitForProcess h + hPutStr stderr "WAITFORPROCESS in lock done" + hFlush stderr havelock else do withLock (`putTMVar` orig) -- cgit v1.2.3 From e2644e698a5a4a31896a3833708742cfd5eaa31f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 14:36:04 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 51 ++++++++++++++++++++++++----------------- 1 file changed, 30 insertions(+), 21 deletions(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 03771bfd..4d74e090 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + -- | Concurrent output handling. module Utility.ConcurrentOutput ( @@ -174,7 +176,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) = + | willOutput (P.std_out p) || willOutput (P.std_err p) = ifM tryTakeOutputLock ( do hPutStrLn stderr $ show ("NOT CONCURRENT", cmd) @@ -188,12 +190,9 @@ createProcessConcurrent p ) | otherwise = P.createProcess p where - willoutput P.Inherit = True - willoutput _ = False - - rediroutput str h - | willoutput str = P.UseHandle h - | otherwise = str + rediroutput ss h + | willOutput ss = P.UseHandle h + | otherwise = ss cmd = case P.cmdspec p of P.ShellCommand s -> s @@ -219,8 +218,8 @@ createProcessConcurrent p hClose toouth hClose toerrh buf <- newMVar [] - void $ async $ outputDrainer fromouth stdout buf - void $ async $ outputDrainer fromerrh stderr buf + void $ async $ outputDrainer (P.std_out p) fromouth stdout buf + void $ async $ outputDrainer (P.std_err p) fromerrh stderr buf void $ async $ bufferWriter buf return r @@ -228,6 +227,10 @@ createProcessConcurrent p (from, to) <- createPipe (,) <$> fdToHandle to <*> fdToHandle from +willOutput :: P.StdStream -> Bool +willOutput P.Inherit = True +willOutput _ = False + type Buffer = [(Handle, BufferedActivity)] data BufferedActivity @@ -236,17 +239,23 @@ data BufferedActivity | InTempFile FilePath deriving (Eq) --- Drain output from the handle, and buffer it in memory. -outputDrainer :: Handle -> Handle -> MVar Buffer -> IO () -outputDrainer fromh toh buf = do - v <- tryIO $ B.hGetSome fromh 1024 - case v of - Right b | not (B.null b) -> do - modifyMVar_ buf $ addBuffer (toh, Output b) - outputDrainer fromh toh buf - _ -> do - modifyMVar_ buf $ pure . (++ [(toh, ReachedEnd)]) - hClose fromh +-- Drain output from the handle, and buffer it. +outputDrainer :: P.StdStream -> Handle -> Handle -> MVar Buffer -> IO () +outputDrainer ss fromh toh buf + | willOutput ss = go + | otherwise = atend + where + go = do + v <- tryIO $ B.hGetSome fromh 1024 + case v of + Right b | not (B.null b) -> do + modifyMVar_ buf $ addBuffer (toh, Output b) + go + _ -> atend + atend = do + modifyMVar_ buf $ pure . (++ [(toh, ReachedEnd)]) + hClose fromh + -- Wait to lock output, and once we can, display everything -- that's put into buffer, until the end is signaled by Nothing @@ -285,7 +294,7 @@ addBuffer (toh, Output b) buf hClose h return ((toh, InTempFile tmp) : other) where - b' = B.concat (mapMaybe getOutput this) <> b + !b' = B.concat (mapMaybe getOutput this) <> b (this, other) = partition same buf same v = fst v == toh && case snd v of Output _ -> True -- cgit v1.2.3 From 480d4eb4993b82e15ecbbfcc4aa6f600166197d2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 14:38:52 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 4d74e090..40e0125e 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -85,11 +85,7 @@ takeOutputLock' block = go =<< withLock tryTakeTMVar ( havelock , if block then do - hPutStr stderr "WAITFORPROCESS in lock" - hFlush stderr void $ P.waitForProcess h - hPutStr stderr "WAITFORPROCESS in lock done" - hFlush stderr havelock else do withLock (`putTMVar` orig) @@ -137,12 +133,7 @@ withConcurrentOutput a = a `finally` drain where -- Just taking the output lock is enough to ensure that anything -- that was buffering output has had a chance to flush its buffer. - drain = do - hPutStrLn stderr "DRAIN" - hFlush stderr - lockOutput (return ()) - hPutStrLn stderr "DRAIN DONE" - hFlush stderr + drain = lockOutput (return ()) -- | Displays a string to stdout, and flush output so it's displayed. -- -- cgit v1.2.3 From a662eb67ec59eee6e49f98eda6dfa48f45b9567d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 14:40:11 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 40e0125e..4d74e090 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -85,7 +85,11 @@ takeOutputLock' block = go =<< withLock tryTakeTMVar ( havelock , if block then do + hPutStr stderr "WAITFORPROCESS in lock" + hFlush stderr void $ P.waitForProcess h + hPutStr stderr "WAITFORPROCESS in lock done" + hFlush stderr havelock else do withLock (`putTMVar` orig) @@ -133,7 +137,12 @@ withConcurrentOutput a = a `finally` drain where -- Just taking the output lock is enough to ensure that anything -- that was buffering output has had a chance to flush its buffer. - drain = lockOutput (return ()) + drain = do + hPutStrLn stderr "DRAIN" + hFlush stderr + lockOutput (return ()) + hPutStrLn stderr "DRAIN DONE" + hFlush stderr -- | Displays a string to stdout, and flush output so it's displayed. -- -- cgit v1.2.3 -- cgit v1.2.3 -- cgit v1.2.3 From 5aac24db607d80bd56ac76312c0c905fe806fc9c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 14:43:48 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 4d74e090..a66180d2 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -295,7 +295,7 @@ addBuffer (toh, Output b) buf return ((toh, InTempFile tmp) : other) where !b' = B.concat (mapMaybe getOutput this) <> b - (this, other) = partition same buf + !(this, other) = partition same buf same v = fst v == toh && case snd v of Output _ -> True _ -> False -- cgit v1.2.3 From 204c453b32ce6a4b0561a5bd5c3feac9e4f32860 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 14:45:08 -0400 Subject: propellor spin --- src/Utility/ConcurrentOutput.hs | 18 +++--------------- 1 file changed, 3 insertions(+), 15 deletions(-) diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index a66180d2..867ee605 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -137,12 +137,7 @@ withConcurrentOutput a = a `finally` drain where -- Just taking the output lock is enough to ensure that anything -- that was buffering output has had a chance to flush its buffer. - drain = do - hPutStrLn stderr "DRAIN" - hFlush stderr - lockOutput (return ()) - hPutStrLn stderr "DRAIN DONE" - hFlush stderr + drain = lockOutput noop -- | Displays a string to stdout, and flush output so it's displayed. -- @@ -178,15 +173,8 @@ createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Ma createProcessConcurrent p | willOutput (P.std_out p) || willOutput (P.std_err p) = ifM tryTakeOutputLock - ( do - hPutStrLn stderr $ show ("NOT CONCURRENT", cmd) - hFlush stderr - firstprocess - , do - v <- withLock $ tryReadTMVar - hPutStrLn stderr $ show ("IS CONCURRENT", cmd, v) - hFlush stderr - concurrentprocess + ( firstprocess + , concurrentprocess ) | otherwise = P.createProcess p where -- cgit v1.2.3