Genesis config propagation, some tracer tweaks

cardano-node/src/Cardano/Node/Configuration/POM.hs

@@ -35,11 +35,12 @@ import           Cardano.Tracing.Config
 import           Cardano.Tracing.OrphanInstances.Network ()
 import           Ouroboros.Consensus.Ledger.SupportsMempool
 import           Ouroboros.Consensus.Mempool (MempoolCapacityBytesOverride (..))
-import           Ouroboros.Consensus.Node (NodeDatabasePaths (..),
-                   pattern DoDiskSnapshotChecksum)
+import           Ouroboros.Consensus.Node (NodeDatabasePaths (..), pattern DoDiskSnapshotChecksum)
 import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..))
-import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (Flag,
-                   NumOfDiskSnapshots (..), SnapshotInterval (..))
+import           Ouroboros.Consensus.Node.Genesis (GenesisConfig, GenesisConfigFlags (..),
+                   defaultGenesisConfigFlags, mkGenesisConfig)
+import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (Flag, NumOfDiskSnapshots (..),
+                   SnapshotInterval (..))
 import           Ouroboros.Network.Diffusion.Configuration as Configuration
 
 import           Control.Monad (when)
@@ -178,6 +179,9 @@ data NodeConfiguration
 
          -- Enable Peer Sharing
        , ncPeerSharing :: PeerSharing
+
+         -- Ouroboros Genesis
+       , ncGenesisConfig :: GenesisConfig
        } deriving (Eq, Show)
 
 
@@ -252,6 +256,9 @@ data PartialNodeConfiguration
 
          -- Peer Sharing
        , pncPeerSharing :: !(Last PeerSharing)
+
+         -- Ouroboros Genesis
+       , pncGenesisConfigFlags :: !(Last GenesisConfigFlags)
        } deriving (Eq, Generic, Show)
 
 instance AdjustFilePaths PartialNodeConfiguration where
@@ -360,6 +367,9 @@ instance FromJSON PartialNodeConfiguration where
       -- DISABLED BY DEFAULT
       pncPeerSharing <- Last <$> v .:? "PeerSharing"
 
+      -- pncConsensusMode determines whether Genesis is enabled in the first place.
+      pncGenesisConfigFlags <- Last <$> v .:? "LowLevelGenesisOptions"
+
       pure PartialNodeConfiguration {
              pncProtocolConfig
            , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty pncSocketPath
@@ -401,6 +411,7 @@ instance FromJSON PartialNodeConfiguration where
            , pncConsensusMode
            , pncEnableP2P
            , pncPeerSharing
+           , pncGenesisConfigFlags
            }
     where
       parseMempoolCapacityBytesOverride v = parseNoOverride <|> parseOverride
@@ -584,6 +595,7 @@ defaultPartialNodeConfiguration =
     , pncConsensusMode = Last (Just defaultConsensusMode)
     , pncEnableP2P     = Last (Just EnabledP2PMode)
     , pncPeerSharing   = Last (Just defaultPeerSharing)
+    , pncGenesisConfigFlags = Last (Just defaultGenesisConfigFlags)
     }
   where
     Configuration.PeerSelectionTargets {
@@ -682,6 +694,14 @@ makeNodeConfiguration pnc = do
     lastToEither "Missing PeerSharing"
     $ pncPeerSharing pnc
 
+  mGenesisConfigFlags <- case ncConsensusMode of
+    PraosMode -> pure Nothing
+    GenesisMode ->
+        fmap Just
+      $ lastToEither "Missing GenesisConfigFlags"
+      $ pncGenesisConfigFlags pnc
+  let ncGenesisConfig = mkGenesisConfig mGenesisConfigFlags
+
   -- TODO: This is not mandatory
   experimentalProtocols <-
     lastToEither "Missing ExperimentalProtocolsEnabled" $
@@ -736,6 +756,7 @@ makeNodeConfiguration pnc = do
                  DisabledP2PMode -> SomeNetworkP2PMode Consensus.DisabledP2PMode
              , ncPeerSharing
              , ncConsensusMode
+             , ncGenesisConfig
              }
 
 ncProtocol :: NodeConfiguration -> Protocol

cardano-node/src/Cardano/Node/Orphans.hs

@@ -1,6 +1,6 @@
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
@@ -10,13 +10,14 @@ module Cardano.Node.Orphans () where
 
 import           Cardano.Api ()
 
-import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (Flag(..))
 import           Ouroboros.Consensus.Node
-import qualified Data.Text as Text
+import           Ouroboros.Consensus.Node.Genesis (GenesisConfigFlags (..))
+import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (Flag (..))
 import           Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..))
 import           Ouroboros.Network.SizeInBytes (SizeInBytes (..))
 
 import           Data.Aeson.Types
+import qualified Data.Text as Text
 import           Text.Printf (PrintfArg (..))
 
 deriving instance Eq NodeDatabasePaths
@@ -60,3 +61,15 @@ instance FromJSON NodeDatabasePaths where
 
 deriving newtype instance FromJSON (Flag symbol)
 deriving newtype instance ToJSON (Flag symbol)
+
+instance FromJSON GenesisConfigFlags where
+  parseJSON = withObject "GenesisConfigFlags" $ \v ->
+    GenesisConfigFlags
+      <$> v .:? "EnableCSJ"       .!= True
+      <*> v .:? "EnableLoEAndGDD" .!= True
+      <*> v .:? "EnableLoP"       .!= True
+      <*> v .:? "BlockFetchGracePeriod"
+      <*> v .:? "BucketCapacity"
+      <*> v .:? "BucketRate"
+      <*> v .:? "CSJJumpSize"
+      <*> v .:? "GDDRateLimit"

cardano-node/src/Cardano/Node/Parsers.hs

@@ -133,6 +133,7 @@ nodeRunParser = do
            , pncConsensusMode = mempty
            , pncEnableP2P = mempty
            , pncPeerSharing = mempty
+           , pncGenesisConfigFlags = mempty
            }
 
 parseSocketPath :: Text -> Parser SocketPath

cardano-node/src/Cardano/Node/Run.hs

@@ -455,7 +455,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do
                                                 (const . pure $ ())
 
         let nodeArgs = RunNodeArgs
-              { rnGenesisConfig  = disableGenesisConfig
+              { rnGenesisConfig  = ncGenesisConfig nc
               , rnTraceConsensus = consensusTracers tracers
               , rnTraceNTN       = nodeToNodeTracers tracers
               , rnTraceNTC       = nodeToClientTracers tracers
@@ -546,7 +546,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do
                            (length ipProducerAddrs)
 
             nodeArgs = RunNodeArgs
-                { rnGenesisConfig  = disableGenesisConfig
+                { rnGenesisConfig  = ncGenesisConfig nc
                 , rnTraceConsensus = consensusTracers tracers
                 , rnTraceNTN       = nodeToNodeTracers tracers
                 , rnTraceNTC       = nodeToClientTracers tracers

cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs

@@ -72,7 +72,6 @@ import           Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..))
 import           Ouroboros.Network.SizeInBytes (SizeInBytes (..))
 import           Ouroboros.Network.TxSubmission.Inbound hiding (txId)
 import           Ouroboros.Network.TxSubmission.Outbound
-import           Network.TypedProtocol.Core
 
 import           Control.Monad (guard)
 import           Control.Monad.Class.MonadTime.SI (Time (..))
@@ -86,6 +85,7 @@ import qualified Data.List as List
 import qualified Data.Text as Text
 import           Data.Time (DiffTime, NominalDiffTime)
 import           Data.Word (Word32, Word64)
+import           Network.TypedProtocol.Core
 
 
 instance (LogFormatting adr, Show adr) => LogFormatting (ConnectionId adr) where
@@ -335,30 +335,6 @@ instance (ConvertRawHash blk, LedgerSupportsProtocol blk)
 
       jumpInfoToPoint = AF.headPoint . jTheirFragment
 
--- TODO @tweag-genesis
-instance MetaTrace (Jumping.TraceEvent addr) where
-  namespaceFor RotatedDynamo{} = Namespace [] ["RotatedDynamo"]
-
-  severityFor (Namespace [] ["RotatedDynamo"]) _ = Just Info
-  severityFor _ _ = Nothing
-
-  documentFor (Namespace [] ["RotatedDynamo"]) =
-    Just "The dynamo rotated"
-  documentFor _ = Nothing
-
-  allNamespaces =
-    [ Namespace [] ["RotatedDynamo"] ]
-
-instance Show addr => LogFormatting (Jumping.TraceEvent addr) where
-  forHuman (RotatedDynamo fromPeer toPeer) =
-    "Rotated the dynamo from " <> showT fromPeer <> " to " <> showT toPeer
-  forMachine _dtal (RotatedDynamo fromPeer toPeer) =
-    mconcat
-      [ "kind" .= String "RotatedDynamo"
-      , "from" .= showT fromPeer
-      , "to" .= showT toPeer
-      ]
-
 tipToObject :: forall blk. ConvertRawHash blk => Tip blk -> Aeson.Object
 tipToObject = \case
   TipGenesis -> mconcat
@@ -2259,6 +2235,44 @@ instance MetaTrace (TraceGsmEvent selection) where
     , Namespace [] ["GsmEventSyncingToPreSyncing"]
     ]
 
+--------------------------------------------------------------------------------
+-- CSJ Tracer
+--------------------------------------------------------------------------------
+
+instance ( LogFormatting peer, Show peer
+         ) => LogFormatting (Jumping.TraceEvent peer) where
+  forMachine dtal =
+    \case
+      RotatedDynamo oldPeer newPeer ->
+        mconcat
+          [ "kind" .= String "RotatedDynamo"
+          , "oldPeer" .= forMachine dtal oldPeer
+          , "newPeer" .= forMachine dtal newPeer
+          ]
+
+  forHuman (RotatedDynamo fromPeer toPeer) =
+    "Rotated the dynamo from " <> showT fromPeer <> " to " <> showT toPeer
+
+instance MetaTrace (Jumping.TraceEvent peer) where
+  namespaceFor =
+    \case
+      RotatedDynamo {}        -> Namespace [] ["RotatedDynamo"]
+
+  severityFor ns _ =
+    case ns of
+      Namespace _ ["RotatedDynamo"]               -> Just Info
+      Namespace _ _                               -> Nothing
+
+  documentFor = \case
+    Namespace _ ["RotatedDynamo"] ->
+      Just "The ChainSync Jumping module has been asked to rotate its dynamo"
+    Namespace _ _ ->
+      Nothing
+
+  allNamespaces =
+    [ Namespace [] ["RotatedDynamo"]
+    ]
+
 --------------------------------------------------------------------------------
 -- Chain tip tracer
 --------------------------------------------------------------------------------

cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs

@@ -26,13 +26,13 @@ import           Cardano.Slotting.Slot (fromWithOrigin)
 import           Cardano.Tracing.OrphanInstances.Common
 import           Cardano.Tracing.OrphanInstances.Network ()
 import           Cardano.Tracing.Render (renderChainHash, renderChunkNo, renderHeaderHash,
-                   renderHeaderHashForVerbosity, renderPointAsPhrase,
-                   renderPointForVerbosity, renderRealPoint, renderRealPointAsPhrase,
-                   renderTipBlockNo, renderTipHash, renderWithOrigin)
+                   renderHeaderHashForVerbosity, renderPointAsPhrase, renderPointForVerbosity,
+                   renderRealPoint, renderRealPointAsPhrase, renderTipBlockNo, renderTipHash,
+                   renderWithOrigin)
 import           Ouroboros.Consensus.Block (BlockProtocol, BlockSupportsProtocol, CannotForge,
                    ConvertRawHash (..), ForgeStateUpdateError, GenesisWindow (..), GetHeader (..),
-                   Header, RealPoint, blockNo, blockPoint, blockPrevHash, getHeader,
-                   pointHash, realPointHash, realPointSlot, withOriginToMaybe)
+                   Header, RealPoint, blockNo, blockPoint, blockPrevHash, getHeader, pointHash,
+                   realPointHash, realPointSlot, withOriginToMaybe)
 import           Ouroboros.Consensus.Block.SupportsSanityCheck
 import           Ouroboros.Consensus.Genesis.Governor (DensityBounds (..), GDDDebugInfo (..),
                    TraceGDDEvent (..))
@@ -79,7 +79,6 @@ import           Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), SlotNo
 import           Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..))
 import           Ouroboros.Network.Point (withOrigin)
 import           Ouroboros.Network.SizeInBytes (SizeInBytes (..))
-import           Network.TypedProtocol.Core
 
 import           Control.Monad (guard)
 import           Data.Aeson (Value (..))
@@ -92,6 +91,7 @@ import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import           Data.Word (Word32)
 import           GHC.Generics (Generic)
+import           Network.TypedProtocol.Core
 import           Numeric (showFFloat)
 
 
@@ -1420,19 +1420,18 @@ instance ( LedgerSupportsProtocol blk,
               , "ourFragment" .= toJSON ((tipToObject . tipFromHeader) `map` AF.toOldestFirst (ChainSync.Client.jOurFragment info))
               , "theirFragment" .= toJSON ((tipToObject . tipFromHeader) `map` AF.toOldestFirst (ChainSync.Client.jTheirFragment info)) ]
 
--- TODO @tweag-genesis
 instance HasPrivacyAnnotation (ChainSync.Client.TraceEvent peer) where
 instance HasSeverityAnnotation (ChainSync.Client.TraceEvent peer) where
-  getSeverityAnnotation _ = Info
-instance Show peer => Transformable Text IO (ChainSync.Client.TraceEvent peer) where
+  getSeverityAnnotation _ = Debug
+instance ToObject peer => Transformable Text IO (ChainSync.Client.TraceEvent peer) where
   trTransformer = trStructured
 
-instance Show peer => ToObject (ChainSync.Client.TraceEvent peer) where
-  toObject _verb (ChainSync.Client.RotatedDynamo fromPeer toPeer) =
+instance ToObject peer => ToObject (ChainSync.Client.TraceEvent peer) where
+  toObject verb (ChainSync.Client.RotatedDynamo oldPeer newPeer) =
     mconcat
       [ "kind" .= String "RotatedDynamo"
-      , "from" .= showT fromPeer
-      , "to" .= showT toPeer
+      , "oldPeer" .= toObject verb oldPeer
+      , "newPeer" .= toObject verb newPeer
       ]
 
 instance ConvertRawHash blk