From dc9813a448d34496214904ddb7cae6dab88ce45e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 14:10:48 -0400 Subject: propellor spin --- src/System/Console/Concurrent/Internal.hs | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index a4cafb61..cc2beb91 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -302,6 +302,7 @@ bgProcess p = do , P.std_err = rediroutput (P.std_err p) toerrh } registerOutputThread + liftIO $ print ("bgProcess", showproc (P.cmdspec p')) r@(_, _, _, h) <- P.createProcess p' `onException` unregisterOutputThread asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h @@ -316,6 +317,8 @@ bgProcess p = do rediroutput ss h | willOutput ss = P.UseHandle h | otherwise = ss + showproc (P.RawCommand c ps) = show (c, ps) + showproc (P.ShellCommand s) = show s #endif willOutput :: P.StdStream -> Bool -- cgit v1.2.3 From 0b97dc3e9c122c7b9ca78012cafb0db8c0fe7844 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 14:13:08 -0400 Subject: propellor spin --- src/System/Console/Concurrent/Internal.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index cc2beb91..9c62a8f2 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -284,12 +284,14 @@ createProcessForeground p = do fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) fgProcess p = do + liftIO $ print ("fgProcess", showproc (P.cmdspec p)) r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock -- Wait for the process to exit and drop the lock. asyncProcessWaiter $ do void $ tryIO $ P.waitForProcess h dropOutputLock + liftIO $ print ("fgProcess done", showproc (P.cmdspec p)) return (toConcurrentProcessHandle r) #ifndef mingw32_HOST_OS @@ -317,9 +319,10 @@ bgProcess p = do rediroutput ss h | willOutput ss = P.UseHandle h | otherwise = ss - showproc (P.RawCommand c ps) = show (c, ps) - showproc (P.ShellCommand s) = show s #endif + +showproc (P.RawCommand c ps) = show (c, ps) +showproc (P.ShellCommand s) = show s willOutput :: P.StdStream -> Bool willOutput P.Inherit = True -- cgit v1.2.3 From 3da43dbbc180c5c923208281567abe225d8bad62 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 14:18:42 -0400 Subject: propellor spin --- src/Propellor/Git/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Propellor/Git/Config.hs b/src/Propellor/Git/Config.hs index f5b6678d..837fc0de 100644 --- a/src/Propellor/Git/Config.hs +++ b/src/Propellor/Git/Config.hs @@ -14,7 +14,7 @@ getGitConfigValue :: String -> IO (Maybe String) getGitConfigValue key = do value <- catchMaybeIO $ takeWhile (/= '\n') - <$> readProcess "git" ["config", key] + <$> readProcess"git" ["config", key] return $ case value of Just v | not (null v) -> Just v _ -> Nothing -- cgit v1.2.3 From a630297c4c0f5aaa5a47e4dbb7eace10f3ed967c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 14:29:00 -0400 Subject: propellor spin --- src/System/Console/Concurrent/Internal.hs | 52 +++++++++++++++++-------------- 1 file changed, 29 insertions(+), 23 deletions(-) (limited to 'src') diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index 9c62a8f2..87f7f8f6 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -77,7 +77,7 @@ tryTakeOutputLock :: IO Bool tryTakeOutputLock = takeOutputLock' False withLock :: (TMVar Lock -> STM a) -> IO a -withLock a = atomically $ a (outputLock globalOutputHandle) +withLock a = atomicallyD "withLock" $ a (outputLock globalOutputHandle) takeOutputLock' :: Bool -> IO Bool takeOutputLock' block = do @@ -94,7 +94,7 @@ takeOutputLock' block = do putTMVar l Locked return True when locked $ do - (outbuf, errbuf) <- atomically $ (,) + (outbuf, errbuf) <- atomicallyD "takeOutputLock" $ (,) <$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer []) <*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer []) emitOutputBuffer StdOut outbuf @@ -122,7 +122,7 @@ flushConcurrentOutput :: IO () flushConcurrentOutput = do -- Wait for all outputThreads to finish. let v = outputThreads globalOutputHandle - atomically $ do + atomicallyD "flushConcurrentOutput" $ do r <- takeTMVar v if r <= 0 then putTMVar v r @@ -171,9 +171,9 @@ outputConcurrent' stdh v = bracket setup cleanup go T.hPutStr h (toOutput v) hFlush h go False = do - oldbuf <- atomically $ takeTMVar bv + oldbuf <- atomicallyD "outputConcurrent" $ takeTMVar bv newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf - atomically $ putTMVar bv newbuf + atomicallyD "outputConcurrent 2" $ putTMVar bv newbuf h = toHandle stdh bv = bufferFor stdh @@ -194,14 +194,14 @@ waitForProcessConcurrent (ConcurrentProcessHandle h) = bracket lock unlock checkexit where lck = waitForProcessLock globalOutputHandle - lock = atomically $ tryPutTMVar lck () - unlock True = atomically $ takeTMVar lck + lock = atomicallyD "waitForProcessConcurrent" $ tryPutTMVar lck () + unlock True = atomicallyD "waitForProcessConcurrent 2" $ takeTMVar lck unlock False = return () checkexit locked = maybe (waitsome locked) return =<< P.getProcessExitCode h waitsome True = do let v = processWaiters globalOutputHandle - l <- atomically $ readTMVar v + l <- atomicallyD "waitForProcessConcurrent 3" $ readTMVar v if null l -- Avoid waitAny [] which blocks forever then P.waitForProcess h @@ -216,7 +216,7 @@ waitForProcessConcurrent (ConcurrentProcessHandle h) = waitsome False = do -- Another thread took the lck first. Wait for that thread to -- wait for one of the running processes to exit. - atomically $ do + atomicallyD "waitForProcessConcurrent 4" $ do putTMVar lck () takeTMVar lck checkexit False @@ -228,16 +228,16 @@ asyncProcessWaiter :: IO () -> IO () asyncProcessWaiter waitaction = do regdone <- newEmptyTMVarIO waiter <- async $ do - self <- atomically (takeTMVar regdone) + self <- atomicallyD "asyncProcessWaiter" (takeTMVar regdone) waitaction `finally` unregister self register waiter regdone where v = processWaiters globalOutputHandle - register waiter regdone = atomically $ do + register waiter regdone = atomicallyD "asyncProcessWaiter 2" $ do l <- takeTMVar v putTMVar v (waiter:l) putTMVar regdone waiter - unregister waiter = atomically $ do + unregister waiter = atomicallyD "asyncProcessWaiter 3" $ do l <- takeTMVar v putTMVar v (filter (/= waiter) l) @@ -359,8 +359,8 @@ setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHand setupOutputBuffer h toh ss fromh = do hClose toh buf <- newMVar (OutputBuffer []) - bufsig <- atomically newEmptyTMVar - bufend <- atomically newEmptyTMVar + bufsig <- atomicallyD "setupOutputBuffer" newEmptyTMVar + bufend <- atomicallyD "setupOutputBuffer 2" newEmptyTMVar void $ async $ outputDrainer ss fromh buf bufsig bufend return (h, buf, bufsig, bufend) @@ -379,21 +379,21 @@ outputDrainer ss fromh buf bufsig bufend changed go atend = do - atomically $ putTMVar bufend AtEnd + atomicallyD "atend" $ putTMVar bufend AtEnd hClose fromh - changed = atomically $ do + changed = atomicallyD "changed" $ do void $ tryTakeTMVar bufsig putTMVar bufsig BufSig registerOutputThread :: IO () registerOutputThread = do let v = outputThreads globalOutputHandle - atomically $ putTMVar v . succ =<< takeTMVar v + atomicallyD "registerOutputThread" $ putTMVar v . succ =<< takeTMVar v unregisterOutputThread :: IO () unregisterOutputThread = do let v = outputThreads globalOutputHandle - atomically $ putTMVar v . pred =<< takeTMVar v + atomicallyD "unregisterOutputThread" $ putTMVar v . pred =<< takeTMVar v -- Wait to lock output, and once we can, display everything -- that's put into the buffers, until the end. @@ -402,9 +402,9 @@ unregisterOutputThread = do -- buffers to the global outputBuffer and errorBuffer. bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO () bufferWriter ts = do - activitysig <- atomically newEmptyTMVar + activitysig <- atomicallyD "bufferWriter" newEmptyTMVar worker1 <- async $ lockOutput $ - ifM (atomically $ tryPutTMVar activitysig ()) + ifM (atomicallyD "bufferWriter 2" $ tryPutTMVar activitysig ()) ( void $ mapConcurrently displaybuf ts , noop -- buffers already moved to global ) @@ -415,7 +415,7 @@ bufferWriter ts = do unregisterOutputThread where displaybuf v@(outh, buf, bufsig, bufend) = do - change <- atomically $ + change <- atomicallyD "bufferWriter 3" $ (Right <$> takeTMVar bufsig) `orElse` (Left <$> takeTMVar bufend) @@ -426,7 +426,7 @@ bufferWriter ts = do Right BufSig -> displaybuf v Left AtEnd -> return () globalbuf activitysig = do - ok <- atomically $ do + ok <- atomicallyD "bufferWriter 4" $ do -- signal we're going to handle it -- (returns false if the displaybuf already did) ok <- tryPutTMVar activitysig () @@ -439,7 +439,7 @@ bufferWriter ts = do -- global output buffer, atomically bs <- forM ts $ \(outh, buf, _bufsig, _bufend) -> (outh,) <$> takeMVar buf - atomically $ + atomicallyD "bufferWriter 5" $ forM_ bs $ \(outh, b) -> bufferOutputSTM' outh b @@ -543,3 +543,9 @@ emitOutputBuffer stdh (OutputBuffer l) = emit t = void $ tryIO $ do T.hPutStr outh t hFlush outh + +atomicallyD m a = do + putStrLn ("START " ++ m) + r <- atomically a + putStrLn ("END " ++ m) + return r -- cgit v1.2.3 From d61a2b62092351dfbaeaee8c833fa4899eb78e0d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 14:36:47 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 2 +- src/Propellor/Engine.hs | 2 +- src/System/Console/Concurrent/Internal.hs | 58 ++++++++++++------------------- 3 files changed, 25 insertions(+), 37 deletions(-) (limited to 'src') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index a0ae9cb5..18101885 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -92,7 +92,7 @@ data CanRebuild = CanRebuild | NoRebuild -- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO () -defaultMain hostlist = withConcurrentOutput $ do +defaultMain hostlist = do Shim.cleanEnv checkDebugMode cmdline <- processCmdLine diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 2e914d67..30026568 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -32,7 +32,7 @@ import Utility.Exception -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. mainProperties :: Host -> IO () -mainProperties host = do +mainProperties host = withConcurrentOutput $ do ret <- runPropellor host $ ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty] messagesDone diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index 87f7f8f6..a4cafb61 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -77,7 +77,7 @@ tryTakeOutputLock :: IO Bool tryTakeOutputLock = takeOutputLock' False withLock :: (TMVar Lock -> STM a) -> IO a -withLock a = atomicallyD "withLock" $ a (outputLock globalOutputHandle) +withLock a = atomically $ a (outputLock globalOutputHandle) takeOutputLock' :: Bool -> IO Bool takeOutputLock' block = do @@ -94,7 +94,7 @@ takeOutputLock' block = do putTMVar l Locked return True when locked $ do - (outbuf, errbuf) <- atomicallyD "takeOutputLock" $ (,) + (outbuf, errbuf) <- atomically $ (,) <$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer []) <*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer []) emitOutputBuffer StdOut outbuf @@ -122,7 +122,7 @@ flushConcurrentOutput :: IO () flushConcurrentOutput = do -- Wait for all outputThreads to finish. let v = outputThreads globalOutputHandle - atomicallyD "flushConcurrentOutput" $ do + atomically $ do r <- takeTMVar v if r <= 0 then putTMVar v r @@ -171,9 +171,9 @@ outputConcurrent' stdh v = bracket setup cleanup go T.hPutStr h (toOutput v) hFlush h go False = do - oldbuf <- atomicallyD "outputConcurrent" $ takeTMVar bv + oldbuf <- atomically $ takeTMVar bv newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf - atomicallyD "outputConcurrent 2" $ putTMVar bv newbuf + atomically $ putTMVar bv newbuf h = toHandle stdh bv = bufferFor stdh @@ -194,14 +194,14 @@ waitForProcessConcurrent (ConcurrentProcessHandle h) = bracket lock unlock checkexit where lck = waitForProcessLock globalOutputHandle - lock = atomicallyD "waitForProcessConcurrent" $ tryPutTMVar lck () - unlock True = atomicallyD "waitForProcessConcurrent 2" $ takeTMVar lck + lock = atomically $ tryPutTMVar lck () + unlock True = atomically $ takeTMVar lck unlock False = return () checkexit locked = maybe (waitsome locked) return =<< P.getProcessExitCode h waitsome True = do let v = processWaiters globalOutputHandle - l <- atomicallyD "waitForProcessConcurrent 3" $ readTMVar v + l <- atomically $ readTMVar v if null l -- Avoid waitAny [] which blocks forever then P.waitForProcess h @@ -216,7 +216,7 @@ waitForProcessConcurrent (ConcurrentProcessHandle h) = waitsome False = do -- Another thread took the lck first. Wait for that thread to -- wait for one of the running processes to exit. - atomicallyD "waitForProcessConcurrent 4" $ do + atomically $ do putTMVar lck () takeTMVar lck checkexit False @@ -228,16 +228,16 @@ asyncProcessWaiter :: IO () -> IO () asyncProcessWaiter waitaction = do regdone <- newEmptyTMVarIO waiter <- async $ do - self <- atomicallyD "asyncProcessWaiter" (takeTMVar regdone) + self <- atomically (takeTMVar regdone) waitaction `finally` unregister self register waiter regdone where v = processWaiters globalOutputHandle - register waiter regdone = atomicallyD "asyncProcessWaiter 2" $ do + register waiter regdone = atomically $ do l <- takeTMVar v putTMVar v (waiter:l) putTMVar regdone waiter - unregister waiter = atomicallyD "asyncProcessWaiter 3" $ do + unregister waiter = atomically $ do l <- takeTMVar v putTMVar v (filter (/= waiter) l) @@ -284,14 +284,12 @@ createProcessForeground p = do fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) fgProcess p = do - liftIO $ print ("fgProcess", showproc (P.cmdspec p)) r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock -- Wait for the process to exit and drop the lock. asyncProcessWaiter $ do void $ tryIO $ P.waitForProcess h dropOutputLock - liftIO $ print ("fgProcess done", showproc (P.cmdspec p)) return (toConcurrentProcessHandle r) #ifndef mingw32_HOST_OS @@ -304,7 +302,6 @@ bgProcess p = do , P.std_err = rediroutput (P.std_err p) toerrh } registerOutputThread - liftIO $ print ("bgProcess", showproc (P.cmdspec p')) r@(_, _, _, h) <- P.createProcess p' `onException` unregisterOutputThread asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h @@ -320,9 +317,6 @@ bgProcess p = do | willOutput ss = P.UseHandle h | otherwise = ss #endif - -showproc (P.RawCommand c ps) = show (c, ps) -showproc (P.ShellCommand s) = show s willOutput :: P.StdStream -> Bool willOutput P.Inherit = True @@ -359,8 +353,8 @@ setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHand setupOutputBuffer h toh ss fromh = do hClose toh buf <- newMVar (OutputBuffer []) - bufsig <- atomicallyD "setupOutputBuffer" newEmptyTMVar - bufend <- atomicallyD "setupOutputBuffer 2" newEmptyTMVar + bufsig <- atomically newEmptyTMVar + bufend <- atomically newEmptyTMVar void $ async $ outputDrainer ss fromh buf bufsig bufend return (h, buf, bufsig, bufend) @@ -379,21 +373,21 @@ outputDrainer ss fromh buf bufsig bufend changed go atend = do - atomicallyD "atend" $ putTMVar bufend AtEnd + atomically $ putTMVar bufend AtEnd hClose fromh - changed = atomicallyD "changed" $ do + changed = atomically $ do void $ tryTakeTMVar bufsig putTMVar bufsig BufSig registerOutputThread :: IO () registerOutputThread = do let v = outputThreads globalOutputHandle - atomicallyD "registerOutputThread" $ putTMVar v . succ =<< takeTMVar v + atomically $ putTMVar v . succ =<< takeTMVar v unregisterOutputThread :: IO () unregisterOutputThread = do let v = outputThreads globalOutputHandle - atomicallyD "unregisterOutputThread" $ putTMVar v . pred =<< takeTMVar v + atomically $ putTMVar v . pred =<< takeTMVar v -- Wait to lock output, and once we can, display everything -- that's put into the buffers, until the end. @@ -402,9 +396,9 @@ unregisterOutputThread = do -- buffers to the global outputBuffer and errorBuffer. bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO () bufferWriter ts = do - activitysig <- atomicallyD "bufferWriter" newEmptyTMVar + activitysig <- atomically newEmptyTMVar worker1 <- async $ lockOutput $ - ifM (atomicallyD "bufferWriter 2" $ tryPutTMVar activitysig ()) + ifM (atomically $ tryPutTMVar activitysig ()) ( void $ mapConcurrently displaybuf ts , noop -- buffers already moved to global ) @@ -415,7 +409,7 @@ bufferWriter ts = do unregisterOutputThread where displaybuf v@(outh, buf, bufsig, bufend) = do - change <- atomicallyD "bufferWriter 3" $ + change <- atomically $ (Right <$> takeTMVar bufsig) `orElse` (Left <$> takeTMVar bufend) @@ -426,7 +420,7 @@ bufferWriter ts = do Right BufSig -> displaybuf v Left AtEnd -> return () globalbuf activitysig = do - ok <- atomicallyD "bufferWriter 4" $ do + ok <- atomically $ do -- signal we're going to handle it -- (returns false if the displaybuf already did) ok <- tryPutTMVar activitysig () @@ -439,7 +433,7 @@ bufferWriter ts = do -- global output buffer, atomically bs <- forM ts $ \(outh, buf, _bufsig, _bufend) -> (outh,) <$> takeMVar buf - atomicallyD "bufferWriter 5" $ + atomically $ forM_ bs $ \(outh, b) -> bufferOutputSTM' outh b @@ -543,9 +537,3 @@ emitOutputBuffer stdh (OutputBuffer l) = emit t = void $ tryIO $ do T.hPutStr outh t hFlush outh - -atomicallyD m a = do - putStrLn ("START " ++ m) - r <- atomically a - putStrLn ("END " ++ m) - return r -- cgit v1.2.3 From af34093977b209c4fb7059677bd537ffd86b516d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Mar 2016 14:41:48 -0400 Subject: move back --- src/Propellor/CmdLine.hs | 2 +- src/Propellor/Engine.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 18101885..a0ae9cb5 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -92,7 +92,7 @@ data CanRebuild = CanRebuild | NoRebuild -- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO () -defaultMain hostlist = do +defaultMain hostlist = withConcurrentOutput $ do Shim.cleanEnv checkDebugMode cmdline <- processCmdLine diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 30026568..2e914d67 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -32,7 +32,7 @@ import Utility.Exception -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. mainProperties :: Host -> IO () -mainProperties host = withConcurrentOutput $ do +mainProperties host = do ret <- runPropellor host $ ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty] messagesDone -- cgit v1.2.3