summaryrefslogtreecommitdiff
path: root/src/Propellor/Message.hs
diff options
context:
space:
mode:
authorJoey Hess2015-10-28 12:19:49 -0400
committerJoey Hess2015-10-28 12:19:49 -0400
commit7a83dab6e977f61b3348aaa9f70bd2a288b4b631 (patch)
tree0eb84165596449bf75b3de8b1aa3888f32d44e4f /src/Propellor/Message.hs
parentf935d1d667f78ba7d34e853346ab0a99b2c4ec14 (diff)
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.
Diffstat (limited to 'src/Propellor/Message.hs')
-rw-r--r--src/Propellor/Message.hs91
1 files changed, 42 insertions, 49 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")