summaryrefslogtreecommitdiff
path: root/src/Propellor/Message.hs
diff options
context:
space:
mode:
authorJoey Hess2015-10-27 17:02:23 -0400
committerJoey Hess2015-10-27 17:02:23 -0400
commit20b04d366b2cff90c39d06fd424ae3e8b67e49f6 (patch)
tree2ebd3fdbacb20ab42bc7ce6b331f99336f551fed /src/Propellor/Message.hs
parent6e3b0022fa451181fdce8abd145e27a64a777711 (diff)
make Propellor.Message use lock to handle concurrent threads outputting messages
Not yet handled: Output from concurrent programs.
Diffstat (limited to 'src/Propellor/Message.hs')
-rw-r--r--src/Propellor/Message.hs92
1 files changed, 83 insertions, 9 deletions
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