{-# 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           Control.Concurrent.STM (atomically)
import           Control.Concurrent.STM.TVar
import           Control.DeepSeq (NFData, deepseq)
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)

---------------------------------------------------------------------------
--
-- | 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) = 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
$ \Map DataPointName DataPoint
store ->
    if DataPointName
dpName DataPointName -> Map DataPointName DataPoint -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map DataPointName DataPoint
store
      then (DataPoint -> DataPoint)
-> DataPointName
-> Map DataPointName DataPoint
-> Map DataPointName DataPoint
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (DataPoint -> DataPoint -> DataPoint
forall a b. a -> b -> a
const (v -> DataPoint
forall v. (ToJSON v, NFData v) => v -> DataPoint
DataPoint (v -> v -> v
forall a b. NFData a => a -> b -> b
deepseq v
obj v
obj))) DataPointName
dpName Map DataPointName DataPoint
store
      else 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 (v -> DataPoint
forall v. (ToJSON v, NFData v) => v -> DataPoint
DataPoint (v -> v -> v
forall a b. NFData a => a -> b -> b
deepseq v
obj v
obj)) Map DataPointName DataPoint
store

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