-- | 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]
(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)

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

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

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

-- | 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 = 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
""
	)

-- | 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 :: 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

-- | 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 :: 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

-- | 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 :: 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)
	-- 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.
	String -> IO a
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 :: 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 []
	-- Note this comes after the color is reset, so that
	-- the color set and reset happen in the same line.
	, String -> IO String
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 = 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")