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