From 490249b919aaf82527b81c88c88350fd478dbed9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 13 Jun 2016 18:56:52 -0400 Subject: add stopPropellorMessage --- src/Propellor/Message.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) (limited to 'src/Propellor/Message.hs') diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 32625e6a..b7e96ec2 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -13,6 +13,7 @@ module Propellor.Message ( warningMessage, infoMessage, errorMessage, + stopPropellorMessage, processChainOutput, messagesDone, createProcessConcurrent, @@ -29,6 +30,7 @@ import Control.Applicative import Prelude import Propellor.Types +import Propellor.Types.Exception import Utility.PartialPrelude import Utility.Monad import Utility.Exception @@ -105,11 +107,29 @@ warningMessage s = liftIO $ infoMessage :: MonadIO m => [String] -> m () infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls +-- | Displays the error message in red, and throws an exception. +-- +-- When used inside a property, the exception will only stop the current +-- property from being ensured. Propellor will continue ensuring other +-- properties. errorMessage :: MonadIO m => String -> m a errorMessage s = liftIO $ do outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s) + -- Normally this exception gets caught and is not displayed, + -- and propellor continues. So it's only displayed if not + -- caught, and so we say, cannot continue. error "Cannot continue!" +-- | Like `errorMessage`, but throws a `StopPropellorException` +-- +-- Think twice before using this. Is the problem so bad that propellor +-- cannot try to ensure other properties? If not, use `errorMessage` +-- instead. +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 $ -- cgit v1.2.3