module Propellor.Message (
getMessageHandle,
isConsole,
forceConsole,
actionMessage,
actionMessageOn,
warningMessage,
infoMessage,
errorMessage,
stopPropellorMessage,
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 Propellor.Types.Exception
import Utility.Monad
import Utility.Exception
data MessageHandle = MessageHandle
{ isConsole :: Bool
}
globalMessageHandle :: MVar MessageHandle
globalMessageHandle = unsafePerformIO $
newMVar =<< MessageHandle
<$> catchDefaultIO False (hIsTerminalDevice stdout)
getMessageHandle :: IO MessageHandle
getMessageHandle = readMVar globalMessageHandle
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) => Desc -> m r -> m r
actionMessage = actionMessage' Nothing
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
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 $
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")