summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Propellor/Message.hs91
-rw-r--r--src/Propellor/Spin.hs2
-rw-r--r--src/Utility/ConcurrentOutput.hs21
3 files changed, 61 insertions, 53 deletions
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)