-- | 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, processChainOutput, messagesDone, createProcessConcurrent, withConcurrentOutput, ) where import System.Console.ANSI import System.IO import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent import System.Console.Concurrent import Control.Applicative import Prelude import Propellor.Types import Utility.PartialPrelude import Utility.Monad import Utility.Exception data MessageHandle = MessageHandle { isConsole :: Bool } -- | A shared global variable for the MessageHandle. {-# NOINLINE globalMessageHandle #-} globalMessageHandle :: MVar MessageHandle globalMessageHandle = unsafePerformIO $ newMVar =<< MessageHandle <$> catchDefaultIO False (hIsTerminalDevice stdout) -- | Gets the global MessageHandle. getMessageHandle :: IO MessageHandle getMessageHandle = readMVar globalMessageHandle -- | 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 }) whenConsole :: String -> IO String whenConsole s = ifM (isConsole <$> getMessageHandle) ( pure s , pure "" ) -- | Shows a message while performing an action, with a colored status -- display. 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, MonadMask m, ActionResult r) => HostName -> Desc -> m r -> m r actionMessageOn = actionMessage' . Just actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r actionMessage' mhn desc a = do liftIO $ outputConcurrent =<< whenConsole (setTitleCode $ "propellor: " ++ desc) r <- a 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) = concat <$> sequence [ whenConsole $ setSGRCode [SetColor Foreground Dull Cyan] , pure (hn ++ " ") , whenConsole $ setSGRCode [] ] warningMessage :: MonadIO m => String -> m () warningMessage s = liftIO $ outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s) infoMessage :: MonadIO m => [String] -> m () infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls errorMessage :: MonadIO m => String -> m a errorMessage s = liftIO $ do outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s) error "Cannot continue!" 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. , pure "\n" ] -- | 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) case v of Nothing -> case lastline of Nothing -> do return FailedChange Just l -> case readish l of Just r -> pure r Nothing -> do outputConcurrent (l ++ "\n") return FailedChange Just s -> do 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 = outputConcurrent =<< whenConsole (setTitleCode "propellor: done")