-- | This module handles all display of output to the console when
-- propellor is ensuring Properties.
--
-- When two threads both try to display a message concurrently, 
-- the messages will be displayed sequentially.

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

-- | Serializable tracing. Export `PROPELLOR_TRACE=1` in the environment to
-- make propellor emit these to stdout, in addition to its other output.
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)

-- | Given a line read from propellor, if it's a serialized Trace,
-- parses it.
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
	}

-- | A shared global variable for the MessageHandle.
{-# 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")

-- | Gets the global MessageHandle.
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

-- | Force console output. This can be used when stdout is not directly
-- connected to a console, but is eventually going to be displayed at a
-- console.
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
""
	)

-- | Shows a message while performing an action, with a colored status
-- display.
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

-- | Shows a message while performing an action on a specified host,
-- with a colored status display.
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

-- | Displays the error message in red, and throws an exception.
--
-- When used inside a property, the exception will make the current
-- property fail. Propellor will continue to the next property.
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)
	-- 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.
	forall a. HasCallStack => String -> a
error String
"Cannot continue!"
 
-- | Like `errorMessage`, but throws a `StopPropellorException`,
-- preventing propellor from continuing to the next property.
--
-- 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 :: 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 []
	-- Note this comes after the color is reset, so that
	-- the color set and reset happen in the same line.
	, forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"\n"
	]

-- | Called when all messages about properties have been printed.
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")