From 6e3b0022fa451181fdce8abd145e27a64a777711 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Oct 2015 16:19:15 -0400 Subject: use a shared global for the MessageHandle --- src/Propellor/Message.hs | 69 +++++++++++++++++++++++------------------------- 1 file changed, 33 insertions(+), 36 deletions(-) (limited to 'src/Propellor/Message.hs') diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 94892da8..9c6cb57c 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -9,10 +9,11 @@ import System.Log.Formatter import System.Log.Handler (setFormatter) import System.Log.Handler.Simple import "mtl" Control.Monad.Reader -import Data.Maybe import Control.Applicative import System.Directory import Control.Monad.IfElse +import System.IO.Unsafe (unsafePerformIO) +import Control.Concurrent import Propellor.Types import Utility.Monad @@ -20,27 +21,26 @@ import Utility.Env import Utility.Process import Utility.Exception -data MessageHandle - = ConsoleMessageHandle - | TextMessageHandle +data MessageHandle = MessageHandle + { isConsole :: Bool + } -mkMessageHandle :: IO MessageHandle -mkMessageHandle = do - ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE")) - ( return ConsoleMessageHandle - , return TextMessageHandle - ) +-- | A shared global variable for the MessageHandle. +{-# NOINLINE globalMessageHandle #-} +globalMessageHandle :: MVar MessageHandle +globalMessageHandle = unsafePerformIO $ do + c <- hIsTerminalDevice stdout + newMVar $ MessageHandle c -forceConsole :: IO () -forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True +getMessageHandle :: IO MessageHandle +getMessageHandle = readMVar globalMessageHandle -isConsole :: MessageHandle -> Bool -isConsole ConsoleMessageHandle = True -isConsole _ = False +forceConsole :: IO () +forceConsole = modifyMVar_ globalMessageHandle $ \mh -> + pure (mh { isConsole = True }) -whenConsole :: MessageHandle -> IO () -> IO () -whenConsole ConsoleMessageHandle a = a -whenConsole _ _ = return () +whenConsole :: IO () -> IO () +whenConsole a = whenM (isConsole <$> getMessageHandle) a -- | Shows a message while performing an action, with a colored status -- display. @@ -54,49 +54,46 @@ actionMessageOn = actionMessage' . Just actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r actionMessage' mhn desc a = do - h <- liftIO mkMessageHandle - liftIO $ whenConsole h $ do + liftIO $ whenConsole $ do setTitle $ "propellor: " ++ desc hFlush stdout r <- a liftIO $ do - whenConsole h $ + whenConsole $ setTitle "propellor: running" - showhn h mhn + showhn mhn putStr $ desc ++ " ... " let (msg, intensity, color) = getActionResult r - colorLine h intensity color msg + colorLine intensity color msg hFlush stdout return r where - showhn _ Nothing = return () - showhn h (Just hn) = do - whenConsole h $ + showhn Nothing = return () + showhn (Just hn) = do + whenConsole $ setSGR [SetColor Foreground Dull Cyan] putStr (hn ++ " ") - whenConsole h $ + whenConsole $ setSGR [] warningMessage :: MonadIO m => String -> m () -warningMessage s = liftIO $ do - h <- mkMessageHandle - colorLine h Vivid Magenta $ "** warning: " ++ s +warningMessage s = liftIO $ + colorLine Vivid Magenta $ "** warning: " ++ s errorMessage :: MonadIO m => String -> m a errorMessage s = liftIO $ do - h <- mkMessageHandle - colorLine h Vivid Red $ "** error: " ++ s + colorLine Vivid Red $ "** error: " ++ s error "Cannot continue!" -colorLine :: MessageHandle -> ColorIntensity -> Color -> String -> IO () -colorLine h intensity color msg = do - whenConsole h $ +colorLine :: ColorIntensity -> Color -> String -> IO () +colorLine intensity color msg = do + whenConsole $ setSGR [SetColor Foreground intensity color] putStr msg - whenConsole h $ + whenConsole $ setSGR [] -- Note this comes after the color is reset, so that -- the color set and reset happen in the same line. -- cgit v1.3-2-g0d8e From 20b04d366b2cff90c39d06fd424ae3e8b67e49f6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Oct 2015 17:02:23 -0400 Subject: make Propellor.Message use lock to handle concurrent threads outputting messages Not yet handled: Output from concurrent programs. --- debian/changelog | 2 +- src/Propellor/Engine.hs | 33 +------------ src/Propellor/Message.hs | 92 ++++++++++++++++++++++++++++++++---- src/Propellor/PrivData.hs | 22 +++++---- src/Propellor/Property/Concurrent.hs | 4 +- 5 files changed, 100 insertions(+), 53 deletions(-) (limited to 'src/Propellor/Message.hs') diff --git a/debian/changelog b/debian/changelog index 6b3f6940..1699b27b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -18,7 +18,7 @@ propellor (2.13.0) UNRELEASED; urgency=medium * combineWith now takes an additional parameter to control how revert actions are combined (API change). * Added Propellor.Property.Concurrent for concurrent properties. - (Note that no output multiplexing is currently done.) + (Note that no command output multiplexing is currently done.) * Add File.isCopyOf. Thanks, Per Olofsson. -- Joey Hess Sat, 24 Oct 2015 15:16:45 -0400 diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index f0bcdac8..36a05b28 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -9,14 +9,12 @@ module Propellor.Engine ( fromHost, fromHost', onlyProcess, - processChainOutput, ) where import System.Exit import System.IO import Data.Monoid import Control.Applicative -import System.Console.ANSI import "mtl" Control.Monad.RWS.Strict import System.PosixCompat import System.Posix.IO @@ -29,8 +27,6 @@ import Propellor.Exception import Propellor.Info import Propellor.Property import Utility.Exception -import Utility.PartialPrelude -import Utility.Monad -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. @@ -38,9 +34,7 @@ mainProperties :: Host -> IO () mainProperties host = do ret <- runPropellor host $ ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty] - whenConsole $ - setTitle "propellor: done" - hFlush stdout + messagesDone case ret of FailedChange -> exitWith (ExitFailure 1) _ -> exitWith ExitSuccess @@ -98,28 +92,3 @@ onlyProcess lockfile a = bracket lock unlock (const a) return l unlock = closeFd alreadyrunning = error "Propellor is already running on this host!" - --- | Reads and displays each line from the Handle, except for the last line --- which is a Result. -processChainOutput :: Handle -> IO Result -processChainOutput h = go Nothing - where - go lastline = do - v <- catchMaybeIO (hGetLine h) - debug ["read from chained propellor: ", show v] - case v of - Nothing -> case lastline of - Nothing -> do - debug ["chained propellor output nothing; assuming it failed"] - return FailedChange - Just l -> case readish l of - Just r -> pure r - Nothing -> do - debug ["chained propellor output did not end with a Result; assuming it failed"] - putStrLn l - hFlush stdout - return FailedChange - Just s -> do - maybe noop (\l -> unless (null l) (putStrLn l)) lastline - hFlush stdout - go (Just s) diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 9c6cb57c..0961a356 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -1,6 +1,26 @@ {-# LANGUAGE PackageImports #-} -module Propellor.Message where +-- | This module handles all display of output to the console when +-- propellor is ensuring Properties. +-- +-- When two threads both try to display a message concurrently, +-- the messages will be displayed sequentially. + +module Propellor.Message ( + getMessageHandle, + isConsole, + forceConsole, + actionMessage, + actionMessageOn, + warningMessage, + infoMessage, + errorMessage, + debug, + checkDebugMode, + enableDebugMode, + processChainOutput, + messagesDone, +) where import System.Console.ANSI import System.IO @@ -16,6 +36,7 @@ import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent import Propellor.Types +import Utility.PartialPrelude import Utility.Monad import Utility.Env import Utility.Process @@ -23,6 +44,7 @@ import Utility.Exception data MessageHandle = MessageHandle { isConsole :: Bool + , outputLock :: MVar () } -- | A shared global variable for the MessageHandle. @@ -30,30 +52,44 @@ data MessageHandle = MessageHandle globalMessageHandle :: MVar MessageHandle globalMessageHandle = unsafePerformIO $ do c <- hIsTerminalDevice stdout - newMVar $ MessageHandle c + o <- newMVar () + newMVar $ MessageHandle c o +-- | Gets the global MessageHandle. getMessageHandle :: IO MessageHandle getMessageHandle = readMVar globalMessageHandle +-- | Takes a lock while performing an action. Any other threads +-- that try to lockOutput at the same time will block. +lockOutput :: (MonadIO m, MonadMask m) => m a -> m a +lockOutput a = do + lck <- liftIO $ outputLock <$> getMessageHandle + bracket_ (liftIO $ takeMVar lck) (liftIO $ putMVar lck ()) a + +-- | Force console output. This can be used when stdout is not directly +-- connected to a console, but is eventually going to be displayed at a +-- console. forceConsole :: IO () forceConsole = modifyMVar_ globalMessageHandle $ \mh -> pure (mh { isConsole = True }) +-- | Only performs the action when at the console, or when console +-- output has been forced. whenConsole :: IO () -> IO () whenConsole a = whenM (isConsole <$> getMessageHandle) a -- | Shows a message while performing an action, with a colored status -- display. -actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r +actionMessage :: (MonadIO m, MonadMask m, ActionResult r) => Desc -> m r -> m r actionMessage = actionMessage' Nothing -- | Shows a message while performing an action on a specified host, -- with a colored status display. -actionMessageOn :: (MonadIO m, ActionResult r) => HostName -> Desc -> m r -> m r +actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc -> m r -> m r actionMessageOn = actionMessage' . Just -actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r -actionMessage' mhn desc a = do +actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r +actionMessage' mhn desc a = lockOutput $ do liftIO $ whenConsole $ do setTitle $ "propellor: " ++ desc hFlush stdout @@ -80,14 +116,18 @@ actionMessage' mhn desc a = do setSGR [] warningMessage :: MonadIO m => String -> m () -warningMessage s = liftIO $ +warningMessage s = liftIO $ lockOutput $ colorLine Vivid Magenta $ "** warning: " ++ s +infoMessage :: MonadIO m => [String] -> m () +infoMessage ls = liftIO $ lockOutput $ + mapM_ putStrLn ls + errorMessage :: MonadIO m => String -> m a -errorMessage s = liftIO $ do +errorMessage s = liftIO $ lockOutput $ do colorLine Vivid Red $ "** error: " ++ s error "Cannot continue!" - + colorLine :: ColorIntensity -> Color -> String -> IO () colorLine intensity color msg = do whenConsole $ @@ -120,3 +160,37 @@ enableDebugMode = do <*> pure (simpleLogFormatter "[$time] $msg") updateGlobalLogger rootLoggerName $ setLevel DEBUG . setHandlers [f] + +-- | Reads and displays each line from the Handle, except for the last line +-- which is a Result. +processChainOutput :: Handle -> IO Result +processChainOutput h = go Nothing + where + go lastline = do + v <- catchMaybeIO (hGetLine h) + debug ["read from chained propellor: ", show v] + case v of + Nothing -> case lastline of + Nothing -> do + debug ["chained propellor output nothing; assuming it failed"] + return FailedChange + Just l -> case readish l of + Just r -> pure r + Nothing -> do + debug ["chained propellor output did not end with a Result; assuming it failed"] + lockOutput $ do + putStrLn l + hFlush stdout + return FailedChange + Just s -> do + lockOutput $ do + maybe noop (\l -> unless (null l) (putStrLn l)) lastline + hFlush stdout + go (Just s) + +-- | Called when all messages about properties have been printed. +messagesDone :: IO () +messagesDone = lockOutput $ do + whenConsole $ + setTitle "propellor: done" + hFlush stdout diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index aac37d14..e59f42c3 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -106,9 +106,9 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> missing = do Context cname <- mkHostContext hc <$> asks hostName warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")" - liftIO $ putStrLn $ "Fix this by running:" - liftIO $ showSet $ - map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist + infoMessage $ + "Fix this by running:" : + showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist) return FailedChange addinfo p = infoProperty (propertyDesc p) @@ -121,11 +121,14 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> fieldlist = map privDataField srclist hc = asHostContext c -showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> IO () -showSet l = forM_ l $ \(f, Context c, md) -> do - putStrLn $ " propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\" - maybe noop (\d -> putStrLn $ " " ++ d) md - putStrLn "" +showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> [String] +showSet = concatMap go + where + go (f, Context c, md) = catMaybes + [ Just $ " propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\" + , maybe Nothing (\d -> Just $ " " ++ d) md + , Just "" + ] addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo addPrivData v = pureInfoProperty (show v) (PrivInfo (S.singleton v)) @@ -207,7 +210,8 @@ listPrivDataFields hosts = do showtable $ map mkrow missing section "How to set missing data:" - showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing + mapM_ putStrLn $ showSet $ + map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing where header = ["Field", "Context", "Used by"] mkrow k@(field, Context context) = diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index c57f5228..645a5dfd 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} --- | Note that this module does not yet arrange for any output multiplexing, --- so the output of concurrent properties will be scrambled together. +-- | Note that any output of commands run by +-- concurrent properties will be scrambled together. module Propellor.Property.Concurrent ( concurrently, -- cgit v1.3-2-g0d8e From 51b397d0415e1efe1df412842ccb76d702140f50 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Oct 2015 23:19:41 -0400 Subject: concurrent version of createProcess Have not yet wired everything up to use this, that currently uses Utility.Process. --- src/Propellor/Message.hs | 213 +++++++++++++++++++++++++++++++++++++++--- src/Propellor/Property/Cmd.hs | 1 + 2 files changed, 201 insertions(+), 13 deletions(-) (limited to 'src/Propellor/Message.hs') diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 0961a356..afe551cf 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -20,10 +20,12 @@ module Propellor.Message ( enableDebugMode, processChainOutput, messagesDone, + createProcess, ) where import System.Console.ANSI import System.IO +import System.Posix.IO import System.Log.Logger import System.Log.Formatter import System.Log.Handler (setFormatter) @@ -34,26 +36,38 @@ import System.Directory import Control.Monad.IfElse import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent +import Control.Concurrent.Async +import Data.Maybe +import Data.Char +import Data.List +import Data.Monoid +import qualified Data.ByteString as B import Propellor.Types import Utility.PartialPrelude import Utility.Monad import Utility.Env -import Utility.Process import Utility.Exception +import qualified Utility.Process as P data MessageHandle = MessageHandle { isConsole :: Bool - , outputLock :: MVar () + , outputLock :: MVar () -- ^ empty when locked + , outputLockedBy :: MVar Locker } +data Locker + = GeneralLock + | ProcessLock P.ProcessHandle + -- | A shared global variable for the MessageHandle. {-# NOINLINE globalMessageHandle #-} globalMessageHandle :: MVar MessageHandle -globalMessageHandle = unsafePerformIO $ do - c <- hIsTerminalDevice stdout - o <- newMVar () - newMVar $ MessageHandle c o +globalMessageHandle = unsafePerformIO $ + newMVar =<< MessageHandle + <$> hIsTerminalDevice stdout + <*> newMVar () + <*> newEmptyMVar -- | Gets the global MessageHandle. getMessageHandle :: IO MessageHandle @@ -62,9 +76,71 @@ getMessageHandle = readMVar globalMessageHandle -- | Takes a lock while performing an action. Any other threads -- that try to lockOutput at the same time will block. lockOutput :: (MonadIO m, MonadMask m) => m a -> m a -lockOutput a = do - lck <- liftIO $ outputLock <$> getMessageHandle - bracket_ (liftIO $ takeMVar lck) (liftIO $ putMVar lck ()) a +lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) + +-- | Blocks until we have the output lock. +takeOutputLock :: IO () +takeOutputLock = void $ takeOutputLock' True + +-- | Tries to take the output lock, without blocking. +tryTakeOutputLock :: IO Bool +tryTakeOutputLock = takeOutputLock' False + +takeOutputLock' :: Bool -> IO Bool +takeOutputLock' block = do + lck <- outputLock <$> getMessageHandle + go =<< tryTakeMVar lck + 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 <$> getMessageHandle + v' <- tryTakeMVar lcker + case v' of + Just (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 (ProcessLock h) + return False + ) + Just GeneralLock -> do + putMVar lcker GeneralLock + whenblock waitlock + Nothing -> whenblock waitlock + + havelock = do + updateOutputLocker GeneralLock + return True + waitlock = do + -- Wait for current lock holder to relinquish + -- it and take the lock. + lck <- outputLock <$> getMessageHandle + takeMVar lck + havelock + whenblock a = if block then a else return False + +-- | Only safe to call after taking the output lock. +dropOutputLock :: IO () +dropOutputLock = do + lcker <- outputLockedBy <$> getMessageHandle + lck <- outputLock <$> getMessageHandle + takeMVar lcker + putMVar lck () + +-- | Only safe to call after takeOutputLock; updates the Locker. +updateOutputLocker :: Locker -> IO () +updateOutputLocker l = do + lcker <- outputLockedBy <$> getMessageHandle + void $ tryTakeMVar lcker + putMVar lcker l + modifyMVar_ lcker (const $ return l) -- | Force console output. This can be used when stdout is not directly -- connected to a console, but is eventually going to be displayed at a @@ -89,14 +165,14 @@ actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc actionMessageOn = actionMessage' . Just actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r -actionMessage' mhn desc a = lockOutput $ do - liftIO $ whenConsole $ do +actionMessage' mhn desc a = do + liftIO $ whenConsole $ lockOutput $ do setTitle $ "propellor: " ++ desc hFlush stdout r <- a - liftIO $ do + liftIO $ lockOutput $ do whenConsole $ setTitle "propellor: running" showhn mhn @@ -151,7 +227,7 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" go Nothing = whenM (doesDirectoryExist ".git") $ whenM (elem "1" . lines <$> getgitconfig) enableDebugMode getgitconfig = catchDefaultIO "" $ - readProcess "git" ["config", "propellor.debug"] + P.readProcess "git" ["config", "propellor.debug"] enableDebugMode :: IO () enableDebugMode = do @@ -194,3 +270,114 @@ messagesDone = lockOutput $ do whenConsole $ setTitle "propellor: done" hFlush stdout + +-- | Wrapper around `System.Process.createProcess` that prevents processes +-- that are running concurrently from writing to the stdout/stderr at the +-- same time. +-- +-- The first process run by createProcess is allowed to write to +-- stdout and stderr in the usual way. +-- +-- However, if a second createProcess runs concurrently with the +-- first, any stdout or stderr that would have been displayed by it is +-- instead buffered. The buffered output will be displayed the next time it +-- is safe to do so (ie, after the first process exits). +-- +-- `Propellor.Property.Cmd` has some other useful actions for running +-- commands, which are based on this. +-- +-- Also does debug logging of all commands run. +createProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) +createProcess p + | hasoutput (P.std_out p) || hasoutput (P.std_err p) = + ifM tryTakeOutputLock + ( firstprocess + , concurrentprocess + ) + | otherwise = P.createProcess p + where + hasoutput P.Inherit = True + hasoutput _ = False + + firstprocess = do + r@(_, _, _, h) <- P.createProcess p + `onException` dropOutputLock + updateOutputLocker (ProcessLock h) + -- 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. + return r + + concurrentprocess = do + (toouth, fromouth) <- pipe + (toerrh, fromerrh) <- pipe + let p' = p + { P.std_out = if hasoutput (P.std_out p) + then P.UseHandle toouth + else P.std_out p + , P.std_err = if hasoutput (P.std_err p) + then P.UseHandle toerrh + else P.std_err p + } + r@(_, _, _, ph) <- P.createProcess p' + hClose toouth + hClose toerrh + buf <- newMVar [] + void $ async $ outputDrainer fromouth stdout buf + void $ async $ outputDrainer fromouth stderr buf + void $ async $ bufferWriter buf + return r + + pipe = do + (from, to) <- createPipe + (,) <$> fdToHandle to <*> fdToHandle from + +type Buffer = [(Handle, Maybe B.ByteString)] + +-- 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 (pure . addBuffer (toh, Just b)) + outputDrainer fromh toh buf + _ -> do + modifyMVar_ buf (pure . (++ [(toh, Nothing)])) + hClose fromh + +-- Wait to lock output, and once we can, display everything +-- that's put into buffer, until the end is signaled by Nothing +-- for both stdout and stderr. +bufferWriter buf = lockOutput (go [stdout, stderr]) + where + go [] = return () + go hs = do + l <- takeMVar buf + forM_ l $ \(h, mb) -> do + maybe noop (B.hPut h) mb + hFlush h + let hs' = filter (\h -> not (any (== (h, Nothing)) l)) hs + putMVar buf [] + go hs' + +-- The buffer can grow up to 1 mb in size, but after that point, +-- it's truncated to avoid propellor using unbounded memory +-- when a process outputs a whole lot of stuff. +bufsz = 1000000 + +addBuffer :: (Handle, Maybe B.ByteString) -> Buffer -> Buffer +addBuffer v@(_, Nothing) buf = buf ++ [v] +addBuffer (toh, Just b) buf = (toh, Just b') : other + where + (this, other) = partition (\v -> fst v == toh && isJust (snd v)) buf + b' = truncateBuffer $ B.concat (mapMaybe snd this) <> b + +-- Truncate a buffer by removing lines from the front until it's +-- small enough. +truncateBuffer :: B.ByteString -> B.ByteString +truncateBuffer b + | B.length b <= bufsz = b + | otherwise = truncateBuffer $ snd $ B.breakByte nl b + where + nl = fromIntegral (ord '\n') diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index 23816a94..f2c5b33e 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -16,6 +16,7 @@ module Propellor.Property.Cmd ( safeSystemEnv, shellEscape, createProcess, + waitForProcess, ) where import Control.Applicative -- cgit v1.3-2-g0d8e From 894e2f7980052f1c331ba7780100ae0ad19856cb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Oct 2015 23:52:02 -0400 Subject: use execProcessConcurrent everywhere Found a reasonable clean way to make Utility.Process use execProcessConcurrent, while still allowing copying updates to it from git-annex. --- propellor.cabal | 2 ++ src/Propellor/Base.hs | 2 ++ src/Propellor/Debug.hs | 36 +++++++++++++++++++++++++++++++ src/Propellor/Message.hs | 49 ++++++++----------------------------------- src/Propellor/Property/Cmd.hs | 2 +- src/Utility/Process.hs | 16 +++++++------- src/Utility/Process/Shim.hs | 8 +++++++ 7 files changed, 66 insertions(+), 49 deletions(-) create mode 100644 src/Propellor/Debug.hs create mode 100644 src/Utility/Process/Shim.hs (limited to 'src/Propellor/Message.hs') diff --git a/propellor.cabal b/propellor.cabal index 7a9d2b5d..63fcaaa5 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -135,6 +135,7 @@ Library Propellor.CmdLine Propellor.Info Propellor.Message + Propellor.Debug Propellor.PrivData Propellor.Engine Propellor.Exception @@ -175,6 +176,7 @@ Library Utility.PartialPrelude Utility.PosixFiles Utility.Process + Utility.Process.Shim Utility.SafeCommand Utility.Scheduled Utility.Table diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs index 3c13bb7d..2a0f5cbc 100644 --- a/src/Propellor/Base.hs +++ b/src/Propellor/Base.hs @@ -15,6 +15,7 @@ module Propellor.Base ( , module Propellor.Engine , module Propellor.Exception , module Propellor.Message + , module Propellor.Debug , module Propellor.Location , module Propellor.Utilities @@ -39,6 +40,7 @@ import Propellor.Property.Cmd import Propellor.PrivData import Propellor.Types.PrivData import Propellor.Message +import Propellor.Debug import Propellor.Exception import Propellor.Info import Propellor.PropAccum diff --git a/src/Propellor/Debug.hs b/src/Propellor/Debug.hs new file mode 100644 index 00000000..ac4a56cc --- /dev/null +++ b/src/Propellor/Debug.hs @@ -0,0 +1,36 @@ +module Propellor.Debug where + +import Control.Applicative +import Control.Monad.IfElse +import System.IO +import System.Directory +import System.Log.Logger +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple + +import Utility.Monad +import Utility.Env +import Utility.Exception +import Utility.Process + +debug :: [String] -> IO () +debug = debugM "propellor" . unwords + +checkDebugMode :: IO () +checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" + where + go (Just "1") = enableDebugMode + go (Just _) = noop + go Nothing = whenM (doesDirectoryExist ".git") $ + whenM (elem "1" . lines <$> getgitconfig) enableDebugMode + getgitconfig = catchDefaultIO "" $ + readProcess "git" ["config", "propellor.debug"] + +enableDebugMode :: IO () +enableDebugMode = do + f <- setFormatter + <$> streamHandler stderr DEBUG + <*> pure (simpleLogFormatter "[$time] $msg") + updateGlobalLogger rootLoggerName $ + setLevel DEBUG . setHandlers [f] diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index afe551cf..4be8263e 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -15,24 +15,16 @@ module Propellor.Message ( warningMessage, infoMessage, errorMessage, - debug, - checkDebugMode, - enableDebugMode, processChainOutput, messagesDone, - createProcess, + createProcessConcurrent, ) where import System.Console.ANSI import System.IO import System.Posix.IO -import System.Log.Logger -import System.Log.Formatter -import System.Log.Handler (setFormatter) -import System.Log.Handler.Simple import "mtl" Control.Monad.Reader import Control.Applicative -import System.Directory import Control.Monad.IfElse import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent @@ -42,13 +34,12 @@ import Data.Char import Data.List import Data.Monoid import qualified Data.ByteString as B +import qualified System.Process as P import Propellor.Types import Utility.PartialPrelude import Utility.Monad -import Utility.Env import Utility.Exception -import qualified Utility.Process as P data MessageHandle = MessageHandle { isConsole :: Bool @@ -131,7 +122,7 @@ dropOutputLock :: IO () dropOutputLock = do lcker <- outputLockedBy <$> getMessageHandle lck <- outputLock <$> getMessageHandle - takeMVar lcker + void $ takeMVar lcker putMVar lck () -- | Only safe to call after takeOutputLock; updates the Locker. @@ -216,27 +207,6 @@ colorLine intensity color msg = do putStrLn "" hFlush stdout -debug :: [String] -> IO () -debug = debugM "propellor" . unwords - -checkDebugMode :: IO () -checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" - where - go (Just "1") = enableDebugMode - go (Just _) = noop - go Nothing = whenM (doesDirectoryExist ".git") $ - whenM (elem "1" . lines <$> getgitconfig) enableDebugMode - getgitconfig = catchDefaultIO "" $ - P.readProcess "git" ["config", "propellor.debug"] - -enableDebugMode :: IO () -enableDebugMode = do - f <- setFormatter - <$> streamHandler stderr DEBUG - <*> pure (simpleLogFormatter "[$time] $msg") - updateGlobalLogger rootLoggerName $ - setLevel DEBUG . setHandlers [f] - -- | Reads and displays each line from the Handle, except for the last line -- which is a Result. processChainOutput :: Handle -> IO Result @@ -244,16 +214,13 @@ processChainOutput h = go Nothing where go lastline = do v <- catchMaybeIO (hGetLine h) - debug ["read from chained propellor: ", show v] case v of Nothing -> case lastline of Nothing -> do - debug ["chained propellor output nothing; assuming it failed"] return FailedChange Just l -> case readish l of Just r -> pure r Nothing -> do - debug ["chained propellor output did not end with a Result; assuming it failed"] lockOutput $ do putStrLn l hFlush stdout @@ -287,8 +254,8 @@ messagesDone = lockOutput $ do -- commands, which are based on this. -- -- Also does debug logging of all commands run. -createProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -createProcess p +createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) +createProcessConcurrent p | hasoutput (P.std_out p) || hasoutput (P.std_err p) = ifM tryTakeOutputLock ( firstprocess @@ -319,12 +286,12 @@ createProcess p then P.UseHandle toerrh else P.std_err p } - r@(_, _, _, ph) <- P.createProcess p' + r <- P.createProcess p' hClose toouth hClose toerrh buf <- newMVar [] void $ async $ outputDrainer fromouth stdout buf - void $ async $ outputDrainer fromouth stderr buf + void $ async $ outputDrainer fromerrh stderr buf void $ async $ bufferWriter buf return r @@ -349,6 +316,7 @@ outputDrainer fromh toh buf = do -- Wait to lock output, and once we can, display everything -- that's put into buffer, until the end is signaled by Nothing -- for both stdout and stderr. +bufferWriter :: MVar Buffer -> IO () bufferWriter buf = lockOutput (go [stdout, stderr]) where go [] = return () @@ -364,6 +332,7 @@ bufferWriter buf = lockOutput (go [stdout, stderr]) -- The buffer can grow up to 1 mb in size, but after that point, -- it's truncated to avoid propellor using unbounded memory -- when a process outputs a whole lot of stuff. +bufsz :: Int bufsz = 1000000 addBuffer :: (Handle, Maybe B.ByteString) -> Buffer -> Buffer diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index f2c5b33e..9536f71d 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -27,7 +27,7 @@ import Propellor.Types import Propellor.Property import Utility.SafeCommand import Utility.Env -import Utility.Process (createProcess, CreateProcess) +import Utility.Process (createProcess, CreateProcess, waitForProcess) -- | A property that can be satisfied by running a command. -- diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs index cc113867..c6699961e 100644 --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -41,9 +41,12 @@ module Utility.Process ( devNull, ) where -import qualified System.Process -import qualified System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) -import System.Process hiding (createProcess, readProcess, waitForProcess) +import qualified Utility.Process.Shim +import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) +import Utility.Process.Shim hiding (createProcess, readProcess, waitForProcess) +import Utility.Misc +import Utility.Exception + import System.Exit import System.IO import System.Log.Logger @@ -58,9 +61,6 @@ import Control.Applicative import Data.Maybe import Prelude -import Utility.Misc -import Utility.Exception - type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a data StdHandle = StdinHandle | StdoutHandle | StderrHandle @@ -372,7 +372,7 @@ startInteractiveProcess cmd args environ = do createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do debugProcess p - System.Process.createProcess p + Utility.Process.Shim.createProcess p -- | Debugging trace for a CreateProcess. debugProcess :: CreateProcess -> IO () @@ -392,6 +392,6 @@ debugProcess p = debugM "Utility.Process" $ unwords -- | Wrapper around 'System.Process.waitForProcess' that does debug logging. waitForProcess :: ProcessHandle -> IO ExitCode waitForProcess h = do - r <- System.Process.waitForProcess h + r <- Utility.Process.Shim.waitForProcess h debugM "Utility.Process" ("process done " ++ show r) return r diff --git a/src/Utility/Process/Shim.hs b/src/Utility/Process/Shim.hs new file mode 100644 index 00000000..0da93bf7 --- /dev/null +++ b/src/Utility/Process/Shim.hs @@ -0,0 +1,8 @@ +module Utility.Process.Shim (module X, createProcess) where + +import System.Process as X hiding (createProcess) +import Propellor.Message (createProcessConcurrent) +import System.IO + +createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess = createProcessConcurrent -- cgit v1.3-2-g0d8e From 357ffb9fd34ebd36e07dece8e45450dbd2f0e8ec Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 00:12:38 -0400 Subject: concurrency docs --- debian/changelog | 2 +- src/Propellor/Message.hs | 16 ++++++++-------- src/Propellor/Property/Concurrent.hs | 37 +++++++++++++++++++++++++++++++++--- 3 files changed, 43 insertions(+), 12 deletions(-) (limited to 'src/Propellor/Message.hs') diff --git a/debian/changelog b/debian/changelog index 1699b27b..6c154e1a 100644 --- a/debian/changelog +++ b/debian/changelog @@ -18,7 +18,7 @@ propellor (2.13.0) UNRELEASED; urgency=medium * combineWith now takes an additional parameter to control how revert actions are combined (API change). * Added Propellor.Property.Concurrent for concurrent properties. - (Note that no command output multiplexing is currently done.) + * execProcess and everything built on it is now concurrent output safe. * Add File.isCopyOf. Thanks, Per Olofsson. -- Joey Hess Sat, 24 Oct 2015 15:16:45 -0400 diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 4be8263e..3792129b 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -238,22 +238,22 @@ messagesDone = lockOutput $ do setTitle "propellor: done" hFlush stdout --- | Wrapper around `System.Process.createProcess` that prevents processes --- that are running concurrently from writing to the stdout/stderr at the --- same time. +-- | Wrapper around `System.Process.createProcess` that prevents +-- multiple processes that are running concurrently from writing +-- to stdout/stderr at the same time. -- --- The first process run by createProcess is allowed to write to +-- The first process is allowed to write to -- stdout and stderr in the usual way. -- --- However, if a second createProcess runs concurrently with the +-- However, if another process runs concurrently with the -- first, any stdout or stderr that would have been displayed by it is -- instead buffered. The buffered output will be displayed the next time it -- is safe to do so (ie, after the first process exits). -- --- `Propellor.Property.Cmd` has some other useful actions for running --- commands, which are based on this. --- -- Also does debug logging of all commands run. +-- +-- Unless you manually import System.Process, every part of propellor +-- that runs a process uses this. createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) createProcessConcurrent p | hasoutput (P.std_out p) || hasoutput (P.std_err p) = diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index 645a5dfd..74afecc4 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -1,14 +1,38 @@ {-# LANGUAGE FlexibleContexts #-} --- | Note that any output of commands run by --- concurrent properties will be scrambled together. +-- | Propellor properties can be made to run concurrently, using this +-- module. This can speed up propellor, at the expense of using more CPUs +-- and other resources. +-- +-- It's up to you to make sure that properties that you make run concurrently +-- don't implicitly depend on one-another. The worst that can happen +-- though, is that propellor fails to ensure some of the properties, +-- and tells you what went wrong. +-- +-- Another potential problem is that output of concurrent properties could +-- interleave into a scrambled mess. This is mostly prevented; all messages +-- output by propellor are concurrency safe, including `errorMessage`, +-- `infoMessage`, etc. However, if you write a property that directly +-- uses `print` or `putStrLn`, you can still experience this problem. +-- +-- Similarly, when properties run external commands, the command's output +-- can be a problem for concurrency. No need to worry; +-- `Propellor.Property.Cmd.createProcess` is concurrent output safe +-- (it actually uses `Propellor.Message.createProcessConcurrent`), and +-- everything else in propellor that runs external commands is built on top +-- of that. Of course, if you import System.Process and use it in a +-- property, you can bypass that and shoot yourself in the foot. +-- +-- Finally, anything that directly accesses the tty can bypass +-- these protections. That's sometimes done for eg, password prompts. +-- A well-written property should avoid running interactive commands +-- anyway. module Propellor.Property.Concurrent ( concurrently, concurrentList, props, getNumProcessors, - withCapabilities, concurrentSatisfy, ) where @@ -20,6 +44,12 @@ import GHC.Conc (getNumProcessors) import Control.Monad.RWS.Strict -- | Ensures two properties concurrently. +-- +-- > & foo `concurrently` bar +-- +-- To ensure three properties concurrently, just use this combinator twice: +-- +-- > & foo `concurrently` bar `concurrently` baz concurrently :: (IsProp p1, IsProp p2, Combines p1 p2, IsProp (CombinedType p1 p2)) => p1 @@ -95,6 +125,7 @@ withCapabilities n a = bracket setup cleanup (const a) return c cleanup = liftIO . setNumCapabilities +-- | Running Propellor actions concurrently. concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result concurrentSatisfy a1 a2 = do h <- ask -- cgit v1.3-2-g0d8e From af68ec950b2480749182d0d6838e96fd02c2c285 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 10:37:19 -0400 Subject: split out generic ConcurrentOutput module to Utility --- propellor.cabal | 1 + src/Propellor/Message.hs | 204 +----------------------------------- src/Utility/ConcurrentOutput.hs | 224 ++++++++++++++++++++++++++++++++++++++++ src/Utility/Process/Shim.hs | 2 +- 4 files changed, 229 insertions(+), 202 deletions(-) create mode 100644 src/Utility/ConcurrentOutput.hs (limited to 'src/Propellor/Message.hs') diff --git a/propellor.cabal b/propellor.cabal index 63fcaaa5..20e82407 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -161,6 +161,7 @@ Library Propellor.Shim Propellor.Property.Chroot.Util Utility.Applicative + Utility.ConcurrentOutput Utility.Data Utility.DataUnits Utility.Directory diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 3792129b..3b06770c 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PackageImports #-} - -- | This module handles all display of output to the console when -- propellor is ensuring Properties. -- @@ -22,117 +20,34 @@ module Propellor.Message ( import System.Console.ANSI import System.IO -import System.Posix.IO -import "mtl" Control.Monad.Reader +import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Applicative import Control.Monad.IfElse import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent -import Control.Concurrent.Async -import Data.Maybe -import Data.Char -import Data.List -import Data.Monoid -import qualified Data.ByteString as B -import qualified System.Process as P import Propellor.Types +import Utility.ConcurrentOutput import Utility.PartialPrelude import Utility.Monad import Utility.Exception data MessageHandle = MessageHandle { isConsole :: Bool - , outputLock :: MVar () -- ^ empty when locked - , outputLockedBy :: MVar Locker } -data Locker - = GeneralLock - | ProcessLock P.ProcessHandle - -- | A shared global variable for the MessageHandle. {-# NOINLINE globalMessageHandle #-} globalMessageHandle :: MVar MessageHandle globalMessageHandle = unsafePerformIO $ newMVar =<< MessageHandle <$> hIsTerminalDevice stdout - <*> newMVar () - <*> newEmptyMVar -- | Gets the global MessageHandle. getMessageHandle :: IO MessageHandle getMessageHandle = readMVar globalMessageHandle --- | Takes a lock while performing an action. Any other threads --- that try to lockOutput at the same time will block. -lockOutput :: (MonadIO m, MonadMask m) => m a -> m a -lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) - --- | Blocks until we have the output lock. -takeOutputLock :: IO () -takeOutputLock = void $ takeOutputLock' True - --- | Tries to take the output lock, without blocking. -tryTakeOutputLock :: IO Bool -tryTakeOutputLock = takeOutputLock' False - -takeOutputLock' :: Bool -> IO Bool -takeOutputLock' block = do - lck <- outputLock <$> getMessageHandle - go =<< tryTakeMVar lck - 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 <$> getMessageHandle - v' <- tryTakeMVar lcker - case v' of - Just (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 (ProcessLock h) - return False - ) - Just GeneralLock -> do - putMVar lcker GeneralLock - whenblock waitlock - Nothing -> whenblock waitlock - - havelock = do - updateOutputLocker GeneralLock - return True - waitlock = do - -- Wait for current lock holder to relinquish - -- it and take the lock. - lck <- outputLock <$> getMessageHandle - takeMVar lck - havelock - whenblock a = if block then a else return False - --- | Only safe to call after taking the output lock. -dropOutputLock :: IO () -dropOutputLock = do - lcker <- outputLockedBy <$> getMessageHandle - lck <- outputLock <$> getMessageHandle - void $ takeMVar lcker - putMVar lck () - --- | Only safe to call after takeOutputLock; updates the Locker. -updateOutputLocker :: Locker -> IO () -updateOutputLocker l = do - lcker <- outputLockedBy <$> getMessageHandle - void $ tryTakeMVar lcker - putMVar lcker l - modifyMVar_ lcker (const $ return l) - -- | Force console output. This can be used when stdout is not directly -- connected to a console, but is eventually going to be displayed at a -- console. @@ -237,116 +152,3 @@ messagesDone = lockOutput $ do whenConsole $ setTitle "propellor: done" hFlush stdout - --- | Wrapper around `System.Process.createProcess` that prevents --- multiple processes that are running concurrently from writing --- to stdout/stderr at the same time. --- --- The first process is allowed to write to --- stdout and stderr in the usual way. --- --- However, if another process runs concurrently with the --- first, any stdout or stderr that would have been displayed by it is --- instead buffered. The buffered output will be displayed the next time it --- is safe to do so (ie, after the first process exits). --- --- Also does debug logging of all commands run. --- --- Unless you manually import System.Process, every part of propellor --- that runs a process uses this. -createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -createProcessConcurrent p - | hasoutput (P.std_out p) || hasoutput (P.std_err p) = - ifM tryTakeOutputLock - ( firstprocess - , concurrentprocess - ) - | otherwise = P.createProcess p - where - hasoutput P.Inherit = True - hasoutput _ = False - - firstprocess = do - r@(_, _, _, h) <- P.createProcess p - `onException` dropOutputLock - updateOutputLocker (ProcessLock h) - -- 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. - return r - - concurrentprocess = do - (toouth, fromouth) <- pipe - (toerrh, fromerrh) <- pipe - let p' = p - { P.std_out = if hasoutput (P.std_out p) - then P.UseHandle toouth - else P.std_out p - , P.std_err = if hasoutput (P.std_err p) - then P.UseHandle toerrh - else P.std_err p - } - r <- P.createProcess p' - hClose toouth - hClose toerrh - buf <- newMVar [] - void $ async $ outputDrainer fromouth stdout buf - void $ async $ outputDrainer fromerrh stderr buf - void $ async $ bufferWriter buf - return r - - pipe = do - (from, to) <- createPipe - (,) <$> fdToHandle to <*> fdToHandle from - -type Buffer = [(Handle, Maybe B.ByteString)] - --- 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 (pure . addBuffer (toh, Just b)) - outputDrainer fromh toh buf - _ -> do - modifyMVar_ buf (pure . (++ [(toh, Nothing)])) - hClose fromh - --- Wait to lock output, and once we can, display everything --- that's put into buffer, until the end is signaled by Nothing --- for both stdout and stderr. -bufferWriter :: MVar Buffer -> IO () -bufferWriter buf = lockOutput (go [stdout, stderr]) - where - go [] = return () - go hs = do - l <- takeMVar buf - forM_ l $ \(h, mb) -> do - maybe noop (B.hPut h) mb - hFlush h - let hs' = filter (\h -> not (any (== (h, Nothing)) l)) hs - putMVar buf [] - go hs' - --- The buffer can grow up to 1 mb in size, but after that point, --- it's truncated to avoid propellor using unbounded memory --- when a process outputs a whole lot of stuff. -bufsz :: Int -bufsz = 1000000 - -addBuffer :: (Handle, Maybe B.ByteString) -> Buffer -> Buffer -addBuffer v@(_, Nothing) buf = buf ++ [v] -addBuffer (toh, Just b) buf = (toh, Just b') : other - where - (this, other) = partition (\v -> fst v == toh && isJust (snd v)) buf - b' = truncateBuffer $ B.concat (mapMaybe snd this) <> b - --- Truncate a buffer by removing lines from the front until it's --- small enough. -truncateBuffer :: B.ByteString -> B.ByteString -truncateBuffer b - | B.length b <= bufsz = b - | otherwise = truncateBuffer $ snd $ B.breakByte nl b - where - nl = fromIntegral (ord '\n') diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs new file mode 100644 index 00000000..cf1d166e --- /dev/null +++ b/src/Utility/ConcurrentOutput.hs @@ -0,0 +1,224 @@ +-- | Concurrent output handling. +-- +-- When two threads both try to display a message concurrently, +-- the messages will be displayed sequentially. + +module Utility.ConcurrentOutput ( + lockOutput, + createProcessConcurrent, +) where + +import System.IO +import System.Posix.IO +import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Applicative +import System.IO.Unsafe (unsafePerformIO) +import Control.Concurrent +import Control.Concurrent.Async +import Data.Maybe +import Data.Char +import Data.List +import Data.Monoid +import qualified Data.ByteString as B +import qualified System.Process as P + +import Utility.Monad +import Utility.Exception + +data OutputHandle = OutputHandle + { outputLock :: MVar () -- ^ empty when locked + , outputLockedBy :: MVar Locker + } + +data Locker + = GeneralLock + | ProcessLock P.ProcessHandle + +-- | A shared global variable for the OutputHandle. +{-# NOINLINE globalOutputHandle #-} +globalOutputHandle :: MVar OutputHandle +globalOutputHandle = unsafePerformIO $ + newMVar =<< OutputHandle + <$> newMVar () + <*> newEmptyMVar + +-- | Gets the global OutputHandle. +getOutputHandle :: IO OutputHandle +getOutputHandle = readMVar globalOutputHandle + +-- | Holds a lock while performing an action. Any other threads +-- that try to lockOutput at the same time will block. +lockOutput :: (MonadIO m, MonadMask m) => m a -> m a +lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) + +-- | Blocks until we have the output lock. +takeOutputLock :: IO () +takeOutputLock = void $ takeOutputLock' True + +-- | Tries to take the output lock, without blocking. +tryTakeOutputLock :: IO Bool +tryTakeOutputLock = takeOutputLock' False + +takeOutputLock' :: Bool -> IO Bool +takeOutputLock' block = do + lck <- outputLock <$> getOutputHandle + go =<< tryTakeMVar lck + 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 (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 (ProcessLock h) + return False + ) + Just GeneralLock -> do + putMVar lcker GeneralLock + whenblock waitlock + Nothing -> whenblock waitlock + + havelock = do + updateOutputLocker GeneralLock + return True + waitlock = do + -- Wait for current lock holder to relinquish + -- it and take the lock. + lck <- outputLock <$> getOutputHandle + takeMVar lck + havelock + 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 () + +-- | 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) + +-- | Wrapper around `System.Process.createProcess` that prevents +-- multiple processes that are running concurrently from writing +-- to stdout/stderr at the same time. +-- +-- The first process is allowed to write to stdout and stderr in the usual way. +-- +-- However, if another process runs concurrently with the +-- first, any stdout or stderr that would have been displayed by it is +-- instead buffered. The buffered output will be displayed the next time it +-- is safe to do so (ie, after the first process exits). +createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) +createProcessConcurrent p + | hasoutput (P.std_out p) || hasoutput (P.std_err p) = + ifM tryTakeOutputLock + ( firstprocess + , concurrentprocess + ) + | otherwise = P.createProcess p + where + hasoutput P.Inherit = True + hasoutput _ = False + + firstprocess = do + r@(_, _, _, h) <- P.createProcess p + `onException` dropOutputLock + updateOutputLocker (ProcessLock h) + -- 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. + return r + + concurrentprocess = do + (toouth, fromouth) <- pipe + (toerrh, fromerrh) <- pipe + let p' = p + { P.std_out = if hasoutput (P.std_out p) + then P.UseHandle toouth + else P.std_out p + , P.std_err = if hasoutput (P.std_err p) + then P.UseHandle toerrh + else P.std_err p + } + r <- P.createProcess p' + hClose toouth + hClose toerrh + buf <- newMVar [] + void $ async $ outputDrainer fromouth stdout buf + void $ async $ outputDrainer fromerrh stderr buf + void $ async $ bufferWriter buf + return r + + pipe = do + (from, to) <- createPipe + (,) <$> fdToHandle to <*> fdToHandle from + +type Buffer = [(Handle, Maybe B.ByteString)] + +-- 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 (pure . addBuffer (toh, Just b)) + outputDrainer fromh toh buf + _ -> do + modifyMVar_ buf (pure . (++ [(toh, Nothing)])) + hClose fromh + +-- Wait to lock output, and once we can, display everything +-- that's put into buffer, until the end is signaled by Nothing +-- for both stdout and stderr. +bufferWriter :: MVar Buffer -> IO () +bufferWriter buf = lockOutput (go [stdout, stderr]) + where + go [] = return () + go hs = do + l <- takeMVar buf + forM_ l $ \(h, mb) -> do + maybe noop (B.hPut h) mb + hFlush h + let hs' = filter (\h -> not (any (== (h, Nothing)) l)) hs + putMVar buf [] + go hs' + +-- The buffer can grow up to 1 mb in size, but after that point, +-- it's truncated to avoid propellor using unbounded memory +-- when a process outputs a whole lot of stuff. +bufsz :: Int +bufsz = 1000000 + +addBuffer :: (Handle, Maybe B.ByteString) -> Buffer -> Buffer +addBuffer v@(_, Nothing) buf = buf ++ [v] +addBuffer (toh, Just b) buf = (toh, Just b') : other + where + (this, other) = partition (\v -> fst v == toh && isJust (snd v)) buf + b' = truncateBuffer $ B.concat (mapMaybe snd this) <> b + +-- Truncate a buffer by removing lines from the front until it's +-- small enough. +truncateBuffer :: B.ByteString -> B.ByteString +truncateBuffer b + | B.length b <= bufsz = b + | otherwise = truncateBuffer $ snd $ B.breakByte nl b + where + nl = fromIntegral (ord '\n') diff --git a/src/Utility/Process/Shim.hs b/src/Utility/Process/Shim.hs index 0da93bf7..202b7c32 100644 --- a/src/Utility/Process/Shim.hs +++ b/src/Utility/Process/Shim.hs @@ -1,7 +1,7 @@ module Utility.Process.Shim (module X, createProcess) where import System.Process as X hiding (createProcess) -import Propellor.Message (createProcessConcurrent) +import Utility.ConcurrentOutput (createProcessConcurrent) import System.IO createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -- cgit v1.3-2-g0d8e From 7a83dab6e977f61b3348aaa9f70bd2a288b4b631 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 12:19:49 -0400 Subject: use outputConcurrent interface This interface will fix the current deadlock when a process is running and the thread that ran it wants to output to the console. The locking and buffering is not implemented yet. --- src/Propellor/Message.hs | 91 +++++++++++++++++++---------------------- src/Propellor/Spin.hs | 2 +- src/Utility/ConcurrentOutput.hs | 21 ++++++++-- 3 files changed, 61 insertions(+), 53 deletions(-) (limited to 'src/Propellor/Message.hs') diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 3b06770c..6d541b9a 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -20,10 +20,8 @@ module Propellor.Message ( import System.Console.ANSI import System.IO -import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Applicative -import Control.Monad.IfElse import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent @@ -55,10 +53,11 @@ forceConsole :: IO () forceConsole = modifyMVar_ globalMessageHandle $ \mh -> pure (mh { isConsole = True }) --- | Only performs the action when at the console, or when console --- output has been forced. -whenConsole :: IO () -> IO () -whenConsole a = whenM (isConsole <$> getMessageHandle) a +whenConsole :: String -> IO String +whenConsole s = ifM (isConsole <$> getMessageHandle) + ( pure s + , pure "" + ) -- | Shows a message while performing an action, with a colored status -- display. @@ -72,55 +71,54 @@ actionMessageOn = actionMessage' . Just actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r actionMessage' mhn desc a = do - liftIO $ whenConsole $ lockOutput $ do - setTitle $ "propellor: " ++ desc - hFlush stdout + liftIO $ outputConcurrent + =<< whenConsole (setTitleCode $ "propellor: " ++ desc) r <- a - liftIO $ lockOutput $ do - whenConsole $ - setTitle "propellor: running" - showhn mhn - putStr $ desc ++ " ... " - let (msg, intensity, color) = getActionResult r - colorLine intensity color msg - hFlush stdout + liftIO $ outputConcurrent . concat =<< sequence + [ whenConsole $ + setTitleCode "propellor: running" + , showhn mhn + , pure $ desc ++ " ... " + , let (msg, intensity, color) = getActionResult r + in colorLine intensity color msg + ] return r where - showhn Nothing = return () - showhn (Just hn) = do - whenConsole $ - setSGR [SetColor Foreground Dull Cyan] - putStr (hn ++ " ") - whenConsole $ - setSGR [] + showhn Nothing = return "" + showhn (Just hn) = concat <$> sequence + [ whenConsole $ + setSGRCode [SetColor Foreground Dull Cyan] + , pure (hn ++ " ") + , whenConsole $ + setSGRCode [] + ] warningMessage :: MonadIO m => String -> m () -warningMessage s = liftIO $ lockOutput $ - colorLine Vivid Magenta $ "** warning: " ++ s +warningMessage s = liftIO $ + outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s) infoMessage :: MonadIO m => [String] -> m () -infoMessage ls = liftIO $ lockOutput $ - mapM_ putStrLn ls +infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls errorMessage :: MonadIO m => String -> m a -errorMessage s = liftIO $ lockOutput $ do - colorLine Vivid Red $ "** error: " ++ s +errorMessage s = liftIO $ do + outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s) error "Cannot continue!" -colorLine :: ColorIntensity -> Color -> String -> IO () -colorLine intensity color msg = do - whenConsole $ - setSGR [SetColor Foreground intensity color] - putStr msg - whenConsole $ - setSGR [] +colorLine :: ColorIntensity -> Color -> String -> IO String +colorLine intensity color msg = concat <$> sequence + [ whenConsole $ + setSGRCode [SetColor Foreground intensity color] + , pure msg + , whenConsole $ + setSGRCode [] -- Note this comes after the color is reset, so that -- the color set and reset happen in the same line. - putStrLn "" - hFlush stdout + , pure "\n" + ] -- | Reads and displays each line from the Handle, except for the last line -- which is a Result. @@ -136,19 +134,14 @@ processChainOutput h = go Nothing Just l -> case readish l of Just r -> pure r Nothing -> do - lockOutput $ do - putStrLn l - hFlush stdout + outputConcurrent l return FailedChange Just s -> do - lockOutput $ do - maybe noop (\l -> unless (null l) (putStrLn l)) lastline - hFlush stdout + outputConcurrent $ + maybe "" (\l -> if null l then "" else l ++ "\n") lastline go (Just s) -- | Called when all messages about properties have been printed. messagesDone :: IO () -messagesDone = lockOutput $ do - whenConsole $ - setTitle "propellor: done" - hFlush stdout +messagesDone = outputConcurrent + =<< whenConsole (setTitleCode "propellor: done") diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 8a40fc87..0c457705 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -206,7 +206,7 @@ updateServer target relay hst connect haveprecompiled getprivdata = sendRepoUrl toh loop (Just NeedPrivData) -> do - sendPrivData hn toh pd =<< getprivdata + sendPrivData hn toh =<< getprivdata loop (Just NeedGitClone) -> do hClose toh diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 8a4bdcf2..0e9a59de 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -1,7 +1,7 @@ -- | Concurrent output handling. module Utility.ConcurrentOutput ( - lockOutput, + outputConcurrent, createProcessConcurrent, ) where @@ -113,6 +113,20 @@ updateOutputLocker l = do putMVar lcker l modifyMVar_ lcker (const $ return l) +-- | Displays a string to stdout, and flush output so it's displayed. +-- +-- Uses locking to ensure that the whole string is output atomically +-- even when other threads are concurrently generating output. +-- +-- When something else is writing to the console at the same time, this does +-- not block. It buffers the string, so it will be displayed once the other +-- writer is done. +outputConcurrent :: String -> IO () +outputConcurrent s = do + putStr s + hFlush stdout + -- TODO + -- | Wrapper around `System.Process.createProcess` that prevents -- multiple processes that are running concurrently from writing -- to stdout/stderr at the same time. @@ -124,8 +138,9 @@ updateOutputLocker l = do -- A process is allowed to write to stdout and stderr in the usual -- way, assuming it can successfully take the output lock. -- --- When the output lock is held (by another process or other caller of --- `lockOutput`), the process is instead run with its stdout and stderr +-- When the output lock is held (by another concurrent process, +-- or because `outputConcurrent` is being called at the same time), +-- the process is instead run with its stdout and stderr -- redirected to a buffer. The buffered output will be displayed as soon -- as the output lock becomes free. createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -- cgit v1.3-2-g0d8e From 68dbfe1b08c9cf1d976ac84ea53817c54fcd3479 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 12:41:15 -0400 Subject: need withConcurrentOutput to flush any buffered concurrent output --- src/Propellor/CmdLine.hs | 2 +- src/Propellor/Message.hs | 1 + src/Utility/ConcurrentOutput.hs | 13 +++++++++++++ src/wrapper.hs | 2 +- 4 files changed, 16 insertions(+), 2 deletions(-) (limited to 'src/Propellor/Message.hs') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 9f798166..4bca3986 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -89,7 +89,7 @@ processCmdLine = go =<< getArgs -- | 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/Message.hs b/src/Propellor/Message.hs index 6d541b9a..7439c362 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -16,6 +16,7 @@ module Propellor.Message ( processChainOutput, messagesDone, createProcessConcurrent, + withConcurrentOutput, ) where import System.Console.ANSI diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 1ca92d90..c6550b84 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -1,6 +1,7 @@ -- | Concurrent output handling. module Utility.ConcurrentOutput ( + withConcurrentOutput, outputConcurrent, createProcessConcurrent, ) where @@ -113,6 +114,18 @@ updateOutputLocker l = do putMVar lcker l modifyMVar_ lcker (const $ return l) +-- | Use this around any IO actions that use `outputConcurrent` +-- or `createProcessConcurrent` +-- +-- This is necessary to ensure that buffered concurrent output actually +-- gets displayed before the program exits. +withConcurrentOutput :: IO a -> IO a +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 ()) + -- | Displays a string to stdout, and flush output so it's displayed. -- -- Uses locking to ensure that the whole string is output atomically diff --git a/src/wrapper.hs b/src/wrapper.hs index e367fe69..0cfe319d 100644 --- a/src/wrapper.hs +++ b/src/wrapper.hs @@ -50,7 +50,7 @@ netrepo :: String netrepo = "https://github.com/joeyh/propellor.git" main :: IO () -main = do +main = withConcurrentOutput $ do args <- getArgs home <- myHomeDir let propellordir = home ".propellor" -- cgit v1.3-2-g0d8e From 86a115aaa0c216e4c46e57a324b58177c8b78435 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 20:10:11 -0400 Subject: have to flush concurrent output before printing result when chaining --- src/Propellor/Message.hs | 2 +- src/Propellor/Property/Chroot.hs | 1 + src/Propellor/Property/Docker.hs | 2 ++ src/Utility/ConcurrentOutput.hs | 30 +++++++++++++++++------------- 4 files changed, 21 insertions(+), 14 deletions(-) (limited to 'src/Propellor/Message.hs') diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 7439c362..7df5104a 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -135,7 +135,7 @@ processChainOutput h = go Nothing Just l -> case readish l of Just r -> pure r Nothing -> do - outputConcurrent l + outputConcurrent (l ++ "\n") return FailedChange Just s -> do outputConcurrent $ diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 8b923aab..e72d1bd9 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -213,6 +213,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = then [Systemd.installed] else map ignoreInfo $ hostProperties h + flushConcurrentOutput putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 5f41209a..9082460f 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -540,6 +540,7 @@ init s = case toContainerId s of warningMessage "Boot provision failed!" void $ async $ job reapzombies job $ do + flushConcurrentOutput void $ tryIO $ ifM (inPath "bash") ( boolSystem "bash" [Param "-l"] , boolSystem "/bin/sh" [] @@ -583,6 +584,7 @@ chain hostlist hn s = case toContainerId s of r <- runPropellor h $ ensureProperties $ map ignoreInfo $ hostProperties h + flushConcurrentOutput putStrLn $ "\n" ++ show r stopContainer :: ContainerId -> IO Bool diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index db0bae0a..3f28068a 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -5,6 +5,7 @@ module Utility.ConcurrentOutput ( withConcurrentOutput, + flushConcurrentOutput, outputConcurrent, createProcessConcurrent, waitForProcessConcurrent, @@ -105,19 +106,22 @@ dropOutputLock = withLock $ void . takeTMVar -- This is necessary to ensure that buffered concurrent output actually -- gets displayed before the program exits. withConcurrentOutput :: IO a -> IO a -withConcurrentOutput a = a `finally` drain - where - -- Wait for all outputThreads to finish. Then, take the output lock - -- to ensure that nothing is currently generating output, and flush - -- any buffered output. - drain = do - v <- outputThreads <$> getOutputHandle - atomically $ do - r <- takeTMVar v - if r == S.empty - then return () - else retry - lockOutput $ return () +withConcurrentOutput a = a `finally` flushConcurrentOutput + +-- | Blocks until any processes started by `createProcessConcurrent` have +-- finished, and any buffered output is displayed. +flushConcurrentOutput :: IO () +flushConcurrentOutput = do + -- Wait for all outputThreads to finish. + v <- outputThreads <$> getOutputHandle + atomically $ do + r <- takeTMVar v + if r == S.empty + then return () + else retry + -- Take output lock to ensure that nothing else is currently + -- generating output, and flush any buffered output. + lockOutput $ return () -- | Displays a string to stdout, and flush output so it's displayed. -- -- cgit v1.3-2-g0d8e