From d2bc84eb5c3f690a51cd7ea737ae83d7256e640b Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Thu, 23 Oct 2025 17:22:06 +0200 Subject: [PATCH 1/6] Update to LSM --- cabal.project | 74 ++++- .../cardano-node-chairman.cabal | 2 +- cardano-node/cardano-node.cabal | 2 +- .../Cardano/Node/Configuration/LedgerDB.hs | 76 ++--- .../src/Cardano/Node/Configuration/POM.hs | 6 +- cardano-node/src/Cardano/Node/Run.hs | 5 +- .../src/Cardano/Node/Tracing/Era/Shelley.hs | 2 + .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 274 ++++++++++-------- .../Tracing/OrphanInstances/Consensus.hs | 27 +- .../Tracing/OrphanInstances/Shelley.hs | 2 + 10 files changed, 291 insertions(+), 179 deletions(-) diff --git a/cabal.project b/cabal.project index 010332df89b..6829b0d30ca 100644 --- a/cabal.project +++ b/cabal.project @@ -13,7 +13,7 @@ repository cardano-haskell-packages -- See CONTRIBUTING for information about these, including some Nix commands -- you need to run if you change them index-state: - , hackage.haskell.org 2025-10-17T00:26:22Z + , hackage.haskell.org 2025-10-23T13:39:53Z , cardano-haskell-packages 2025-11-07T15:42:47Z packages: @@ -61,14 +61,70 @@ package plutus-scripts-bench allow-newer: , katip:Win32 -if impl (ghc >= 9.12) - allow-newer: - -- https://github.com/kapralVV/Unique/issues/11 - , Unique:hashable - - -- https://github.com/Gabriella439/Haskell-Pipes-Safe-Library/pull/70 - , pipes-safe:base - -- IMPORTANT -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. +source-repository-package + type: git + location: https://github.com/intersectmbo/cardano-cli.git + tag: 86ccb5dae44af6f085b594a9f7b516f1e2345d28 + --sha256: sha256-sCYz2MEQ51YERL99iXN+rf0TXXz3FD13Pv+AYT/2RSo= + subdir: cardano-cli + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-api + tag: c03ca3c768e21ec2c6f5761af5007894116fd8ac + --sha256: sha256-8tcpe3UyqoEy+IUaBZ8UaWB4X5gvox+2/h3ccxxaNjs= + subdir: + cardano-api + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus + tag: d14d43e6582da900a75cb97c5c4d0292d232052f + --sha256: sha256-Zn9gnpR9JnWcs0X4xUAWgJVzmTHjTHdn7uLwKw7erwQ= + subdir: + ouroboros-consensus + ouroboros-consensus-cardano + ouroboros-consensus-diffusion + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger + tag: fb09078fa55015c881303a2ddb609c024cec258f + --sha256: sha256-9Y9CRiyMn0AWD+C4aNVMaJgrj3FDAYfCX4VrLvtoMaI= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/alonzo/test-suite + eras/babbage/impl + eras/conway/impl + eras/dijkstra/impl + eras/mary/impl + eras/shelley/impl + eras/shelley/test-suite + eras/shelley-ma/test-suite + libs/cardano-ledger-api + libs/cardano-ledger-core + libs/cardano-ledger-binary + libs/cardano-protocol-tpraos + libs/non-integral + libs/small-steps + libs/cardano-data + libs/set-algebra + libs/vector-map + eras/byron/chain/executable-spec + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/byron/crypto + +-- Backported version of https://github.com/IntersectMBO/ouroboros-network/pull/5161 +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network + tag: 1385b53cefb81e79553b6b0252537455833ea9c4 + --sha256: sha256-zZ7WsMfRs1fG16bmvI5vIh4fhQ8RGyEvYGLSWlrxpg0= + subdir: + ouroboros-network-api + ouroboros-network diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index 100bbdafcc4..a5290360c9f 100644 --- a/cardano-node-chairman/cardano-node-chairman.cabal +++ b/cardano-node-chairman/cardano-node-chairman.cabal @@ -44,7 +44,7 @@ executable cardano-node-chairman build-depends: cardano-api , cardano-crypto-class , cardano-git-rev ^>= 0.2.2 - , cardano-ledger-core ^>= 1.18 + , cardano-ledger-core ^>= 1.19 , cardano-node ^>= 10.6 , cardano-prelude , containers diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index cc1024e54dd..99ec06d1472 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -188,7 +188,7 @@ library , network-mux >= 0.8 , nothunks , optparse-applicative-fork >= 0.18.1 - , ouroboros-consensus ^>= 0.28 + , ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm} ^>= 0.28 , ouroboros-consensus-cardano ^>= 0.26 , ouroboros-consensus-diffusion ^>= 0.24 , ouroboros-consensus-protocol diff --git a/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs index f43c5029725..32ea7e9143c 100644 --- a/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs +++ b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs @@ -1,28 +1,35 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Node.Configuration.LedgerDB ( - DeprecatedOptions (..) - , LedgerDbConfiguration (..) - , LedgerDbSelectorFlag(..) - , Gigabytes - , noDeprecatedOptions - , selectorToArgs - ) where + DeprecatedOptions (..), + LedgerDbConfiguration (..), + LedgerDbSelectorFlag (..), + Gigabytes, + noDeprecatedOptions, + selectorToArgs, +) where +import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1 -import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB (LMDBLimits (..)) -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 -import Ouroboros.Consensus.Util.Args +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import qualified Data.Aeson.Types as Aeson (FromJSON) import Data.Maybe (fromMaybe) -import Data.SOP.Dict +import Data.Proxy +import System.FilePath +import System.Random (StdGen) -- | Choose the LedgerDB Backend -- @@ -34,21 +41,25 @@ import Data.SOP.Dict -- -- - 'V1LMDB': uses less memory but is somewhat slower. -- --- - 'V1InMemory': Not intended for production. It is an in-memory reproduction --- of the LMDB implementation. +-- - 'V2LSM': Uses the LSM backend. data LedgerDbSelectorFlag = V1LMDB V1.FlushFrequency -- ^ The frequency at which changes are flushed to the disk. (Maybe FilePath) - -- ^ Path for the live tables. + -- ^ Path for the live tables. If not provided the default will be used + -- (@/lmdb@). (Maybe Gigabytes) -- ^ A map size can be specified, this is the maximum disk space the LMDB -- database can fill. If not provided, the default of 16GB will be used. (Maybe Int) -- ^ An override to the max number of readers. - | V1InMemory V1.FlushFrequency | V2InMemory + | V2LSM + (Maybe FilePath) + -- ^ Maybe a custom path to the LSM database. If not provided the default + -- will be used (@/lsm@). + deriving (Eq, Show) -- | Some options that existed in the TopLevel were now moved to a @@ -118,24 +129,23 @@ toBytes (Gigabytes x) = x * 1024 * 1024 * 1024 -- * The @lmdb-simple@ and @haskell-lmdb@ forked repositories. -- * The official LMDB API documentation at -- . -defaultLMDBLimits :: LMDBLimits -defaultLMDBLimits = LMDBLimits { - lmdbMapSize = 16 * 1024 * 1024 * 1024 - , lmdbMaxDatabases = 10 - , lmdbMaxReaders = 16 +defaultLMDBLimits :: LMDB.LMDBLimits +defaultLMDBLimits = LMDB.LMDBLimits { + LMDB.lmdbMapSize = 16 * 1024 * 1024 * 1024 + , LMDB.lmdbMaxDatabases = 10 + , LMDB.lmdbMaxReaders = 16 } -defaultLMDBPath :: FilePath -defaultLMDBPath = "mainnet/db/lmdb" +defaultLMDBPath :: FilePath -> FilePath +defaultLMDBPath = ( "lmdb") -selectorToArgs :: LedgerDbSelectorFlag -> Complete LedgerDbFlavorArgs IO -selectorToArgs (V1InMemory ff) = LedgerDbFlavorArgsV1 $ V1.V1Args ff V1.InMemoryBackingStoreArgs -selectorToArgs V2InMemory = LedgerDbFlavorArgsV2 $ V2.V2Args V2.InMemoryHandleArgs -selectorToArgs (V1LMDB ff fp l mxReaders) = - LedgerDbFlavorArgsV1 - $ V1.V1Args ff - $ V1.LMDBBackingStoreArgs - (fromMaybe defaultLMDBPath fp) - (maybe id (\overrideMaxReaders lim -> lim { lmdbMaxReaders = overrideMaxReaders }) mxReaders - $ maybe id (\ll lim -> lim { lmdbMapSize = toBytes ll }) l defaultLMDBLimits) - Dict +selectorToArgs :: forall blk. (LedgerSupportsProtocol blk, LedgerSupportsLedgerDB blk) => LedgerDbSelectorFlag -> FilePath -> StdGen -> (LedgerDbBackendArgs IO blk, StdGen) +selectorToArgs V2InMemory _ = InMemory.mkInMemoryArgs +selectorToArgs (V1LMDB ff fp l mxReaders) fastStoragePath = + LMDB.mkLMDBArgs + ff + (fromMaybe (defaultLMDBPath fastStoragePath) fp) + ( maybe id (\overrideMaxReaders lim -> lim{LMDB.lmdbMaxReaders = overrideMaxReaders}) mxReaders $ + maybe id (\ll lim -> lim{LMDB.lmdbMapSize = toBytes ll}) l defaultLMDBLimits + ) +selectorToArgs (V2LSM fp) fastStoragePath = LSM.mkLSMArgs (Proxy @blk) (fromMaybe "lsm" fp) fastStoragePath diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 4255c77d775..296d94cde8d 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -466,9 +466,6 @@ instance FromJSON PartialNodeConfiguration where qsize <- (fmap RequestedQueryBatchSize <$> o .:? "QueryBatchSize") .!= DefaultQueryBatchSize backend <- o .:? "Backend" .!= "V2InMemory" selector <- case backend of - "V1InMemory" -> do - flush <- (fmap RequestedFlushFrequency <$> o .:? "FlushFrequency") .!= DefaultFlushFrequency - return $ V1InMemory flush "V1LMDB" -> do flush <- (fmap RequestedFlushFrequency <$> o .:? "FlushFrequency") .!= DefaultFlushFrequency mapSize :: Maybe Gigabytes <- o .:? "MapSize" @@ -476,6 +473,9 @@ instance FromJSON PartialNodeConfiguration where mxReaders :: Maybe Int <- o .:? "MaxReaders" return $ V1LMDB flush lmdbPath mapSize mxReaders "V2InMemory" -> return V2InMemory + "V2LSM" -> do + lsmPath :: Maybe FilePath <- o .:? "LSMDatabasePath" + pure $ V2LSM lsmPath _ -> fail $ "Malformed LedgerDB Backend: " <> backend pure $ Just $ LedgerDbConfiguration ldbSnapNum ldbSnapInterval qsize selector deprecatedOpts diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index d16f4003986..5ea0647586b 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -68,7 +68,7 @@ import Cardano.Tracing.Tracers import qualified Ouroboros.Consensus.Config as Consensus import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..)) import Ouroboros.Consensus.Node (SnapshotPolicyArgs (..), - NodeDatabasePaths (..), RunNodeArgs (..), StdRunNodeArgs (..)) + NodeDatabasePaths (..), nonImmutableDbPath, RunNodeArgs (..), StdRunNodeArgs (..)) import Ouroboros.Consensus.Protocol.Praos.AgentClient (KESAgentClientTrace) import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId) import Ouroboros.Consensus.Node (RunNodeArgs (..), @@ -79,7 +79,6 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import qualified Ouroboros.Consensus.Node.Tracers as Consensus import qualified Ouroboros.Consensus.Storage.LedgerDB.Args as LDBArgs -import Ouroboros.Consensus.Storage.LedgerDB.V2.Args import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.Orphans () @@ -560,7 +559,7 @@ handleSimpleNode blockType runP tracers nc onKernel = do , srnChainSyncIdleTimeout = customizeChainSyncTimeout , srnSnapshotPolicyArgs = snapshotPolicyArgs , srnQueryBatchSize = queryBatchSize - , srnLdbFlavorArgs = selectorToArgs ldbBackend + , srnLedgerDbBackendArgs = selectorToArgs ldbBackend (nonImmutableDbPath dbPath) } where customizeChainSyncTimeout :: ChainSyncIdleTimeout diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index 0f76c298ab1..05ad20f5e26 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -1073,6 +1073,8 @@ instance , LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" era)) ) => LogFormatting (Conway.ConwayLedgerPredFailure era) where forMachine v (Conway.ConwayUtxowFailure f) = forMachine v f + forMachine _verb (Conway.ConwayWithdrawalsMissingAccounts _) = mconcat [ "todo" .= String "todo"] + forMachine _verb (Conway.ConwayIncompleteWithdrawals _) = mconcat [ "todo" .= String "todo"] forMachine _ (Conway.ConwayTxRefScriptsSizeTooBig Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ConwayTxRefScriptsSizeTooBig" , "actual" .= mismatchSupplied diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index e41a61bdf98..579904f7db9 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -37,7 +37,10 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import qualified Ouroboros.Consensus.Storage.VolatileDB as VolDB import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.Enclose @@ -52,6 +55,10 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Word (Word64) import Numeric (showFFloat) +import Data.Void (absurd) +import Data.Typeable (cast) +import Data.Typeable (Typeable) +import Ouroboros.Consensus.Peras.SelectView -- {-# ANN module ("HLint: ignore Redundant bracket" :: Text) #-} @@ -103,6 +110,8 @@ instance ( LogFormatting (Header blk) "Chain Selection was starved." ChainDB.ChainSelStarvation (FallingEdgeWith pt) -> "Chain Selection was unstarved by " <> renderRealPoint pt + forHuman (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen + forHuman (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen forMachine _ ChainDB.TraceLastShutdownUnclean = mconcat [ "kind" .= String "LastShutdownUnclean" ] @@ -132,6 +141,9 @@ instance ( LogFormatting (Header blk) forMachine details v forMachine details (ChainDB.TraceVolatileDBEvent v) = forMachine details v + forMachine _ (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen + forMachine _ (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen + asMetrics ChainDB.TraceLastShutdownUnclean = [] asMetrics (ChainDB.TraceChainSelStarvationEvent _) = [] @@ -145,6 +157,8 @@ instance ( LogFormatting (Header blk) asMetrics (ChainDB.TraceLedgerDBEvent v) = asMetrics v asMetrics (ChainDB.TraceImmutableDBEvent v) = asMetrics v asMetrics (ChainDB.TraceVolatileDBEvent v) = asMetrics v + asMetrics (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen + asMetrics (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen instance MetaTrace (ChainDB.TraceEvent blk) where @@ -172,6 +186,8 @@ instance MetaTrace (ChainDB.TraceEvent blk) where nsPrependInner "ImmDbEvent" (namespaceFor ev) namespaceFor (ChainDB.TraceVolatileDBEvent ev) = nsPrependInner "VolatileDbEvent" (namespaceFor ev) + namespaceFor (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen + namespaceFor (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen severityFor (Namespace _ ["LastShutdownUnclean"]) _ = Just Info severityFor (Namespace _ ["ChainSelStarvationEvent"]) _ = Just Debug @@ -491,10 +507,10 @@ instance ( LogFormatting (Header blk) in mconcat $ [ "kind" .= String "AddedToCurrentChain" , "newtip" .= renderPointForDetails DDetailed (AF.headPoint extended) - , "newTipSelectView" .= forMachine DDetailed (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= forMachine DDetailed (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= forMachine DDetailed oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo] + ++ [ "oldSuffixSelectView" .= forMachine DDetailed oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] ] ++ [ "headers" .= toJSON (forMachine DDetailed `map` addedHdrsNewChain base extended) ] @@ -507,10 +523,10 @@ instance ( LogFormatting (Header blk) mconcat $ [ "kind" .= String "AddedToCurrentChain" , "newtip" .= renderPointForDetails dtal (AF.headPoint extended) - , "newTipSelectView" .= forMachine dtal (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= forMachine dtal (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= forMachine dtal oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo] + ++ [ "oldSuffixSelectView" .= forMachine dtal oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] ] ++ [ "events" .= toJSON (map (forMachine dtal) events) | not (null events) ] @@ -526,10 +542,10 @@ instance ( LogFormatting (Header blk) in mconcat $ [ "kind" .= String "TraceAddBlockEvent.SwitchedToAFork" , "newtip" .= renderPointForDetails DDetailed (AF.headPoint new) - , "newTipSelectView" .= forMachine DDetailed (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= forMachine DDetailed (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= forMachine DDetailed oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo] + ++ [ "oldSuffixSelectView" .= forMachine DDetailed oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] ] ++ [ "headers" .= toJSON (forMachine DDetailed `map` addedHdrsNewChain old new) ] @@ -542,10 +558,10 @@ instance ( LogFormatting (Header blk) mconcat $ [ "kind" .= String "TraceAddBlockEvent.SwitchedToAFork" , "newtip" .= renderPointForDetails dtal (AF.headPoint new) - , "newTipSelectView" .= forMachine dtal (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= forMachine dtal (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= forMachine dtal oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo] + ++ [ "oldSuffixSelectView" .= forMachine dtal oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] ] ++ [ "events" .= toJSON (map (forMachine dtal) events) | not (null events) ] @@ -1920,52 +1936,93 @@ instance MetaTrace LedgerDB.FlavorImplSpecificTrace where nsPrependInner "V2" (namespaceFor ev) severityFor (Namespace out ("V1" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTrace) Nothing + severityFor (Namespace out tl :: Namespace V1.SomeBackendTrace) Nothing severityFor (Namespace out ("V1" : tl)) (Just (LedgerDB.FlavorImplSpecificTraceV1 ev)) = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTrace) (Just ev) + severityFor (Namespace out tl :: Namespace V1.SomeBackendTrace) (Just ev) severityFor (Namespace out ("V2" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V2.FlavorImplSpecificTrace) Nothing + severityFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) Nothing severityFor (Namespace out ("V2" : tl)) (Just (LedgerDB.FlavorImplSpecificTraceV2 ev)) = - severityFor (Namespace out tl :: Namespace V2.FlavorImplSpecificTrace) (Just ev) + severityFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) (Just ev) severityFor _ _ = Nothing documentFor (Namespace out ("V1" : tl)) = - documentFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTrace) + documentFor (Namespace out tl :: Namespace V1.SomeBackendTrace) documentFor (Namespace out ("V2" : tl)) = - documentFor (Namespace out tl :: Namespace V2.FlavorImplSpecificTrace) + documentFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) documentFor _ = Nothing allNamespaces = map (nsPrependInner "V1") - (allNamespaces :: [Namespace V1.FlavorImplSpecificTrace]) + (allNamespaces :: [Namespace V1.SomeBackendTrace]) ++ map (nsPrependInner "V2") - (allNamespaces :: [Namespace V2.FlavorImplSpecificTrace]) + (allNamespaces :: [Namespace V2.LedgerDBV2Trace]) -------------------------------------------------------------------------------- -- V1 -------------------------------------------------------------------------------- -instance LogFormatting V1.FlavorImplSpecificTrace where - forMachine dtal (V1.FlavorImplSpecificTraceInMemory ev) = forMachine dtal ev - forMachine dtal (V1.FlavorImplSpecificTraceOnDisk ev) = forMachine dtal ev +unwrapV1Trace :: forall a backend. Typeable backend => (V1.Trace LMDB.LMDB -> a) -> V1.Trace backend -> a +unwrapV1Trace g ev = + case cast @(V1.Trace backend) @(V1.Trace LMDB.LMDB) ev of + Just t -> g t + _ -> error "blah" + +instance LogFormatting V1.SomeBackendTrace where + forMachine dtal (V1.SomeBackendTrace ev) = + unwrapV1Trace (forMachine dtal) ev + + forHuman (V1.SomeBackendTrace ev) = + unwrapV1Trace forHuman ev + +instance MetaTrace V1.SomeBackendTrace where + namespaceFor (V1.SomeBackendTrace ev) = + unwrapV1Trace (nsPrependInner "LMDB" . namespaceFor) ev + + severityFor (Namespace out ("LMDB" : tl)) (Just (V1.SomeBackendTrace ev)) = + unwrapV1Trace (severityFor (Namespace out tl :: Namespace (V1.Trace LMDB.LMDB)) . Just) ev + severityFor (Namespace _ ("LMDB" : _)) Nothing = + Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ("LMDB" : _)) = + Just "An LMDB trace" + documentFor _ = Nothing + + allNamespaces = + map (nsPrependInner "LMDB") + (allNamespaces :: [Namespace (V1.Trace LMDB.LMDB)]) - forHuman (V1.FlavorImplSpecificTraceInMemory ev) = forHuman ev - forHuman (V1.FlavorImplSpecificTraceOnDisk ev) = forHuman ev +instance LogFormatting (V1.Trace LMDB.LMDB) where + forMachine _dtal (LMDB.OnDiskBackingStoreInitialise limits) = + mconcat [ "kind" .= String "LMDBBackingStoreInitialise", "limits" .= showT limits ] + forMachine dtal (LMDB.OnDiskBackingStoreTrace ev) = forMachine dtal ev -instance LogFormatting V1.FlavorImplSpecificTraceInMemory where - forMachine _dtal V1.InMemoryBackingStoreInitialise = mempty - forMachine dtal (V1.InMemoryBackingStoreTrace ev) = forMachine dtal ev + forHuman (LMDB.OnDiskBackingStoreInitialise limits) = "Initializing LMDB backing store with limits " <> showT limits + forHuman (LMDB.OnDiskBackingStoreTrace ev) = forHuman ev - forHuman V1.InMemoryBackingStoreInitialise = "Initializing in-memory backing store" - forHuman (V1.InMemoryBackingStoreTrace ev) = forHuman ev +instance MetaTrace (V1.Trace LMDB.LMDB) where + namespaceFor LMDB.OnDiskBackingStoreInitialise{} = + Namespace [] ["Initialise"] + namespaceFor (LMDB.OnDiskBackingStoreTrace ev) = + nsPrependInner "BackingStoreEvent" (namespaceFor ev) -instance LogFormatting V1.FlavorImplSpecificTraceOnDisk where - forMachine _dtal (V1.OnDiskBackingStoreInitialise limits) = - mconcat [ "limits" .= showT limits ] - forMachine dtal (V1.OnDiskBackingStoreTrace ev) = forMachine dtal ev + severityFor (Namespace _ ("Initialise" : _)) _ = Just Debug + severityFor (Namespace out ("BackingStoreEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) Nothing + severityFor (Namespace out ("BackingStoreEvent" : tl)) (Just (LMDB.OnDiskBackingStoreTrace ev)) = + severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) (Just ev) + severityFor _ _ = Nothing + + documentFor (Namespace _ ("Initialise" : _)) = Just + "Backing store is being initialised" + documentFor (Namespace out ("BackingStoreEvent" : tl)) = + documentFor (Namespace out tl :: Namespace V1.BackingStoreTrace) + documentFor _ = Nothing - forHuman (V1.OnDiskBackingStoreInitialise limits) = "Initializing on-disk backing store with limits " <> showT limits - forHuman (V1.OnDiskBackingStoreTrace ev) = forHuman ev + allNamespaces = + Namespace [] ["Initialise"] + : map (nsPrependInner "BackingStoreEvent") + (allNamespaces :: [Namespace V1.BackingStoreTrace]) instance LogFormatting V1.BackingStoreTrace where forMachine _dtals V1.BSOpening = mempty @@ -2005,81 +2062,6 @@ instance LogFormatting V1.BackingStoreValueHandleTrace where forMachine _dtals V1.BSVHStatting = mempty forMachine _dtals V1.BSVHStatted = mempty -instance MetaTrace V1.FlavorImplSpecificTrace where - namespaceFor (V1.FlavorImplSpecificTraceInMemory ev) = - nsPrependInner "InMemory" (namespaceFor ev) - namespaceFor (V1.FlavorImplSpecificTraceOnDisk ev) = - nsPrependInner "OnDisk" (namespaceFor ev) - - severityFor (Namespace out ("InMemory" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceInMemory) Nothing - severityFor (Namespace out ("InMemory" : tl)) (Just (V1.FlavorImplSpecificTraceInMemory ev)) = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceInMemory) (Just ev) - severityFor (Namespace out ("OnDisk" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceOnDisk) Nothing - severityFor (Namespace out ("OnDisk" : tl)) (Just (V1.FlavorImplSpecificTraceOnDisk ev)) = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceOnDisk) (Just ev) - severityFor _ _ = Nothing - - documentFor (Namespace out ("InMemory" : tl)) = - documentFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceInMemory) - documentFor (Namespace out ("OnDisk" : tl)) = - documentFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceOnDisk) - documentFor _ = Nothing - - allNamespaces = - map (nsPrependInner "InMemory") - (allNamespaces :: [Namespace V1.FlavorImplSpecificTraceInMemory]) - ++ map (nsPrependInner "OnDisk") - (allNamespaces :: [Namespace V1.FlavorImplSpecificTraceOnDisk]) - -instance MetaTrace V1.FlavorImplSpecificTraceInMemory where - namespaceFor V1.InMemoryBackingStoreInitialise = Namespace [] ["Initialise"] - namespaceFor (V1.InMemoryBackingStoreTrace bsTrace) = - nsPrependInner "BackingStoreEvent" (namespaceFor bsTrace) - - severityFor (Namespace _ ("Initialise" : _)) _ = Just Debug - severityFor (Namespace out ("BackingStoreEvent" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) Nothing - severityFor (Namespace out ("BackingStoreEvent" : tl)) (Just (V1.InMemoryBackingStoreTrace ev)) = - severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) (Just ev) - severityFor _ _ = Nothing - - documentFor (Namespace _ ("Initialise" : _)) = Just - "Backing store is being initialised" - documentFor (Namespace out ("BackingStoreEvent" : tl)) = - documentFor (Namespace out tl :: Namespace V1.BackingStoreTrace) - documentFor _ = Nothing - - allNamespaces = - Namespace [] ["Initialise"] - : map (nsPrependInner "BackingStoreEvent") - (allNamespaces :: [Namespace V1.BackingStoreTrace]) - -instance MetaTrace V1.FlavorImplSpecificTraceOnDisk where - namespaceFor V1.OnDiskBackingStoreInitialise{} = - Namespace [] ["Initialise"] - namespaceFor (V1.OnDiskBackingStoreTrace ev) = - nsPrependInner "BackingStoreEvent" (namespaceFor ev) - - severityFor (Namespace _ ("Initialise" : _)) _ = Just Debug - severityFor (Namespace out ("BackingStoreEvent" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) Nothing - severityFor (Namespace out ("BackingStoreEvent" : tl)) (Just (V1.OnDiskBackingStoreTrace ev)) = - severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) (Just ev) - severityFor _ _ = Nothing - - documentFor (Namespace _ ("Initialise" : _)) = Just - "Backing store is being initialised" - documentFor (Namespace out ("BackingStoreEvent" : tl)) = - documentFor (Namespace out tl :: Namespace V1.BackingStoreTrace) - documentFor _ = Nothing - - allNamespaces = - Namespace [] ["Initialise"] - : map (nsPrependInner "BackingStoreEvent") - (allNamespaces :: [Namespace V1.BackingStoreTrace]) - instance MetaTrace V1.BackingStoreTrace where namespaceFor V1.BSOpening = Namespace [] ["Opening"] namespaceFor V1.BSOpened{} = Namespace [] ["Opened"] @@ -2238,42 +2220,87 @@ instance MetaTrace V1.BackingStoreValueHandleTrace where , Namespace [] ["Statted"] ] -instance LogFormatting V2.FlavorImplSpecificTrace where +{------------------------------------------------------------------------------- + V2 +-------------------------------------------------------------------------------} + +instance LogFormatting V2.LedgerDBV2Trace where forMachine _dtal V2.TraceLedgerTablesHandleCreate = mconcat [ "kind" .= String "LedgerTablesHandleCreate" ] forMachine _dtal V2.TraceLedgerTablesHandleClose = mconcat [ "kind" .= String "LedgerTablesHandleClose" ] + forMachine dtal (V2.BackendTrace ev) = forMachine dtal ev forHuman V2.TraceLedgerTablesHandleCreate = "Created a new 'LedgerTablesHandle', potentially by duplicating an existing one" forHuman V2.TraceLedgerTablesHandleClose = "Closed a 'LedgerTablesHandle'" + forHuman (V2.BackendTrace ev) = forHuman ev -instance MetaTrace V2.FlavorImplSpecificTrace where +instance MetaTrace V2.LedgerDBV2Trace where namespaceFor V2.TraceLedgerTablesHandleCreate = Namespace [] ["LedgerTablesHandleCreate"] namespaceFor V2.TraceLedgerTablesHandleClose = Namespace [] ["LedgerTablesHandleClose"] + namespaceFor (V2.BackendTrace ev) = nsPrependInner "BackendTrace" (namespaceFor ev) severityFor (Namespace _ ["LedgerTablesHandleCreate"]) _ = Just Debug severityFor (Namespace _ ["LedgerTablesHandleClose"]) _ = Just Debug + severityFor (Namespace _ ("BackendTrace":_)) _ = Just Debug severityFor _ _ = Nothing - -- suspicious - privacyFor (Namespace _ ["LedgerTablesHandleCreate"]) _ = Just Public - privacyFor (Namespace _ ["LedgerTablesHandleClose"]) _ = Just Public - privacyFor _ _ = Just Public - documentFor (Namespace _ ["LedgerTablesHandleCreate"]) = - Just "An in-memory backing store event" + Just "Created a ledger tables handle" documentFor (Namespace _ ["LedgerTablesHandleClose"]) = - Just "An on-disk backing store event" + Just "Closed a ledger tables handle" documentFor _ = Nothing allNamespaces = [ Namespace [] ["LedgerTablesHandleCreate"] , Namespace [] ["LedgerTablesHandleClose"] - ] + ] ++ map (nsPrependInner "BackendTrace") (allNamespaces :: [Namespace V2.SomeBackendTrace]) + +instance LogFormatting V2.SomeBackendTrace where + forMachine dtal (V2.SomeBackendTrace ev) = unwrapV2Trace (forMachine dtal) ev + + forHuman (V2.SomeBackendTrace ev) = unwrapV2Trace forHuman ev + +instance MetaTrace V2.SomeBackendTrace where + namespaceFor (V2.SomeBackendTrace ev) = + unwrapV2Trace (nsPrependInner "LSM" . namespaceFor) ev + + severityFor (Namespace _ ("LSM" : _)) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace out ("LSM" : tl)) = documentFor @(V2.Trace LSM.LSM) (Namespace out tl) + documentFor _ = Nothing + + allNamespaces = + map (nsPrependInner "LSM") (allNamespaces :: [Namespace (V2.Trace LSM.LSM)]) + +instance LogFormatting (V2.Trace LSM.LSM) where + forMachine _dtal (LSM.LSMTreeTrace ev) = mconcat [ "kind" .= String "LSMTreeTrace", "content" .= showT ev] + forHuman (LSM.LSMTreeTrace ev) = showT ev + +instance MetaTrace (V2.Trace LSM.LSM) where + namespaceFor LSM.LSMTreeTrace{} = Namespace [] ["LSMTrace"] + severityFor (Namespace _ ["LSMTrace"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["LSMTrace"]) = + Just "A trace from the LSM-trees backend" + documentFor _ = Nothing + + allNamespaces = [Namespace [] ["LSMTrace"]] + +unwrapV2Trace :: forall a backend. Typeable backend => (V2.Trace LSM.LSM -> a) -> V2.Trace backend -> a +unwrapV2Trace g ev = + case cast @(V2.Trace backend) @(V2.Trace InMemory.Mem) ev of + Just (InMemory.NoTrace v) -> absurd v + Nothing -> + case cast @(V2.Trace backend) @(V2.Trace LSM.LSM) ev of + Just t -> g t + _ -> error "blah" -------------------------------------------------------------------------------- -- ImmDB.TraceEvent @@ -2889,3 +2916,6 @@ instance (Show (PBFT.PBftVerKeyHash c)) [ "kind" .= String "PBftCannotForgeThresholdExceeded" , "numForged" .= numForged ] + +instance LogFormatting (WeightedSelectView proto) where -- TODO @amesgen + forMachine _ _ = undefined diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs index e22cf83c3b7..85145a59088 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs @@ -19,6 +19,7 @@ module Cardano.Tracing.OrphanInstances.Consensus () where +import Ouroboros.Consensus.Peras.SelectView import Cardano.Node.Tracing.Tracers.ConsensusStartupException (ConsensusStartupException (..)) import Cardano.Prelude (Typeable, maximumDef) @@ -174,7 +175,6 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where ChainDB.PoppedReprocessLoEBlocksFromQueue -> Debug ChainDB.ChainSelectionLoEDebug _ _ -> Debug - getSeverityAnnotation (ChainDB.TraceLedgerDBEvent ev) = case ev of LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of LedgerDB.TookSnapshot {} -> Info @@ -252,6 +252,9 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where getSeverityAnnotation ChainDB.TraceChainSelStarvationEvent{} = Debug + getSeverityAnnotation (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen + getSeverityAnnotation (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen + instance HasSeverityAnnotation (LedgerEvent blk) where getSeverityAnnotation (LedgerUpdate _) = Notice getSeverityAnnotation (LedgerWarning _) = Critical @@ -785,10 +788,14 @@ instance ( ConvertRawHash blk ChainDB.TraceChainSelStarvationEvent ev -> case ev of ChainDB.ChainSelStarvation RisingEdge -> "Chain Selection was starved." ChainDB.ChainSelStarvation (FallingEdgeWith pt) -> "Chain Selection was unstarved by " <> renderRealPoint pt + ChainDB.TracePerasCertDbEvent _ -> undefined -- TODO @amesgen + ChainDB.TraceAddPerasCertEvent _ -> undefined -- TODO @amesgen where showProgressT :: Int -> Int -> Text showProgressT chunkNo outOf = pack (showFFloat (Just 2) (100 * fromIntegral chunkNo / fromIntegral outOf :: Float) mempty) + + -- -- | instances of @ToObject@ -- @@ -971,10 +978,10 @@ instance ( ConvertRawHash blk [ "kind" .= String "TraceAddBlockEvent.AddedToCurrentChain" , "newtip" .= renderPointForVerbosity verb (AF.headPoint extended) , "chainLengthDelta" .= extended `chainLengthΔ` base - , "newTipSelectView" .= toObject verb (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= toObject verb (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= toObject verb oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo] + ++ [ "oldSuffixSelectView" .= toObject verb oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] ] ++ [ "headers" .= toJSON (toObject verb `map` addedHdrsNewChain base extended) | verb == MaximalVerbosity ] @@ -987,10 +994,10 @@ instance ( ConvertRawHash blk , "chainLengthDelta" .= new `chainLengthΔ` old -- Check that the SwitchedToAFork event was triggered by a proper fork. , "realFork" .= not (AF.withinFragmentBounds (AF.headPoint old) new) - , "newTipSelectView" .= toObject verb (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= toObject verb (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= toObject verb oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo] + ++ [ "oldSuffixSelectView" .= toObject verb oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] ] ++ [ "headers" .= toJSON (toObject verb `map` addedHdrsNewChain old new) | verb == MaximalVerbosity ] @@ -1065,6 +1072,9 @@ instance ( ConvertRawHash blk chainLengthΔ :: AF.AnchoredFragment (Header blk) -> AF.AnchoredFragment (Header blk) -> Int chainLengthΔ = on (-) (fromWithOrigin (-1) . fmap (fromIntegral . unBlockNo) . AF.headBlockNo) + toObject _verb (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen + toObject _verb (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen + toObject MinimalVerbosity (ChainDB.TraceLedgerDBEvent _ev) = mempty -- no output toObject verb (ChainDB.TraceLedgerDBEvent ev) = case ev of LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of @@ -1457,6 +1467,9 @@ instance ( LedgerSupportsProtocol blk, , "theirFragment" .= toJSON ((tipToObject . tipFromHeader) `map` AF.toOldestFirst (ChainSync.Client.jTheirFragment info)) ] +instance ToObject (WeightedSelectView proto) where -- TODO @amesgen + toObject _ _ = undefined + instance HasPrivacyAnnotation (ChainSync.Client.TraceEventCsj peer blk) where instance HasSeverityAnnotation (ChainSync.Client.TraceEventCsj peer blk) where getSeverityAnnotation _ = Debug diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index d8645b49170..20d492b083e 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -334,6 +334,8 @@ instance , ToObject (PredicateFailure (Core.EraRule "GOV" ledgerera)) ) => ToObject (Conway.ConwayLedgerPredFailure ledgerera) where toObject verb (Conway.ConwayUtxowFailure f) = toObject verb f + toObject _verb (Conway.ConwayWithdrawalsMissingAccounts _) = mconcat [ "todo" .= String "todo"] + toObject _verb (Conway.ConwayIncompleteWithdrawals _) = mconcat [ "todo" .= String "todo"] toObject _ (Conway.ConwayTxRefScriptsSizeTooBig Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ConwayTxRefScriptsSizeTooBig" , "actual" .= mismatchSupplied From a245119adde5b995f9615b821c5fbf7e290508c7 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 24 Oct 2025 15:28:16 +0200 Subject: [PATCH 2/6] Stealing tracers from #6333 --- .../src/Cardano/Node/TraceConstraints.hs | 5 +- .../src/Cardano/Node/Tracing/Era/HardFork.hs | 12 +- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 246 ++++++++++++++++-- .../Cardano/Node/Tracing/Tracers/Consensus.hs | 1 - .../Tracing/OrphanInstances/Consensus.hs | 25 +- .../Tracing/OrphanInstances/HardFork.hs | 12 +- cardano-node/src/Cardano/Tracing/Tracers.hs | 7 +- 7 files changed, 266 insertions(+), 42 deletions(-) diff --git a/cardano-node/src/Cardano/Node/TraceConstraints.hs b/cardano-node/src/Cardano/Node/TraceConstraints.hs index ec4b9f61034..9ba6e7ef726 100644 --- a/cardano-node/src/Cardano/Node/TraceConstraints.hs +++ b/cardano-node/src/Cardano/Node/TraceConstraints.hs @@ -23,6 +23,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, HasTxId import Ouroboros.Consensus.Node.NetworkProtocolVersion (HasNetworkProtocolVersion (BlockNodeToClientVersion, BlockNodeToNodeVersion)) import Ouroboros.Consensus.Node.Run (RunNode, SerialiseNodeToNodeConstraints) +import Ouroboros.Consensus.Peras.SelectView import Ouroboros.Consensus.Protocol.Abstract (SelectView, ValidationErr) import Ouroboros.Consensus.Shelley.Ledger.Mempool (GenTx, TxId) import Ouroboros.Network.Block (Serialised) @@ -51,7 +52,7 @@ type TraceConstraints blk = , ToObject (LedgerError blk) , ToObject (LedgerEvent blk) , ToObject (OtherHeaderEnvelopeError blk) - , ToObject (SelectView (BlockProtocol blk)) + , ToObject (WeightedSelectView (BlockProtocol blk)) , ToObject (ValidationErr (BlockProtocol blk)) , ToObject (CannotForge blk) , ToObject (ForgeStateUpdateError blk) @@ -66,7 +67,7 @@ type TraceConstraints blk = , LogFormatting (LedgerUpdate blk) , LogFormatting (LedgerWarning blk) , LogFormatting (OtherHeaderEnvelopeError blk) - , LogFormatting (SelectView (BlockProtocol blk)) + , LogFormatting (WeightedSelectView (BlockProtocol blk)) , LogFormatting (ValidationErr (BlockProtocol blk)) , LogFormatting (CannotForge blk) , LogFormatting (ForgeStateUpdateError blk) diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs b/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs index 7e528ba3c2f..aebc3a1f721 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs @@ -19,7 +19,7 @@ import Cardano.Logging import Cardano.Slotting.Slot (EpochSize (..)) import Cardano.Tracing.OrphanInstances.HardFork () import Ouroboros.Consensus.Block (BlockProtocol, CannotForge, ForgeStateInfo, - ForgeStateUpdateError) + ForgeStateUpdateError, PerasWeight (..)) import Ouroboros.Consensus.BlockchainTime (getSlotLength) import Ouroboros.Consensus.Cardano.Condense () import Ouroboros.Consensus.HardFork.Combinator @@ -36,7 +36,8 @@ import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError) import Ouroboros.Consensus.Ledger.Abstract (LedgerError) import Ouroboros.Consensus.Ledger.Inspect (LedgerUpdate, LedgerWarning) import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr) -import Ouroboros.Consensus.Protocol.Abstract (ValidationErr, TiebreakerView, SelectView(..)) +import Ouroboros.Consensus.Peras.SelectView +import Ouroboros.Consensus.Protocol.Abstract (TiebreakerView, ValidationErr) import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Condense (Condense (..)) @@ -352,10 +353,11 @@ instance LogFormatting (ForgeStateUpdateError blk) => LogFormatting (WrapForgeSt instance All (LogFormatting `Compose` WrapTiebreakerView) xs => LogFormatting (HardForkTiebreakerView xs) where forMachine dtal = forMachine dtal . getHardForkTiebreakerView -instance LogFormatting (TiebreakerView protocol) => LogFormatting (SelectView protocol) where +instance LogFormatting (TiebreakerView protocol) => LogFormatting (WeightedSelectView protocol) where forMachine dtal sv = mconcat - [ "blockNo" .= svBlockNo sv - , forMachine dtal (svTiebreakerView sv) + [ "blockNo" .= wsvBlockNo sv + , "weightBoost" .= unPerasWeight (wsvWeightBoost sv) + , forMachine dtal (wsvTiebreaker sv) ] instance All (LogFormatting `Compose` WrapTiebreakerView) xs => LogFormatting (OneEraTiebreakerView xs) where diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 579904f7db9..537d23e1eca 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -28,7 +28,7 @@ import Ouroboros.Consensus.Ledger.Abstract (LedgerError) import Ouroboros.Consensus.Ledger.Extended (ExtValidationError (..)) import Ouroboros.Consensus.Ledger.Inspect (InspectLedger, LedgerEvent (..)) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) -import Ouroboros.Consensus.Protocol.Abstract (SelectView, ValidationErr) +import Ouroboros.Consensus.Protocol.Abstract (ValidationErr) import qualified Ouroboros.Consensus.Protocol.PBFT as PBFT import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmDB @@ -41,6 +41,7 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM +import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolDB import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.Enclose @@ -56,8 +57,7 @@ import qualified Data.Text.Encoding as Text import Data.Word (Word64) import Numeric (showFFloat) import Data.Void (absurd) -import Data.Typeable (cast) -import Data.Typeable (Typeable) +import Data.Typeable (Typeable, cast) import Ouroboros.Consensus.Peras.SelectView -- {-# ANN module ("HLint: ignore Redundant bracket" :: Text) #-} @@ -86,7 +86,7 @@ withAddedToCurrentChainEmptyLimited tr = do instance ( LogFormatting (Header blk) , LogFormatting (LedgerEvent blk) , LogFormatting (RealPoint blk) - , LogFormatting (SelectView (BlockProtocol blk)) + , LogFormatting (WeightedSelectView (BlockProtocol blk)) , ConvertRawHash blk , ConvertRawHash (Header blk) , LedgerSupportsProtocol blk @@ -110,8 +110,8 @@ instance ( LogFormatting (Header blk) "Chain Selection was starved." ChainDB.ChainSelStarvation (FallingEdgeWith pt) -> "Chain Selection was unstarved by " <> renderRealPoint pt - forHuman (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen - forHuman (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen + forHuman (ChainDB.TracePerasCertDbEvent ev) = forHuman ev + forHuman (ChainDB.TraceAddPerasCertEvent ev) = forHuman ev forMachine _ ChainDB.TraceLastShutdownUnclean = mconcat [ "kind" .= String "LastShutdownUnclean" ] @@ -141,8 +141,10 @@ instance ( LogFormatting (Header blk) forMachine details v forMachine details (ChainDB.TraceVolatileDBEvent v) = forMachine details v - forMachine _ (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen - forMachine _ (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen + forMachine details (ChainDB.TracePerasCertDbEvent v) = + forMachine details v + forMachine details (ChainDB.TraceAddPerasCertEvent v) = + forMachine details v asMetrics ChainDB.TraceLastShutdownUnclean = [] @@ -157,8 +159,8 @@ instance ( LogFormatting (Header blk) asMetrics (ChainDB.TraceLedgerDBEvent v) = asMetrics v asMetrics (ChainDB.TraceImmutableDBEvent v) = asMetrics v asMetrics (ChainDB.TraceVolatileDBEvent v) = asMetrics v - asMetrics (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen - asMetrics (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen + asMetrics (ChainDB.TracePerasCertDbEvent v) = asMetrics v + asMetrics (ChainDB.TraceAddPerasCertEvent v) = asMetrics v instance MetaTrace (ChainDB.TraceEvent blk) where @@ -186,8 +188,10 @@ instance MetaTrace (ChainDB.TraceEvent blk) where nsPrependInner "ImmDbEvent" (namespaceFor ev) namespaceFor (ChainDB.TraceVolatileDBEvent ev) = nsPrependInner "VolatileDbEvent" (namespaceFor ev) - namespaceFor (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen - namespaceFor (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen + namespaceFor (ChainDB.TracePerasCertDbEvent ev) = + nsPrependInner "PerasCertDbEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceAddPerasCertEvent ev) = + nsPrependInner "AddPerasCertEvent" (namespaceFor ev) severityFor (Namespace _ ["LastShutdownUnclean"]) _ = Just Info severityFor (Namespace _ ["ChainSelStarvationEvent"]) _ = Just Debug @@ -231,6 +235,14 @@ instance MetaTrace (ChainDB.TraceEvent blk) where severityFor (Namespace out tl) (Just ev') severityFor (Namespace out ("VolatileDbEvent" : tl)) Nothing = severityFor (Namespace out tl :: Namespace (VolDB.TraceEvent blk)) Nothing + severityFor (Namespace out ("PerasCertDbEvent" : tl)) (Just (ChainDB.TracePerasCertDbEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("PerasCertDbEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) Nothing + severityFor (Namespace out ("AddPerasCertEvent" : tl)) (Just (ChainDB.TraceAddPerasCertEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("AddPerasCertEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) Nothing severityFor _ns _ = Nothing privacyFor (Namespace _ ["LastShutdownUnclean"]) _ = Just Public @@ -275,6 +287,14 @@ instance MetaTrace (ChainDB.TraceEvent blk) where privacyFor (Namespace out tl) (Just ev') privacyFor (Namespace out ("VolatileDbEvent" : tl)) Nothing = privacyFor (Namespace out tl :: Namespace (VolDB.TraceEvent blk)) Nothing + privacyFor (Namespace out ("PerasCertDbEvent" : tl)) (Just (ChainDB.TracePerasCertDbEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("PerasCertDbEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) Nothing + privacyFor (Namespace out ("AddPerasCertEvent" : tl)) (Just (ChainDB.TraceAddPerasCertEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("AddPerasCertEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) Nothing privacyFor _ _ = Nothing detailsFor (Namespace _ ["LastShutdownUnclean"]) _ = Just DNormal @@ -319,6 +339,14 @@ instance MetaTrace (ChainDB.TraceEvent blk) where detailsFor (Namespace out tl) (Just ev') detailsFor (Namespace out ("VolatileDbEvent" : tl)) Nothing = detailsFor (Namespace out tl :: (Namespace (VolDB.TraceEvent blk))) Nothing + detailsFor (Namespace out ("PerasCertDbEvent" : tl)) (Just (ChainDB.TracePerasCertDbEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("PerasCertDbEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) Nothing + detailsFor (Namespace out ("AddPerasCertEvent" : tl)) (Just (ChainDB.TraceAddPerasCertEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("AddPerasCertEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) Nothing detailsFor _ _ = Nothing metricsDocFor (Namespace out ("AddBlockEvent" : tl)) = @@ -372,6 +400,10 @@ instance MetaTrace (ChainDB.TraceEvent blk) where documentFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) documentFor (Namespace out ("VolatileDbEvent" : tl)) = documentFor (Namespace out tl :: Namespace (VolDB.TraceEvent blk)) + documentFor (Namespace out ("PerasCertDbEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) + documentFor (Namespace out ("AddPerasCertEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) documentFor _ = Nothing allNamespaces = @@ -397,6 +429,10 @@ instance MetaTrace (ChainDB.TraceEvent blk) where (allNamespaces :: [Namespace (ImmDB.TraceEvent blk)]) ++ map (nsPrependInner "VolatileDbEvent") (allNamespaces :: [Namespace (VolDB.TraceEvent blk)]) + ++ map (nsPrependInner "PerasCertDbEvent") + (allNamespaces :: [Namespace (PerasCertDB.TraceEvent blk)]) + ++ map (nsPrependInner "AddPerasCertEvent") + (allNamespaces :: [Namespace (ChainDB.TraceAddPerasCertEvent blk)]) ) @@ -408,7 +444,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where instance ( LogFormatting (Header blk) , LogFormatting (LedgerEvent blk) , LogFormatting (RealPoint blk) - , LogFormatting (SelectView (BlockProtocol blk)) + , LogFormatting (WeightedSelectView (BlockProtocol blk)) , ConvertRawHash blk , ConvertRawHash (Header blk) , LedgerSupportsProtocol blk @@ -2917,5 +2953,185 @@ instance (Show (PBFT.PBftVerKeyHash c)) , "numForged" .= numForged ] -instance LogFormatting (WeightedSelectView proto) where -- TODO @amesgen - forMachine _ _ = undefined +-- PerasCertDB.TraceEvent instances +instance LogFormatting (PerasCertDB.TraceEvent blk) where + forHuman (PerasCertDB.AddedPerasCert _cert _peer) = "Added Peras certificate to database" + forHuman (PerasCertDB.IgnoredCertAlreadyInDB _cert _peer) = "Ignored Peras certificate already in database" + forHuman PerasCertDB.OpenedPerasCertDB = "Opened Peras certificate database" + forHuman PerasCertDB.ClosedPerasCertDB = "Closed Peras certificate database" + forHuman (PerasCertDB.AddingPerasCert _cert _peer) = "Adding Peras certificate to database" + + forMachine _dtal (PerasCertDB.AddedPerasCert cert _peer) = + mconcat ["kind" .= String "AddedPerasCert", + "cert" .= String (Text.pack $ show cert)] + forMachine _dtal (PerasCertDB.IgnoredCertAlreadyInDB cert _peer) = + mconcat ["kind" .= String "IgnoredCertAlreadyInDB", + "cert" .= String (Text.pack $ show cert)] + forMachine _dtal PerasCertDB.OpenedPerasCertDB = + mconcat ["kind" .= String "OpenedPerasCertDB"] + forMachine _dtal PerasCertDB.ClosedPerasCertDB = + mconcat ["kind" .= String "ClosedPerasCertDB"] + forMachine _dtal (PerasCertDB.AddingPerasCert cert _peer) = + mconcat ["kind" .= String "AddingPerasCert", + "cert" .= String (Text.pack $ show cert)] + + asMetrics _ = [] + +-- ChainDB.TraceAddPerasCertEvent instances +instance ConvertRawHash blk => LogFormatting (ChainDB.TraceAddPerasCertEvent blk) where + forHuman (ChainDB.AddedPerasCertToQueue roundNo boostedBlock _queueSize) = + "Added Peras certificate for round " <> Text.pack (show roundNo) <> + " boosting block " <> renderPoint boostedBlock <> " to queue" + forHuman (ChainDB.PoppedPerasCertFromQueue roundNo boostedBlock) = + "Popped Peras certificate for round " <> Text.pack (show roundNo) <> + " boosting block " <> renderPoint boostedBlock <> " from queue" + forHuman (ChainDB.IgnorePerasCertTooOld roundNo boostedBlock immutableSlot) = + "Ignored Peras certificate for round " <> Text.pack (show roundNo) <> + " boosting block " <> renderPoint boostedBlock <> + " (too old, immutable slot: " <> renderPoint (AF.anchorToPoint immutableSlot) <> ")" + forHuman (ChainDB.PerasCertBoostsCurrentChain roundNo boostedBlock) = + "Peras certificate for round " <> Text.pack (show roundNo) <> + " boosts current chain block " <> renderPoint boostedBlock + forHuman (ChainDB.PerasCertBoostsGenesis roundNo) = + "Peras certificate for round " <> Text.pack (show roundNo) <> " boosts Genesis" + forHuman (ChainDB.PerasCertBoostsBlockNotYetReceived roundNo boostedBlock) = + "Peras certificate for round " <> Text.pack (show roundNo) <> + " boosts block " <> renderPoint boostedBlock <> " not yet received" + forHuman (ChainDB.ChainSelectionForBoostedBlock roundNo boostedBlock) = + "Chain selection for block " <> renderPoint boostedBlock <> + " boosted by Peras certificate from round " <> Text.pack (show roundNo) + + forMachine _dtal (ChainDB.AddedPerasCertToQueue roundNo boostedBlock queueSize) = + mconcat ["kind" .= String "AddedPerasCertToQueue", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock), + "queueSize" .= toJSON queueSize] + forMachine _dtal (ChainDB.PoppedPerasCertFromQueue roundNo boostedBlock) = + mconcat ["kind" .= String "PoppedPerasCertFromQueue", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock)] + forMachine _dtal (ChainDB.IgnorePerasCertTooOld roundNo boostedBlock immutableSlot) = + mconcat ["kind" .= String "IgnorePerasCertTooOld", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock), + "immutableSlot" .= String (renderPoint (AF.anchorToPoint immutableSlot))] + forMachine _dtal (ChainDB.PerasCertBoostsCurrentChain roundNo boostedBlock) = + mconcat ["kind" .= String "PerasCertBoostsCurrentChain", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock)] + forMachine _dtal (ChainDB.PerasCertBoostsGenesis roundNo) = + mconcat ["kind" .= String "PerasCertBoostsGenesis", + "round" .= String (Text.pack $ show roundNo)] + forMachine _dtal (ChainDB.PerasCertBoostsBlockNotYetReceived roundNo boostedBlock) = + mconcat ["kind" .= String "PerasCertBoostsBlockNotYetReceived", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock)] + forMachine _dtal (ChainDB.ChainSelectionForBoostedBlock roundNo boostedBlock) = + mconcat ["kind" .= String "ChainSelectionForBoostedBlock", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock)] + + asMetrics _ = [] + +-- PerasCertDB.TraceEvent MetaTrace instance +instance MetaTrace (PerasCertDB.TraceEvent blk) where + namespaceFor (PerasCertDB.AddedPerasCert _ _) = + Namespace [] ["AddedPerasCert"] + namespaceFor (PerasCertDB.IgnoredCertAlreadyInDB _ _) = + Namespace [] ["IgnoredCertAlreadyInDB"] + namespaceFor PerasCertDB.OpenedPerasCertDB = + Namespace [] ["OpenedPerasCertDB"] + namespaceFor PerasCertDB.ClosedPerasCertDB = + Namespace [] ["ClosedPerasCertDB"] + namespaceFor (PerasCertDB.AddingPerasCert _ _) = + Namespace [] ["AddingPerasCert"] + + severityFor (Namespace _ ["AddedPerasCert"]) _ = Just Info + severityFor (Namespace _ ["IgnoredCertAlreadyInDB"]) _ = Just Info + severityFor (Namespace _ ["OpenedPerasCertDB"]) _ = Just Info + severityFor (Namespace _ ["ClosedPerasCertDB"]) _ = Just Info + severityFor (Namespace _ ["AddingPerasCert"]) _ = Just Debug + severityFor _ _ = Nothing + + privacyFor (Namespace _ ["AddedPerasCert"]) _ = Just Public + privacyFor (Namespace _ ["IgnoredCertAlreadyInDB"]) _ = Just Public + privacyFor (Namespace _ ["OpenedPerasCertDB"]) _ = Just Public + privacyFor (Namespace _ ["ClosedPerasCertDB"]) _ = Just Public + privacyFor (Namespace _ ["AddingPerasCert"]) _ = Just Public + privacyFor _ _ = Nothing + + detailsFor (Namespace _ ["AddedPerasCert"]) _ = Just DNormal + detailsFor (Namespace _ ["IgnoredCertAlreadyInDB"]) _ = Just DNormal + detailsFor (Namespace _ ["OpenedPerasCertDB"]) _ = Just DNormal + detailsFor (Namespace _ ["ClosedPerasCertDB"]) _ = Just DNormal + detailsFor (Namespace _ ["AddingPerasCert"]) _ = Just DDetailed + detailsFor _ _ = Nothing + + documentFor (Namespace _ ["AddedPerasCert"]) = Just "Certificate added to Peras certificate database" + documentFor (Namespace _ ["IgnoredCertAlreadyInDB"]) = Just "Certificate ignored as it was already in the database" + documentFor (Namespace _ ["OpenedPerasCertDB"]) = Just "Peras certificate database opened" + documentFor (Namespace _ ["ClosedPerasCertDB"]) = Just "Peras certificate database closed" + documentFor (Namespace _ ["AddingPerasCert"]) = Just "Adding certificate to Peras certificate database" + documentFor _ = Nothing + + allNamespaces = + [Namespace [] ["AddedPerasCert"], + Namespace [] ["IgnoredCertAlreadyInDB"], + Namespace [] ["OpenedPerasCertDB"], + Namespace [] ["ClosedPerasCertDB"], + Namespace [] ["AddingPerasCert"]] + +-- ChainDB.TraceAddPerasCertEvent MetaTrace instance +instance MetaTrace (ChainDB.TraceAddPerasCertEvent blk) where + namespaceFor ChainDB.AddedPerasCertToQueue{} = Namespace [] ["AddedPerasCertToQueue"] + namespaceFor (ChainDB.PoppedPerasCertFromQueue _ _) = Namespace [] ["PoppedPerasCertFromQueue"] + namespaceFor ChainDB.IgnorePerasCertTooOld{} = Namespace [] ["IgnorePerasCertTooOld"] + namespaceFor (ChainDB.PerasCertBoostsCurrentChain _ _) = Namespace [] ["PerasCertBoostsCurrentChain"] + namespaceFor (ChainDB.PerasCertBoostsGenesis _) = Namespace [] ["PerasCertBoostsGenesis"] + namespaceFor (ChainDB.PerasCertBoostsBlockNotYetReceived _ _) = Namespace [] ["PerasCertBoostsBlockNotYetReceived"] + namespaceFor (ChainDB.ChainSelectionForBoostedBlock _ _) = Namespace [] ["ChainSelectionForBoostedBlock"] + + severityFor (Namespace _ ["AddedPerasCertToQueue"]) _ = Just Debug + severityFor (Namespace _ ["PoppedPerasCertFromQueue"]) _ = Just Debug + severityFor (Namespace _ ["IgnorePerasCertTooOld"]) _ = Just Info + severityFor (Namespace _ ["PerasCertBoostsCurrentChain"]) _ = Just Info + severityFor (Namespace _ ["PerasCertBoostsGenesis"]) _ = Just Info + severityFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) _ = Just Info + severityFor (Namespace _ ["ChainSelectionForBoostedBlock"]) _ = Just Info + severityFor _ _ = Nothing + + privacyFor (Namespace _ ["AddedPerasCertToQueue"]) _ = Just Public + privacyFor (Namespace _ ["PoppedPerasCertFromQueue"]) _ = Just Public + privacyFor (Namespace _ ["IgnorePerasCertTooOld"]) _ = Just Public + privacyFor (Namespace _ ["PerasCertBoostsCurrentChain"]) _ = Just Public + privacyFor (Namespace _ ["PerasCertBoostsGenesis"]) _ = Just Public + privacyFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) _ = Just Public + privacyFor (Namespace _ ["ChainSelectionForBoostedBlock"]) _ = Just Public + privacyFor _ _ = Nothing + + detailsFor (Namespace _ ["AddedPerasCertToQueue"]) _ = Just DDetailed + detailsFor (Namespace _ ["PoppedPerasCertFromQueue"]) _ = Just DDetailed + detailsFor (Namespace _ ["IgnorePerasCertTooOld"]) _ = Just DNormal + detailsFor (Namespace _ ["PerasCertBoostsCurrentChain"]) _ = Just DNormal + detailsFor (Namespace _ ["PerasCertBoostsGenesis"]) _ = Just DNormal + detailsFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) _ = Just DNormal + detailsFor (Namespace _ ["ChainSelectionForBoostedBlock"]) _ = Just DNormal + detailsFor _ _ = Nothing + + documentFor (Namespace _ ["AddedPerasCertToQueue"]) = Just "Peras certificate added to processing queue" + documentFor (Namespace _ ["PoppedPerasCertFromQueue"]) = Just "Peras certificate popped from processing queue" + documentFor (Namespace _ ["IgnorePerasCertTooOld"]) = Just "Peras certificate ignored as it is too old compared to immutable slot" + documentFor (Namespace _ ["PerasCertBoostsCurrentChain"]) = Just "Peras certificate boosts a block on the current selection" + documentFor (Namespace _ ["PerasCertBoostsGenesis"]) = Just "Peras certificate boosts the Genesis point" + documentFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) = Just "Peras certificate boosts a block not yet received" + documentFor (Namespace _ ["ChainSelectionForBoostedBlock"]) = Just "Perform chain selection for block boosted by Peras certificate" + documentFor _ = Nothing + + allNamespaces = + [Namespace [] ["AddedPerasCertToQueue"], + Namespace [] ["PoppedPerasCertFromQueue"], + Namespace [] ["IgnorePerasCertTooOld"], + Namespace [] ["PerasCertBoostsCurrentChain"], + Namespace [] ["PerasCertBoostsGenesis"], + Namespace [] ["PerasCertBoostsBlockNotYetReceived"], + Namespace [] ["ChainSelectionForBoostedBlock"]] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 5d76470c82a..c25ec4677d3 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -83,7 +83,6 @@ import Data.Time (NominalDiffTime) import Data.Word (Word32, Word64) import Network.TypedProtocol.Core - instance (LogFormatting adr, Show adr) => LogFormatting (ConnectionId adr) where forMachine _dtal (ConnectionId local' remote) = mconcat [ "connectionId" .= String (showT local' diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs index 85145a59088..1e810273c7e 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs @@ -252,8 +252,8 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where getSeverityAnnotation ChainDB.TraceChainSelStarvationEvent{} = Debug - getSeverityAnnotation (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen - getSeverityAnnotation (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen + getSeverityAnnotation ChainDB.TracePerasCertDbEvent{} = Info + getSeverityAnnotation ChainDB.TraceAddPerasCertEvent{} = Info instance HasSeverityAnnotation (LedgerEvent blk) where getSeverityAnnotation (LedgerUpdate _) = Notice @@ -523,7 +523,7 @@ instance ( ConvertRawHash blk , InspectLedger blk , ToObject (Header blk) , ToObject (LedgerEvent blk) - , ToObject (SelectView (BlockProtocol blk))) + , ToObject (WeightedSelectView (BlockProtocol blk))) => Transformable Text IO (ChainDB.TraceEvent blk) where trTransformer = trStructuredText @@ -788,8 +788,8 @@ instance ( ConvertRawHash blk ChainDB.TraceChainSelStarvationEvent ev -> case ev of ChainDB.ChainSelStarvation RisingEdge -> "Chain Selection was starved." ChainDB.ChainSelStarvation (FallingEdgeWith pt) -> "Chain Selection was unstarved by " <> renderRealPoint pt - ChainDB.TracePerasCertDbEvent _ -> undefined -- TODO @amesgen - ChainDB.TraceAddPerasCertEvent _ -> undefined -- TODO @amesgen + ChainDB.TracePerasCertDbEvent ev -> showT ev + ChainDB.TraceAddPerasCertEvent ev -> showT ev where showProgressT :: Int -> Int -> Text showProgressT chunkNo outOf = pack (showFFloat (Just 2) (100 * fromIntegral chunkNo / fromIntegral outOf :: Float) mempty) @@ -933,7 +933,7 @@ instance ( ConvertRawHash blk , LedgerSupportsProtocol blk , ToObject (Header blk) , ToObject (LedgerEvent blk) - , ToObject (SelectView (BlockProtocol blk))) + , ToObject (WeightedSelectView (BlockProtocol blk))) => ToObject (ChainDB.TraceEvent blk) where toObject _verb ChainDB.TraceLastShutdownUnclean = mconcat [ "kind" .= String "TraceLastShutdownUnclean" ] @@ -1072,8 +1072,14 @@ instance ( ConvertRawHash blk chainLengthΔ :: AF.AnchoredFragment (Header blk) -> AF.AnchoredFragment (Header blk) -> Int chainLengthΔ = on (-) (fromWithOrigin (-1) . fmap (fromIntegral . unBlockNo) . AF.headBlockNo) - toObject _verb (ChainDB.TracePerasCertDbEvent _) = undefined -- TODO @amesgen - toObject _verb (ChainDB.TraceAddPerasCertEvent _) = undefined -- TODO @amesgen + toObject _verb (ChainDB.TracePerasCertDbEvent ev) = + mconcat [ "kind" .= String "TracePerasCertDbEvent" + , "event" .= show ev + ] + toObject _verb (ChainDB.TraceAddPerasCertEvent ev) = + mconcat [ "kind" .= String "TraceAddPerasCertEvent" + , "event" .= show ev + ] toObject MinimalVerbosity (ChainDB.TraceLedgerDBEvent _ev) = mempty -- no output toObject verb (ChainDB.TraceLedgerDBEvent ev) = case ev of @@ -1467,9 +1473,6 @@ instance ( LedgerSupportsProtocol blk, , "theirFragment" .= toJSON ((tipToObject . tipFromHeader) `map` AF.toOldestFirst (ChainSync.Client.jTheirFragment info)) ] -instance ToObject (WeightedSelectView proto) where -- TODO @amesgen - toObject _ _ = undefined - instance HasPrivacyAnnotation (ChainSync.Client.TraceEventCsj peer blk) where instance HasSeverityAnnotation (ChainSync.Client.TraceEventCsj peer blk) where getSeverityAnnotation _ = Debug diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs index 8c75604c5cb..1736b04f68c 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs @@ -22,7 +22,7 @@ import Cardano.Slotting.Slot (EpochSize (..)) import Cardano.Tracing.OrphanInstances.Common import Cardano.Tracing.OrphanInstances.Consensus () import Ouroboros.Consensus.Block (BlockProtocol, CannotForge, ForgeStateInfo, - ForgeStateUpdateError) + ForgeStateUpdateError, PerasWeight (..)) import Ouroboros.Consensus.BlockchainTime (getSlotLength) import Ouroboros.Consensus.Cardano.Condense () import Ouroboros.Consensus.HardFork.Combinator @@ -43,7 +43,7 @@ import Ouroboros.Consensus.Ledger.Inspect (LedgerUpdate, LedgerWarning import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr) import Ouroboros.Consensus.Node.NetworkProtocolVersion (BlockNodeToClientVersion, BlockNodeToNodeVersion) -import Ouroboros.Consensus.Protocol.Abstract (ValidationErr, SelectView (svTiebreakerView, svBlockNo), ConsensusProtocol (TiebreakerView)) +import Ouroboros.Consensus.Protocol.Abstract (ValidationErr, ConsensusProtocol (TiebreakerView)) import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Condense (Condense (..)) @@ -53,6 +53,7 @@ import qualified Data.ByteString.Short as SBS import Data.Proxy (Proxy (..)) import Data.SOP (All, Compose, K (..)) import Data.SOP.Strict +import Ouroboros.Consensus.Peras.SelectView -- @@ -434,10 +435,11 @@ instance (ToJSON (BlockNodeToNodeVersion blk)) => ToJSON (WrapNodeToNodeVersion instance All (ToObject `Compose` WrapTiebreakerView) xs => ToObject (HardForkTiebreakerView xs) where toObject verb = toObject verb . getHardForkTiebreakerView -instance ToObject (TiebreakerView protocol) => ToObject (SelectView protocol) where +instance ToObject (TiebreakerView protocol) => ToObject (WeightedSelectView protocol) where toObject verb sv = mconcat - [ "blockNo" .= svBlockNo sv - , toObject verb (svTiebreakerView sv) + [ "blockNo" .= wsvBlockNo sv + , "weightBoost" .= unPerasWeight (wsvWeightBoost sv) + , toObject verb (wsvTiebreaker sv) ] instance All (ToObject `Compose` WrapTiebreakerView) xs => ToObject (OneEraTiebreakerView xs) where diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 3657b3e0c4a..a7e211c0925 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -74,7 +74,7 @@ import qualified Ouroboros.Consensus.Network.NodeToClient as NodeToClient import qualified Ouroboros.Consensus.Network.NodeToNode as NodeToNode import qualified Ouroboros.Consensus.Node.Run as Consensus (RunNode) import qualified Ouroboros.Consensus.Node.Tracers as Consensus -import Ouroboros.Consensus.Protocol.Abstract (SelectView, ValidationErr) +import Ouroboros.Consensus.Protocol.Abstract (ValidationErr) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB @@ -135,6 +135,7 @@ import qualified System.Metrics.Counter as Counter import qualified System.Metrics.Gauge as Gauge import qualified System.Metrics.Label as Label import qualified System.Remote.Monitoring.Wai as EKG +import Ouroboros.Consensus.Peras.SelectView {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -550,7 +551,7 @@ teeTraceChainTip , InspectLedger blk , ToObject (Header blk) , ToObject (LedgerEvent blk) - , ToObject (SelectView (BlockProtocol blk)) + , ToObject (WeightedSelectView (BlockProtocol blk)) ) => BlockConfig blk -> ForgingStats @@ -574,7 +575,7 @@ teeTraceChainTipElide , InspectLedger blk , ToObject (Header blk) , ToObject (LedgerEvent blk) - , ToObject (SelectView (BlockProtocol blk)) + , ToObject (WeightedSelectView (BlockProtocol blk)) ) => TracingVerbosity -> MVar (Maybe (WithSeverity (ChainDB.TraceEvent blk)), Integer) From 5c37efcfa55c9ff55dce0807c541c3089004b6d3 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 25 Nov 2025 10:49:15 +0100 Subject: [PATCH 3/6] Update deps, complete tracers --- .../plutus-scripts-bench.cabal | 2 +- bench/tx-generator/tx-generator.cabal | 2 +- cabal.project | 35 ++++--- cardano-node/cardano-node.cabal | 2 +- .../src/Cardano/Node/Tracing/Era/Shelley.hs | 10 +- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 99 +++++++++---------- .../Tracing/OrphanInstances/Shelley.hs | 10 +- cardano-submit-api/cardano-submit-api.cabal | 2 +- cardano-testnet/cardano-testnet.cabal | 2 +- 9 files changed, 90 insertions(+), 74 deletions(-) diff --git a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal index f01eb46d08e..a9d22c097a5 100644 --- a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal +++ b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal @@ -82,7 +82,7 @@ library -- IOG dependencies -------------------------- build-depends: - , cardano-api ^>=10.19 + , cardano-api ^>=10.20 , plutus-ledger-api ^>=1.53 , plutus-tx ^>=1.53 , plutus-tx-plugin ^>=1.53 diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index 5beffe64a9d..cae0f4170cb 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -111,7 +111,7 @@ library , attoparsec-aeson , base16-bytestring , bytestring - , cardano-api ^>= 10.19 + , cardano-api ^>= 10.20 , cardano-binary , cardano-cli ^>= 10.13 , cardano-crypto-class diff --git a/cabal.project b/cabal.project index 6829b0d30ca..0a555fce59d 100644 --- a/cabal.project +++ b/cabal.project @@ -67,23 +67,23 @@ allow-newer: source-repository-package type: git location: https://github.com/intersectmbo/cardano-cli.git - tag: 86ccb5dae44af6f085b594a9f7b516f1e2345d28 - --sha256: sha256-sCYz2MEQ51YERL99iXN+rf0TXXz3FD13Pv+AYT/2RSo= + tag: 6c8fd34e3faaf6c9b8f592a48941ec67fe5b2f65 + --sha256: sha256-ZVwWBUed/Y+U1gzUfdl39r3V7kypbl3SRlCkEQQcaLA= subdir: cardano-cli source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: c03ca3c768e21ec2c6f5761af5007894116fd8ac - --sha256: sha256-8tcpe3UyqoEy+IUaBZ8UaWB4X5gvox+2/h3ccxxaNjs= + tag: 23f57762c5cc6a4d965b9eac5caaab786d3d9f51 + --sha256: sha256-7KmcH9JiK1+3h/hTP+4TMA41jqgUGwYQ7liBPB2iQA8= subdir: cardano-api source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: d14d43e6582da900a75cb97c5c4d0292d232052f - --sha256: sha256-Zn9gnpR9JnWcs0X4xUAWgJVzmTHjTHdn7uLwKw7erwQ= + tag: fd423c545f38ede5f5ffc1d7cc56c006818392fa + --sha256: sha256-iIDQBnR63QZas71KrgD9usf5SEh0AALTMdVJSl2YRvg= subdir: ouroboros-consensus ouroboros-consensus-cardano @@ -121,10 +121,19 @@ source-repository-package -- Backported version of https://github.com/IntersectMBO/ouroboros-network/pull/5161 source-repository-package - type: git - location: https://github.com/IntersectMBO/ouroboros-network - tag: 1385b53cefb81e79553b6b0252537455833ea9c4 - --sha256: sha256-zZ7WsMfRs1fG16bmvI5vIh4fhQ8RGyEvYGLSWlrxpg0= - subdir: - ouroboros-network-api - ouroboros-network + type: git + location: https://github.com/IntersectMBO/ouroboros-network + tag: dfcb1f9c578ec8cd5114fea9696e7be6c9001323 + --sha256: sha256-omXPdi/T/f3gq9rOH20zX+x3WvaxlB704g07RF/13Nk= + subdir: + ouroboros-network-api + ouroboros-network + +source-repository-package + type: git + location: https://github.com/IntersectMBO/lsm-tree + tag: 96474ce9559573698095229d8d08bd1a95b7ae01 + --sha256: sha256-5Tk4kVP6U0MuPHjRNal9XFFz6TgHBoFOhGCzEYrV3v4= + subdir: + lsm-tree + blockio diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 99ec06d1472..8fe8ef0bca8 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -141,7 +141,7 @@ library , async , base16-bytestring , bytestring - , cardano-api ^>= 10.19 + , cardano-api ^>= 10.20 , cardano-crypto-class , cardano-crypto-wrapper , cardano-git-rev ^>=0.2.2 diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index 05ad20f5e26..280b31bad1d 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -1073,8 +1073,14 @@ instance , LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" era)) ) => LogFormatting (Conway.ConwayLedgerPredFailure era) where forMachine v (Conway.ConwayUtxowFailure f) = forMachine v f - forMachine _verb (Conway.ConwayWithdrawalsMissingAccounts _) = mconcat [ "todo" .= String "todo"] - forMachine _verb (Conway.ConwayIncompleteWithdrawals _) = mconcat [ "todo" .= String "todo"] + forMachine _ (Conway.ConwayWithdrawalsMissingAccounts missingWithdrawals) = + mconcat [ "kind" .= String "ConwayWithdrawalsMissingAccounts" + , "withdrawals" .= unWithdrawals missingWithdrawals + ] + forMachine _ (Conway.ConwayIncompleteWithdrawals incompleteWithdrawals) = + mconcat [ "kind" .= String "ConwayIncompleteWithdrawals" + , "withdrawals" .= unWithdrawals incompleteWithdrawals + ] forMachine _ (Conway.ConwayTxRefScriptsSizeTooBig Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ConwayTxRefScriptsSizeTooBig" , "actual" .= mismatchSupplied diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 537d23e1eca..5c7db9b426d 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -1874,29 +1874,43 @@ instance LogFormatting LedgerDB.TraceForkerEventWithKey where "Forker " <> showT k <> ": " <> forHuman ev instance LogFormatting LedgerDB.TraceForkerEvent where - forMachine _dtals LedgerDB.ForkerOpen = mempty - forMachine _dtals LedgerDB.ForkerCloseUncommitted = mempty - forMachine _dtals LedgerDB.ForkerCloseCommitted = mempty - forMachine _dtals LedgerDB.ForkerReadTablesStart = mempty - forMachine _dtals LedgerDB.ForkerReadTablesEnd = mempty - forMachine _dtals LedgerDB.ForkerRangeReadTablesStart = mempty - forMachine _dtals LedgerDB.ForkerRangeReadTablesEnd = mempty + forMachine _dtals LedgerDB.ForkerOpen = + mconcat [ "kind" .= String "ForkerOpen" ] + forMachine _dtals (LedgerDB.ForkerReadTables e) = + mconcat [ "kind" .= String "ForkerReadTables" + , "edge" .= case e of + RisingEdge -> String "RisingEdge" + FallingEdgeWith t -> toJSON t + ] + forMachine _dtals (LedgerDB.ForkerRangeReadTables e) = + mconcat [ "kind" .= String "ForkerRangeReadTables" + , "edge" .= case e of + RisingEdge -> String "RisingEdge" + FallingEdgeWith t -> toJSON t + ] forMachine _dtals LedgerDB.ForkerReadStatistics = mempty - forMachine _dtals LedgerDB.ForkerPushStart = mempty - forMachine _dtals LedgerDB.ForkerPushEnd = mempty - forMachine _dtals LedgerDB.DanglingForkerClosed = mempty + forMachine _dtals (LedgerDB.ForkerPush e) = + mconcat [ "kind" .= String "ForkerPush" + , "edge" .= case e of + RisingEdge -> String "RisingEdge" + FallingEdgeWith t -> toJSON t + ] + forMachine _dtals (LedgerDB.ForkerClose wc) = + mconcat [ "kind" .= String "ForkerClose" + , "wasCommitted" .= toJSON (wc == LedgerDB.ForkerWasCommitted) + ] forHuman LedgerDB.ForkerOpen = "Opened forker" - forHuman LedgerDB.ForkerCloseUncommitted = "Forker closed without committing" - forHuman LedgerDB.ForkerCloseCommitted = "Forker closed after committing" - forHuman LedgerDB.ForkerReadTablesStart = "Started to read tables" - forHuman LedgerDB.ForkerReadTablesEnd = "Finish reading tables" - forHuman LedgerDB.ForkerRangeReadTablesStart = "Started to range read tables" - forHuman LedgerDB.ForkerRangeReadTablesEnd = "Finish range reading tables" - forHuman LedgerDB.ForkerReadStatistics = "Gathering statistics" - forHuman LedgerDB.ForkerPushStart = "Started to push" - forHuman LedgerDB.ForkerPushEnd = "Pushed" - forHuman LedgerDB.DanglingForkerClosed = "Closed dangling forker" + forHuman (LedgerDB.ForkerReadTables RisingEdge) = "Forker reading tables" + forHuman (LedgerDB.ForkerReadTables (FallingEdgeWith t)) = "Forker read tables, took " <> showT t + forHuman (LedgerDB.ForkerRangeReadTables RisingEdge) = "Forker range reading tables" + forHuman (LedgerDB.ForkerRangeReadTables (FallingEdgeWith t)) = "Forker range read tables, took " <> showT t + forHuman LedgerDB.ForkerReadStatistics = "Forker gathering statistics" + forHuman (LedgerDB.ForkerPush RisingEdge) = "Forker pushing" + forHuman (LedgerDB.ForkerPush (FallingEdgeWith t)) = "Forker pushed, took " <> showT t + forHuman (LedgerDB.ForkerClose wc) = "Closed forker, " <> case wc of + LedgerDB.ForkerWasCommitted -> "was committed" + LedgerDB.ForkerWasUncommitted -> "was discarded" instance MetaTrace LedgerDB.TraceForkerEventWithKey where namespaceFor (LedgerDB.TraceForkerEventWithKey _ ev) = @@ -1910,48 +1924,29 @@ instance MetaTrace LedgerDB.TraceForkerEventWithKey where instance MetaTrace LedgerDB.TraceForkerEvent where namespaceFor LedgerDB.ForkerOpen = Namespace [] ["Open"] - namespaceFor LedgerDB.ForkerCloseUncommitted = Namespace [] ["CloseUncommitted"] - namespaceFor LedgerDB.ForkerCloseCommitted = Namespace [] ["CloseCommitted"] - namespaceFor LedgerDB.ForkerReadTablesStart = Namespace [] ["StartRead"] - namespaceFor LedgerDB.ForkerReadTablesEnd = Namespace [] ["FinishRead"] - namespaceFor LedgerDB.ForkerRangeReadTablesStart = Namespace [] ["StartRangeRead"] - namespaceFor LedgerDB.ForkerRangeReadTablesEnd = Namespace [] ["FinishRangeRead"] + namespaceFor LedgerDB.ForkerReadTables{} = Namespace [] ["Read"] + namespaceFor LedgerDB.ForkerRangeReadTables{} = Namespace [] ["RangeRead"] namespaceFor LedgerDB.ForkerReadStatistics = Namespace [] ["Statistics"] - namespaceFor LedgerDB.ForkerPushStart = Namespace [] ["StartPush"] - namespaceFor LedgerDB.ForkerPushEnd = Namespace [] ["FinishPush"] - namespaceFor LedgerDB.DanglingForkerClosed = Namespace [] ["DanglingForkerClosed"] + namespaceFor LedgerDB.ForkerPush{} = Namespace [] ["Push"] + namespaceFor LedgerDB.ForkerClose{} = Namespace [] ["Close"] severityFor _ _ = Just Debug - documentFor (Namespace _ ("Open" : _tl)) = Just - "A forker is being opened" - documentFor (Namespace _ ("CloseUncommitted" : _tl)) = Just $ - mconcat [ "A forker was closed without being committed." - , " This is usually the case with forkers that are not opened for chain selection," - , " and for forkers on discarded forks"] - documentFor (Namespace _ ("CloseCommitted" : _tl)) = Just "A forker was committed (the LedgerDB was modified accordingly) and closed" - documentFor (Namespace _ ("StartRead" : _tl)) = Just "The process for reading ledger tables started" - documentFor (Namespace _ ("FinishRead" : _tl)) = Just "Values from the ledger tables were read" - documentFor (Namespace _ ("StartRangeRead" : _tl)) = Just "The process for range reading ledger tables started" - documentFor (Namespace _ ("FinishRangeRead" : _tl)) = Just "Values from the ledger tables were range-read" + documentFor (Namespace _ ("Open" : _tl)) = Just "A forker is being opened" + documentFor (Namespace _ ("Read" : _tl)) = Just "A forker is reading values" + documentFor (Namespace _ ("RangeRead" : _tl)) = Just "A forker is range reading values" documentFor (Namespace _ ("Statistics" : _tl)) = Just "Statistics were gathered from the forker" - documentFor (Namespace _ ("StartPush" : _tl)) = Just "A ledger state is going to be pushed to the forker" - documentFor (Namespace _ ("FinishPush" : _tl)) = Just "A ledger state was pushed to the forker" - documentFor (Namespace _ ("DanglingForkerClosed" : _tl)) = Just "A dangling forker was closed" + documentFor (Namespace _ ("Push" : _tl)) = Just "A forker is pushing a new ledger state" + documentFor (Namespace _ ("Close" : _tl)) = Just "A forker was closed" documentFor _ = Nothing allNamespaces = [ Namespace [] ["Open"] - , Namespace [] ["CloseUncommitted"] - , Namespace [] ["CloseCommitted"] - , Namespace [] ["StartRead"] - , Namespace [] ["FinishRead"] - , Namespace [] ["StartRangeRead"] - , Namespace [] ["FinishRangeRead"] + , Namespace [] ["Read"] + , Namespace [] ["RangeRead"] , Namespace [] ["Statistics"] - , Namespace [] ["StartPush"] - , Namespace [] ["FinishPush"] - , Namespace [] ["DanglingForkerClosed"] + , Namespace [] ["Push"] + , Namespace [] ["Close"] ] -------------------------------------------------------------------------------- diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index 20d492b083e..7e12078bf34 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -334,8 +334,14 @@ instance , ToObject (PredicateFailure (Core.EraRule "GOV" ledgerera)) ) => ToObject (Conway.ConwayLedgerPredFailure ledgerera) where toObject verb (Conway.ConwayUtxowFailure f) = toObject verb f - toObject _verb (Conway.ConwayWithdrawalsMissingAccounts _) = mconcat [ "todo" .= String "todo"] - toObject _verb (Conway.ConwayIncompleteWithdrawals _) = mconcat [ "todo" .= String "todo"] + toObject _ (Conway.ConwayWithdrawalsMissingAccounts missingWithdrawals) = + mconcat [ "kind" .= String "ConwayWithdrawalsMissingAccounts" + , "withdrawals" .= unWithdrawals missingWithdrawals + ] + toObject _ (Conway.ConwayIncompleteWithdrawals incompleteWithdrawals) = + mconcat [ "kind" .= String "ConwayIncompleteWithdrawals" + , "withdrawals" .= unWithdrawals incompleteWithdrawals + ] toObject _ (Conway.ConwayTxRefScriptsSizeTooBig Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ConwayTxRefScriptsSizeTooBig" , "actual" .= mismatchSupplied diff --git a/cardano-submit-api/cardano-submit-api.cabal b/cardano-submit-api/cardano-submit-api.cabal index fc79003264b..cf3ba25c80a 100644 --- a/cardano-submit-api/cardano-submit-api.cabal +++ b/cardano-submit-api/cardano-submit-api.cabal @@ -39,7 +39,7 @@ library , aeson , async , bytestring - , cardano-api ^>= 10.19 + , cardano-api ^>= 10.20 , cardano-binary , cardano-cli ^>= 10.13 , cardano-crypto-class ^>= 2.2 diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index fb8ed8f5f46..88795b0e9f0 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -40,7 +40,7 @@ library , aeson-pretty , ansi-terminal , bytestring - , cardano-api ^>= 10.19 + , cardano-api ^>= 10.20 , cardano-cli:{cardano-cli, cardano-cli-test-lib} ^>= 10.13 , cardano-crypto-class , cardano-crypto-wrapper From b3d7412a24e2896e5be357c124c179801ce30a1c Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 25 Nov 2025 23:49:38 +0100 Subject: [PATCH 4/6] Fixup consensus databases paths when completing config --- cabal.project | 16 ++++++++-------- .../src/Cardano/Node/Configuration/POM.hs | 16 ++++++++++++---- 2 files changed, 20 insertions(+), 12 deletions(-) diff --git a/cabal.project b/cabal.project index 0a555fce59d..c11a22092c0 100644 --- a/cabal.project +++ b/cabal.project @@ -67,23 +67,23 @@ allow-newer: source-repository-package type: git location: https://github.com/intersectmbo/cardano-cli.git - tag: 6c8fd34e3faaf6c9b8f592a48941ec67fe5b2f65 - --sha256: sha256-ZVwWBUed/Y+U1gzUfdl39r3V7kypbl3SRlCkEQQcaLA= + tag: 6691afc0a51e16b98236f85fda4e8d6b49174370 + --sha256: sha256-TDHJeC+chGZJsIgRUpw2hZuLErktkxIfFbc+WHFHn0k= subdir: cardano-cli source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: 23f57762c5cc6a4d965b9eac5caaab786d3d9f51 - --sha256: sha256-7KmcH9JiK1+3h/hTP+4TMA41jqgUGwYQ7liBPB2iQA8= + tag: 58941c7b1e71be38a3ba63a1b815ac386574287e + --sha256: sha256-D/+yB+jclri/K5XPrM+ygBrN5bUizamX+zNeE5AqWpI= subdir: cardano-api source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: fd423c545f38ede5f5ffc1d7cc56c006818392fa - --sha256: sha256-iIDQBnR63QZas71KrgD9usf5SEh0AALTMdVJSl2YRvg= + tag: 41f32e52644aa168c4f4d4ef645ed6c3ec2ecfd6 + --sha256: sha256-4ukkuRURJ24nXN+sfbFrDr0aYc1SPFvQO0XCVJuQris= subdir: ouroboros-consensus ouroboros-consensus-cardano @@ -132,8 +132,8 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/lsm-tree - tag: 96474ce9559573698095229d8d08bd1a95b7ae01 - --sha256: sha256-5Tk4kVP6U0MuPHjRNal9XFFz6TgHBoFOhGCzEYrV3v4= + tag: 3c51ea5ac6400f32a7bdf17260325d4d0a360a98 + --sha256: sha256-44SHqtAciPhoI6ysLt8RdNvlVvN91GWHMnr68vOU2gQ= subdir: lsm-tree blockio diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 296d94cde8d..aa30b3de0ae 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -38,7 +38,7 @@ import Cardano.Tracing.Config import Cardano.Tracing.OrphanInstances.Network () import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mempool (MempoolCapacityBytesOverride (..)) -import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) +import Ouroboros.Consensus.Node (NodeDatabasePaths (..), nonImmutableDbPath) import Ouroboros.Consensus.Node.Genesis (GenesisConfig, GenesisConfigFlags, defaultGenesisConfigFlags, mkGenesisConfig) import Ouroboros.Consensus.Storage.LedgerDB.Args (QueryBatchSize (..)) @@ -759,9 +759,6 @@ makeNodeConfiguration pnc = do ncConsensusMode <- lastToEither "Missing ConsensusMode" $ pncConsensusMode pnc - ncLedgerDbConfig <- - lastToEither "Missing LedgerDb config" - $ pncLedgerDbConfig pnc ncProtocolIdleTimeout <- lastToEither "Missing ProtocolIdleTimeout" $ pncProtocolIdleTimeout pnc @@ -798,6 +795,17 @@ makeNodeConfiguration pnc = do ncResponderCoreAffinityPolicy <- lastToEither "Missing ResponderCoreAffinityPolicy" $ pncResponderCoreAffinityPolicy pnc + let + fixupConsensusDbPath (LedgerDbConfiguration ds si qbs (V1LMDB ff Nothing mg mi) dopt) = + LedgerDbConfiguration ds si qbs (V1LMDB ff (Just $ nonImmutableDbPath databaseFile "lmdb") mg mi) dopt + fixupConsensusDbPath (LedgerDbConfiguration ds si qbs (V2LSM Nothing) dopt) = + LedgerDbConfiguration ds si qbs (V2LSM (Just $ nonImmutableDbPath databaseFile "lsm")) dopt + fixupConsensusDbPath l = l + + ncLedgerDbConfig <- + fixupConsensusDbPath + <$> lastToEither "Missing LedgerDb config" (pncLedgerDbConfig pnc) + let deadlineTargets = PeerSelectionTargets { targetNumberOfRootPeers = ncDeadlineTargetOfRootPeers, From 4c57847c39f63962e6816d568a6a483f64b75511 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 28 Oct 2025 15:52:49 +0100 Subject: [PATCH 5/6] Implement non-native snapshots command --- cabal.project | 6 +- cardano-node/app/cardano-node.hs | 19 ++++-- cardano-node/cardano-node.cabal | 3 +- .../src/Cardano/Node/Configuration/POM.hs | 7 ++ cardano-node/src/Cardano/Node/Parsers.hs | 14 ++++ cardano-node/src/Cardano/Snapshots/Run.hs | 67 +++++++++++++++++++ 6 files changed, 105 insertions(+), 11 deletions(-) create mode 100644 cardano-node/src/Cardano/Snapshots/Run.hs diff --git a/cabal.project b/cabal.project index c11a22092c0..a078ce3a713 100644 --- a/cabal.project +++ b/cabal.project @@ -82,12 +82,12 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: 41f32e52644aa168c4f4d4ef645ed6c3ec2ecfd6 - --sha256: sha256-4ukkuRURJ24nXN+sfbFrDr0aYc1SPFvQO0XCVJuQris= + tag: 163895614992007a09675fd15980578ecd6e1e91 + --sha256: sha256-1rbaFlFzSiMNe6vzUMuIsO4COF16adUZYak/jfyw4IU= subdir: ouroboros-consensus - ouroboros-consensus-cardano ouroboros-consensus-diffusion + ouroboros-consensus-cardano source-repository-package type: git diff --git a/cardano-node/app/cardano-node.hs b/cardano-node/app/cardano-node.hs index a550735de7a..4c4efa7b879 100644 --- a/cardano-node/app/cardano-node.hs +++ b/cardano-node/app/cardano-node.hs @@ -8,8 +8,9 @@ import Cardano.Git.Rev (gitRev) import Cardano.Node.Configuration.POM (PartialNodeConfiguration(..)) import Cardano.Node.Handlers.TopLevel import Cardano.Node.Parsers (nodeCLIParser, parserHelpHeader, parserHelpOptions, - renderHelpDoc) + renderHelpDoc, parseSnapshotsCmd) import Cardano.Node.Run (runNode) +import Cardano.Snapshots.Run (canonicalizeSnapshots, NodeDatabasePaths) import Cardano.Node.Tracing.Documentation (TraceDocumentationCmd (..), parseTraceDocumentationCmd, runTraceDocumentationCmd) @@ -37,6 +38,7 @@ main = do warnIfSet args pncMaybeMempoolCapacityOverride "mempool-capacity-override" "MempoolCapacityBytesOverride" runNode args TraceDocumentation tdc -> runTraceDocumentationCmd tdc + CanonicalizeSnapshotsCmd cfg db -> canonicalizeSnapshots cfg db VersionCmd -> runVersionCommand where @@ -54,13 +56,15 @@ main = do opts :: Opt.ParserInfo Command opts = - Opt.info (fmap RunCmd nodeCLIParser + let pp = fmap RunCmd nodeCLIParser <|> fmap TraceDocumentation parseTraceDocumentationCmd <|> parseVersionCmd - <**> helperBrief "help" "Show this help text" nodeCliHelpMain) + <|> fmap (uncurry CanonicalizeSnapshotsCmd) parseSnapshotsCmd + in Opt.info (pp + <**> helperBrief "help" "Show this help text" (nodeCliHelpMain pp)) ( Opt.fullDesc <> - Opt.progDesc "Start node of the Cardano blockchain." + Opt.progDesc "The Cardano blockchain node" ) helperBrief :: String -> String -> String -> Parser (a -> a) @@ -68,15 +72,16 @@ main = do [ Opt.long l , Opt.help d ] - nodeCliHelpMain :: String - nodeCliHelpMain = renderHelpDoc 80 $ - parserHelpHeader "cardano-node" nodeCLIParser + nodeCliHelpMain :: Parser a -> String + nodeCliHelpMain pp = renderHelpDoc 80 $ + parserHelpHeader "cardano-node" pp <$$> "" <$$> parserHelpOptions nodeCLIParser data Command = RunCmd PartialNodeConfiguration | TraceDocumentation TraceDocumentationCmd + | CanonicalizeSnapshotsCmd FilePath (Maybe NodeDatabasePaths) | VersionCmd -- Yes! A --version flag or version command. Either guess is right! diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 8fe8ef0bca8..67dadcd58dd 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -132,6 +132,7 @@ library Cardano.Tracing.Shutdown Cardano.Tracing.Startup Cardano.Tracing.Tracers + Cardano.Snapshots.Run other-modules: Paths_cardano_node autogen-modules: Paths_cardano_node @@ -189,7 +190,7 @@ library , nothunks , optparse-applicative-fork >= 0.18.1 , ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm} ^>= 0.28 - , ouroboros-consensus-cardano ^>= 0.26 + , ouroboros-consensus-cardano:{ouroboros-consensus-cardano, snapshot-conversion} ^>= 0.26 , ouroboros-consensus-diffusion ^>= 0.24 , ouroboros-consensus-protocol , ouroboros-network-api ^>= 0.16 diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index aa30b3de0ae..c9c3893447a 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -269,6 +269,8 @@ data PartialNodeConfiguration , pncGenesisConfigFlags :: !(Last GenesisConfigFlags) , pncResponderCoreAffinityPolicy :: !(Last ResponderCoreAffinityPolicy) + + , pncCanonicalSnapshotOutputPath :: !(Last FilePath) } deriving (Eq, Generic, Show) instance AdjustFilePaths PartialNodeConfiguration where @@ -381,6 +383,9 @@ instance FromJSON PartialNodeConfiguration where <$> v .:? "ResponderCoreAffinityPolicy" <*> v .:? "ForkPolicy" -- deprecated + pncCanonicalSnapshotOutputPath <- + Last <$> v .:? "CanonicalSnapshotsOutputPath" + pure PartialNodeConfiguration { pncProtocolConfig , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty pncSocketPath @@ -425,6 +430,7 @@ instance FromJSON PartialNodeConfiguration where , pncPeerSharing , pncGenesisConfigFlags , pncResponderCoreAffinityPolicy + , pncCanonicalSnapshotOutputPath } where parseMempoolCapacityBytesOverride v = parseNoOverride <|> parseOverride @@ -687,6 +693,7 @@ defaultPartialNodeConfiguration = , pncGenesisConfigFlags = Last (Just defaultGenesisConfigFlags) -- https://ouroboros-consensus.cardano.intersectmbo.org/haddocks/ouroboros-consensus-diffusion/Ouroboros-Consensus-Node-Genesis.html#v:defaultGenesisConfigFlags , pncResponderCoreAffinityPolicy = Last $ Just NoResponderCoreAffinity + , pncCanonicalSnapshotOutputPath = mempty } lastOption :: Parser a -> Parser (Last a) diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index 86773d3726c..eece225fd3b 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -11,6 +11,7 @@ module Cardano.Node.Parsers , parserHelpOptions , renderHelpDoc , parseHostPort + , parseSnapshotsCmd ) where import Cardano.Logging.Types @@ -140,6 +141,7 @@ nodeRunParser = do , pncPeerSharing = mempty , pncGenesisConfigFlags = mempty , pncResponderCoreAffinityPolicy = mempty + , pncCanonicalSnapshotOutputPath = mempty } parseSocketPath :: Text -> Parser SocketPath @@ -434,3 +436,15 @@ parserHelpOptions = fromMaybe mempty . OptI.unChunk . OptI.fullDesc (Opt.prefs m renderHelpDoc :: Int -> OptI.Doc -> String renderHelpDoc cols = (`OptI.renderShowS` "") . OptI.layoutPretty (OptI.LayoutOptions (OptI.AvailablePerLine cols 1.0)) + +parseSnapshotsCmd :: Parser (FilePath, Maybe NodeDatabasePaths) +parseSnapshotsCmd = subparser + ( commandGroup "Canonicalize snapshots" + <> metavar "run" + <> command "canonicalize-snapshots" + (info (((,) + <$> parseConfigFile + <*> optional (parseDbPath <|> fmap OnePathForAllDbs parseImmutableDbPath) + ) <**> helper) + (progDesc "Canonicalize all snapshots" )) + ) diff --git a/cardano-node/src/Cardano/Snapshots/Run.hs b/cardano-node/src/Cardano/Snapshots/Run.hs new file mode 100644 index 00000000000..fcac909e362 --- /dev/null +++ b/cardano-node/src/Cardano/Snapshots/Run.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Cardano.Snapshots.Run ( + canonicalizeSnapshots, + NodeDatabasePaths, +) where + +import qualified Cardano.Api.Consensus as Api +import Cardano.Node.Configuration.LedgerDB +import Cardano.Node.Configuration.POM +import Cardano.Node.Protocol +import Cardano.Node.Types (ConfigYamlFilePath (..)) +import Control.Exception +import Control.Monad (forM_) +import Control.Monad.Except +import Data.Monoid (Last (..)) +import Ouroboros.Consensus.Cardano.SnapshotConversion +import Ouroboros.Consensus.Node (NodeDatabasePaths (..), immutableDbPath) +import System.Directory (doesFileExist, listDirectory) +import System.FilePath (()) + +canonicalizeSnapshots :: FilePath -> Maybe NodeDatabasePaths -> IO () +canonicalizeSnapshots cfg (Last -> db) = do + configYamlPc <- parseNodeConfigurationFP $ Just $ ConfigYamlFilePath cfg + + let cfgFromFile = defaultPartialNodeConfiguration <> configYamlPc + + mOut = getLast (pncCanonicalSnapshotOutputPath cfgFromFile) + + mOtherConfigs = do + a <- getLast (pncDatabaseFile cfgFromFile <> db) + b <- getLast (pncLedgerDbConfig cfgFromFile) + c <- getLast (pncProtocolConfig cfgFromFile) + d <- getLast (pncProtocolFiles cfgFromFile) + pure (a, b, c, d) + + case (mOut, mOtherConfigs) of + (Nothing, _) -> pure () + (_, Nothing) -> error "Impossible, some arguments were missing yet there should be at least a default value for those" + (Just out, Just (immutableDbPath -> dbPath, LedgerDbConfiguration _ _ _ selector _, pInfo, cfgFiles)) -> do + snaps <- listDirectory (dbPath "ledger") + someConsensusProto <- + runThrowExceptT $ + mkConsensusProtocol + pInfo + (Just cfgFiles) + case someConsensusProto of + SomeConsensusProtocol Api.CardanoBlockType pInfoArgs -> do + let inFmt = case selector of + V1LMDB{} -> LMDB + V2InMemory{} -> Mem + V2LSM Nothing -> flip LSM (dbPath "lsm") + V2LSM (Just lsmDb) -> flip LSM (dbPath lsmDb) + forM_ snaps $ \snap -> do + exists <- doesFileExist (out snap "meta") + if exists + then putStrLn $ "Snapshot at " <> dbPath "ledger" snap <> " already converted" + else do + putStrLn $ "Converting snapshot at " <> dbPath "ledger" snap + runThrowExceptT $ convertSnapshot False (fst $ Api.protocolInfo @IO pInfoArgs) (inFmt (dbPath "ledger" snap)) (Mem $ out snap) + putStrLn "Done" + _ -> pure () + +runThrowExceptT :: (Exception e) => ExceptT e IO a -> IO a +runThrowExceptT act = runExceptT act >>= either throwIO pure From d1b4f95028eceac35671ce12e0bda7f8b814d327 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 28 Oct 2025 17:47:41 +0100 Subject: [PATCH 6/6] Hook --- cardano-node/app/cardano-node.hs | 2 +- cardano-node/cardano-node.cabal | 1 + .../src/Cardano/Node/Configuration/POM.hs | 3 ++ cardano-node/src/Cardano/Node/Parsers.hs | 4 +-- cardano-node/src/Cardano/Node/Tracing/API.hs | 25 ++++++++++--- .../src/Cardano/Node/Tracing/Tracers.hs | 4 ++- cardano-node/src/Cardano/Snapshots/Run.hs | 36 +++++++++++++++++-- 7 files changed, 64 insertions(+), 11 deletions(-) diff --git a/cardano-node/app/cardano-node.hs b/cardano-node/app/cardano-node.hs index 4c4efa7b879..a54e32c2eb8 100644 --- a/cardano-node/app/cardano-node.hs +++ b/cardano-node/app/cardano-node.hs @@ -81,7 +81,7 @@ main = do data Command = RunCmd PartialNodeConfiguration | TraceDocumentation TraceDocumentationCmd - | CanonicalizeSnapshotsCmd FilePath (Maybe NodeDatabasePaths) + | CanonicalizeSnapshotsCmd (Maybe FilePath) (Maybe NodeDatabasePaths) | VersionCmd -- Yes! A --version flag or version command. Either guess is right! diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 67dadcd58dd..d56e4bc6872 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -199,6 +199,7 @@ library , ouroboros-network-protocols ^>= 0.15 , prettyprinter , prettyprinter-ansi-terminal + , process , psqueues , random , resource-registry diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index c9c3893447a..1571e302d45 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -174,6 +174,8 @@ data NodeConfiguration , ncGenesisConfig :: GenesisConfig , ncResponderCoreAffinityPolicy :: ResponderCoreAffinityPolicy + + , ncCanonicalSnapshotOutputPath :: Maybe FilePath } deriving (Eq, Show) -- | We expose the `Ouroboros.Network.Mux.ForkPolicy` as a `NodeConfiguration` field. @@ -887,6 +889,7 @@ makeNodeConfiguration pnc = do , ncConsensusMode , ncGenesisConfig , ncResponderCoreAffinityPolicy + , ncCanonicalSnapshotOutputPath = getLast $ pncCanonicalSnapshotOutputPath pnc } ncProtocol :: NodeConfiguration -> Protocol diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index eece225fd3b..8db5a6a56a6 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -437,13 +437,13 @@ renderHelpDoc :: Int -> OptI.Doc -> String renderHelpDoc cols = (`OptI.renderShowS` "") . OptI.layoutPretty (OptI.LayoutOptions (OptI.AvailablePerLine cols 1.0)) -parseSnapshotsCmd :: Parser (FilePath, Maybe NodeDatabasePaths) +parseSnapshotsCmd :: Parser (Maybe FilePath, Maybe NodeDatabasePaths) parseSnapshotsCmd = subparser ( commandGroup "Canonicalize snapshots" <> metavar "run" <> command "canonicalize-snapshots" (info (((,) - <$> parseConfigFile + <$> optional parseConfigFile <*> optional (parseDbPath <|> fmap OnePathForAllDbs parseImmutableDbPath) ) <**> helper) (progDesc "Canonicalize all snapshots" )) diff --git a/cardano-node/src/Cardano/Node/Tracing/API.hs b/cardano-node/src/Cardano/Node/Tracing/API.hs index d18ee73e9f7..7c9af72be44 100644 --- a/cardano-node/src/Cardano/Node/Tracing/API.hs +++ b/cardano-node/src/Cardano/Node/Tracing/API.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE PackageImports #-} @@ -37,7 +38,8 @@ import Prelude import Control.DeepSeq (deepseq) import Control.Monad (forM_) -import "contra-tracer" Control.Tracer (traceWith) +import "contra-tracer" Control.Tracer (traceWith, Tracer) +import qualified "contra-tracer" Control.Tracer as CT import "trace-dispatcher" Control.Tracer (nullTracer) import qualified Data.Map.Strict as Map import Data.Maybe @@ -48,7 +50,11 @@ import System.Metrics as EKG import Trace.Forward.Forwarding (initForwardingDelayed) import Trace.Forward.Utils.TraceObject (writeToSink) - +import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB +import Ouroboros.Consensus.Util.Enclose +import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.TraceEvent as LedgerDB +import Cardano.Snapshots.Run initTraceDispatcher :: forall blk. @@ -69,7 +75,16 @@ initTraceDispatcher nc p networkMagic nodeKernel noBlockForging = do (unConfigPath $ ncConfigFile nc) defaultCardanoConfig - (kickoffForwarder, kickoffPrometheusSimple, tracers) <- mkTracers trConfig + let onChainDbEvent = if isJust (ncCanonicalSnapshotOutputPath nc) + then CT.Tracer $ \case + (ChainDB.TraceLedgerDBEvent + (LedgerDB.LedgerDBSnapshotEvent + (LedgerDB.TookSnapshot _ _ (FallingEdgeWith _))) + ) -> spawnCanonicalizer + _ -> pure () + else CT.nullTracer + + (kickoffForwarder, kickoffPrometheusSimple, tracers) <- mkTracers trConfig onChainDbEvent -- The NodeInfo DataPoint needs to be fully evaluated and stored -- before it is queried for the first time by cardano-tracer. @@ -107,11 +122,12 @@ initTraceDispatcher nc p networkMagic nodeKernel noBlockForging = do mkTracers :: TraceConfig + -> Tracer IO (ChainDB.TraceEvent blk) -> IO ( IO () , IO (Maybe String) , Tracers RemoteAddress LocalAddress blk IO ) - mkTracers trConfig = do + mkTracers trConfig onChainDbEvent = do ekgStore <- EKG.newStore EKG.registerGcMetrics ekgStore ekgTrace <- ekgTracer trConfig ekgStore @@ -144,6 +160,7 @@ initTraceDispatcher nc p networkMagic nodeKernel noBlockForging = do nodeKernel stdoutTrace fwdTracer + onChainDbEvent (Just ekgTrace) dpTracer trConfig diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index 12736ccda66..a9b10e0fe0f 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -79,13 +79,14 @@ mkDispatchTracers => NodeKernelData blk -> Trace IO FormattedMessage -> Trace IO FormattedMessage + -> Tracer IO (ChainDB.TraceEvent blk) -> Maybe (Trace IO FormattedMessage) -> Trace IO DataPoint -> TraceConfig -> SomeConsensusProtocol -> IO (Tracers RemoteAddress LocalAddress blk IO) -mkDispatchTracers nodeKernel trBase trForward mbTrEKG trDataPoint trConfig p = do +mkDispatchTracers nodeKernel trBase trForward onChainDBEventTracer mbTrEKG trDataPoint trConfig p = do configReflection <- emptyConfigReflection @@ -175,6 +176,7 @@ mkDispatchTracers nodeKernel trBase trForward mbTrEKG trDataPoint trConfig p = d chainDBTracer = Tracer (traceWith chainDBTr') <> Tracer (traceWith replayBlockTr') <> Tracer (SR.traceNodeStateChainDB p nodeStateDP) + <> onChainDBEventTracer , consensusTracers = consensusTr , churnModeTracer = Tracer (traceWith churnModeTr) , nodeToClientTracers = nodeToClientTr diff --git a/cardano-node/src/Cardano/Snapshots/Run.hs b/cardano-node/src/Cardano/Snapshots/Run.hs index fcac909e362..b7bfa6ae1ec 100644 --- a/cardano-node/src/Cardano/Snapshots/Run.hs +++ b/cardano-node/src/Cardano/Snapshots/Run.hs @@ -4,26 +4,56 @@ module Cardano.Snapshots.Run ( canonicalizeSnapshots, + spawnCanonicalizer, NodeDatabasePaths, ) where import qualified Cardano.Api.Consensus as Api import Cardano.Node.Configuration.LedgerDB import Cardano.Node.Configuration.POM +import Cardano.Node.Parsers (nodeCLIParser) import Cardano.Node.Protocol import Cardano.Node.Types (ConfigYamlFilePath (..)) import Control.Exception -import Control.Monad (forM_) +import Control.Monad (forM_, void) +import Control.Monad.Class.MonadFork import Control.Monad.Except +import Data.Maybe (fromMaybe) import Data.Monoid (Last (..)) +import Options.Applicative import Ouroboros.Consensus.Cardano.SnapshotConversion import Ouroboros.Consensus.Node (NodeDatabasePaths (..), immutableDbPath) import System.Directory (doesFileExist, listDirectory) +import System.Environment import System.FilePath (()) +import System.IO (hPutStrLn, stderr) +import System.Process -canonicalizeSnapshots :: FilePath -> Maybe NodeDatabasePaths -> IO () +spawnCanonicalizer :: IO () +spawnCanonicalizer = + void $ forkIO $ do + putStrLn "SPAWNING" + progName <- getExecutablePath + putStrLn progName + mPnc <- execParserPure defaultPrefs (info nodeCLIParser mempty) <$> getArgs + case mPnc of + Success pnc -> do + let cfg = case getLast $ pncConfigFile pnc of + Nothing -> [] + Just (ConfigYamlFilePath cfgFile) -> ["--config", cfgFile] + db = case getLast $ pncDatabaseFile pnc of + Nothing -> [] + Just (OnePathForAllDbs p) -> ["--database-path", p] + Just (MultipleDbPaths imm _) -> ["--database-path", imm] + (_, out, err) <- + readProcessWithExitCode progName ("canonicalize-snapshots" : cfg ++ db) "" + putStrLn out + hPutStrLn stderr err + _ -> pure () + +canonicalizeSnapshots :: Maybe FilePath -> Maybe NodeDatabasePaths -> IO () canonicalizeSnapshots cfg (Last -> db) = do - configYamlPc <- parseNodeConfigurationFP $ Just $ ConfigYamlFilePath cfg + configYamlPc <- parseNodeConfigurationFP $ Just $ ConfigYamlFilePath $ fromMaybe "configuration/cardano/mainnet-config.json" cfg let cfgFromFile = defaultPartialNodeConfiguration <> configYamlPc