{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Bcc.Node.Configuration.Logging
  ( LoggingLayer (..)
  , EKGDirect(..)
  , createLoggingLayer
  , nodeBasicInfo
  , shutdownLoggingLayer
  , traceCounter
  -- re-exports
  , Trace
  , Configuration
  , LoggerName
  , Severity (..)
  , mkLOMeta
  , LOMeta (..)
  , LOContent (..)
  ) where

import           Bcc.Prelude hiding (trace)

import qualified Control.Concurrent.Async as Async
import           Control.Exception.Safe (MonadCatch)
import           Control.Monad.Trans.Except.Extra (catchIOExceptT)
import           Control.Tracer
import           Data.List (nub)
import qualified Data.Map as Map
import           Data.Text (pack)
import           Data.Time.Clock (UTCTime, getCurrentTime)
import           Data.Version (showVersion)
import           System.Metrics.Counter (Counter)
import           System.Metrics.Gauge (Gauge)
import           System.Metrics.Label (Label)
import qualified System.Remote.Monitoring as EKG

import           Bcc.BM.Backend.Aggregation (plugin)
import           Bcc.BM.Backend.EKGView (plugin)
import           Bcc.BM.Backend.Monitoring (plugin)
import           Bcc.BM.Backend.Switchboard (Switchboard)
import qualified Bcc.BM.Backend.Switchboard as Switchboard
import           Bcc.BM.Backend.TraceForwarder (plugin)
import           Bcc.BM.Configuration (Configuration)
import qualified Bcc.BM.Configuration as Config
import qualified Bcc.BM.Configuration.Model as Config
import           Bcc.BM.Data.Aggregated (Measurable (..))
import           Bcc.BM.Data.Backend (Backend, BackendKind (..))
import           Bcc.BM.Data.LogItem (LOContent (..), LOMeta (..), LoggerName)
import qualified Bcc.BM.Observer.Monadic as Monadic
import qualified Bcc.BM.Observer.STM as Stm
import           Bcc.BM.Plugin (loadPlugin)
#if defined(SYSTEMD)
import           Bcc.BM.Scribe.Systemd (plugin)
#endif
import           Bcc.BM.Setup (setupTrace_, shutdown)
import           Bcc.BM.Stats
import           Bcc.BM.Stats.Resources
import qualified Bcc.BM.Trace as Trace
import           Bcc.BM.Tracing

import qualified Bcc.Chain.Genesis as Gen
import           Bcc.Slotting.Slot (EpochSize (..))
import qualified Shardagnostic.Consensus.BlockchainTime.WallClock.Types as WCT
import           Shardagnostic.Consensus.Cole.Ledger.Conversions
import           Shardagnostic.Consensus.Bcc.Block
import           Shardagnostic.Consensus.Bcc.CanHardFork
import qualified Shardagnostic.Consensus.Config as Consensus
import           Shardagnostic.Consensus.Config.SupportsNode (ConfigSupportsNode (..))
import           Shardagnostic.Consensus.HardFork.Combinator.Degenerate
import           Shardagnostic.Consensus.Node.ProtocolInfo
import           Shardagnostic.Consensus.Sophie.Ledger.Ledger
import qualified Sophie.Spec.Ledger.API as SL

import           Bcc.Api.Protocol.Types (BlockType (..), protocolInfo)
import           Bcc.Config.Git.Rev (gitRev)
import           Bcc.Node.Configuration.POM (NodeConfiguration (..), ncProtocol)
import           Bcc.Node.Protocol.Types (SomeConsensusProtocol (..))
import           Bcc.Node.Types
import           Bcc.Tracing.OrphanInstances.Common ()
import           Paths_bcc_node (version)

--------------------------------
-- Layer
--------------------------------

-- | The LoggingLayer interface that we can expose.
-- We want to do this since we want to be able to mock out any function tied to logging.
--
-- The good side of this is that _each function has it's own effects_
-- and that is ideal for tracking the functions effects and constraining
-- the user (programmer) of those function to use specific effects in them.
-- https://github.com/The-Blockchain-Company/bcc-sl/blob/develop/util/src/Pos/Util/Log/LogSafe.hs
data LoggingLayer = LoggingLayer
  { LoggingLayer -> forall (m :: * -> *). MonadIO m => Trace m Text
llBasicTrace :: forall m. (MonadIO m) => Trace m Text
  , LoggingLayer
-> forall (m :: * -> *) a.
   (MonadIO m, Show a) =>
   Trace m a -> a -> m ()
llLogDebug :: forall m a. (MonadIO m, Show a) => Trace m a -> a -> m ()
  , LoggingLayer
-> forall (m :: * -> *) a.
   (MonadIO m, Show a) =>
   Trace m a -> a -> m ()
llLogInfo :: forall m a. (MonadIO m, Show a) => Trace m a -> a -> m ()
  , LoggingLayer
-> forall (m :: * -> *) a.
   (MonadIO m, Show a) =>
   Trace m a -> a -> m ()
llLogNotice :: forall m a. (MonadIO m, Show a) => Trace m a -> a -> m ()
  , LoggingLayer
-> forall (m :: * -> *) a.
   (MonadIO m, Show a) =>
   Trace m a -> a -> m ()
llLogWarning :: forall m a. (MonadIO m, Show a) => Trace m a -> a -> m ()
  , LoggingLayer
-> forall (m :: * -> *) a.
   (MonadIO m, Show a) =>
   Trace m a -> a -> m ()
llLogError :: forall m a. (MonadIO m, Show a) => Trace m a -> a -> m ()
  , LoggingLayer
-> forall (m :: * -> *) a. Show a => Text -> Trace m a -> Trace m a
llAppendName :: forall m a. (Show a) => LoggerName -> Trace m a -> Trace m a
  , LoggingLayer
-> forall a t.
   Show a =>
   Trace IO a -> Severity -> Text -> IO t -> IO t
llBracketMonadIO :: forall a t. (Show a) => Trace IO a -> Severity -> Text -> IO t -> IO t
  , LoggingLayer
-> forall (m :: * -> *) a t.
   (MonadCatch m, MonadIO m, Show a) =>
   Trace m a -> Severity -> Text -> m t -> m t
llBracketMonadM
      :: forall m a t. (MonadCatch m, MonadIO m, Show a)
      => Trace m a -> Severity -> Text -> m t -> m t
  , LoggingLayer
-> forall (m :: * -> *) a t.
   (MonadIO m, Show a) =>
   Trace m a -> Severity -> Text -> m t -> m t
llBracketMonadX
      :: forall m a t. (MonadIO m, Show a) => Trace m a -> Severity -> Text -> m t -> m t
  , LoggingLayer
-> forall a t.
   Show a =>
   Trace IO a -> Severity -> Text -> STM t -> IO t
llBracketStmIO :: forall a t. (Show a) => Trace IO a -> Severity -> Text -> STM t -> IO t
  , LoggingLayer
-> forall a t.
   Show a =>
   Trace IO a
   -> Severity -> Text -> STM (t, [(LOMeta, LOContent a)]) -> IO t
llBracketStmLogIO
      :: forall a t. (Show a)
      => Trace IO a -> Severity -> Text -> STM (t,[(LOMeta, LOContent a)]) -> IO t
  , LoggingLayer -> Configuration
llConfiguration :: Configuration
  , LoggingLayer -> Backend Text -> BackendKind -> IO ()
llAddBackend :: Backend Text -> BackendKind -> IO ()
  , LoggingLayer -> Switchboard Text
llSwitchboard :: Switchboard Text
  , LoggingLayer -> Maybe EKGDirect
llEKGDirect :: Maybe EKGDirect
  }

data EKGDirect = EKGDirect
  { EKGDirect -> Server
ekgServer   :: EKG.Server
  , EKGDirect -> MVar (Map Text Gauge)
ekgGauges   :: MVar (Map.Map Text Gauge)
  , EKGDirect -> MVar (Map Text Label)
ekgLabels   :: MVar (Map.Map Text Label)
  , EKGDirect -> MVar (Map Text Counter)
ekgCounters :: MVar (Map.Map Text Counter)
  }

--------------------------------
-- Feature
--------------------------------

-- | Either parse a filepath into a logging 'Configuration',
--   or supply a mute 'Configuration'.
loggingCLIConfiguration
    :: Maybe FilePath
    -> ExceptT ConfigError IO Configuration
loggingCLIConfiguration :: Maybe FilePath -> ExceptT ConfigError IO Configuration
loggingCLIConfiguration = ExceptT ConfigError IO Configuration
-> (FilePath -> ExceptT ConfigError IO Configuration)
-> Maybe FilePath
-> ExceptT ConfigError IO Configuration
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ExceptT ConfigError IO Configuration
emptyConfig FilePath -> ExceptT ConfigError IO Configuration
readConfig
 where
   readConfig :: FilePath -> ExceptT ConfigError IO Configuration
   readConfig :: FilePath -> ExceptT ConfigError IO Configuration
readConfig FilePath
fp =
     IO Configuration
-> (IOException -> ConfigError)
-> ExceptT ConfigError IO Configuration
forall (m :: * -> *) a x.
MonadIO m =>
IO a -> (IOException -> x) -> ExceptT x m a
catchIOExceptT (FilePath -> IO Configuration
Config.setup FilePath
fp) ((IOException -> ConfigError)
 -> ExceptT ConfigError IO Configuration)
-> (IOException -> ConfigError)
-> ExceptT ConfigError IO Configuration
forall a b. (a -> b) -> a -> b
$ \(IOException
_ :: IOException) -> FilePath -> ConfigError
ConfigErrorFileNotFound FilePath
fp

   emptyConfig :: ExceptT ConfigError IO Configuration
   emptyConfig :: ExceptT ConfigError IO Configuration
emptyConfig = IO Configuration -> ExceptT ConfigError IO Configuration
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Configuration -> ExceptT ConfigError IO Configuration)
-> IO Configuration -> ExceptT ConfigError IO Configuration
forall a b. (a -> b) -> a -> b
$ do
     Configuration
c <- IO Configuration
Config.empty
     Configuration -> Severity -> IO ()
Config.setMinSeverity Configuration
c Severity
Info
     Configuration -> IO Configuration
forall (f :: * -> *) a. Applicative f => a -> f a
pure Configuration
c

-- | Create logging feature for `bcc-node`
createLoggingLayer
  :: Text
  -> NodeConfiguration
  -> SomeConsensusProtocol
  -> ExceptT ConfigError IO LoggingLayer
createLoggingLayer :: Text
-> NodeConfiguration
-> SomeConsensusProtocol
-> ExceptT ConfigError IO LoggingLayer
createLoggingLayer Text
ver NodeConfiguration
nodeConfig' SomeConsensusProtocol
p = do

  Configuration
logConfig <- Maybe FilePath -> ExceptT ConfigError IO Configuration
loggingCLIConfiguration (Maybe FilePath -> ExceptT ConfigError IO Configuration)
-> Maybe FilePath -> ExceptT ConfigError IO Configuration
forall a b. (a -> b) -> a -> b
$
    if NodeConfiguration -> Bool
ncLoggingSwitch NodeConfiguration
nodeConfig'
    -- Re-interpret node config again, as logging 'Configuration':
    then FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath)
-> (ConfigYamlFilePath -> FilePath)
-> ConfigYamlFilePath
-> Maybe FilePath
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ConfigYamlFilePath -> FilePath
unConfigPath (ConfigYamlFilePath -> Maybe FilePath)
-> ConfigYamlFilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ NodeConfiguration -> ConfigYamlFilePath
ncConfigFile NodeConfiguration
nodeConfig'
    else Maybe FilePath
forall a. Maybe a
Nothing

  -- These have to be set before the switchboard is set up.
  IO () -> ExceptT ConfigError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ConfigError IO ())
-> IO () -> ExceptT ConfigError IO ()
forall a b. (a -> b) -> a -> b
$ do
    Configuration -> Text -> Text -> IO ()
Config.setTextOption Configuration
logConfig Text
"appversion" Text
ver
    Configuration -> Text -> Text -> IO ()
Config.setTextOption Configuration
logConfig Text
"appcommit" Text
gitRev

  (Trace IO Text
baseTrace, Switchboard Text
switchBoard) <- IO (Trace IO Text, Switchboard Text)
-> ExceptT ConfigError IO (Trace IO Text, Switchboard Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Trace IO Text, Switchboard Text)
 -> ExceptT ConfigError IO (Trace IO Text, Switchboard Text))
-> IO (Trace IO Text, Switchboard Text)
-> ExceptT ConfigError IO (Trace IO Text, Switchboard Text)
forall a b. (a -> b) -> a -> b
$ Configuration -> Text -> IO (Trace IO Text, Switchboard Text)
forall (m :: * -> *) a.
(MonadIO m, ToJSON a, FromJSON a, ToObject a) =>
Configuration -> Text -> m (Trace m a, Switchboard a)
setupTrace_ Configuration
logConfig Text
"bcc"

  let loggingEnabled :: Bool
      loggingEnabled :: Bool
loggingEnabled = NodeConfiguration -> Bool
ncLoggingSwitch NodeConfiguration
nodeConfig'
      trace :: Trace IO Text
      trace :: Trace IO Text
trace = if Bool
loggingEnabled
              then Trace IO Text
baseTrace
              else Trace IO Text
forall (m :: * -> *) a. Applicative m => Tracer m a
Trace.nullTracer

  Bool -> ExceptT ConfigError IO () -> ExceptT ConfigError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
loggingEnabled (ExceptT ConfigError IO () -> ExceptT ConfigError IO ())
-> ExceptT ConfigError IO () -> ExceptT ConfigError IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> ExceptT ConfigError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ConfigError IO ())
-> IO () -> ExceptT ConfigError IO ()
forall a b. (a -> b) -> a -> b
$
    NodeConfiguration
-> Configuration -> Switchboard Text -> Trace IO Text -> IO ()
loggingPreInit NodeConfiguration
nodeConfig' Configuration
logConfig Switchboard Text
switchBoard Trace IO Text
trace

  Maybe Server
mEKGServer <- IO (Maybe Server) -> ExceptT ConfigError IO (Maybe Server)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Server) -> ExceptT ConfigError IO (Maybe Server))
-> IO (Maybe Server) -> ExceptT ConfigError IO (Maybe Server)
forall a b. (a -> b) -> a -> b
$ Switchboard Text -> IO (Maybe Server)
forall a. Switchboard a -> IO (Maybe Server)
Switchboard.getSbEKGServer Switchboard Text
switchBoard

  Maybe EKGDirect
mbEkgDirect <- case Maybe Server
mEKGServer of
                  Maybe Server
Nothing -> Maybe EKGDirect -> ExceptT ConfigError IO (Maybe EKGDirect)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe EKGDirect
forall a. Maybe a
Nothing
                  Just Server
sv -> do
                    MVar (Map Text Gauge)
refGauge   <- IO (MVar (Map Text Gauge))
-> ExceptT ConfigError IO (MVar (Map Text Gauge))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (Map Text Gauge))
 -> ExceptT ConfigError IO (MVar (Map Text Gauge)))
-> IO (MVar (Map Text Gauge))
-> ExceptT ConfigError IO (MVar (Map Text Gauge))
forall a b. (a -> b) -> a -> b
$ Map Text Gauge -> IO (MVar (Map Text Gauge))
forall a. a -> IO (MVar a)
newMVar Map Text Gauge
forall k a. Map k a
Map.empty
                    MVar (Map Text Label)
refLabel   <- IO (MVar (Map Text Label))
-> ExceptT ConfigError IO (MVar (Map Text Label))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (Map Text Label))
 -> ExceptT ConfigError IO (MVar (Map Text Label)))
-> IO (MVar (Map Text Label))
-> ExceptT ConfigError IO (MVar (Map Text Label))
forall a b. (a -> b) -> a -> b
$ Map Text Label -> IO (MVar (Map Text Label))
forall a. a -> IO (MVar a)
newMVar Map Text Label
forall k a. Map k a
Map.empty
                    MVar (Map Text Counter)
refCounter <- IO (MVar (Map Text Counter))
-> ExceptT ConfigError IO (MVar (Map Text Counter))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (Map Text Counter))
 -> ExceptT ConfigError IO (MVar (Map Text Counter)))
-> IO (MVar (Map Text Counter))
-> ExceptT ConfigError IO (MVar (Map Text Counter))
forall a b. (a -> b) -> a -> b
$ Map Text Counter -> IO (MVar (Map Text Counter))
forall a. a -> IO (MVar a)
newMVar Map Text Counter
forall k a. Map k a
Map.empty
                    Maybe EKGDirect -> ExceptT ConfigError IO (Maybe EKGDirect)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe EKGDirect -> ExceptT ConfigError IO (Maybe EKGDirect))
-> Maybe EKGDirect -> ExceptT ConfigError IO (Maybe EKGDirect)
forall a b. (a -> b) -> a -> b
$ EKGDirect -> Maybe EKGDirect
forall a. a -> Maybe a
Just EKGDirect :: Server
-> MVar (Map Text Gauge)
-> MVar (Map Text Label)
-> MVar (Map Text Counter)
-> EKGDirect
EKGDirect {
                        ekgServer :: Server
ekgServer   = Server
sv
                      , ekgGauges :: MVar (Map Text Gauge)
ekgGauges   = MVar (Map Text Gauge)
refGauge
                      , ekgLabels :: MVar (Map Text Label)
ekgLabels   = MVar (Map Text Label)
refLabel
                      , ekgCounters :: MVar (Map Text Counter)
ekgCounters = MVar (Map Text Counter)
refCounter
                      }

  LoggingLayer -> ExceptT ConfigError IO LoggingLayer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoggingLayer -> ExceptT ConfigError IO LoggingLayer)
-> LoggingLayer -> ExceptT ConfigError IO LoggingLayer
forall a b. (a -> b) -> a -> b
$ Configuration
-> Switchboard Text
-> Maybe EKGDirect
-> Trace IO Text
-> LoggingLayer
mkLogLayer Configuration
logConfig Switchboard Text
switchBoard Maybe EKGDirect
mbEkgDirect Trace IO Text
trace
 where
   loggingPreInit
     :: NodeConfiguration
     -> Configuration
     -> Switchboard Text
     -> Trace IO Text
     -> IO ()
   loggingPreInit :: NodeConfiguration
-> Configuration -> Switchboard Text -> Trace IO Text -> IO ()
loggingPreInit NodeConfiguration
nodeConfig Configuration
logConfig Switchboard Text
switchBoard Trace IO Text
trace = do
     Configuration -> IO (Maybe Endpoint)
Config.getEKGBindAddr Configuration
logConfig IO (Maybe Endpoint) -> (Maybe Endpoint -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Endpoint
mbEndpoint ->
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Endpoint -> Bool
forall a. Maybe a -> Bool
isJust Maybe Endpoint
mbEndpoint) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         Configuration
-> Trace IO Text -> Switchboard Text -> IO (Plugin Text)
forall (s :: * -> *) a.
(IsEffectuator s a, ToJSON a, FromJSON a) =>
Configuration -> Trace IO a -> s a -> IO (Plugin a)
Bcc.BM.Backend.EKGView.plugin Configuration
logConfig Trace IO Text
trace Switchboard Text
switchBoard
           IO (Plugin Text) -> (Plugin Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Switchboard Text -> Plugin Text -> IO ()
forall a. Switchboard a -> Plugin a -> IO ()
loadPlugin Switchboard Text
switchBoard

     Configuration -> IO (Maybe RemoteAddr)
Config.getForwardTo Configuration
logConfig IO (Maybe RemoteAddr) -> (Maybe RemoteAddr -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe RemoteAddr
forwardTo ->
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe RemoteAddr -> Bool
forall a. Maybe a -> Bool
isJust Maybe RemoteAddr
forwardTo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
         -- Since the configuration contains 'traceForwardTo' section,
         -- node's information (metrics/peers/errors) should be forwarded
         -- to an external process (for example, RTView).

         -- Activate TraceForwarder plugin (there is no need to add 'TraceForwarderBK'
         -- to 'setupBackends' list).
         UTCTime
nodeStartTime <- IO UTCTime
getCurrentTime
         Configuration
-> Trace IO Text
-> Switchboard Text
-> Text
-> IO [LogObject Text]
-> IO (Plugin Text)
forall a (s :: * -> *).
(IsEffectuator s a, ToJSON a, FromJSON a) =>
Configuration
-> Trace IO a -> s a -> Text -> IO [LogObject a] -> IO (Plugin a)
Bcc.BM.Backend.TraceForwarder.plugin Configuration
logConfig
                                                  Trace IO Text
trace
                                                  Switchboard Text
switchBoard
                                                  Text
"forwarderMinSeverity"
                                                  (NodeConfiguration
-> SomeConsensusProtocol -> UTCTime -> IO [LogObject Text]
nodeBasicInfo NodeConfiguration
nodeConfig SomeConsensusProtocol
p UTCTime
nodeStartTime)
           IO (Plugin Text) -> (Plugin Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Switchboard Text -> Plugin Text -> IO ()
forall a. Switchboard a -> Plugin a -> IO ()
loadPlugin Switchboard Text
switchBoard

         -- Forward all the metrics/peers/errors to 'TraceForwarderBK' using 'mapBackends'.
         -- If 'TraceForwarderBK' is already added in 'mapBackends' - ignore it.
         let metricsLogger :: Text
metricsLogger = Text
"bcc.node.metrics" -- All metrics and peers info are here.
             errorsLoggers :: Text
errorsLoggers = Text
"bcc.node" -- All errors (messages with 'Warning+' severity) are here.

         [Text] -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text
metricsLogger, Text
errorsLoggers] ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
loggerName ->
           Configuration -> Text -> IO [BackendKind]
Config.getBackends Configuration
logConfig Text
loggerName IO [BackendKind] -> ([BackendKind] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[BackendKind]
backends ->
             Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BackendKind
TraceForwarderBK BackendKind -> [BackendKind] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [BackendKind]
backends) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
               Configuration -> Text -> Maybe [BackendKind] -> IO ()
Config.setBackends Configuration
logConfig Text
loggerName (Maybe [BackendKind] -> IO ()) -> Maybe [BackendKind] -> IO ()
forall a b. (a -> b) -> a -> b
$ [BackendKind] -> Maybe [BackendKind]
forall a. a -> Maybe a
Just (BackendKind
TraceForwarderBK BackendKind -> [BackendKind] -> [BackendKind]
forall a. a -> [a] -> [a]
: [BackendKind]
backends)

     Configuration
-> Trace IO Text -> Switchboard Text -> IO (Plugin Text)
forall (s :: * -> *) a.
(IsEffectuator s a, ToJSON a, FromJSON a) =>
Configuration -> Trace IO a -> s a -> IO (Plugin a)
Bcc.BM.Backend.Aggregation.plugin Configuration
logConfig Trace IO Text
trace Switchboard Text
switchBoard
       IO (Plugin Text) -> (Plugin Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Switchboard Text -> Plugin Text -> IO ()
forall a. Switchboard a -> Plugin a -> IO ()
loadPlugin Switchboard Text
switchBoard
     Configuration
-> Trace IO Text -> Switchboard Text -> IO (Plugin Text)
forall (s :: * -> *) a.
(IsEffectuator s a, ToJSON a, FromJSON a) =>
Configuration -> Trace IO a -> s a -> IO (Plugin a)
Bcc.BM.Backend.Monitoring.plugin Configuration
logConfig Trace IO Text
trace Switchboard Text
switchBoard
       IO (Plugin Text) -> (Plugin Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Switchboard Text -> Plugin Text -> IO ()
forall a. Switchboard a -> Plugin a -> IO ()
loadPlugin Switchboard Text
switchBoard

#if defined(SYSTEMD)
     Configuration
-> Trace IO Text -> Switchboard Text -> Text -> IO (Plugin Text)
forall (s :: * -> *) a.
(IsEffectuator s a, ToJSON a, FromJSON a) =>
Configuration -> Trace IO a -> s a -> Text -> IO (Plugin a)
Bcc.BM.Scribe.Systemd.plugin Configuration
logConfig Trace IO Text
trace Switchboard Text
switchBoard Text
"bcc"
       IO (Plugin Text) -> (Plugin Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Switchboard Text -> Plugin Text -> IO ()
forall a. Switchboard a -> Plugin a -> IO ()
loadPlugin Switchboard Text
switchBoard
#endif

     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NodeConfiguration -> Bool
ncLogMetrics NodeConfiguration
nodeConfig) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       -- Record node metrics, if configured
       Trace IO Text -> IO ()
startCapturingMetrics Trace IO Text
trace

   mkLogLayer :: Configuration -> Switchboard Text -> Maybe EKGDirect -> Trace IO Text -> LoggingLayer
   mkLogLayer :: Configuration
-> Switchboard Text
-> Maybe EKGDirect
-> Trace IO Text
-> LoggingLayer
mkLogLayer Configuration
logConfig Switchboard Text
switchBoard Maybe EKGDirect
mbEkgDirect Trace IO Text
trace =
     LoggingLayer :: (forall (m :: * -> *). MonadIO m => Trace m Text)
-> (forall (m :: * -> *) a.
    (MonadIO m, Show a) =>
    Trace m a -> a -> m ())
-> (forall (m :: * -> *) a.
    (MonadIO m, Show a) =>
    Trace m a -> a -> m ())
-> (forall (m :: * -> *) a.
    (MonadIO m, Show a) =>
    Trace m a -> a -> m ())
-> (forall (m :: * -> *) a.
    (MonadIO m, Show a) =>
    Trace m a -> a -> m ())
-> (forall (m :: * -> *) a.
    (MonadIO m, Show a) =>
    Trace m a -> a -> m ())
-> (forall (m :: * -> *) a.
    Show a =>
    Text -> Trace m a -> Trace m a)
-> (forall a t.
    Show a =>
    Trace IO a -> Severity -> Text -> IO t -> IO t)
-> (forall (m :: * -> *) a t.
    (MonadCatch m, MonadIO m, Show a) =>
    Trace m a -> Severity -> Text -> m t -> m t)
-> (forall (m :: * -> *) a t.
    (MonadIO m, Show a) =>
    Trace m a -> Severity -> Text -> m t -> m t)
-> (forall a t.
    Show a =>
    Trace IO a -> Severity -> Text -> STM t -> IO t)
-> (forall a t.
    Show a =>
    Trace IO a
    -> Severity -> Text -> STM (t, [(LOMeta, LOContent a)]) -> IO t)
-> Configuration
-> (Backend Text -> BackendKind -> IO ())
-> Switchboard Text
-> Maybe EKGDirect
-> LoggingLayer
LoggingLayer
       { llBasicTrace :: forall (m :: * -> *). MonadIO m => Trace m Text
llBasicTrace = (forall x. IO x -> m x)
-> Trace IO Text -> Tracer m (Text, LogObject Text)
forall (m :: * -> *) (n :: * -> *) a.
(forall x. m x -> n x)
-> Tracer m (Text, LogObject a) -> Tracer n (Text, LogObject a)
Trace.natTrace forall x. IO x -> m x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO Trace IO Text
trace
       , llLogDebug :: forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Trace m a -> a -> m ()
llLogDebug = forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Trace m a -> a -> m ()
forall (m :: * -> *) a. MonadIO m => Trace m a -> a -> m ()
Trace.logDebug
       , llLogInfo :: forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Trace m a -> a -> m ()
llLogInfo = forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Trace m a -> a -> m ()
forall (m :: * -> *) a. MonadIO m => Trace m a -> a -> m ()
Trace.logInfo
       , llLogNotice :: forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Trace m a -> a -> m ()
llLogNotice = forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Trace m a -> a -> m ()
forall (m :: * -> *) a. MonadIO m => Trace m a -> a -> m ()
Trace.logNotice
       , llLogWarning :: forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Trace m a -> a -> m ()
llLogWarning = forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Trace m a -> a -> m ()
forall (m :: * -> *) a. MonadIO m => Trace m a -> a -> m ()
Trace.logWarning
       , llLogError :: forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Trace m a -> a -> m ()
llLogError = forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Trace m a -> a -> m ()
forall (m :: * -> *) a. MonadIO m => Trace m a -> a -> m ()
Trace.logError
       , llAppendName :: forall (m :: * -> *) a. Show a => Text -> Trace m a -> Trace m a
llAppendName = forall (m :: * -> *) a. Show a => Text -> Trace m a -> Trace m a
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
Trace.appendName
       , llBracketMonadIO :: forall a t.
Show a =>
Trace IO a -> Severity -> Text -> IO t -> IO t
llBracketMonadIO = Configuration -> Trace IO a -> Severity -> Text -> IO t -> IO t
forall a t.
Configuration -> Trace IO a -> Severity -> Text -> IO t -> IO t
Monadic.bracketObserveIO Configuration
logConfig
       , llBracketMonadM :: forall (m :: * -> *) a t.
(MonadCatch m, MonadIO m, Show a) =>
Trace m a -> Severity -> Text -> m t -> m t
llBracketMonadM = Configuration -> Trace m a -> Severity -> Text -> m t -> m t
forall (m :: * -> *) a t.
(MonadCatch m, MonadIO m) =>
Configuration -> Trace m a -> Severity -> Text -> m t -> m t
Monadic.bracketObserveM Configuration
logConfig
       , llBracketMonadX :: forall (m :: * -> *) a t.
(MonadIO m, Show a) =>
Trace m a -> Severity -> Text -> m t -> m t
llBracketMonadX = Configuration -> Trace m a -> Severity -> Text -> m t -> m t
forall (m :: * -> *) a t.
MonadIO m =>
Configuration -> Trace m a -> Severity -> Text -> m t -> m t
Monadic.bracketObserveX Configuration
logConfig
       , llBracketStmIO :: forall a t.
Show a =>
Trace IO a -> Severity -> Text -> STM t -> IO t
llBracketStmIO = Configuration -> Trace IO a -> Severity -> Text -> STM t -> IO t
forall a t.
Configuration -> Trace IO a -> Severity -> Text -> STM t -> IO t
Stm.bracketObserveIO Configuration
logConfig
       , llBracketStmLogIO :: forall a t.
Show a =>
Trace IO a
-> Severity -> Text -> STM (t, [(LOMeta, LOContent a)]) -> IO t
llBracketStmLogIO = Configuration
-> Trace IO a
-> Severity
-> Text
-> STM (t, [(LOMeta, LOContent a)])
-> IO t
forall a t.
Configuration
-> Trace IO a
-> Severity
-> Text
-> STM (t, [(LOMeta, LOContent a)])
-> IO t
Stm.bracketObserveLogIO Configuration
logConfig
       , llConfiguration :: Configuration
llConfiguration = Configuration
logConfig
       , llAddBackend :: Backend Text -> BackendKind -> IO ()
llAddBackend = Switchboard Text -> Backend Text -> BackendKind -> IO ()
forall a. Switchboard a -> Backend a -> BackendKind -> IO ()
Switchboard.addExternalBackend Switchboard Text
switchBoard
       , llSwitchboard :: Switchboard Text
llSwitchboard = Switchboard Text
switchBoard
       , llEKGDirect :: Maybe EKGDirect
llEKGDirect = Maybe EKGDirect
mbEkgDirect
       }

   startCapturingMetrics :: Trace IO Text -> IO ()
   startCapturingMetrics :: Trace IO Text -> IO ()
startCapturingMetrics Trace IO Text
tr = do
     IO (Async Any) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async Any) -> IO ())
-> (IO () -> IO (Async Any)) -> IO () -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
Async.async (IO Any -> IO (Async Any))
-> (IO () -> IO Any) -> IO () -> IO (Async Any)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
       IO (Maybe ResourceStats)
readResourceStats
         IO (Maybe ResourceStats) -> (Maybe ResourceStats -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (ResourceStats -> IO ()) -> Maybe ResourceStats -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
                   (Trace IO Text -> ResourceStats -> IO ()
traceResourceStats
                      (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"node" Trace IO Text
tr))
       Int -> IO ()
threadDelay Int
1000000 -- TODO:  make configurable
   traceResourceStats :: Trace IO Text -> ResourceStats -> IO ()
   traceResourceStats :: Trace IO Text -> ResourceStats -> IO ()
traceResourceStats Trace IO Text
tr ResourceStats
rs = do
     Tracer IO ResourceStats -> ResourceStats -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TracingVerbosity -> Trace IO Text -> Tracer IO ResourceStats
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
TracingVerbosity -> Trace m a -> Tracer m b
toLogObject' TracingVerbosity
NormalVerbosity (Trace IO Text -> Tracer IO ResourceStats)
-> Trace IO Text -> Tracer IO ResourceStats
forall a b. (a -> b) -> a -> b
$ Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"resources" Trace IO Text
tr) ResourceStats
rs
     Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"Stat.cputicks"    Trace IO Text
tr (Int -> IO ()) -> (Word64 -> Int) -> Word64 -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceStats -> Word64
forall a. Resources a -> a
rCentiCpu ResourceStats
rs
     Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"Mem.resident"     Trace IO Text
tr (Int -> IO ()) -> (Word64 -> Int) -> Word64 -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceStats -> Word64
forall a. Resources a -> a
rRSS ResourceStats
rs
     Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"RTS.gcLiveBytes"  Trace IO Text
tr (Int -> IO ()) -> (Word64 -> Int) -> Word64 -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceStats -> Word64
forall a. Resources a -> a
rLive ResourceStats
rs
     Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"RTS.gcHeapBytes"  Trace IO Text
tr (Int -> IO ()) -> (Word64 -> Int) -> Word64 -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceStats -> Word64
forall a. Resources a -> a
rHeap ResourceStats
rs
     Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"RTS.gcMajorNum"   Trace IO Text
tr (Int -> IO ()) -> (Word64 -> Int) -> Word64 -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceStats -> Word64
forall a. Resources a -> a
rGcsMajor ResourceStats
rs
     Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"RTS.gcMinorNum"   Trace IO Text
tr (Int -> IO ()) -> (Word64 -> Int) -> Word64 -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceStats -> Word64
forall a. Resources a -> a
rGcsMinor ResourceStats
rs
     Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"RTS.gcticks"      Trace IO Text
tr (Int -> IO ()) -> (Word64 -> Int) -> Word64 -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceStats -> Word64
forall a. Resources a -> a
rCentiGC ResourceStats
rs
     Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"RTS.mutticks"     Trace IO Text
tr (Int -> IO ()) -> (Word64 -> Int) -> Word64 -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceStats -> Word64
forall a. Resources a -> a
rCentiMut ResourceStats
rs
     Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"Stat.threads"     Trace IO Text
tr (Int -> IO ()) -> (Word64 -> Int) -> Word64 -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> IO ()) -> Word64 -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceStats -> Word64
forall a. Resources a -> a
rThreads ResourceStats
rs

traceCounter
  :: Text
  -> Trace IO Text
  -> Int
  -> IO ()
traceCounter :: Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
logValueName Trace IO Text
tracer Int
aCounter = do
  LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Notice PrivacyAnnotation
Public
  Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
Trace.traceNamedObject
    (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"metrics" Trace IO Text
tracer)
    (LOMeta
meta, Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
logValueName (Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
aCounter))

shutdownLoggingLayer :: LoggingLayer -> IO ()
shutdownLoggingLayer :: LoggingLayer -> IO ()
shutdownLoggingLayer = Switchboard Text -> IO ()
forall a.
(ToJSON a, FromJSON a, ToObject a) =>
Switchboard a -> IO ()
shutdown (Switchboard Text -> IO ())
-> (LoggingLayer -> Switchboard Text) -> LoggingLayer -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LoggingLayer -> Switchboard Text
llSwitchboard

-- The node provides the basic node's information for TraceForwarderBK.
-- It will be sent once TraceForwarderBK is connected to an external process
-- (for example, RTView).
nodeBasicInfo :: NodeConfiguration
              -> SomeConsensusProtocol
              -> UTCTime
              -> IO [LogObject Text]
nodeBasicInfo :: NodeConfiguration
-> SomeConsensusProtocol -> UTCTime -> IO [LogObject Text]
nodeBasicInfo NodeConfiguration
nc (SomeConsensusProtocol BlockType blk
whichP ProtocolInfoArgs IO blk
pForInfo) UTCTime
nodeStartTime' = do
  LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Notice PrivacyAnnotation
Public
  let cfg :: TopLevelConfig blk
cfg = ProtocolInfo IO blk -> TopLevelConfig blk
forall (m :: * -> *) b. ProtocolInfo m b -> TopLevelConfig b
pInfoConfig (ProtocolInfo IO blk -> TopLevelConfig blk)
-> ProtocolInfo IO blk -> TopLevelConfig blk
forall a b. (a -> b) -> a -> b
$ ProtocolInfoArgs IO blk -> ProtocolInfo IO blk
forall (m :: * -> *) blk.
Protocol m blk =>
ProtocolInfoArgs m blk -> ProtocolInfo m blk
protocolInfo ProtocolInfoArgs IO blk
pForInfo
      protocolDependentItems :: [(Text, Text)]
protocolDependentItems =
        case BlockType blk
whichP of
          BlockType blk
ColeBlockType ->
            let DegenLedgerConfig PartialLedgerConfig ColeBlock
cfgCole = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.configLedger TopLevelConfig blk
cfg
            in TopLevelConfig blk -> ColePartialLedgerConfig -> [(Text, Text)]
forall a b blk.
(IsString a, ConvertText FilePath b, ConfigSupportsNode blk) =>
TopLevelConfig blk -> ColePartialLedgerConfig -> [(a, b)]
getGenesisValuesCole TopLevelConfig blk
cfg PartialLedgerConfig ColeBlock
ColePartialLedgerConfig
cfgCole
          BlockType blk
SophieBlockType ->
            let DegenLedgerConfig PartialLedgerConfig (SophieBlock StandardSophie)
cfgSophie = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.configLedger TopLevelConfig blk
cfg
            in Text -> SophiePartialLedgerConfig StandardSophie -> [(Text, Text)]
forall a b era.
(IsString a, ConvertText FilePath b, Semigroup a) =>
a -> SophiePartialLedgerConfig era -> [(a, b)]
getGenesisValues Text
"Sophie" PartialLedgerConfig (SophieBlock StandardSophie)
SophiePartialLedgerConfig StandardSophie
cfgSophie
          BlockType blk
BccBlockType ->
            let BccLedgerConfig PartialLedgerConfig ColeBlock
cfgCole PartialLedgerConfig (SophieBlock StandardSophie)
cfgSophie PartialLedgerConfig (SophieBlock (EvieEra StandardCrypto))
cfgEvie PartialLedgerConfig (SophieBlock (JenEra StandardCrypto))
cfgJen PartialLedgerConfig (SophieBlock (AurumEra StandardCrypto))
cfgAurum = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.configLedger TopLevelConfig blk
cfg
            in TopLevelConfig blk -> ColePartialLedgerConfig -> [(Text, Text)]
forall a b blk.
(IsString a, ConvertText FilePath b, ConfigSupportsNode blk) =>
TopLevelConfig blk -> ColePartialLedgerConfig -> [(a, b)]
getGenesisValuesCole TopLevelConfig blk
cfg PartialLedgerConfig ColeBlock
ColePartialLedgerConfig
cfgCole
               [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ Text -> SophiePartialLedgerConfig StandardSophie -> [(Text, Text)]
forall a b era.
(IsString a, ConvertText FilePath b, Semigroup a) =>
a -> SophiePartialLedgerConfig era -> [(a, b)]
getGenesisValues Text
"Sophie" PartialLedgerConfig (SophieBlock StandardSophie)
SophiePartialLedgerConfig StandardSophie
cfgSophie
               [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ Text
-> SophiePartialLedgerConfig (EvieEra StandardCrypto)
-> [(Text, Text)]
forall a b era.
(IsString a, ConvertText FilePath b, Semigroup a) =>
a -> SophiePartialLedgerConfig era -> [(a, b)]
getGenesisValues Text
"Evie" PartialLedgerConfig (SophieBlock (EvieEra StandardCrypto))
SophiePartialLedgerConfig (EvieEra StandardCrypto)
cfgEvie
               [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ Text
-> SophiePartialLedgerConfig (JenEra StandardCrypto)
-> [(Text, Text)]
forall a b era.
(IsString a, ConvertText FilePath b, Semigroup a) =>
a -> SophiePartialLedgerConfig era -> [(a, b)]
getGenesisValues Text
"Jen"    PartialLedgerConfig (SophieBlock (JenEra StandardCrypto))
SophiePartialLedgerConfig (JenEra StandardCrypto)
cfgJen
               [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ Text
-> SophiePartialLedgerConfig (AurumEra StandardCrypto)
-> [(Text, Text)]
forall a b era.
(IsString a, ConvertText FilePath b, Semigroup a) =>
a -> SophiePartialLedgerConfig era -> [(a, b)]
getGenesisValues Text
"Aurum"  PartialLedgerConfig (SophieBlock (AurumEra StandardCrypto))
SophiePartialLedgerConfig (AurumEra StandardCrypto)
cfgAurum
      items :: [(Text, Text)]
items = [(Text, Text)] -> [(Text, Text)]
forall a. Eq a => [a] -> [a]
nub ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$
        [ (Text
"protocol",      FilePath -> Text
pack (FilePath -> Text) -> (Protocol -> FilePath) -> Protocol -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Protocol -> FilePath
protocolName (Protocol -> Text) -> Protocol -> Text
forall a b. (a -> b) -> a -> b
$ NodeConfiguration -> Protocol
ncProtocol NodeConfiguration
nc)
        , (Text
"version",       FilePath -> Text
pack (FilePath -> Text) -> (Version -> FilePath) -> Version -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Version -> FilePath
showVersion (Version -> Text) -> Version -> Text
forall a b. (a -> b) -> a -> b
$ Version
version)
        , (Text
"commit",        Text
gitRev)
        , (Text
"nodeStartTime", UTCTime -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show UTCTime
nodeStartTime')
        ] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [(Text, Text)]
protocolDependentItems
      logObjects :: [LogObject Text]
logObjects =
        ((Text, Text) -> LogObject Text)
-> [(Text, Text)] -> [LogObject Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Text
nm, Text
msg) -> Text -> LOMeta -> LOContent Text -> LogObject Text
forall a. Text -> LOMeta -> LOContent a -> LogObject a
LogObject (Text
"basicInfo." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm) LOMeta
meta (Text -> LOContent Text
forall a. a -> LOContent a
LogMessage Text
msg)) [(Text, Text)]
items
  [LogObject Text] -> IO [LogObject Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [LogObject Text]
logObjects
 where
  getGenesisValuesCole :: TopLevelConfig blk -> ColePartialLedgerConfig -> [(a, b)]
getGenesisValuesCole TopLevelConfig blk
cfg ColePartialLedgerConfig
config =
    let genesis :: LedgerConfig ColeBlock
genesis = ColePartialLedgerConfig -> LedgerConfig ColeBlock
coleLedgerConfig ColePartialLedgerConfig
config
    in [ (a
"systemStartTime",  UTCTime -> b
forall a b. (Show a, ConvertText FilePath b) => a -> b
show (SystemStart -> UTCTime
WCT.getSystemStart (SystemStart -> UTCTime)
-> (BlockConfig blk -> SystemStart) -> BlockConfig blk -> UTCTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BlockConfig blk -> SystemStart
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> SystemStart
getSystemStart (BlockConfig blk -> UTCTime) -> BlockConfig blk -> UTCTime
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
Consensus.configBlock TopLevelConfig blk
cfg))
       , (a
"slotLengthCole",  NominalDiffTime -> b
forall a b. (Show a, ConvertText FilePath b) => a -> b
show (SlotLength -> NominalDiffTime
WCT.getSlotLength (SlotLength -> NominalDiffTime)
-> (Natural -> SlotLength) -> Natural -> NominalDiffTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Natural -> SlotLength
fromColeSlotLength (Natural -> NominalDiffTime) -> Natural -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Config -> Natural
genesisSlotLength LedgerConfig ColeBlock
Config
genesis))
       , (a
"epochLengthCole", Word64 -> b
forall a b. (Show a, ConvertText FilePath b) => a -> b
show (EpochSize -> Word64
unEpochSize (EpochSize -> Word64)
-> (EpochSlots -> EpochSize) -> EpochSlots -> Word64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EpochSlots -> EpochSize
fromColeEpochSlots (EpochSlots -> Word64) -> EpochSlots -> Word64
forall a b. (a -> b) -> a -> b
$ Config -> EpochSlots
Gen.configEpochSlots LedgerConfig ColeBlock
Config
genesis))
       ]
  getGenesisValues :: a -> SophiePartialLedgerConfig era -> [(a, b)]
getGenesisValues a
era SophiePartialLedgerConfig era
config =
    let genesis :: SophieGenesis era
genesis = SophieLedgerConfig era -> SophieGenesis era
forall era. SophieLedgerConfig era -> SophieGenesis era
sophieLedgerGenesis (SophieLedgerConfig era -> SophieGenesis era)
-> SophieLedgerConfig era -> SophieGenesis era
forall a b. (a -> b) -> a -> b
$ SophiePartialLedgerConfig era -> SophieLedgerConfig era
forall era. SophiePartialLedgerConfig era -> SophieLedgerConfig era
sophieLedgerConfig SophiePartialLedgerConfig era
config
    in [ (a
"systemStartTime",          UTCTime -> b
forall a b. (Show a, ConvertText FilePath b) => a -> b
show (SophieGenesis era -> UTCTime
forall era. SophieGenesis era -> UTCTime
SL.sgSystemStart SophieGenesis era
genesis))
       , (a
"slotLength" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
era,        NominalDiffTime -> b
forall a b. (Show a, ConvertText FilePath b) => a -> b
show (SlotLength -> NominalDiffTime
WCT.getSlotLength (SlotLength -> NominalDiffTime)
-> (NominalDiffTime -> SlotLength)
-> NominalDiffTime
-> NominalDiffTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NominalDiffTime -> SlotLength
WCT.mkSlotLength (NominalDiffTime -> NominalDiffTime)
-> NominalDiffTime -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ SophieGenesis era -> NominalDiffTime
forall era. SophieGenesis era -> NominalDiffTime
SL.sgSlotLength SophieGenesis era
genesis))
       , (a
"epochLength" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
era,       Word64 -> b
forall a b. (Show a, ConvertText FilePath b) => a -> b
show (EpochSize -> Word64
unEpochSize (EpochSize -> Word64)
-> (SophieGenesis era -> EpochSize) -> SophieGenesis era -> Word64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SophieGenesis era -> EpochSize
forall era. SophieGenesis era -> EpochSize
SL.sgEpochLength (SophieGenesis era -> Word64) -> SophieGenesis era -> Word64
forall a b. (a -> b) -> a -> b
$ SophieGenesis era
genesis))
       , (a
"slotsPerKESPeriod" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
era, Word64 -> b
forall a b. (Show a, ConvertText FilePath b) => a -> b
show (SophieGenesis era -> Word64
forall era. SophieGenesis era -> Word64
SL.sgSlotsPerKESPeriod SophieGenesis era
genesis))
       ]