{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Logging.Tracer.Standard (
    standardTracer
) where

import           Cardano.Logging.DocuGenerator
import           Cardano.Logging.Types
import           Cardano.Logging.Utils (threadLabelMe)

import           Control.Concurrent.Async
import           Control.Concurrent.Chan.Unagi.Bounded
import           Control.Exception (BlockedIndefinitelyOnMVar (..), handle)
import           Control.Monad (forever, when)
import           Control.Monad.IO.Class
import qualified Control.Tracer as T
import           Data.IORef
import           Data.Maybe (isNothing)
import           Data.Text (Text)
import qualified Data.Text.IO as TIO
import           System.IO (hFlush, stdout)

-- | The state of a standard tracer
newtype StandardTracerState =  StandardTracerState {
    StandardTracerState -> Maybe (InChan Text, OutChan Text, Async ())
stRunning :: Maybe (InChan Text, OutChan Text, Async ())
}

emptyStandardTracerState :: StandardTracerState
emptyStandardTracerState :: StandardTracerState
emptyStandardTracerState = Maybe (InChan Text, OutChan Text, Async ()) -> StandardTracerState
StandardTracerState Maybe (InChan Text, OutChan Text, Async ())
forall a. Maybe a
Nothing

-- | The standardTracer handles stdout logging in a thread-safe manner.
--   It is strongly advised to construct only one standardTracer for any application.
standardTracer :: forall m. (MonadIO m)
  => m (Trace m FormattedMessage)
standardTracer :: forall (m :: * -> *). MonadIO m => m (Trace m FormattedMessage)
standardTracer = do
    IORef StandardTracerState
stateRef <- IO (IORef StandardTracerState) -> m (IORef StandardTracerState)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef StandardTracerState) -> m (IORef StandardTracerState))
-> IO (IORef StandardTracerState) -> m (IORef StandardTracerState)
forall a b. (a -> b) -> a -> b
$ StandardTracerState -> IO (IORef StandardTracerState)
forall a. a -> IO (IORef a)
newIORef StandardTracerState
emptyStandardTracerState
    Trace m FormattedMessage -> m (Trace m FormattedMessage)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace m FormattedMessage -> m (Trace m FormattedMessage))
-> Trace m FormattedMessage -> m (Trace m FormattedMessage)
forall a b. (a -> b) -> a -> b
$ Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Trace m FormattedMessage
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl FormattedMessage)
 -> Trace m FormattedMessage)
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Trace m FormattedMessage
forall a b. (a -> b) -> a -> b
$ TracerA m (LoggingContext, Either TraceControl FormattedMessage) ()
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
T.arrow (TracerA
   m (LoggingContext, Either TraceControl FormattedMessage) ()
 -> Tracer m (LoggingContext, Either TraceControl FormattedMessage))
-> TracerA
     m (LoggingContext, Either TraceControl FormattedMessage) ()
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
forall a b. (a -> b) -> a -> b
$ ((LoggingContext, Either TraceControl FormattedMessage) -> m ())
-> TracerA
     m (LoggingContext, Either TraceControl FormattedMessage) ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
T.emit (((LoggingContext, Either TraceControl FormattedMessage) -> m ())
 -> TracerA
      m (LoggingContext, Either TraceControl FormattedMessage) ())
-> ((LoggingContext, Either TraceControl FormattedMessage) -> m ())
-> TracerA
     m (LoggingContext, Either TraceControl FormattedMessage) ()
forall a b. (a -> b) -> a -> b
$ (LoggingContext -> Either TraceControl FormattedMessage -> m ())
-> (LoggingContext, Either TraceControl FormattedMessage) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (IORef StandardTracerState
-> LoggingContext -> Either TraceControl FormattedMessage -> m ()
output IORef StandardTracerState
stateRef)
  where
    output ::
         IORef StandardTracerState
      -> LoggingContext
      -> Either TraceControl FormattedMessage
      -> m ()
    output :: IORef StandardTracerState
-> LoggingContext -> Either TraceControl FormattedMessage -> m ()
output IORef StandardTracerState
stateRef LoggingContext{} (Right (FormattedHuman Bool
_c Text
msg)) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      StandardTracerState
st  <- IORef StandardTracerState -> IO StandardTracerState
forall a. IORef a -> IO a
readIORef IORef StandardTracerState
stateRef
      case StandardTracerState -> Maybe (InChan Text, OutChan Text, Async ())
stRunning StandardTracerState
st of
        Just (InChan Text
inChannel, OutChan Text
_, Async ()
_) -> InChan Text -> Text -> IO ()
forall a. InChan a -> a -> IO ()
writeChan InChan Text
inChannel Text
msg
        Maybe (InChan Text, OutChan Text, Async ())
Nothing                -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    output IORef StandardTracerState
stateRef LoggingContext{} (Right (FormattedMachine Text
msg)) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      StandardTracerState
st  <- IORef StandardTracerState -> IO StandardTracerState
forall a. IORef a -> IO a
readIORef IORef StandardTracerState
stateRef
      case StandardTracerState -> Maybe (InChan Text, OutChan Text, Async ())
stRunning StandardTracerState
st of
        Just (InChan Text
inChannel, OutChan Text
_, Async ()
_) -> InChan Text -> Text -> IO ()
forall a. InChan a -> a -> IO ()
writeChan InChan Text
inChannel Text
msg
        Maybe (InChan Text, OutChan Text, Async ())
Nothing                -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    output IORef StandardTracerState
stateRef LoggingContext{} (Left TraceControl
TCReset) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      StandardTracerState
st <- IORef StandardTracerState -> IO StandardTracerState
forall a. IORef a -> IO a
readIORef IORef StandardTracerState
stateRef
      case StandardTracerState -> Maybe (InChan Text, OutChan Text, Async ())
stRunning StandardTracerState
st of
        Maybe (InChan Text, OutChan Text, Async ())
Nothing -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (InChan Text, OutChan Text, Async ()) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (InChan Text, OutChan Text, Async ()) -> Bool)
-> Maybe (InChan Text, OutChan Text, Async ()) -> Bool
forall a b. (a -> b) -> a -> b
$ StandardTracerState -> Maybe (InChan Text, OutChan Text, Async ())
stRunning StandardTracerState
st) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                      IORef StandardTracerState -> IO ()
startStdoutThread IORef StandardTracerState
stateRef
        Just (InChan Text, OutChan Text, Async ())
_  -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    output IORef StandardTracerState
_ LoggingContext
lk c :: Either TraceControl FormattedMessage
c@(Left TCDocument {}) =
       BackendConfig
-> (LoggingContext, Either TraceControl FormattedMessage) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
BackendConfig -> (LoggingContext, Either TraceControl a) -> m ()
docIt
        (FormatLogging -> BackendConfig
Stdout FormatLogging
MachineFormat) -- TODO Find out the right format
        (LoggingContext
lk, Either TraceControl FormattedMessage
c)
    output IORef StandardTracerState
_stateRef LoggingContext {} Either TraceControl FormattedMessage
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Forks a new thread, which writes messages to stdout
startStdoutThread :: IORef StandardTracerState -> IO ()
startStdoutThread :: IORef StandardTracerState -> IO ()
startStdoutThread IORef StandardTracerState
stateRef = do
    (InChan Text
inChan, OutChan Text
outChan) <- Int -> IO (InChan Text, OutChan Text)
forall a. Int -> IO (InChan a, OutChan a)
newChan Int
2048
    Async ()
as <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ String -> IO ()
threadLabelMe String
"StdoutTrace" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutChan Text -> IO ()
stdoutThread OutChan Text
outChan
    Async () -> IO ()
forall a. Async a -> IO ()
link Async ()
as
    IORef StandardTracerState -> StandardTracerState -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef StandardTracerState
stateRef (StandardTracerState -> IO ()) -> StandardTracerState -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (InChan Text, OutChan Text, Async ()) -> StandardTracerState
StandardTracerState ((InChan Text, OutChan Text, Async ())
-> Maybe (InChan Text, OutChan Text, Async ())
forall a. a -> Maybe a
Just (InChan Text
inChan, OutChan Text
outChan, Async ()
as))

-- | The new thread, which does the actual write from the queue.
--   Will safely terminate when all producers have gone out of scope.
stdoutThread :: OutChan Text -> IO ()
stdoutThread :: OutChan Text -> IO ()
stdoutThread OutChan Text
outChan =
  (BlockedIndefinitelyOnMVar -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      OutChan Text -> IO Text
forall a. OutChan a -> IO a
readChan OutChan Text
outChan
        IO Text -> (Text -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> IO ()
TIO.putStrLn
      Handle -> IO ()
hFlush Handle
stdout