{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Logging.Tracer.DataPoint
  (
    DataPoint (..)
  , DataPointName
  , DataPointStore
  , initDataPointStore
  , writeToStore
  , dataPointTracer
  , mkDataPointTracer
  ) where

import           Cardano.Logging.DocuGenerator
import           Cardano.Logging.Trace
import           Cardano.Logging.Types
import           Cardano.Logging.Utils (tryEvalNF)

import           Control.Concurrent.STM (atomically)
import           Control.Concurrent.STM.TVar
import           Control.DeepSeq (NFData)
import           Control.Exception (SomeException, displayException)
import           Control.Monad.IO.Class
import qualified Control.Tracer as NT
import           Data.Aeson
import qualified Data.Map.Strict as M
import           Data.Text (Text, intercalate)
import           System.IO (hPutStrLn, stderr)


---------------------------------------------------------------------------
--
-- | Type wrapper for some value of type 'v'. The only reason we need this
--   wrapper is an ability to store different values in the same 'DataPointStore'.
--
--   Please note that when the acceptor application will read the value of type 'v'
--   from the store, this value is just as unstructured JSON, but not Haskell
--   value of type 'v'. That's why 'FromJSON' instance for type 'v' should be
--   available for the acceptor application, to decode unstructured JSON.
--
data DataPoint where
  DataPoint :: (ToJSON v, NFData v) => !v -> DataPoint

type DataPointName  = Text
type DataPointStore = TVar (M.Map DataPointName DataPoint)


initDataPointStore :: IO DataPointStore
initDataPointStore :: IO DataPointStore
initDataPointStore = Map DataPointName DataPoint -> IO DataPointStore
forall a. a -> IO (TVar a)
newTVarIO Map DataPointName DataPoint
forall k a. Map k a
M.empty

-- | Write 'DataPoint' to the store.
writeToStore
  :: DataPointStore
  -> DataPointName
  -> DataPoint
  -> IO ()
writeToStore :: DataPointStore -> DataPointName -> DataPoint -> IO ()
writeToStore DataPointStore
dpStore DataPointName
dpName (DataPoint v
obj) =
  v -> IO (Either SomeException v)
forall a. NFData a => a -> IO (Either SomeException a)
tryEvalNF v
obj IO (Either SomeException v)
-> (Either SomeException v -> 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
>>= (SomeException -> IO ())
-> (v -> IO ()) -> Either SomeException v -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SomeException
ex :: SomeException) -> [Char] -> IO ()
errorInPureCode ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
ex) v -> IO ()
go
  where
    -- obj' is expected to be in NF
    go :: v -> IO ()
go v
obj' =
      let !newVal :: DataPoint
newVal = v -> DataPoint
forall v. (ToJSON v, NFData v) => v -> DataPoint
DataPoint v
obj'
      in STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
          DataPointStore
-> (Map DataPointName DataPoint -> Map DataPointName DataPoint)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' DataPointStore
dpStore ((Map DataPointName DataPoint -> Map DataPointName DataPoint)
 -> STM ())
-> (Map DataPointName DataPoint -> Map DataPointName DataPoint)
-> STM ()
forall a b. (a -> b) -> a -> b
$
            DataPointName
-> DataPoint
-> Map DataPointName DataPoint
-> Map DataPointName DataPoint
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert DataPointName
dpName DataPoint
newVal
    errorInPureCode :: [Char] -> IO ()
errorInPureCode [Char]
err = Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error evaluating datapoint " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DataPointName -> [Char]
forall a. Show a => a -> [Char]
show DataPointName
dpName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err

dataPointTracer :: forall m. MonadIO m
  => DataPointStore
  -> Trace m DataPoint
dataPointTracer :: forall (m :: * -> *).
MonadIO m =>
DataPointStore -> Trace m DataPoint
dataPointTracer DataPointStore
dataPointStore =
    Tracer m (LoggingContext, Either TraceControl DataPoint)
-> Trace m DataPoint
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl DataPoint)
 -> Trace m DataPoint)
-> Tracer m (LoggingContext, Either TraceControl DataPoint)
-> Trace m DataPoint
forall a b. (a -> b) -> a -> b
$ TracerA m (LoggingContext, Either TraceControl DataPoint) ()
-> Tracer m (LoggingContext, Either TraceControl DataPoint)
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
NT.arrow (TracerA m (LoggingContext, Either TraceControl DataPoint) ()
 -> Tracer m (LoggingContext, Either TraceControl DataPoint))
-> TracerA m (LoggingContext, Either TraceControl DataPoint) ()
-> Tracer m (LoggingContext, Either TraceControl DataPoint)
forall a b. (a -> b) -> a -> b
$ ((LoggingContext, Either TraceControl DataPoint) -> m ())
-> TracerA m (LoggingContext, Either TraceControl DataPoint) ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
NT.emit (((LoggingContext, Either TraceControl DataPoint) -> m ())
 -> TracerA m (LoggingContext, Either TraceControl DataPoint) ())
-> ((LoggingContext, Either TraceControl DataPoint) -> m ())
-> TracerA m (LoggingContext, Either TraceControl DataPoint) ()
forall a b. (a -> b) -> a -> b
$ (LoggingContext -> Either TraceControl DataPoint -> m ())
-> (LoggingContext, Either TraceControl DataPoint) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LoggingContext -> Either TraceControl DataPoint -> m ()
output
  where
    output ::
         LoggingContext
      -> Either TraceControl DataPoint
      -> m ()
    output :: LoggingContext -> Either TraceControl DataPoint -> m ()
output LoggingContext {[DataPointName]
Maybe SeverityS
Maybe Privacy
Maybe DetailLevel
lcNSInner :: [DataPointName]
lcNSPrefix :: [DataPointName]
lcSeverity :: Maybe SeverityS
lcPrivacy :: Maybe Privacy
lcDetails :: Maybe DetailLevel
lcNSInner :: LoggingContext -> [DataPointName]
lcNSPrefix :: LoggingContext -> [DataPointName]
lcSeverity :: LoggingContext -> Maybe SeverityS
lcPrivacy :: LoggingContext -> Maybe Privacy
lcDetails :: LoggingContext -> Maybe DetailLevel
..} (Right DataPoint
val) =
      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
$ DataPointStore -> DataPointName -> DataPoint -> IO ()
writeToStore DataPointStore
dataPointStore ([DataPointName] -> DataPointName
nameSpaceToText ([DataPointName]
lcNSPrefix [DataPointName] -> [DataPointName] -> [DataPointName]
forall a. [a] -> [a] -> [a]
++ [DataPointName]
lcNSInner)) DataPoint
val
    output 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
      () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    output LoggingContext
lk (Left c :: TraceControl
c@TCDocument {}) = do
      BackendConfig -> (LoggingContext, Either TraceControl Any) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
BackendConfig -> (LoggingContext, Either TraceControl a) -> m ()
docIt BackendConfig
DatapointBackend (LoggingContext
lk, TraceControl -> Either TraceControl Any
forall a b. a -> Either a b
Left TraceControl
c)
    output LoggingContext {} Either TraceControl DataPoint
_  = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    nameSpaceToText :: [Text] -> Text
    nameSpaceToText :: [DataPointName] -> DataPointName
nameSpaceToText = DataPointName -> [DataPointName] -> DataPointName
intercalate DataPointName
"."

-- A simple dataPointTracer which supports building a namespace.
mkDataPointTracer :: forall dp. (ToJSON dp, MetaTrace dp, NFData dp)
  => Trace IO DataPoint
  -> IO (Trace IO dp)
mkDataPointTracer :: forall dp.
(ToJSON dp, MetaTrace dp, NFData dp) =>
Trace IO DataPoint -> IO (Trace IO dp)
mkDataPointTracer Trace IO DataPoint
trDataPoint = do
    let tr :: Trace IO dp
tr = (dp -> DataPoint) -> Trace IO DataPoint -> Trace IO dp
forall a' a. (a' -> a) -> Trace IO a -> Trace IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
NT.contramap dp -> DataPoint
forall v. (ToJSON v, NFData v) => v -> DataPoint
DataPoint Trace IO DataPoint
trDataPoint
    Trace IO dp -> IO (Trace IO dp)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace IO dp -> IO (Trace IO dp))
-> Trace IO dp -> IO (Trace IO dp)
forall a b. (a -> b) -> a -> b
$ Trace IO dp -> Trace IO dp
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withInnerNames Trace IO dp
tr