module Propellor.Message (
getMessageHandle,
isConsole,
forceConsole,
actionMessage,
actionMessageOn,
warningMessage,
infoMessage,
errorMessage,
stopPropellorMessage,
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 Propellor.Types.Exception
import Utility.PartialPrelude
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 $
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!"
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"
]
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)
messagesDone :: IO ()
messagesDone = outputConcurrent
=<< whenConsole (setTitleCode "propellor: done")