{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}

module Cardano.Node.Tracing.API
  ( initTraceDispatcher
  ) where

import           Prelude
import           Cardano.Prelude (first)

import           "contra-tracer" Control.Tracer (traceWith)
import           "trace-dispatcher" Control.Tracer (nullTracer)
import qualified Data.Map as Map
import           Data.Maybe (fromMaybe)
import           Data.Time.Clock (getCurrentTime)


import           System.Metrics as EKG

import           Network.Mux.Trace (TraceLabelPeer (..))

import           Ouroboros.Consensus.Ledger.Inspect (LedgerEvent)
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client (TraceChainSyncClientEvent)
import           Ouroboros.Consensus.Node (NetworkP2PMode, RunNode)
import           Ouroboros.Network.ConnectionId (ConnectionId)
import           Ouroboros.Network.Magic (NetworkMagic)
import           Ouroboros.Network.NodeToClient (withIOManager)
import           Ouroboros.Network.NodeToNode (RemoteAddress)

import           Cardano.Node.Configuration.NodeAddress (SocketPath (..))
import           Cardano.Node.Configuration.POM (NodeConfiguration (..), ncProtocol)
import           Cardano.Node.Protocol.Types
import           Cardano.Node.Queries
import           Cardano.Node.Startup
import           Cardano.Node.TraceConstraints
import           Cardano.Node.Tracing
import           Cardano.Node.Types

import           Cardano.Logging hiding (traceWith)
import           Cardano.Node.Tracing.StateRep (NodeState (..))
import           Cardano.Node.Tracing.Tracers
import           Cardano.Node.Tracing.Tracers.Peer (startPeerTracer)
import           Cardano.Node.Tracing.Tracers.Resources (startResourceTracer)

initTraceDispatcher ::
  forall blk p2p.
  ( RunNode blk
  , TraceConstraints blk
  , LogFormatting (LedgerEvent blk)
  , LogFormatting
    (TraceLabelPeer (ConnectionId RemoteAddress) (TraceChainSyncClientEvent blk))
  )
  => NodeConfiguration
  -> SomeConsensusProtocol
  -> NetworkMagic
  -> NodeKernelData blk
  -> NetworkP2PMode p2p
  -> IO (Tracers RemoteConnectionId LocalConnectionId blk p2p)
initTraceDispatcher :: NodeConfiguration
-> SomeConsensusProtocol
-> NetworkMagic
-> NodeKernelData blk
-> NetworkP2PMode p2p
-> IO (Tracers RemoteConnectionId LocalConnectionId blk p2p)
initTraceDispatcher NodeConfiguration
nc SomeConsensusProtocol
p NetworkMagic
networkMagic NodeKernelData blk
nodeKernel NetworkP2PMode p2p
p2pMode = do
  TraceConfig
trConfig <- FilePath -> IO TraceConfig
readConfiguration (ConfigYamlFilePath -> FilePath
unConfigPath (ConfigYamlFilePath -> FilePath) -> ConfigYamlFilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ NodeConfiguration -> ConfigYamlFilePath
ncConfigFile NodeConfiguration
nc)
  FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"New tracer configuration: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> TraceConfig -> FilePath
forall a. Show a => a -> FilePath
show TraceConfig
trConfig

  Tracers RemoteConnectionId LocalConnectionId blk p2p
tracers <- TraceConfig
-> IO (Tracers RemoteConnectionId LocalConnectionId blk p2p)
mkTracers TraceConfig
trConfig

  Tracer IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracers RemoteConnectionId LocalConnectionId blk p2p
-> Tracer IO NodeState
forall peer localPeer blk (p2p :: P2P).
Tracers peer localPeer blk p2p -> Tracer IO NodeState
nodeStateTracer Tracers RemoteConnectionId LocalConnectionId blk p2p
tracers) NodeState
NodeTracingOnlineConfiguring

  Tracer IO ResourceStats -> Int -> IO ()
startResourceTracer
    (Tracers RemoteConnectionId LocalConnectionId blk p2p
-> Tracer IO ResourceStats
forall peer localPeer blk (p2p :: P2P).
Tracers peer localPeer blk p2p -> Tracer IO ResourceStats
resourcesTracer Tracers RemoteConnectionId LocalConnectionId blk p2p
tracers)
    (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1000 (TraceConfig -> Maybe Int
tcResourceFrequency TraceConfig
trConfig))

  Tracer IO [PeerT blk] -> NodeKernelData blk -> Int -> IO ()
forall blk.
Tracer IO [PeerT blk] -> NodeKernelData blk -> Int -> IO ()
startPeerTracer
    (Tracers RemoteConnectionId LocalConnectionId blk p2p
-> Tracer IO [PeerT blk]
forall peer localPeer blk (p2p :: P2P).
Tracers peer localPeer blk p2p -> Tracer IO [PeerT blk]
peersTracer Tracers RemoteConnectionId LocalConnectionId blk p2p
tracers)
    NodeKernelData blk
nodeKernel
    (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
2000 (TraceConfig -> Maybe Int
tcPeerFrequency TraceConfig
trConfig))

  UTCTime
now <- IO UTCTime
getCurrentTime
  Protocol
-> SomeConsensusProtocol -> TraceConfig -> UTCTime -> IO NodeInfo
prepareNodeInfo (NodeConfiguration -> Protocol
ncProtocol NodeConfiguration
nc) SomeConsensusProtocol
p TraceConfig
trConfig UTCTime
now
    IO NodeInfo -> (NodeInfo -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tracer IO NodeInfo -> NodeInfo -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracers RemoteConnectionId LocalConnectionId blk p2p
-> Tracer IO NodeInfo
forall peer localPeer blk (p2p :: P2P).
Tracers peer localPeer blk p2p -> Tracer IO NodeInfo
nodeInfoTracer Tracers RemoteConnectionId LocalConnectionId blk p2p
tracers)

  Tracers RemoteConnectionId LocalConnectionId blk p2p
-> IO (Tracers RemoteConnectionId LocalConnectionId blk p2p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracers RemoteConnectionId LocalConnectionId blk p2p
tracers
 where
  mkTracers :: TraceConfig
-> IO (Tracers RemoteConnectionId LocalConnectionId blk p2p)
mkTracers TraceConfig
trConfig = do
    Store
ekgStore <- IO Store
EKG.newStore
    Store -> IO ()
EKG.registerGcMetrics Store
ekgStore
    Trace IO FormattedMessage
ekgTrace <- Either Store Server -> IO (Trace IO FormattedMessage)
forall (m :: * -> *).
MonadIO m =>
Either Store Server -> m (Trace m FormattedMessage)
ekgTracer (Store -> Either Store Server
forall a b. a -> Either a b
Left Store
ekgStore)

    Trace IO FormattedMessage
stdoutTrace <- IO (Trace IO FormattedMessage)
forall (m :: * -> *). MonadIO m => m (Trace m FormattedMessage)
standardTracer

    -- We should initialize forwarding only if 'Forwarder' backend
    -- is presented in the node's configuration.
    (Trace IO FormattedMessage
fwdTracer, Trace IO DataPoint
dpTracer) <-
      if Bool
forwarderBackendEnabled
        then do
          -- TODO: check if this is the correct way to use withIOManager
          (ForwardSink TraceObject
forwardSink, DataPointStore
dpStore) <- (IOManager -> IO (ForwardSink TraceObject, DataPointStore))
-> IO (ForwardSink TraceObject, DataPointStore)
WithIOManager
withIOManager ((IOManager -> IO (ForwardSink TraceObject, DataPointStore))
 -> IO (ForwardSink TraceObject, DataPointStore))
-> (IOManager -> IO (ForwardSink TraceObject, DataPointStore))
-> IO (ForwardSink TraceObject, DataPointStore)
forall a b. (a -> b) -> a -> b
$ \IOManager
iomgr -> do
            let tracerSocketMode :: Maybe (FilePath, ForwarderMode)
tracerSocketMode = (FilePath, ForwarderMode) -> Maybe (FilePath, ForwarderMode)
forall a. a -> Maybe a
Just ((FilePath, ForwarderMode) -> Maybe (FilePath, ForwarderMode))
-> ((SocketPath, ForwarderMode) -> (FilePath, ForwarderMode))
-> (SocketPath, ForwarderMode)
-> Maybe (FilePath, ForwarderMode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SocketPath -> FilePath)
-> (SocketPath, ForwarderMode) -> (FilePath, ForwarderMode)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SocketPath -> FilePath
unSocketPath ((SocketPath, ForwarderMode) -> Maybe (FilePath, ForwarderMode))
-> Maybe (SocketPath, ForwarderMode)
-> Maybe (FilePath, ForwarderMode)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NodeConfiguration -> Maybe (SocketPath, ForwarderMode)
ncTraceForwardSocket NodeConfiguration
nc
            IOManager
-> TraceConfig
-> NetworkMagic
-> Store
-> Maybe (FilePath, ForwarderMode)
-> IO (ForwardSink TraceObject, DataPointStore)
forall (m :: * -> *).
MonadIO m =>
IOManager
-> TraceConfig
-> NetworkMagic
-> Store
-> Maybe (FilePath, ForwarderMode)
-> m (ForwardSink TraceObject, DataPointStore)
initForwarding IOManager
iomgr TraceConfig
trConfig NetworkMagic
networkMagic Store
ekgStore Maybe (FilePath, ForwarderMode)
tracerSocketMode
          (Trace IO FormattedMessage, Trace IO DataPoint)
-> IO (Trace IO FormattedMessage, Trace IO DataPoint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForwardSink TraceObject -> Trace IO FormattedMessage
forall (m :: * -> *).
MonadIO m =>
ForwardSink TraceObject -> Trace m FormattedMessage
forwardTracer ForwardSink TraceObject
forwardSink, DataPointStore -> Trace IO DataPoint
forall (m :: * -> *).
MonadIO m =>
DataPointStore -> Trace m DataPoint
dataPointTracer DataPointStore
dpStore)
        else
          -- Since 'Forwarder' backend isn't enabled, there is no forwarding.
          -- So we use nullTracers to ignore 'TraceObject's and 'DataPoint's.
          (Trace IO FormattedMessage, Trace IO DataPoint)
-> IO (Trace IO FormattedMessage, Trace IO DataPoint)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tracer IO (LoggingContext, Either TraceControl FormattedMessage)
-> Trace IO FormattedMessage
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer IO (LoggingContext, Either TraceControl FormattedMessage)
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer, Tracer IO (LoggingContext, Either TraceControl DataPoint)
-> Trace IO DataPoint
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer IO (LoggingContext, Either TraceControl DataPoint)
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer)

    NodeKernelData blk
-> Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe (Trace IO FormattedMessage)
-> Trace IO DataPoint
-> TraceConfig
-> NetworkP2PMode p2p
-> SomeConsensusProtocol
-> IO (Tracers RemoteConnectionId LocalConnectionId blk p2p)
forall blk (p2p :: P2P).
(RunNode blk, TraceConstraints blk,
 LogFormatting (LedgerEvent blk),
 LogFormatting
   (TraceLabelPeer
      RemoteConnectionId (TraceChainSyncClientEvent blk))) =>
NodeKernelData blk
-> Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe (Trace IO FormattedMessage)
-> Trace IO DataPoint
-> TraceConfig
-> NetworkP2PMode p2p
-> SomeConsensusProtocol
-> IO (Tracers RemoteConnectionId LocalConnectionId blk p2p)
mkDispatchTracers
      NodeKernelData blk
nodeKernel
      Trace IO FormattedMessage
stdoutTrace
      Trace IO FormattedMessage
fwdTracer
      (Trace IO FormattedMessage -> Maybe (Trace IO FormattedMessage)
forall a. a -> Maybe a
Just Trace IO FormattedMessage
ekgTrace)
      Trace IO DataPoint
dpTracer
      TraceConfig
trConfig
      NetworkP2PMode p2p
p2pMode
      SomeConsensusProtocol
p
   where
    forwarderBackendEnabled :: Bool
forwarderBackendEnabled =
      (ConfigOption -> Bool) -> [ConfigOption] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ConfigOption -> Bool
checkForwarder ([ConfigOption] -> Bool)
-> (Map Namespace [ConfigOption] -> [ConfigOption])
-> Map Namespace [ConfigOption]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[ConfigOption]] -> [ConfigOption]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ConfigOption]] -> [ConfigOption])
-> (Map Namespace [ConfigOption] -> [[ConfigOption]])
-> Map Namespace [ConfigOption]
-> [ConfigOption]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Namespace [ConfigOption] -> [[ConfigOption]]
forall k a. Map k a -> [a]
Map.elems (Map Namespace [ConfigOption] -> Bool)
-> Map Namespace [ConfigOption] -> Bool
forall a b. (a -> b) -> a -> b
$ TraceConfig -> Map Namespace [ConfigOption]
tcOptions TraceConfig
trConfig

    checkForwarder :: ConfigOption -> Bool
checkForwarder (ConfBackend [BackendConfig]
backends') = BackendConfig
Forwarder BackendConfig -> [BackendConfig] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BackendConfig]
backends'
    checkForwarder ConfigOption
_ = Bool
False