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. --- src/Propellor/Message.hs | 92 +++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 83 insertions(+), 9 deletions(-) (limited to 'src/Propellor/Message.hs') 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 -- cgit v1.2.3