module Propellor.Message (
Trace(..),
parseTrace,
getMessageHandle,
isConsole,
forceConsole,
actionMessage,
actionMessageOn,
warningMessage,
infoMessage,
errorMessage,
stopPropellorMessage,
messagesDone,
createProcessConcurrent,
withConcurrentOutput,
) where
import System.Console.ANSI
import System.IO
import Control.Monad.IfElse
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 Propellor.Types.Exception
import Utility.Monad
import Utility.Env
import Utility.Exception
import Utility.PartialPrelude
data Trace
= ActionStart (Maybe HostName) Desc
| ActionEnd (Maybe HostName) Desc Result
deriving (Read, Show)
parseTrace :: String -> Maybe Trace
parseTrace = readish
data MessageHandle = MessageHandle
{ isConsole :: Bool
, traceEnabled :: Bool
}
{-# NOINLINE globalMessageHandle #-}
globalMessageHandle :: MVar MessageHandle
globalMessageHandle = unsafePerformIO $
newMVar =<< MessageHandle
<$> catchDefaultIO False (hIsTerminalDevice stdout)
<*> ((== Just "1") <$> getEnv "PROPELLOR_TRACE")
getMessageHandle :: IO MessageHandle
getMessageHandle = readMVar globalMessageHandle
trace :: Trace -> IO ()
trace t = whenM (traceEnabled <$> getMessageHandle) $
putStrLn $ show t
forceConsole :: IO ()
forceConsole = modifyMVar_ globalMessageHandle $ \mh ->
pure (mh { isConsole = True })
whenConsole :: String -> IO String
whenConsole s = ifM (isConsole <$> getMessageHandle)
( pure s
, pure ""
)
actionMessage :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => Desc -> m r -> m r
actionMessage = actionMessage' Nothing
actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => HostName -> Desc -> m r -> m r
actionMessageOn = actionMessage' . Just
actionMessage' :: (MonadIO m, ActionResult r, ToResult r) => Maybe HostName -> Desc -> m r -> m r
actionMessage' mhn desc a = do
liftIO $ trace $ ActionStart mhn desc
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
]
liftIO $ trace $ ActionEnd mhn desc (toResult r)
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 $
errorConcurrent =<< 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
errorConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
error "Cannot continue!"
stopPropellorMessage :: MonadIO m => String -> m a
stopPropellorMessage s = liftIO $ do
outputConcurrent =<< colorLine Vivid Red ("** fatal error: " ++ s)
throwM $ StopPropellorException "Cannot continue!"
colorLine :: ColorIntensity -> Color -> String -> IO String
colorLine intensity color msg = concat <$> sequence
[ whenConsole $
setSGRCode [SetColor Foreground intensity color]
, pure msg
, whenConsole $
setSGRCode []
, pure "\n"
]
messagesDone :: IO ()
messagesDone = outputConcurrent
=<< whenConsole (setTitleCode "propellor: done")