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

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

import qualified Cardano.Api as Api
import           Cardano.Prelude hiding (trace)

import qualified Control.Concurrent as Conc
import qualified Control.Concurrent.Async as Async
import           Control.Exception.Safe (MonadCatch)
import           Control.Monad.Trans.Except.Extra (catchIOExceptT)
import           "contra-tracer" Control.Tracer
import           Data.List (nub)
import qualified Data.Map.Strict 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           Cardano.BM.Backend.Aggregation (plugin)
import           Cardano.BM.Backend.EKGView (plugin)
import           Cardano.BM.Backend.Monitoring (plugin)
import           Cardano.BM.Backend.Switchboard (Switchboard)
import qualified Cardano.BM.Backend.Switchboard as Switchboard
import           Cardano.BM.Backend.TraceForwarder (plugin)
import           Cardano.BM.Configuration (Configuration)
import qualified Cardano.BM.Configuration as Config
import qualified Cardano.BM.Configuration.Model as Config
import           Cardano.BM.Data.Aggregated (Measurable (..))
import           Cardano.BM.Data.Backend (Backend, BackendKind (..))
import           Cardano.BM.Data.LogItem (LOContent (..), LOMeta (..), LoggerName)
import qualified Cardano.BM.Observer.Monadic as Monadic
import qualified Cardano.BM.Observer.STM as Stm
import           Cardano.BM.Plugin (loadPlugin)
#if defined(SYSTEMD)
import           Cardano.BM.Scribe.Systemd (plugin)
#endif
import           Cardano.BM.Setup (setupTrace_, shutdown)
import           Cardano.BM.Stats
import           Cardano.BM.Stats.Resources
import qualified Cardano.BM.Trace as Trace
import           Cardano.BM.Tracing

import qualified Cardano.Chain.Genesis as Gen
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as WCT
import           Ouroboros.Consensus.Byron.Ledger.Conversions
import           Ouroboros.Consensus.Cardano.Block
import           Ouroboros.Consensus.Cardano.CanHardFork
import qualified Ouroboros.Consensus.Config as Consensus
import           Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..))
import           Ouroboros.Consensus.HardFork.Combinator.Degenerate
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.Shelley.Ledger.Ledger

import           Cardano.Git.Rev (gitRev)
import           Cardano.Node.Configuration.POM (NodeConfiguration (..), ncProtocol)
import           Cardano.Node.Protocol.Types (SomeConsensusProtocol (..))
import           Cardano.Node.Types
import           Cardano.Slotting.Slot (EpochSize (..))
import           Cardano.Tracing.Config (TraceOptions (..))
import           Cardano.Tracing.OrphanInstances.Common ()
import           Paths_cardano_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/input-output-hk/cardano-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 `cardano-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
"cardano"

  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
mbEKGServer <- 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
mbEKGServer 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)
Cardano.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)
Cardano.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
"cardano.node.metrics" -- All metrics and peers info are here.
             errorsLoggers :: Text
errorsLoggers = Text
"cardano.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)
Cardano.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)
Cardano.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)
Cardano.BM.Scribe.Systemd.plugin Configuration
logConfig Trace IO Text
trace Switchboard Text
switchBoard Text
"cardano"
       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
       TraceOptions -> Trace IO Text -> IO ()
startCapturingMetrics (NodeConfiguration -> TraceOptions
ncTraceConfig NodeConfiguration
nodeConfig) 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 :: TraceOptions
    -> Trace IO Text
    -> IO ()
   startCapturingMetrics :: TraceOptions -> Trace IO Text -> IO ()
startCapturingMetrics (TraceDispatcher TraceSelection
_) Trace IO Text
_tr = do
      () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

   startCapturingMetrics TraceOptions
_ 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 ()
Conc.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).
--
-- TODO: it should return 'StartupTrace' rather than raw 'LogObject's.
--
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
Api.protocolInfo ProtocolInfoArgs IO blk
pForInfo
      protocolDependentItems :: [(Text, Text)]
protocolDependentItems =
        case BlockType blk
whichP of
          BlockType blk
Api.ByronBlockType ->
            let DegenLedgerConfig PartialLedgerConfig ByronBlock
cfgByron = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.configLedger TopLevelConfig blk
cfg
            in TopLevelConfig blk -> ByronPartialLedgerConfig -> [(Text, Text)]
forall a b blk.
(IsString a, StringConv FilePath b, ConfigSupportsNode blk) =>
TopLevelConfig blk -> ByronPartialLedgerConfig -> [(a, b)]
getGenesisValuesByron TopLevelConfig blk
cfg ByronPartialLedgerConfig
PartialLedgerConfig ByronBlock
cfgByron
          BlockType blk
Api.ShelleyBlockType ->
            let DegenLedgerConfig PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
cfgShelley = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.configLedger TopLevelConfig blk
cfg
            in Text
-> ShelleyPartialLedgerConfig StandardShelley -> [(Text, Text)]
forall a b era.
(IsString a, StringConv FilePath b, Semigroup a) =>
a -> ShelleyPartialLedgerConfig era -> [(a, b)]
getGenesisValues Text
"Shelley" ShelleyPartialLedgerConfig StandardShelley
PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
cfgShelley
          BlockType blk
Api.CardanoBlockType ->
            let CardanoLedgerConfig PartialLedgerConfig ByronBlock
cfgByron PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
cfgShelley PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
cfgAllegra
                                    PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
cfgMary PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
cfgAlonzo PartialLedgerConfig
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
cfgBabbage = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.configLedger TopLevelConfig blk
cfg
            in TopLevelConfig blk -> ByronPartialLedgerConfig -> [(Text, Text)]
forall a b blk.
(IsString a, StringConv FilePath b, ConfigSupportsNode blk) =>
TopLevelConfig blk -> ByronPartialLedgerConfig -> [(a, b)]
getGenesisValuesByron TopLevelConfig blk
cfg ByronPartialLedgerConfig
PartialLedgerConfig ByronBlock
cfgByron
               [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ Text
-> ShelleyPartialLedgerConfig StandardShelley -> [(Text, Text)]
forall a b era.
(IsString a, StringConv FilePath b, Semigroup a) =>
a -> ShelleyPartialLedgerConfig era -> [(a, b)]
getGenesisValues Text
"Shelley" ShelleyPartialLedgerConfig StandardShelley
PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
cfgShelley
               [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ Text
-> ShelleyPartialLedgerConfig (AllegraEra StandardCrypto)
-> [(Text, Text)]
forall a b era.
(IsString a, StringConv FilePath b, Semigroup a) =>
a -> ShelleyPartialLedgerConfig era -> [(a, b)]
getGenesisValues Text
"Allegra" ShelleyPartialLedgerConfig (AllegraEra StandardCrypto)
PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
cfgAllegra
               [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ Text
-> ShelleyPartialLedgerConfig (MaryEra StandardCrypto)
-> [(Text, Text)]
forall a b era.
(IsString a, StringConv FilePath b, Semigroup a) =>
a -> ShelleyPartialLedgerConfig era -> [(a, b)]
getGenesisValues Text
"Mary"    ShelleyPartialLedgerConfig (MaryEra StandardCrypto)
PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
cfgMary
               [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ Text
-> ShelleyPartialLedgerConfig (AlonzoEra StandardCrypto)
-> [(Text, Text)]
forall a b era.
(IsString a, StringConv FilePath b, Semigroup a) =>
a -> ShelleyPartialLedgerConfig era -> [(a, b)]
getGenesisValues Text
"Alonzo"  ShelleyPartialLedgerConfig (AlonzoEra StandardCrypto)
PartialLedgerConfig
  (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
cfgAlonzo
               [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ Text
-> ShelleyPartialLedgerConfig (BabbageEra StandardCrypto)
-> [(Text, Text)]
forall a b era.
(IsString a, StringConv FilePath b, Semigroup a) =>
a -> ShelleyPartialLedgerConfig era -> [(a, b)]
getGenesisValues Text
"Babbage"  ShelleyPartialLedgerConfig (BabbageEra StandardCrypto)
PartialLedgerConfig
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
cfgBabbage
      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
forall a b. (Show a, StringConv FilePath b) => a -> b
show (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, StringConv 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
  getGenesisValuesByron :: TopLevelConfig blk -> ByronPartialLedgerConfig -> [(a, b)]
getGenesisValuesByron TopLevelConfig blk
cfg ByronPartialLedgerConfig
config =
    let genesis :: LedgerConfig ByronBlock
genesis = ByronPartialLedgerConfig -> LedgerConfig ByronBlock
byronLedgerConfig ByronPartialLedgerConfig
config
    in [ (a
"systemStartTime",  UTCTime -> b
forall a b. (Show a, StringConv 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
"slotLengthByron",  NominalDiffTime -> b
forall a b. (Show a, StringConv 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
fromByronSlotLength (Natural -> NominalDiffTime) -> Natural -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Config -> Natural
genesisSlotLength Config
LedgerConfig ByronBlock
genesis))
       , (a
"epochLengthByron", Word64 -> b
forall a b. (Show a, StringConv 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
fromByronEpochSlots (EpochSlots -> Word64) -> EpochSlots -> Word64
forall a b. (a -> b) -> a -> b
$ Config -> EpochSlots
Gen.configEpochSlots Config
LedgerConfig ByronBlock
genesis))
       ]
  getGenesisValues :: a -> ShelleyPartialLedgerConfig era -> [(a, b)]
getGenesisValues a
era ShelleyPartialLedgerConfig era
config =
    let genesis :: ShelleyGenesis era
genesis = ShelleyLedgerConfig era -> ShelleyGenesis era
forall era. ShelleyLedgerConfig era -> ShelleyGenesis era
shelleyLedgerGenesis (ShelleyLedgerConfig era -> ShelleyGenesis era)
-> ShelleyLedgerConfig era -> ShelleyGenesis era
forall a b. (a -> b) -> a -> b
$ ShelleyPartialLedgerConfig era -> ShelleyLedgerConfig era
forall era.
ShelleyPartialLedgerConfig era -> ShelleyLedgerConfig era
shelleyLedgerConfig ShelleyPartialLedgerConfig era
config
    in [ (a
"systemStartTime",          UTCTime -> b
forall a b. (Show a, StringConv FilePath b) => a -> b
show (ShelleyGenesis era -> UTCTime
forall era. ShelleyGenesis era -> UTCTime
SL.sgSystemStart ShelleyGenesis era
genesis))
       , (a
"slotLength" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
era,        NominalDiffTime -> b
forall a b. (Show a, StringConv 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
$ ShelleyGenesis era -> NominalDiffTime
forall era. ShelleyGenesis era -> NominalDiffTime
SL.sgSlotLength ShelleyGenesis era
genesis))
       , (a
"epochLength" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
era,       Word64 -> b
forall a b. (Show a, StringConv FilePath b) => a -> b
show (EpochSize -> Word64
unEpochSize (EpochSize -> Word64)
-> (ShelleyGenesis era -> EpochSize)
-> ShelleyGenesis era
-> Word64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShelleyGenesis era -> EpochSize
forall era. ShelleyGenesis era -> EpochSize
SL.sgEpochLength (ShelleyGenesis era -> Word64) -> ShelleyGenesis era -> Word64
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis era
genesis))
       , (a
"slotsPerKESPeriod" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
era, Word64 -> b
forall a b. (Show a, StringConv FilePath b) => a -> b
show (ShelleyGenesis era -> Word64
forall era. ShelleyGenesis era -> Word64
SL.sgSlotsPerKESPeriod ShelleyGenesis era
genesis))
       ]