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 (ReadPrec [Trace]
ReadPrec Trace
Int -> ReadS Trace
ReadS [Trace]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Trace]
$creadListPrec :: ReadPrec [Trace]
readPrec :: ReadPrec Trace
$creadPrec :: ReadPrec Trace
readList :: ReadS [Trace]
$creadList :: ReadS [Trace]
readsPrec :: Int -> ReadS Trace
$creadsPrec :: Int -> ReadS Trace
Read, Int -> Trace -> ShowS
[Trace] -> ShowS
Trace -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Trace] -> ShowS
$cshowList :: [Trace] -> ShowS
show :: Trace -> String
$cshow :: Trace -> String
showsPrec :: Int -> Trace -> ShowS
$cshowsPrec :: Int -> Trace -> ShowS
Show)
parseTrace :: String -> Maybe Trace
parseTrace :: String -> Maybe Trace
parseTrace = forall a. Read a => String -> Maybe a
readish
data MessageHandle = MessageHandle
{ MessageHandle -> Bool
isConsole :: Bool
, MessageHandle -> Bool
traceEnabled :: Bool
}
{-# NOINLINE globalMessageHandle #-}
globalMessageHandle :: MVar MessageHandle
globalMessageHandle :: MVar MessageHandle
globalMessageHandle = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$
forall a. a -> IO (MVar a)
newMVar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> Bool -> MessageHandle
MessageHandle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO Bool
False (Handle -> IO Bool
hIsTerminalDevice Handle
stdout)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just String
"1") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
getEnv String
"PROPELLOR_TRACE")
getMessageHandle :: IO MessageHandle
getMessageHandle :: IO MessageHandle
getMessageHandle = forall a. MVar a -> IO a
readMVar MVar MessageHandle
globalMessageHandle
trace :: Trace -> IO ()
trace :: Trace -> IO ()
trace Trace
t = forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (MessageHandle -> Bool
traceEnabled forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO MessageHandle
getMessageHandle) forall a b. (a -> b) -> a -> b
$
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Trace
t
forceConsole :: IO ()
forceConsole :: IO ()
forceConsole = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar MessageHandle
globalMessageHandle forall a b. (a -> b) -> a -> b
$ \MessageHandle
mh ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MessageHandle
mh { isConsole :: Bool
isConsole = Bool
True })
whenConsole :: String -> IO String
whenConsole :: String -> IO String
whenConsole String
s = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (MessageHandle -> Bool
isConsole forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO MessageHandle
getMessageHandle)
( forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s
, forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
)
actionMessage :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => Desc -> m r -> m r
actionMessage :: forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage = forall (m :: * -> *) r.
(MonadIO m, ActionResult r, ToResult r) =>
Maybe String -> String -> m r -> m r
actionMessage' forall a. Maybe a
Nothing
actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => HostName -> Desc -> m r -> m r
actionMessageOn :: forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> String -> m r -> m r
actionMessageOn = forall (m :: * -> *) r.
(MonadIO m, ActionResult r, ToResult r) =>
Maybe String -> String -> m r -> m r
actionMessage' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
actionMessage' :: (MonadIO m, ActionResult r, ToResult r) => Maybe HostName -> Desc -> m r -> m r
actionMessage' :: forall (m :: * -> *) r.
(MonadIO m, ActionResult r, ToResult r) =>
Maybe String -> String -> m r -> m r
actionMessage' Maybe String
mhn String
desc m r
a = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Trace -> IO ()
trace forall a b. (a -> b) -> a -> b
$ Maybe String -> String -> Trace
ActionStart Maybe String
mhn String
desc
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall v. Outputable v => v -> IO ()
outputConcurrent
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
whenConsole (ShowS
setTitleCode forall a b. (a -> b) -> a -> b
$ String
"propellor: " forall a. [a] -> [a] -> [a]
++ String
desc)
r
r <- m r
a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall v. Outputable v => v -> IO ()
outputConcurrent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ String -> IO String
whenConsole forall a b. (a -> b) -> a -> b
$
ShowS
setTitleCode String
"propellor: running"
, Maybe String -> IO String
showhn Maybe String
mhn
, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
desc forall a. [a] -> [a] -> [a]
++ String
" ... "
, let (String
msg, ColorIntensity
intensity, Color
color) = forall a. ActionResult a => a -> (String, ColorIntensity, Color)
getActionResult r
r
in ColorIntensity -> Color -> String -> IO String
colorLine ColorIntensity
intensity Color
color String
msg
]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Trace -> IO ()
trace forall a b. (a -> b) -> a -> b
$ Maybe String -> String -> Result -> Trace
ActionEnd Maybe String
mhn String
desc (forall t. ToResult t => t -> Result
toResult r
r)
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
where
showhn :: Maybe String -> IO String
showhn Maybe String
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return String
""
showhn (Just String
hn) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ String -> IO String
whenConsole forall a b. (a -> b) -> a -> b
$
[SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Cyan]
, forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
hn forall a. [a] -> [a] -> [a]
++ String
" ")
, String -> IO String
whenConsole forall a b. (a -> b) -> a -> b
$
[SGR] -> String
setSGRCode []
]
warningMessage :: MonadIO m => String -> m ()
warningMessage :: forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage String
s = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall v. Outputable v => v -> IO ()
errorConcurrent forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ColorIntensity -> Color -> String -> IO String
colorLine ColorIntensity
Vivid Color
Magenta (String
"** warning: " forall a. [a] -> [a] -> [a]
++ String
s)
infoMessage :: MonadIO m => [String] -> m ()
infoMessage :: forall (m :: * -> *). MonadIO m => [String] -> m ()
infoMessage [String]
ls = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall v. Outputable v => v -> IO ()
outputConcurrent forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. [a] -> [a] -> [a]
++ String
"\n") [String]
ls
errorMessage :: MonadIO m => String -> m a
errorMessage :: forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage String
s = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall v. Outputable v => v -> IO ()
errorConcurrent forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ColorIntensity -> Color -> String -> IO String
colorLine ColorIntensity
Vivid Color
Red (String
"** error: " forall a. [a] -> [a] -> [a]
++ String
s)
forall a. HasCallStack => String -> a
error String
"Cannot continue!"
stopPropellorMessage :: MonadIO m => String -> m a
stopPropellorMessage :: forall (m :: * -> *) a. MonadIO m => String -> m a
stopPropellorMessage String
s = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall v. Outputable v => v -> IO ()
outputConcurrent forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ColorIntensity -> Color -> String -> IO String
colorLine ColorIntensity
Vivid Color
Red (String
"** fatal error: " forall a. [a] -> [a] -> [a]
++ String
s)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> StopPropellorException
StopPropellorException String
"Cannot continue!"
colorLine :: ColorIntensity -> Color -> String -> IO String
colorLine :: ColorIntensity -> Color -> String -> IO String
colorLine ColorIntensity
intensity Color
color String
msg = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ String -> IO String
whenConsole forall a b. (a -> b) -> a -> b
$
[SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
intensity Color
color]
, forall (f :: * -> *) a. Applicative f => a -> f a
pure String
msg
, String -> IO String
whenConsole forall a b. (a -> b) -> a -> b
$
[SGR] -> String
setSGRCode []
, forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"\n"
]
messagesDone :: IO ()
messagesDone :: IO ()
messagesDone = forall v. Outputable v => v -> IO ()
outputConcurrent
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
whenConsole (ShowS
setTitleCode String
"propellor: done")