From 2260d524b53cfa0782dcbfabe268b31003b47cfd Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Thu, 29 Feb 2024 10:24:30 +0100 Subject: [PATCH 01/26] UTXO-HD ONE COMMIT --- .github/workflows/lmdb.pc | 11 + .gitignore | 5 +- cabal.project | 17 ++ cardano-node/cardano-node.cabal | 4 + .../Cardano/Node/Configuration/LedgerDB.hs | 89 ++++++ .../src/Cardano/Node/Configuration/POM.hs | 73 +++-- cardano-node/src/Cardano/Node/Parsers.hs | 87 +++++- cardano-node/src/Cardano/Node/Queries.hs | 28 +- cardano-node/src/Cardano/Node/Run.hs | 28 +- .../src/Cardano/Node/Tracing/StateRep.hs | 25 +- .../src/Cardano/Node/Tracing/Tracers.hs | 5 +- .../Tracing/Tracers/BlockReplayProgress.hs | 6 +- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 273 ++++++++++++------ .../Cardano/Node/Tracing/Tracers/Consensus.hs | 82 +++++- .../src/Cardano/Node/Tracing/Tracers/Peer.hs | 3 +- .../Cardano/Node/Tracing/Tracers/Resources.hs | 6 +- .../Tracing/Tracers/StartLeadershipCheck.hs | 16 +- cardano-node/src/Cardano/Tracing/Config.hs | 9 + .../Tracing/OrphanInstances/Consensus.hs | 217 ++++++++------ .../Tracing/OrphanInstances/Network.hs | 2 +- cardano-node/src/Cardano/Tracing/Tracers.hs | 67 +++-- cardano-node/test/Test/Cardano/Node/POM.hs | 12 + 22 files changed, 765 insertions(+), 300 deletions(-) create mode 100644 .github/workflows/lmdb.pc create mode 100644 cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs diff --git a/.github/workflows/lmdb.pc b/.github/workflows/lmdb.pc new file mode 100644 index 00000000000..fc4838ed478 --- /dev/null +++ b/.github/workflows/lmdb.pc @@ -0,0 +1,11 @@ +prefix=/usr/local +exec_prefix=${prefix} +libdir=${exec_prefix}/lib +includedir=${exec_prefix}/include + +Name: liblmdb +Description: Lightning Memory-Mapped Database +URL: https://symas.com/products/lightning-memory-mapped-database/ +Version: 0.9.29 +Libs: -L${libdir} -llmdb +Cflags: -I${includedir} \ No newline at end of file diff --git a/.gitignore b/.gitignore index 52c85c4f0c3..5f9e7137522 100644 --- a/.gitignore +++ b/.gitignore @@ -7,8 +7,7 @@ /cabal.project.old configuration/defaults/simpleview/genesis/ configuration/defaults/liveview/genesis/ -dist-newstyle/ -dist-profiled/ +dist-* dist/ *~ \#* @@ -24,7 +23,7 @@ stack.yaml.lock /db /db-[0-9] /logs -/mainnet +/mainnet* /profile /launch_* /state-* diff --git a/cabal.project b/cabal.project index df7fb2d8628..a45dc7554f2 100644 --- a/cabal.project +++ b/cabal.project @@ -32,6 +32,15 @@ packages: trace-resources trace-forward + ../ouroboros-consensus/ouroboros-consensus + ../ouroboros-consensus/ouroboros-consensus-cardano + ../ouroboros-consensus/ouroboros-consensus-diffusion + ../ouroboros-consensus/ouroboros-consensus-protocol + ../ouroboros-consensus/sop-extras + ../ouroboros-consensus/strict-sop-core + + ../cardano-api/cardano-api + program-options ghc-options: -Werror @@ -60,3 +69,11 @@ package plutus-scripts-bench -- temporary! Please read the section in CONTRIBUTING about updating dependencies. -- `smtp-mail` should depend on `crypton-connection` rather than `connection`! + +source-repository-package + type: git + location: https://github.com/jasagredo/latex-svg + tag: 05dc866baadcdd04a23ed1a488440372f97afb70 + --sha256: 1amaipl1f516m4yh9x02cqsbv50riszmbdjdmvfpw19vspv1szsx + subdir: + latex-svg-image diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index ae0a9a99030..110675aefce 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -70,6 +70,7 @@ library exposed-modules: Cardano.Node.Configuration.Logging Cardano.Node.Configuration.NodeAddress Cardano.Node.Configuration.POM + Cardano.Node.Configuration.LedgerDB Cardano.Node.Configuration.Socket Cardano.Node.Configuration.Topology Cardano.Node.Configuration.TopologyP2P @@ -201,6 +202,9 @@ library , stm , strict-sop-core , strict-stm + , sop-core + , sop-extras + , text >= 2.0 , time , trace-dispatcher ^>= 2.5 , trace-forward ^>= 2.2 diff --git a/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs new file mode 100644 index 00000000000..3ccd7408371 --- /dev/null +++ b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Node.Configuration.LedgerDB ( + BackingStoreSelectorFlag(..) + , Gigabytes + , toBytes + , defaultLMDBLimits + ) where + +import Prelude + +import qualified Data.Aeson.Types as Aeson (FromJSON) +import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB (LMDBLimits (..)) + +-- | Choose the LedgerDB Backend +-- +-- As of UTxO-HD, the LedgerDB now uses either an in-memory backend or LMDB to +-- keep track of differences in the UTxO set. +-- +-- - 'InMemory': uses more memory than the minimum requirements but is somewhat +-- faster. +-- - 'LMDB': uses less memory but is somewhat slower. +-- +-- See 'Ouroboros.Consnesus.Storage.LedgerDB.OnDisk.BackingStoreSelector'. +data BackingStoreSelectorFlag = + 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. + | InMemory + deriving (Eq, Show) + +-- | A number of gigabytes. +newtype Gigabytes = Gigabytes Int + deriving stock (Eq, Show) + deriving newtype (Read, Aeson.FromJSON) + +-- | Convert a number of Gigabytes to the equivalent number of bytes. +toBytes :: Gigabytes -> Int +toBytes (Gigabytes x) = x * 1024 * 1024 * 1024 + +-- | Recommended settings for the LMDB backing store. +-- +-- === @'lmdbMapSize'@ +-- The default @'LMDBLimits'@ uses an @'lmdbMapSize'@ of @1024 * 1024 * 1024 * 16@ +-- bytes, or 16 Gigabytes. @'lmdbMapSize'@ sets the size of the memory map +-- that is used internally by the LMDB backing store, and is also the +-- maximum size of the on-disk database. 16 GB should be sufficient for the +-- medium term, i.e., it is sufficient until a more performant alternative to +-- the LMDB backing store is implemented, which will probably replace the LMDB +-- backing store altogether. +-- +-- Note(jdral): It is recommended not to set the @'lmdbMapSize'@ to a value +-- that is much smaller than 16 GB through manual configuration: the node will +-- die with a fatal error as soon as the database size exceeds the +-- @'lmdbMapSize'@. If this fatal error were to occur, we would expect that +-- the node can continue normal operation if it is restarted with a higher +-- @'lmdbMapSize'@ configured. Nonetheless, this situation should be avoided. +-- +-- === @'lmdbMaxDatabases'@ +-- The @'lmdbMaxDatabases'@ is set to 10, which means that the LMDB backing +-- store will allow up @<= 10@ internal databases. We say /internal/ +-- databases, since they are not exposed outside the backing store interface, +-- such that from the outside view there is just one /logical/ database. +-- Two of these internal databases are reserved for normal operation of the +-- backing store, while the remaining databases will be used to store ledger +-- tables. At the moment, there is at most one ledger table that will be +-- stored in an internal database: the UTxO. Nonetheless, we set +-- @'lmdbMaxDatabases'@ to @10@ in order to future-proof these limits. +-- +-- === @'lmdbMaxReaders'@ +-- The @'lmdbMaxReaders'@ limit sets the maximum number of threads that can +-- read from the LMDB database. Currently, there should only be a single reader +-- active. Again, we set @'lmdbMaxReaders'@ to @16@ in order to future-proof +-- these limits. +-- +-- === References +-- For more information about LMDB limits, one should inspect: +-- * 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 + } diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index b81c9afc453..190c2f682fe 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -24,6 +24,7 @@ where import Cardano.Crypto (RequiresNetworkMagic (..)) import Cardano.Logging.Types +import Cardano.Node.Configuration.LedgerDB import Cardano.Node.Configuration.NodeAddress (SocketPath) import Cardano.Node.Configuration.Socket (SocketConfig (..)) import Cardano.Node.Handlers.Shutdown @@ -34,8 +35,9 @@ import Cardano.Tracing.OrphanInstances.Network () import Ouroboros.Consensus.Mempool (MempoolCapacityBytes (..), MempoolCapacityBytesOverride (..)) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) -import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (NumOfDiskSnapshots (..), - SnapshotInterval (..)) +import Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..), + QueryBatchSize (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (SnapshotInterval (..)) import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) @@ -102,9 +104,7 @@ data NodeConfiguration , ncProtocolConfig :: !NodeProtocolConfiguration -- Node parameters, not protocol-specific: - , ncDiffusionMode :: !DiffusionMode - , ncNumOfDiskSnapshots :: !NumOfDiskSnapshots - , ncSnapshotInterval :: !SnapshotInterval + , ncDiffusionMode :: !DiffusionMode -- | During the development and integration of new network protocols -- (node-to-node and node-to-client) we wish to be able to test them @@ -132,6 +132,12 @@ data NodeConfiguration , ncMaybeMempoolCapacityOverride :: !(Maybe MempoolCapacityBytesOverride) + -- LedgerDB configuration + , ncSnapshotInterval :: !SnapshotInterval + , ncLedgerDBBackend :: !BackingStoreSelectorFlag + , ncFlushFrequency :: !FlushFrequency + , ncQueryBatchSize :: !QueryBatchSize + -- | Protocol idleness timeout, see -- 'Ouroboros.Network.Diffusion.daProtocolIdleTimeout'. -- @@ -185,8 +191,6 @@ data PartialNodeConfiguration -- Node parameters, not protocol-specific: , pncDiffusionMode :: !(Last DiffusionMode ) - , pncNumOfDiskSnapshots :: !(Last NumOfDiskSnapshots) - , pncSnapshotInterval :: !(Last SnapshotInterval) , pncExperimentalProtocolsEnabled :: !(Last Bool) -- BlockFetch configuration @@ -202,6 +206,12 @@ data PartialNodeConfiguration -- Configuration for testing purposes , pncMaybeMempoolCapacityOverride :: !(Last MempoolCapacityBytesOverride) + -- LedgerDB configuration + , pncSnapshotInterval :: !(Last SnapshotInterval) + , pncLedgerDBBackend :: !(Last BackingStoreSelectorFlag) + , pncFlushFrequency :: !(Last FlushFrequency) + , pncQueryBatchSize :: !(Last QueryBatchSize) + -- Network timeouts , pncProtocolIdleTimeout :: !(Last DiffTime) , pncTimeWaitTimeout :: !(Last DiffTime) @@ -244,10 +254,6 @@ instance FromJSON PartialNodeConfiguration where pncSocketPath <- Last <$> v .:? "SocketPath" pncDiffusionMode <- Last . fmap getDiffusionMode <$> v .:? "DiffusionMode" - pncNumOfDiskSnapshots - <- Last . fmap RequestedNumOfDiskSnapshots <$> v .:? "NumOfDiskSnapshots" - pncSnapshotInterval - <- Last . fmap RequestedSnapshotInterval <$> v .:? "SnapshotInterval" pncExperimentalProtocolsEnabled <- fmap Last $ do mValue <- v .:? "ExperimentalProtocolsEnabled" @@ -289,6 +295,12 @@ instance FromJSON PartialNodeConfiguration where <*> parseHardForkProtocol v pncMaybeMempoolCapacityOverride <- Last <$> parseMempoolCapacityBytesOverride v + -- LedgerDB configuration + pncSnapshotInterval <- Last . fmap RequestedSnapshotInterval <$> v .:? "SnapshotInterval" + pncLedgerDBBackend <- Last <$> parseLedgerDBBackend v + pncFlushFrequency <- Last . fmap RequestedFlushFrequency <$> v .:? "FlushFrequency" + pncQueryBatchSize <- Last . fmap RequestedQueryBatchSize <$> v .:? "QueryBatchSize" + -- Network timeouts pncProtocolIdleTimeout <- Last <$> v .:? "ProtocolIdleTimeout" pncTimeWaitTimeout <- Last <$> v .:? "TimeWaitTimeout" @@ -325,8 +337,6 @@ instance FromJSON PartialNodeConfiguration where pncProtocolConfig , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty pncSocketPath , pncDiffusionMode - , pncNumOfDiskSnapshots - , pncSnapshotInterval , pncExperimentalProtocolsEnabled , pncMaxConcurrencyBulkSync , pncMaxConcurrencyDeadline @@ -342,6 +352,10 @@ instance FromJSON PartialNodeConfiguration where , pncShutdownConfig = mempty , pncStartAsNonProducingNode = Last $ Just False , pncMaybeMempoolCapacityOverride + , pncSnapshotInterval + , pncLedgerDBBackend + , pncFlushFrequency + , pncQueryBatchSize , pncProtocolIdleTimeout , pncTimeWaitTimeout , pncChainSyncIdleTimeout @@ -370,6 +384,17 @@ instance FromJSON PartialNodeConfiguration where , show invalid ] Nothing -> return Nothing + + parseLedgerDBBackend v = do + maybeString :: Maybe String <- v .:? "LedgerDBBackend" + case maybeString of + Just "InMemory" -> return $ Just InMemory + Just "LMDB" -> do + mapSize :: Maybe Gigabytes <- v .:? "LMDBMapSize" + return . Just . LMDB $ mapSize + Nothing -> return Nothing + Just whatever -> fail $ "Malformed LedgerDBBackend" <> whatever + parseByronProtocol v = do primary <- v .:? "ByronGenesisFile" secondary <- v .:? "GenesisFile" @@ -496,8 +521,6 @@ defaultPartialNodeConfiguration = , pncLoggingSwitch = Last $ Just True , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty mempty , pncDiffusionMode = Last $ Just InitiatorAndResponderDiffusionMode - , pncNumOfDiskSnapshots = Last $ Just DefaultNumOfDiskSnapshots - , pncSnapshotInterval = Last $ Just DefaultSnapshotInterval , pncExperimentalProtocolsEnabled = Last $ Just False , pncTopologyFile = Last . Just $ TopologyFile "configuration/cardano/mainnet-topology.json" , pncProtocolFiles = mempty @@ -511,6 +534,10 @@ defaultPartialNodeConfiguration = , pncTraceConfig = mempty , pncTraceForwardSocket = mempty , pncMaybeMempoolCapacityOverride = mempty + , pncSnapshotInterval = Last $ Just DefaultSnapshotInterval + , pncLedgerDBBackend = Last $ Just InMemory + , pncFlushFrequency = Last $ Just DefaultFlushFrequency + , pncQueryBatchSize = Last $ Just DefaultQueryBatchSize , pncProtocolIdleTimeout = Last (Just 5) , pncTimeWaitTimeout = Last (Just 60) , pncAcceptedConnectionsLimit = @@ -548,7 +575,6 @@ makeNodeConfiguration pnc = do logMetrics <- lastToEither "Missing LogMetrics" $ pncLogMetrics pnc traceConfig <- first Text.unpack $ partialTraceSelectionToEither $ pncTraceConfig pnc diffusionMode <- lastToEither "Missing DiffusionMode" $ pncDiffusionMode pnc - numOfDiskSnapshots <- lastToEither "Missing NumOfDiskSnapshots" $ pncNumOfDiskSnapshots pnc snapshotInterval <- lastToEither "Missing SnapshotInterval" $ pncSnapshotInterval pnc shutdownConfig <- lastToEither "Missing ShutdownConfig" $ pncShutdownConfig pnc socketConfig <- lastToEither "Missing SocketConfig" $ pncSocketConfig pnc @@ -574,6 +600,15 @@ makeNodeConfiguration pnc = do ncTargetNumberOfActiveBigLedgerPeers <- lastToEither "Missing TargetNumberOfActiveBigLedgerPeers" $ pncTargetNumberOfActiveBigLedgerPeers pnc + ncLedgerDBBackend <- + lastToEither "Missing LedgerDBBackend" + $ pncLedgerDBBackend pnc + ncFlushFrequency <- + lastToEither "Missing FlushFrequency" + $ pncFlushFrequency pnc + ncQueryBatchSize <- + lastToEither "Missing QueryBatchSize" + $ pncQueryBatchSize pnc ncProtocolIdleTimeout <- lastToEither "Missing ProtocolIdleTimeout" $ pncProtocolIdleTimeout pnc @@ -617,8 +652,6 @@ makeNodeConfiguration pnc = do , ncProtocolConfig = protocolConfig , ncSocketConfig = socketConfig , ncDiffusionMode = diffusionMode - , ncNumOfDiskSnapshots = numOfDiskSnapshots - , ncSnapshotInterval = snapshotInterval , ncExperimentalProtocolsEnabled = experimentalProtocols , ncMaxConcurrencyBulkSync = getLast $ pncMaxConcurrencyBulkSync pnc , ncMaxConcurrencyDeadline = getLast $ pncMaxConcurrencyDeadline pnc @@ -628,6 +661,10 @@ makeNodeConfiguration pnc = do else TracingOff , ncTraceForwardSocket = getLast $ pncTraceForwardSocket pnc , ncMaybeMempoolCapacityOverride = getLast $ pncMaybeMempoolCapacityOverride pnc + , ncSnapshotInterval = snapshotInterval + , ncLedgerDBBackend + , ncFlushFrequency + , ncQueryBatchSize , ncProtocolIdleTimeout , ncTimeWaitTimeout , ncChainSyncIdleTimeout diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index 2faf78ffd65..b4ef8cf9418 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -22,8 +22,6 @@ import Cardano.Node.Types import Cardano.Prelude (ConvertText (..)) import Ouroboros.Consensus.Mempool (MempoolCapacityBytes (..), MempoolCapacityBytesOverride (..)) -import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (NumOfDiskSnapshots (..), - SnapshotInterval (..)) import Data.Foldable import Data.Maybe (fromMaybe) @@ -37,6 +35,12 @@ import qualified Options.Applicative.Help as OptI import System.Posix.Types (Fd (..)) import Text.Read (readMaybe) +import Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..), + QueryBatchSize (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (SnapshotInterval (..)) + +import Cardano.Node.Configuration.LedgerDB + nodeCLIParser :: Parser PartialNodeConfiguration nodeCLIParser = subparser ( commandGroup "Run the node" @@ -70,8 +74,6 @@ nodeRunParser = do -- NodeConfiguration filepath nodeConfigFp <- lastOption parseConfigFile - numOfDiskSnapshots <- lastOption parseNumOfDiskSnapshots - snapshotInterval <- lastOption parseSnapshotInterval validate <- lastOption parseValidateDB shutdownIPC <- lastOption parseShutdownIPC @@ -79,6 +81,12 @@ nodeRunParser = do maybeMempoolCapacityOverride <- lastOption parseMempoolCapacityOverride + -- LedgerDB configuration + snapshotInterval <- lastOption parseSnapshotInterval + ledgerDBBackend <- lastOption parseLedgerDBBackend + pncFlushFrequency <- lastOption parseFlushFrequency + pncQueryBatchSize <- lastOption parseQueryBatchSize + pure $ PartialNodeConfiguration { pncSocketConfig = Last . Just $ SocketConfig @@ -90,8 +98,6 @@ nodeRunParser = do , pncTopologyFile = TopologyFile <$> topFp , pncDatabaseFile = DbFile <$> dbFp , pncDiffusionMode = mempty - , pncNumOfDiskSnapshots = numOfDiskSnapshots - , pncSnapshotInterval = snapshotInterval , pncExperimentalProtocolsEnabled = mempty , pncProtocolFiles = Last $ Just ProtocolFilepaths { byronCertFile @@ -113,6 +119,10 @@ nodeRunParser = do , pncTraceConfig = mempty , pncTraceForwardSocket = traceForwardSocket , pncMaybeMempoolCapacityOverride = maybeMempoolCapacityOverride + , pncSnapshotInterval = snapshotInterval + , pncLedgerDBBackend = ledgerDBBackend + , pncFlushFrequency + , pncQueryBatchSize , pncProtocolIdleTimeout = mempty , pncTimeWaitTimeout = mempty , pncChainSyncIdleTimeout = mempty @@ -221,9 +231,63 @@ parseMempoolCapacityOverride = parseOverride <|> parseNoOverride parseNoOverride = flag' NoMempoolCapacityBytesOverride ( long "no-mempool-capacity-override" - <> help "The port number" + <> help "Don't override the mempool capacity" ) +parseLedgerDBBackend :: Parser BackingStoreSelectorFlag +parseLedgerDBBackend = parseInMemory <|> parseLMDB <*> optional parseMapSize + where + parseInMemory :: Parser BackingStoreSelectorFlag + parseInMemory = + flag' InMemory ( long "in-memory-ledger-db-backend" + <> help "Use the InMemory ledger DB backend. \ + \ Incompatible with `--lmdb-ledger-db-backend`. \ + \ The node uses the in-memory backend by default \ + \ if no ``--*-db-backend`` flags are set." + ) + + parseLMDB :: Parser (Maybe Gigabytes -> BackingStoreSelectorFlag) + parseLMDB = + flag' LMDB ( long "lmdb-ledger-db-backend" + <> help "Use the LMDB ledger DB backend. By default, the \ + \ mapsize (maximum database size) of the backend \ + \ is set to 16 Gigabytes. Warning: if the database \ + \ size exceeds the given mapsize, the node will \ + \ abort. Therefore, the mapsize should be set to a \ + \ value high enough to guarantee that the maximum \ + \ database size will not be reached during the \ + \ expected node uptime. \ + \ Incompatible with `--in-memory-ledger-db-backend`." + ) + + parseMapSize :: Parser Gigabytes + parseMapSize = + option auto ( + long "lmdb-mapsize" + <> metavar "NR_GIGABYTES" + <> help "The maximum database size defined in number of Gigabytes." + ) + +parseFlushFrequency :: Parser FlushFrequency +parseFlushFrequency = RequestedFlushFrequency <$> + option auto ( + long "flush-frequency" + <> metavar "WORD" + <> help "Flush parts of the ledger state to disk after WORD blocks have \ + \moved into the immutable part of the chain. This should be at \ + \least 0." + ) + +parseQueryBatchSize :: Parser QueryBatchSize +parseQueryBatchSize = RequestedQueryBatchSize <$> + option auto ( + long "query-batch-size" + <> metavar "WORD" + <> help "When reading large amounts of ledger state data from disk for a \ + \ledger state query, perform reads in batches of WORD size. This \ + \should be at least 1." + ) + parseDbPath :: Parser FilePath parseDbPath = strOption @@ -330,15 +394,6 @@ parseStartAsNonProducingNode = ] ] -parseNumOfDiskSnapshots :: Parser NumOfDiskSnapshots -parseNumOfDiskSnapshots = fmap RequestedNumOfDiskSnapshots parseNum - where - parseNum = Opt.option auto - ( long "num-of-disk-snapshots" - <> metavar "NUMOFDISKSNAPSHOTS" - <> help "Number of ledger snapshots stored on disk." - ) - -- TODO revisit because it sucks parseSnapshotInterval :: Parser SnapshotInterval parseSnapshotInterval = fmap (RequestedSnapshotInterval . secondsToDiffTime) parseDifftime diff --git a/cardano-node/src/Cardano/Node/Queries.hs b/cardano-node/src/Cardano/Node/Queries.hs index 4424333367c..561cff85f85 100644 --- a/cardano-node/src/Cardano/Node/Queries.hs +++ b/cardano-node/src/Cardano/Node/Queries.hs @@ -36,6 +36,14 @@ module Cardano.Node.Queries , fromSMaybe ) where +import Control.Monad.STM (atomically) +import Data.ByteString (ByteString) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.Map.Strict as Map +import Data.SOP +import Data.SOP.Functors +import Data.Word (Word64) + import qualified Cardano.Chain.Block as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto.Hash as Crypto @@ -59,7 +67,7 @@ import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (OneEraForgeStateInfo (..), OneEraForgeStateUpdateError (..)) import Ouroboros.Consensus.HardFork.Combinator.Embed.Unary -import Ouroboros.Consensus.Ledger.Abstract (IsLedger) +import Ouroboros.Consensus.Ledger.Abstract (EmptyMK) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import Ouroboros.Consensus.Node (NodeKernel (..)) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey @@ -74,13 +82,6 @@ import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.NodeToClient (LocalConnectionId) import Ouroboros.Network.NodeToNode (RemoteAddress, RemoteConnectionId) -import Control.Monad.STM (atomically) -import Data.ByteString (ByteString) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import qualified Data.Map.Strict as Map -import Data.SOP -import Data.Word (Word64) - -- -- * TxId -> ByteString projection -- @@ -229,8 +230,8 @@ instance All GetKESInfo xs => GetKESInfo (HardForkBlock xs) where -- * General ledger -- class LedgerQueries blk where - ledgerUtxoSize :: LedgerState blk -> Int - ledgerDelegMapSize :: LedgerState blk -> Int + ledgerUtxoSize :: LedgerState blk EmptyMK -> Int + ledgerDelegMapSize :: LedgerState blk EmptyMK -> Int instance LedgerQueries Byron.ByronBlock where ledgerUtxoSize = Map.size . Byron.unUTxO . Byron.cvsUtxo . Byron.byronLedgerState @@ -256,8 +257,8 @@ instance LedgerQueries (Shelley.ShelleyBlock protocol era) where instance (LedgerQueries x, NoHardForks x) => LedgerQueries (HardForkBlock '[x]) where - ledgerUtxoSize = ledgerUtxoSize . project - ledgerDelegMapSize = ledgerDelegMapSize . project + ledgerUtxoSize = ledgerUtxoSize . unFlip . project . Flip + ledgerDelegMapSize = ledgerDelegMapSize . unFlip . project . Flip instance LedgerQueries (Cardano.CardanoBlock c) where ledgerUtxoSize = \case @@ -302,8 +303,7 @@ mapNodeKernelDataIO f (NodeKernelData ref) = readIORef ref >>= traverse f nkQueryLedger :: - IsLedger (LedgerState blk) - => (ExtLedgerState blk -> a) + (ExtLedgerState blk EmptyMK -> a) -> NodeKernel IO RemoteAddress LocalConnectionId blk -> IO a nkQueryLedger f NodeKernel{getChainDB} = diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 1b474f7c14c..8e9b4c552e5 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -22,6 +22,7 @@ module Cardano.Node.Run , checkVRFFilePermissions ) where +import qualified Ouroboros.Consensus.Storage.LedgerDB.Impl.Args as LDBArgs import Cardano.Api (File (..), FileDirection (..)) import qualified Cardano.Api as Api @@ -46,6 +47,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Monoid (Last (..)) import Data.Proxy (Proxy (..)) +import Data.SOP.Dict import Data.Text (Text, breakOn, pack) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -89,10 +91,11 @@ import Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..)) import qualified Ouroboros.Consensus.Config as Consensus import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..)) -import Ouroboros.Consensus.Node (DiskPolicyArgs (..), NetworkP2PMode (..), +import Ouroboros.Consensus.Node (NetworkP2PMode (..), RunNodeArgs (..), StdRunNodeArgs (..), stdChainSyncTimeout) import qualified Ouroboros.Consensus.Node as Node (getChainDB, run) import Ouroboros.Consensus.Node.NetworkProtocolVersion +import qualified Ouroboros.Consensus.Node.Tracers as Consensus import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Util.Orphans () import qualified Ouroboros.Network.Diffusion as Diffusion @@ -129,6 +132,10 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Type (UseLedgerPeer import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers) +import Cardano.Node.Configuration.LedgerDB +import Ouroboros.Consensus.Storage.LedgerDB.V2.Args +import Ouroboros.Consensus.Util.Args + {- HLINT ignore "Fuse concatMap/map" -} {- HLINT ignore "Redundant <$>" -} {- HLINT ignore "Use fewer imports" -} @@ -473,6 +480,10 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do (readTVar publicRootsVar) (readTVar useLedgerVar) (readTVar useBootstrapVar) + + srnL :: Complete LedgerDbFlavorArgs IO + srnL = V2Args InMemoryHandleArgs + in Node.run nodeArgs { @@ -486,7 +497,6 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do { srnBfcMaxConcurrencyBulkSync = unMaxConcurrencyBulkSync <$> ncMaxConcurrencyBulkSync nc , srnBfcMaxConcurrencyDeadline = unMaxConcurrencyDeadline <$> ncMaxConcurrencyDeadline nc , srnChainDbValidateOverride = ncValidateDB nc - , srnDiskPolicyArgs = diskPolicyArgs , srnDatabasePath = dbPath , srnDiffusionArguments = diffusionArguments , srnDiffusionArgumentsExtra = diffusionArgumentsExtra @@ -496,6 +506,8 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , srnTraceChainDB = chainDBTracer tracers , srnMaybeMempoolCapacityOverride = ncMaybeMempoolCapacityOverride nc , srnChainSyncTimeout = customizeChainSyncTimeout + , srnSnapshotInterval = ncSnapshotInterval nc + , srnLdbFlavorArgs = LDBArgs.LedgerDbFlavorArgsV2 srnL } DisabledP2PMode -> do nt <- TopologyNonP2P.readTopologyFileOrError nc @@ -535,6 +547,9 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , rnPeerSharing = ncPeerSharing nc , rnGetUseBootstrapPeers = pure DontUseBootstrapPeers } + + srnL :: Complete LedgerDbFlavorArgs IO + srnL = V2Args InMemoryHandleArgs #ifdef UNIX -- initial `SIGHUP` handler; it only warns that neither updating of -- topology is supported nor updating block forging is yet possible. @@ -559,7 +574,6 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do { srnBfcMaxConcurrencyBulkSync = unMaxConcurrencyBulkSync <$> ncMaxConcurrencyBulkSync nc , srnBfcMaxConcurrencyDeadline = unMaxConcurrencyDeadline <$> ncMaxConcurrencyDeadline nc , srnChainDbValidateOverride = ncValidateDB nc - , srnDiskPolicyArgs = diskPolicyArgs , srnDatabasePath = dbPath , srnDiffusionArguments = diffusionArguments , srnDiffusionArgumentsExtra = mkNonP2PArguments ipProducers dnsProducers @@ -569,6 +583,8 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , srnTraceChainDB = chainDBTracer tracers , srnChainSyncTimeout = customizeChainSyncTimeout , srnMaybeMempoolCapacityOverride = ncMaybeMempoolCapacityOverride nc + , srnSnapshotInterval = ncSnapshotInterval nc + , srnLdbFlavorArgs = LDBArgs.LedgerDbFlavorArgsV2 srnL } where @@ -628,12 +644,6 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do Nothing -> id Just version_ -> Map.takeWhileAntitone (<= version_) - diskPolicyArgs :: DiskPolicyArgs - diskPolicyArgs = - DiskPolicyArgs - (ncSnapshotInterval nc) - (ncNumOfDiskSnapshots nc) - -------------------------------------------------------------------------------- -- SIGHUP Handlers -------------------------------------------------------------------------------- diff --git a/cardano-node/src/Cardano/Node/Tracing/StateRep.hs b/cardano-node/src/Cardano/Node/Tracing/StateRep.hs index b34e63ec717..3553a5bcad5 100644 --- a/cardano-node/src/Cardano/Node/Tracing/StateRep.hs +++ b/cardano-node/src/Cardano/Node/Tracing/StateRep.hs @@ -32,6 +32,7 @@ import qualified Ouroboros.Consensus.Node.NetworkProtocolVersion as NPV import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal import qualified Ouroboros.Consensus.Storage.LedgerDB as LgrDb +import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import Ouroboros.Network.Block (pointSlot) import Control.DeepSeq (NFData) @@ -40,6 +41,8 @@ import Data.Text (Text) import Data.Time.Clock import Data.Time.Clock.POSIX import GHC.Generics (Generic) +import Cardano.Slotting.Slot (withOrigin) +import Cardano.Tracing.OrphanInstances.Network () deriving instance FromJSON ChunkNo @@ -59,8 +62,8 @@ data OpeningDbs deriving instance (NFData OpeningDbs) data Replays - = ReplayFromGenesis (WithOrigin SlotNo) - | ReplayFromSnapshot SlotNo (WithOrigin SlotNo) (WithOrigin SlotNo) + = ReplayFromGenesis + | ReplayFromSnapshot SlotNo | ReplayedBlock SlotNo (WithOrigin SlotNo) (WithOrigin SlotNo) deriving (Generic, FromJSON, ToJSON) @@ -208,21 +211,23 @@ traceNodeStateChainDB _scp tr ev = traceWith tr $ NodeOpeningDbs $ OpenedImmutableDB (pointSlot p) chunk ChainDB.StartedOpeningVolatileDB -> traceWith tr $ NodeOpeningDbs StartedOpeningVolatileDB - ChainDB.OpenedVolatileDB -> + ChainDB.OpenedVolatileDB {} -> traceWith tr $ NodeOpeningDbs OpenedVolatileDB ChainDB.StartedOpeningLgrDB -> traceWith tr $ NodeOpeningDbs StartedOpeningLgrDB ChainDB.OpenedLgrDB -> traceWith tr $ NodeOpeningDbs OpenedLgrDB _ -> return () - ChainDB.TraceLedgerReplayEvent ev' -> + ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerReplayEvent ev') -> case ev' of - LgrDb.ReplayFromGenesis (LgrDb.ReplayGoal p) -> - traceWith tr $ NodeReplays $ ReplayFromGenesis (pointSlot p) - LgrDb.ReplayFromSnapshot _ (RP.RealPoint s _) (LgrDb.ReplayStart rs) (LgrDb.ReplayGoal rp) -> - traceWith tr $ NodeReplays $ ReplayFromSnapshot s (pointSlot rs) (pointSlot rp) - LgrDb.ReplayedBlock (RP.RealPoint s _) _ (LgrDb.ReplayStart rs) (LgrDb.ReplayGoal rp) -> - traceWith tr $ NodeReplays $ ReplayedBlock s (pointSlot rs) (pointSlot rp) + LedgerDB.TraceReplayStartEvent ev'' -> case ev'' of + LgrDb.ReplayFromGenesis -> + traceWith tr $ NodeReplays $ ReplayFromGenesis + LgrDb.ReplayFromSnapshot _ (LgrDb.ReplayStart rs) -> + traceWith tr $ NodeReplays $ ReplayFromSnapshot (withOrigin undefined id $ pointSlot rs) + LedgerDB.TraceReplayProgressEvent ev'' -> case ev'' of + LgrDb.ReplayedBlock (RP.RealPoint s _) _ (LgrDb.ReplayStart rs) (LgrDb.ReplayGoal rp) -> + traceWith tr $ NodeReplays $ ReplayedBlock s (pointSlot rs) (pointSlot rp) ChainDB.TraceInitChainSelEvent ev' -> case ev' of ChainDB.StartedInitChainSelection -> diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index b62ed90e8ac..73ad97280fc 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -127,8 +127,9 @@ mkDispatchTracers nodeKernel trBase trForward mbTrEKG trDataPoint trConfig enabl configureTracers configReflection trConfig [chainDBTr] -- Filter out replayed blocks for this tracer let chainDBTr' = filterTrace - (\case (_, ChainDB.TraceLedgerReplayEvent - LedgerDB.ReplayedBlock {}) -> False + (\case (_, ChainDB.TraceLedgerDBEvent + (LedgerDB.LedgerReplayEvent (LedgerDB.TraceReplayProgressEvent + (LedgerDB.ReplayedBlock {})))) -> False (_, _) -> True) chainDBTr diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/BlockReplayProgress.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/BlockReplayProgress.hs index 5365bc19793..87fabf8c80d 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/BlockReplayProgress.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/BlockReplayProgress.hs @@ -74,8 +74,10 @@ replayBlockStats :: MonadIO m -> ChainDB.TraceEvent blk -> m ReplayBlockStats replayBlockStats ReplayBlockStats {..} _context - (ChainDB.TraceLedgerReplayEvent (LedgerDB.ReplayedBlock pt [] - (LedgerDB.ReplayStart replayTo) _)) = do + (ChainDB.TraceLedgerDBEvent + (LedgerDB.LedgerReplayEvent + (LedgerDB.TraceReplayProgressEvent + (LedgerDB.ReplayedBlock pt [] (LedgerDB.ReplayStart replayTo) _)))) = do let slotno = toInteger $ unSlotNo (realPointSlot pt) endslot = toInteger $ withOrigin 0 unSlotNo (pointSlot replayTo) progress' = (fromInteger slotno * 100.0) / fromInteger (max slotno endslot) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 66944e99d24..80c0fe198c4 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -19,6 +19,8 @@ import Cardano.Node.Tracing.Era.Shelley () import Cardano.Node.Tracing.Formatting () import Cardano.Node.Tracing.Render import Cardano.Prelude (maximumDef) + +import Ouroboros.Network.Block (MaxSlotNo(..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.HeaderValidation (HeaderEnvelopeError (..), HeaderError (..), OtherHeaderEnvelopeError) @@ -32,8 +34,8 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmDB import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (chunkNoToInt) import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB -import Ouroboros.Consensus.Storage.LedgerDB (UpdateLedgerDbTraceEvent (..)) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots as LedgerDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolDB import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.Enclose @@ -86,8 +88,7 @@ instance ( LogFormatting (Header blk) forHuman (ChainDB.TraceInitChainSelEvent v) = forHumanOrMachine v forHuman (ChainDB.TraceOpenEvent v) = forHumanOrMachine v forHuman (ChainDB.TraceIteratorEvent v) = forHumanOrMachine v - forHuman (ChainDB.TraceSnapshotEvent v) = forHumanOrMachine v - forHuman (ChainDB.TraceLedgerReplayEvent v) = forHumanOrMachine v + forHuman (ChainDB.TraceLedgerDBEvent v) = forHumanOrMachine v forHuman (ChainDB.TraceImmutableDBEvent v) = forHumanOrMachine v forHuman (ChainDB.TraceVolatileDBEvent v) = forHumanOrMachine v @@ -105,9 +106,7 @@ instance ( LogFormatting (Header blk) forMachine details v forMachine details (ChainDB.TraceIteratorEvent v) = forMachine details v - forMachine details (ChainDB.TraceSnapshotEvent v) = - forMachine details v - forMachine details (ChainDB.TraceLedgerReplayEvent v) = + forMachine details (ChainDB.TraceLedgerDBEvent v) = forMachine details v forMachine details (ChainDB.TraceImmutableDBEvent v) = forMachine details v @@ -121,8 +120,7 @@ instance ( LogFormatting (Header blk) asMetrics (ChainDB.TraceInitChainSelEvent v) = asMetrics v asMetrics (ChainDB.TraceOpenEvent v) = asMetrics v asMetrics (ChainDB.TraceIteratorEvent v) = asMetrics v - asMetrics (ChainDB.TraceSnapshotEvent v) = asMetrics v - asMetrics (ChainDB.TraceLedgerReplayEvent v) = asMetrics v + asMetrics (ChainDB.TraceLedgerDBEvent v) = asMetrics v asMetrics (ChainDB.TraceImmutableDBEvent v) = asMetrics v asMetrics (ChainDB.TraceVolatileDBEvent v) = asMetrics v @@ -142,10 +140,8 @@ instance MetaTrace (ChainDB.TraceEvent blk) where nsPrependInner "OpenEvent" (namespaceFor ev) namespaceFor (ChainDB.TraceIteratorEvent ev) = nsPrependInner "IteratorEvent" (namespaceFor ev) - namespaceFor (ChainDB.TraceSnapshotEvent ev) = + namespaceFor (ChainDB.TraceLedgerDBEvent ev) = nsPrependInner "LedgerEvent" (namespaceFor ev) - namespaceFor (ChainDB.TraceLedgerReplayEvent ev) = - nsPrependInner "LedgerReplay" (namespaceFor ev) namespaceFor (ChainDB.TraceImmutableDBEvent ev) = nsPrependInner "ImmDbEvent" (namespaceFor ev) namespaceFor (ChainDB.TraceVolatileDBEvent ev) = @@ -179,14 +175,10 @@ instance MetaTrace (ChainDB.TraceEvent blk) where severityFor (Namespace out tl) (Just ev') severityFor (Namespace out ("IteratorEvent" : tl)) Nothing = severityFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) Nothing - severityFor (Namespace out ("LedgerEvent" : tl)) (Just (ChainDB.TraceSnapshotEvent ev')) = + severityFor (Namespace out ("LedgerEvent" : tl)) (Just (ChainDB.TraceLedgerDBEvent ev')) = severityFor (Namespace out tl) (Just ev') severityFor (Namespace out ("LedgerEvent" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) Nothing - severityFor (Namespace out ("LedgerReplay" : tl)) (Just (ChainDB.TraceLedgerReplayEvent ev')) = - severityFor (Namespace out tl) (Just ev') - severityFor (Namespace out ("LedgerReplay" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) Nothing + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceLedgerDBEvent blk)) Nothing severityFor (Namespace out ("ImmDbEvent" : tl)) (Just (ChainDB.TraceImmutableDBEvent ev')) = severityFor (Namespace out tl) (Just ev') severityFor (Namespace out ("ImmDbEvent" : tl)) Nothing = @@ -225,14 +217,10 @@ instance MetaTrace (ChainDB.TraceEvent blk) where privacyFor (Namespace out tl) (Just ev') privacyFor (Namespace out ("IteratorEvent" : tl)) Nothing = privacyFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) Nothing - privacyFor (Namespace out ("LedgerEvent" : tl)) (Just (ChainDB.TraceSnapshotEvent ev')) = + privacyFor (Namespace out ("LedgerEvent" : tl)) (Just (ChainDB.TraceLedgerDBEvent ev')) = privacyFor (Namespace out tl) (Just ev') privacyFor (Namespace out ("LedgerEvent" : tl)) Nothing = - privacyFor (Namespace out tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) Nothing - privacyFor (Namespace out ("LedgerReplay" : tl)) (Just (ChainDB.TraceLedgerReplayEvent ev')) = - privacyFor (Namespace out tl) (Just ev') - privacyFor (Namespace out ("LedgerReplay" : tl)) Nothing = - privacyFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) Nothing + privacyFor (Namespace out tl :: Namespace (LedgerDB.TraceLedgerDBEvent blk)) Nothing privacyFor (Namespace out ("ImmDbEvent" : tl)) (Just (ChainDB.TraceImmutableDBEvent ev')) = privacyFor (Namespace out tl) (Just ev') privacyFor (Namespace out ("ImmDbEvent" : tl)) Nothing = @@ -271,14 +259,10 @@ instance MetaTrace (ChainDB.TraceEvent blk) where detailsFor (Namespace out tl) (Just ev') detailsFor (Namespace out ("IteratorEvent" : tl)) Nothing = detailsFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) Nothing - detailsFor (Namespace out ("LedgerEvent" : tl)) (Just (ChainDB.TraceSnapshotEvent ev')) = + detailsFor (Namespace out ("LedgerEvent" : tl)) (Just (ChainDB.TraceLedgerDBEvent ev')) = detailsFor (Namespace out tl) (Just ev') detailsFor (Namespace out ("LedgerEvent" : tl)) Nothing = detailsFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) Nothing - detailsFor (Namespace out ("LedgerReplay" : tl)) (Just (ChainDB.TraceLedgerReplayEvent ev')) = - detailsFor (Namespace out tl) (Just ev') - detailsFor (Namespace out ("LedgerReplay" : tl)) Nothing = - detailsFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) Nothing detailsFor (Namespace out ("ImmDbEvent" : tl)) (Just (ChainDB.TraceImmutableDBEvent ev')) = detailsFor (Namespace out tl) (Just ev') detailsFor (Namespace out ("ImmDbEvent" : tl)) Nothing = @@ -304,7 +288,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where metricsDocFor (Namespace out ("IteratorEvent" : tl)) = metricsDocFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) metricsDocFor (Namespace out ("LedgerEvent" : tl)) = - metricsDocFor (Namespace out tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) + metricsDocFor (Namespace out tl :: Namespace (LedgerDB.TraceLedgerDBEvent blk)) metricsDocFor (Namespace out ("LedgerReplay" : tl)) = metricsDocFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) metricsDocFor (Namespace out ("ImmDbEvent" : tl)) = @@ -328,7 +312,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where documentFor (Namespace out ("IteratorEvent" : tl)) = documentFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) documentFor (Namespace out ("LedgerEvent" : tl)) = - documentFor (Namespace out tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) + documentFor (Namespace out tl :: Namespace (LedgerDB.TraceLedgerDBEvent blk)) documentFor (Namespace out ("LedgerReplay" : tl)) = documentFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) documentFor (Namespace out ("ImmDbEvent" : tl)) = @@ -353,7 +337,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where ++ map (nsPrependInner "IteratorEvent") (allNamespaces :: [Namespace (ChainDB.TraceIteratorEvent blk)]) ++ map (nsPrependInner "LedgerEvent") - (allNamespaces :: [Namespace (LedgerDB.TraceSnapshotEvent blk)]) + (allNamespaces :: [Namespace (LedgerDB.TraceLedgerDBEvent blk)]) ++ map (nsPrependInner "LedgerReplay") (allNamespaces :: [Namespace (LedgerDB.TraceReplayEvent blk)]) ++ map (nsPrependInner "ImmDbEvent") @@ -394,8 +378,6 @@ instance ( LogFormatting (Header blk) "Popping block from queue" FallingEdgeWith pt -> "Popped block from queue: " <> renderRealPointAsPhrase pt - forHuman (ChainDB.BlockInTheFuture pt slot) = - "Ignoring block from future: " <> renderRealPointAsPhrase pt <> ", slot " <> condenseT slot forHuman (ChainDB.StoreButDontChange pt) = "Ignoring block: " <> renderRealPointAsPhrase pt forHuman (ChainDB.TryAddToCurrentChain pt) = @@ -439,10 +421,6 @@ instance ( LogFormatting (Header blk) , case edgePt of RisingEdge -> "risingEdge" .= True FallingEdgeWith pt -> "block" .= forMachine dtal pt ] - forMachine dtal (ChainDB.BlockInTheFuture pt slot) = - mconcat [ "kind" .= String "BlockInTheFuture" - , "block" .= forMachine dtal pt - , "slot" .= forMachine dtal slot ] forMachine dtal (ChainDB.StoreButDontChange pt) = mconcat [ "kind" .= String "StoreButDontChange" , "block" .= forMachine dtal pt ] @@ -526,8 +504,6 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where Namespace [] ["AddedBlockToQueue"] namespaceFor ChainDB.PoppedBlockFromQueue {} = Namespace [] ["PoppedBlockFromQueue"] - namespaceFor ChainDB.BlockInTheFuture {} = - Namespace [] ["BlockInTheFuture"] namespaceFor ChainDB.AddedBlockToVolatileDB {} = Namespace [] ["AddedBlockToVolatileDB"] namespaceFor ChainDB.TryAddToCurrentChain {} = @@ -1044,7 +1020,7 @@ instance ( LedgerSupportsProtocol blk renderPointAsPhrase (AF.headPoint c) <> ", slots " <> Text.intercalate ", " (map (renderPoint . headerPoint) hdrs) forHuman (ChainDB.UpdateLedgerDbTraceEvent - (StartedPushingBlockToTheLedgerDb + (LedgerDB.StartedPushingBlockToTheLedgerDb (LedgerDB.PushStart start) (LedgerDB.PushGoal goal) (LedgerDB.Pushing curr))) = @@ -1073,7 +1049,7 @@ instance ( LedgerSupportsProtocol blk , "block" .= renderPointForDetails dtal (AF.headPoint c) , "headers" .= map (renderPointForDetails dtal . headerPoint) hdrs ] forMachine _dtal (ChainDB.UpdateLedgerDbTraceEvent - (StartedPushingBlockToTheLedgerDb + (LedgerDB.StartedPushingBlockToTheLedgerDb (LedgerDB.PushStart start) (LedgerDB.PushGoal goal) (LedgerDB.Pushing curr))) = @@ -1146,7 +1122,9 @@ instance ConvertRawHash blk forHuman (ChainDB.OpenedImmutableDB immTip chunk) = "Opened imm db with immutable tip at " <> renderPointAsPhrase immTip <> " and chunk " <> showT chunk - forHuman ChainDB.OpenedVolatileDB = "Opened vol db" + forHuman (ChainDB.OpenedVolatileDB mx) = "Opened " <> case mx of + NoMaxSlotNo -> "empty Volatile DB" + MaxSlotNo mxx -> "Volatile DB with max slot seen " <> showT mxx forHuman ChainDB.OpenedLgrDB = "Opened lgr db" forHuman ChainDB.StartedOpeningDB = "Started opening Chain DB" forHuman ChainDB.StartedOpeningImmutableDB = "Started opening Immutable DB" @@ -1165,7 +1143,7 @@ instance ConvertRawHash blk mconcat [ "kind" .= String "OpenedImmutableDB" , "immtip" .= forMachine dtal immTip , "epoch" .= String ((Text.pack . show) epoch) ] - forMachine _dtal ChainDB.OpenedVolatileDB = + forMachine _dtal ChainDB.OpenedVolatileDB {} = mconcat [ "kind" .= String "OpenedVolatileDB" ] forMachine _dtal ChainDB.OpenedLgrDB = mconcat [ "kind" .= String "OpenedLgrDB" ] @@ -1220,13 +1198,13 @@ instance MetaTrace (ChainDB.TraceOpenEvent blk) where documentFor (Namespace _ ["OpenedLgrDB"]) = Just "The LedgerDB was opened." documentFor (Namespace _ ["StartedOpeningDB"]) = Just - "" + "The ChainDB is being opened." documentFor (Namespace _ ["StartedOpeningImmutableDB"]) = Just - "" + "The ImmDB is being opened." documentFor (Namespace _ ["StartedOpeningVolatileDB"]) = Just - "" + "The VolatileDB is being opened." documentFor (Namespace _ ["StartedOpeningLgrDB"]) = Just - "" + "The LedgerDB is being opened." documentFor _ = Nothing allNamespaces = @@ -1440,19 +1418,65 @@ instance MetaTrace (ChainDB.UnknownRange blk) where ] -- -------------------------------------------------------------------------------- --- -- LedgerDB.TraceSnapshotEvent +-- -- LedgerDB.TraceLedgerDBEvent -- -------------------------------------------------------------------------------- +instance ( StandardHash blk + , ConvertRawHash blk) + => LogFormatting (LedgerDB.TraceLedgerDBEvent blk) where + + forMachine dtals (LedgerDB.LedgerDBSnapshotEvent ev) = + mconcat [ "kind" .= String "SnapshotEvent" + , "event" .= forMachine dtals ev + ] + forMachine dtals (LedgerDB.LedgerReplayEvent ev) = + mconcat [ "kind" .= String "ReplayEvent" + , "event" .= forMachine dtals ev + ] + forMachine _dtals (LedgerDB.LedgerDBForkerEvent (LedgerDB.TraceForkerEventWithKey k ev)) = + mconcat [ "kind" .= String "ForkerEvent" + , "key" .= show k + , "event" .= show ev + ] + forMachine _dtals (LedgerDB.LedgerDBFlavorImplEvent ev) = + mconcat [ "kind" .= String "FlavorEvent" + , "event" .= show ev + ] + + forHuman (LedgerDB.LedgerDBSnapshotEvent ev) = forHuman ev + forHuman (LedgerDB.LedgerReplayEvent ev) = forHuman ev + forHuman (LedgerDB.LedgerDBForkerEvent (LedgerDB.TraceForkerEventWithKey k ev)) = "Forker " <> showT k <> ": " <> showT ev + forHuman (LedgerDB.LedgerDBFlavorImplEvent ev) = showT ev + +instance MetaTrace (LedgerDB.TraceLedgerDBEvent blk) where + + namespaceFor (LedgerDB.LedgerDBSnapshotEvent ev) = + nsPrependInner "Snapshot" (namespaceFor ev) + namespaceFor (LedgerDB.LedgerReplayEvent ev) = + nsPrependInner "Replay" (namespaceFor ev) + namespaceFor (LedgerDB.LedgerDBForkerEvent _ev) = + Namespace [] ["Forker"] + namespaceFor (LedgerDB.LedgerDBFlavorImplEvent _ev) = + Namespace [] ["Flavor"] + + severityFor (Namespace out ("Snapshot" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) Nothing + severityFor (Namespace _out ("Replay" : _tl)) Nothing = Just Info + severityFor (Namespace _out (["Forker"])) Nothing = Just Debug + severityFor (Namespace _out (["Flavor"])) Nothing = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace o ("Snapshot" : tl)) = + documentFor (Namespace o tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) + documentFor _ = Nothing + + allNamespaces = + map (nsPrependInner "Snapshot") + (allNamespaces :: [Namespace (LedgerDB.TraceSnapshotEvent blk)]) + instance ( StandardHash blk , ConvertRawHash blk) => LogFormatting (LedgerDB.TraceSnapshotEvent blk) where - forHuman (LedgerDB.TookSnapshot snap pt) = - "Took ledger snapshot " <> showT snap <> - " at " <> renderRealPointAsPhrase pt - forHuman (LedgerDB.DeletedSnapshot snap) = - "Deleted old snapshot " <> showT snap - forHuman (LedgerDB.InvalidSnapshot snap failure) = - "Invalid snapshot " <> showT snap <> showT failure forMachine dtals (LedgerDB.TookSnapshot snap pt) = mconcat [ "kind" .= String "TookSnapshot" @@ -1463,32 +1487,42 @@ instance ( StandardHash blk , "snapshot" .= forMachine dtals snap ] forMachine dtals (LedgerDB.InvalidSnapshot snap failure) = mconcat [ "kind" .= String "InvalidSnapshot" - , "snapshot" .= forMachine dtals snap - , "failure" .= show failure ] + , "snapshot" .= forMachine dtals snap + , "failure" .= show failure + ] + + forHuman (LedgerDB.TookSnapshot snap pt) = + "Took ledger snapshot " <> showT snap <> + " at " <> renderRealPointAsPhrase pt + forHuman (LedgerDB.DeletedSnapshot snap) = + "Deleted old snapshot " <> showT snap + forHuman (LedgerDB.InvalidSnapshot snap failure) = + "Invalid snapshot " <> showT snap <> showT failure instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where - namespaceFor LedgerDB.TookSnapshot {} = Namespace [] ["TookSnapshot"] - namespaceFor LedgerDB.DeletedSnapshot {} = Namespace [] ["DeletedSnapshot"] - namespaceFor LedgerDB.InvalidSnapshot {} = Namespace [] ["InvalidSnapshot"] - severityFor (Namespace _ ["TookSnapshot"]) _ = Just Info - severityFor (Namespace _ ["DeletedSnapshot"]) _ = Just Debug - severityFor (Namespace _ ["InvalidSnapshot"]) _ = Just Error - severityFor _ _ = Nothing + namespaceFor LedgerDB.TookSnapshot {} = Namespace [] ["TookSnapshot"] + namespaceFor LedgerDB.DeletedSnapshot {} = Namespace [] ["DeletedSnapshot"] + namespaceFor LedgerDB.InvalidSnapshot {} = Namespace [] ["InvalidSnapshot"] - documentFor (Namespace _ ["TookSnapshot"]) = Just - "A snapshot was written to disk." - documentFor (Namespace _ ["DeletedSnapshot"]) = Just - "A snapshot was written to disk." - documentFor (Namespace _ ["InvalidSnapshot"]) = Just - "An on disk snapshot was skipped because it was invalid." - documentFor _ = Nothing + severityFor (Namespace _ ["TookSnapshot"]) _ = Just Info + severityFor (Namespace _ ["DeletedSnpshot"]) _ = Just Debug + severityFor (Namespace _ ["InvalidSnapshot"]) _ = Just Error + severityFor _ _ = Nothing - allNamespaces = - [ Namespace [] ["TookSnapshot"] - , Namespace [] ["DeletedSnapshot"] - , Namespace [] ["InvalidSnapshot"] - ] + documentFor (Namespace _ ["TookSnapshot"]) = Just + "A snapshot was written to disk." + documentFor (Namespace _ ["DeletedSnapshot"]) = Just + "A snapshot was deleted from disk." + documentFor (Namespace _ ["InvalidSnapshot"]) = Just + "An on disk snapshot was skipped because it was invalid." + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["TookSnapshot"] + , Namespace [] ["DeletedSnapshot"] + , Namespace [] ["InvalidSnapshot"] + ] -------------------------------------------------------------------------------- @@ -1496,12 +1530,31 @@ instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where -------------------------------------------------------------------------------- instance (StandardHash blk, ConvertRawHash blk) - => LogFormatting (LedgerDB.TraceReplayEvent blk) where - forHuman (LedgerDB.ReplayFromGenesis _replayTo) = + => LogFormatting (LedgerDB.TraceReplayStartEvent blk) where + forHuman LedgerDB.ReplayFromGenesis = "Replaying ledger from genesis" - forHuman (LedgerDB.ReplayFromSnapshot snap tip' _ _) = + forHuman (LedgerDB.ReplayFromSnapshot snap (LedgerDB.ReplayStart tip')) = "Replaying ledger from snapshot " <> showT snap <> " at " <> - renderRealPointAsPhrase tip' + renderPointAsPhrase tip' + + forMachine _dtal LedgerDB.ReplayFromGenesis = + mconcat [ "kind" .= String "ReplayFromGenesis" ] + forMachine dtal (LedgerDB.ReplayFromSnapshot snap tip') = + mconcat [ "kind" .= String "ReplayFromSnapshot" + , "snapshot" .= forMachine dtal snap + , "tip" .= show tip' ] + +instance (StandardHash blk, ConvertRawHash blk) + => LogFormatting (LedgerDB.TraceReplayEvent blk) where + + forHuman (LedgerDB.TraceReplayStartEvent ev') = forHuman ev' + forHuman (LedgerDB.TraceReplayProgressEvent ev') = forHuman ev' + + forMachine dtal (LedgerDB.TraceReplayStartEvent ev') = forMachine dtal ev' + forMachine dtal (LedgerDB.TraceReplayProgressEvent ev') = forMachine dtal ev' + +instance (StandardHash blk, ConvertRawHash blk) + => LogFormatting (LedgerDB.TraceReplayProgressEvent blk) where forHuman (LedgerDB.ReplayedBlock pt _ledgerEvents @@ -1521,12 +1574,6 @@ instance (StandardHash blk, ConvertRawHash blk) <> showProgressT (fromIntegral atDiff) (fromIntegral toDiff) <> "%" - forMachine _dtal (LedgerDB.ReplayFromGenesis _replayTo) = - mconcat [ "kind" .= String "ReplayFromGenesis" ] - forMachine dtal (LedgerDB.ReplayFromSnapshot snap tip' _ _) = - mconcat [ "kind" .= String "ReplayFromSnapshot" - , "snapshot" .= forMachine dtal snap - , "tip" .= show tip' ] forMachine _dtal (LedgerDB.ReplayedBlock pt _ledgerEvents @@ -1536,14 +1583,12 @@ instance (StandardHash blk, ConvertRawHash blk) , "slot" .= unSlotNo (realPointSlot pt) , "tip" .= withOrigin 0 unSlotNo (pointSlot replayTo) ] -instance MetaTrace (LedgerDB.TraceReplayEvent blk) where +instance MetaTrace (LedgerDB.TraceReplayStartEvent blk) where namespaceFor LedgerDB.ReplayFromGenesis {} = Namespace [] ["ReplayFromGenesis"] namespaceFor LedgerDB.ReplayFromSnapshot {} = Namespace [] ["ReplayFromSnapshot"] - namespaceFor LedgerDB.ReplayedBlock {} = Namespace [] ["ReplayedBlock"] severityFor (Namespace _ ["ReplayFromGenesis"]) _ = Just Info severityFor (Namespace _ ["ReplayFromSnapshot"]) _ = Just Info - severityFor (Namespace _ ["ReplayedBlock"]) _ = Just Info severityFor _ _ = Nothing documentFor (Namespace _ ["ReplayFromGenesis"]) = Just $ mconcat @@ -1558,6 +1603,44 @@ instance MetaTrace (LedgerDB.TraceReplayEvent blk) where , " The @replayTo@ parameter corresponds to the block at the tip of the" , " ImmDB, i.e., the last block to replay." ] + documentFor _ = Nothing + + allNamespaces = [Namespace [] ["ReplayFromGenesis"] + , Namespace [] ["ReplayFromSnapshot"] + ] + +instance MetaTrace (LedgerDB.TraceReplayEvent blk) where + namespaceFor LedgerDB.TraceReplayStartEvent {} = Namespace [] ["ReplayStart"] + namespaceFor LedgerDB.TraceReplayProgressEvent {} = Namespace [] ["ReplayProgress"] + + severityFor (Namespace _ ["ReplayStart"]) _ = Just Info + severityFor (Namespace _ ["ReplayProgress"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace _ ["ReplayFromGenesis"]) = Just $ mconcat + [ "There were no LedgerDB snapshots on disk, so we're replaying all" + , " blocks starting from Genesis against the initial ledger." + , " The @replayTo@ parameter corresponds to the block at the tip of the" + , " ImmDB, i.e., the last block to replay." + ] + documentFor (Namespace _ ["ReplayFromSnapshot"]) = Just $ mconcat + [ "There was a LedgerDB snapshot on disk corresponding to the given tip." + , " We're replaying more recent blocks against it." + , " The @replayTo@ parameter corresponds to the block at the tip of the" + , " ImmDB, i.e., the last block to replay." + ] + documentFor _ = Nothing + + allNamespaces = [Namespace [] ["ReplayFromGenesis"] + , Namespace [] ["ReplayFromSnapshot"] + ] + +instance MetaTrace (LedgerDB.TraceReplayProgressEvent blk) where + namespaceFor LedgerDB.ReplayedBlock {} = Namespace [] ["ReplayedBlock"] + + severityFor (Namespace _ ["ReplayedBlock"]) _ = Just Info + severityFor _ _ = Nothing + documentFor (Namespace _ ["ReplayedBlock"]) = Just $ mconcat [ "We replayed the given block (reference) on the genesis snapshot" , " during the initialisation of the LedgerDB." @@ -1569,9 +1652,7 @@ instance MetaTrace (LedgerDB.TraceReplayEvent blk) where documentFor _ = Nothing allNamespaces = - [ Namespace [] ["ReplayFromGenesis"] - , Namespace [] ["ReplayFromSnapshot"] - , Namespace [] ["ReplayedBlock"] + [ Namespace [] ["ReplayedBlock"] ] -------------------------------------------------------------------------------- @@ -1956,17 +2037,22 @@ instance StandardHash blk => LogFormatting (VolDB.TraceEvent blk) where mconcat [ "kind" .= String "InvalidFileNames" , "files" .= String (Text.pack . show $ map show fsPaths) ] + forMachine _dtal VolDB.DBClosed = + mconcat [ "kind" .= String "DBClosed" + ] instance MetaTrace (VolDB.TraceEvent blk) where namespaceFor VolDB.DBAlreadyClosed {} = Namespace [] ["DBAlreadyClosed"] namespaceFor VolDB.BlockAlreadyHere {} = Namespace [] ["BlockAlreadyHere"] namespaceFor VolDB.Truncate {} = Namespace [] ["Truncate"] namespaceFor VolDB.InvalidFileNames {} = Namespace [] ["InvalidFileNames"] + namespaceFor VolDB.DBClosed {} = Namespace [] ["DBClosed"] severityFor (Namespace _ ["DBAlreadyClosed"]) _ = Just Debug severityFor (Namespace _ ["BlockAlreadyHere"]) _ = Just Debug severityFor (Namespace _ ["Truncate"]) _ = Just Debug severityFor (Namespace _ ["InvalidFileNames"]) _ = Just Debug + severityFor (Namespace _ ["DBClosed"]) _ = Just Info severityFor _ _ = Nothing documentFor (Namespace _ ["DBAlreadyClosed"]) = Just @@ -1977,6 +2063,8 @@ instance MetaTrace (VolDB.TraceEvent blk) where "Truncates a file up to offset because of the error." documentFor (Namespace _ ["InvalidFileNames"]) = Just "Reports a list of invalid file paths." + documentFor (Namespace _ ["DBClosed"]) = Just + "Closing the Volatile DB." documentFor _ = Nothing allNamespaces = @@ -1984,6 +2072,7 @@ instance MetaTrace (VolDB.TraceEvent blk) where , Namespace [] ["BlockAlreadyHere"] , Namespace [] ["Truncate"] , Namespace [] ["InvalidFileNames"] + , Namespace [] ["DBClosed"] ] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 0e2bfeb48f3..e91bb804a98 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -846,6 +846,7 @@ instance , LogFormatting (GenTx blk) , ToJSON (GenTxId blk) , LedgerSupportsMempool blk + , ConvertRawHash blk ) => LogFormatting (TraceEventMempool blk) where forMachine dtal (TraceMempoolAddedTx tx _mpSzBefore mpSzAfter) = mconcat @@ -885,6 +886,34 @@ instance , "txsInvalidated" .= map (forMachine dtal . txForgetValidated) txs1 , "mempoolSize" .= forMachine dtal mpSz ] + forMachine _ TraceMempoolAttemptingSync = + mconcat + [ "kind" .= String "TraceMempoolAttemptingSync" + ] + forMachine dtal (TraceMempoolSyncNotNeeded t _) = + mconcat + [ "kind" .= String "TraceMempoolSyncNotNeeded" + , "tip" .= forMachine dtal t + ] + forMachine _ TraceMempoolSyncDone = + mconcat + [ "kind" .= String "TraceMempoolSyncDone" + ] + forMachine dtal (TraceMempoolAttemptingAdd tx) = + mconcat + [ "kind" .= String "TraceMempoolAttemptingAdd" + , "tx" .= forMachine dtal tx + ] + forMachine dtal (TraceMempoolLedgerFound p) = + mconcat + [ "kind" .= String "TraceMempoolLedgerFound" + , "tip" .= forMachine dtal p + ] + forMachine dtal (TraceMempoolLedgerNotFound p) = + mconcat + [ "kind" .= String "TraceMempoolLedgerNotFound" + , "tip" .= forMachine dtal p + ] asMetrics (TraceMempoolAddedTx _tx _mpSzBefore mpSz) = [ IntM "Mempool.TxsInMempool" (fromIntegral $ msNumTxs mpSz) @@ -894,19 +923,22 @@ instance [ IntM "Mempool.TxsInMempool" (fromIntegral $ msNumTxs mpSz) , IntM "Mempool.MempoolBytes" (fromIntegral $ msNumBytes mpSz) ] - asMetrics (TraceMempoolRemoveTxs _txs mpSz) = - [ IntM "Mempool.TxsInMempool" (fromIntegral $ msNumTxs mpSz) - , IntM "Mempool.MempoolBytes" (fromIntegral $ msNumBytes mpSz) - ] - asMetrics (TraceMempoolManuallyRemovedTxs [] _txs1 mpSz) = + asMetrics (TraceMempoolRemoveTxs txs mpSz) = [ IntM "Mempool.TxsInMempool" (fromIntegral $ msNumTxs mpSz) , IntM "Mempool.MempoolBytes" (fromIntegral $ msNumBytes mpSz) + , CounterM "Mempool.TxsRemovedNum" (Just (fromIntegral $ length txs)) ] asMetrics (TraceMempoolManuallyRemovedTxs txs _txs1 mpSz) = [ IntM "Mempool.TxsInMempool" (fromIntegral $ msNumTxs mpSz) , IntM "Mempool.MempoolBytes" (fromIntegral $ msNumBytes mpSz) - , CounterM "Mempool.TxsProcessedNum" (Just (fromIntegral $ length txs)) + , CounterM "Mempool.TxsRemovedNum" (Just (fromIntegral $ length txs)) ] + asMetrics TraceMempoolAttemptingSync = [] + asMetrics TraceMempoolSyncNotNeeded {} = [] + asMetrics TraceMempoolSyncDone = [] + asMetrics TraceMempoolAttemptingAdd {} = [] + asMetrics TraceMempoolLedgerFound {} = [] + asMetrics TraceMempoolLedgerNotFound {} = [] instance LogFormatting MempoolSize where forMachine _dtal MempoolSize{msNumTxs, msNumBytes} = @@ -921,11 +953,23 @@ instance MetaTrace (TraceEventMempool blk) where namespaceFor TraceMempoolRejectedTx {} = Namespace [] ["RejectedTx"] namespaceFor TraceMempoolRemoveTxs {} = Namespace [] ["RemoveTxs"] namespaceFor TraceMempoolManuallyRemovedTxs {} = Namespace [] ["ManuallyRemovedTxs"] + namespaceFor TraceMempoolAttemptingSync = Namespace [] ["MempoolAttemptingSync"] + namespaceFor TraceMempoolSyncNotNeeded {} = Namespace [] ["MempoolSyncNotNeeded"] + namespaceFor TraceMempoolSyncDone = Namespace [] ["MempoolSyncDone"] + namespaceFor TraceMempoolAttemptingAdd {} = Namespace [] ["MempoolAttemptAdd"] + namespaceFor TraceMempoolLedgerFound {} = Namespace [] ["MempoolLedgerFound"] + namespaceFor TraceMempoolLedgerNotFound {} = Namespace [] ["MempoolLedgerNotFound"] severityFor (Namespace _ ["AddedTx"]) _ = Just Info severityFor (Namespace _ ["RejectedTx"]) _ = Just Info - severityFor (Namespace _ ["RemoveTxs"]) _ = Just Info - severityFor (Namespace _ ["ManuallyRemovedTxs"]) _ = Just Info + severityFor (Namespace _ ["RemoveTxs"]) _ = Just Debug + severityFor (Namespace _ ["ManuallyRemovedTxs"]) _ = Just Warning + severityFor (Namespace _ ["MempoolAttemptingSync"]) _ = Just Debug + severityFor (Namespace _ ["MempoolSyncNotNeeded"]) _ = Just Debug + severityFor (Namespace _ ["MempoolSyncDone"]) _ = Just Debug + severityFor (Namespace _ ["MempoolAttemptAdd"]) _ = Just Debug + severityFor (Namespace _ ["MempoolLedgerFound"]) _ = Just Debug + severityFor (Namespace _ ["MempoolLedgerNotFound"]) _ = Just Debug severityFor _ _ = Nothing metricsDocFor (Namespace _ ["AddedTx"]) = @@ -950,7 +994,7 @@ instance MetaTrace (TraceEventMempool blk) where documentFor (Namespace _ ["AddedTx"]) = Just "New, valid transaction that was added to the Mempool." documentFor (Namespace _ ["RejectedTx"]) = Just $ mconcat - [ "New, invalid transaction thas was rejected and thus not added to" + [ "New, invalid transaction that was rejected and thus not added to" , " the Mempool." ] documentFor (Namespace _ ["RemoveTxs"]) = Just $ mconcat @@ -960,6 +1004,20 @@ instance MetaTrace (TraceEventMempool blk) where ] documentFor (Namespace _ ["ManuallyRemovedTxs"]) = Just "Transactions that have been manually removed from the Mempool." + documentFor (Namespace _ ["MempoolAttemptingSync"]) = Just + "Mempool attempting to perform a sync with the LedgerDB." + documentFor (Namespace _ ["MempoolSyncNotNeeded"]) = Just + "The mempool and the LedgerDB are in sync already." + documentFor (Namespace _ ["MempoolSyncDone"]) = Just + "The mempool and the LedgerDB are in sync now." + documentFor (Namespace _ ["MempoolAttemptAdd"]) = Just + "Mempool is about to try to validate and add a transaction." + documentFor (Namespace _ ["MempoolLedgerNotFound"]) = Just $ mconcat + [ "Ledger state requested by the mempool no longer in LedgerDB." + , " Will have to re-sync." + ] + documentFor (Namespace _ ["MempoolLedgerFound"]) = Just + "Ledger state requested by the mempool is in the LedgerDB." documentFor _ = Nothing allNamespaces = @@ -967,6 +1025,12 @@ instance MetaTrace (TraceEventMempool blk) where , Namespace [] ["RejectedTx"] , Namespace [] ["RemoveTxs"] , Namespace [] ["ManuallyRemovedTxs"] + , Namespace [] ["MempoolAttemptingSync"] + , Namespace [] ["MempoolSyncNotNeeded"] + , Namespace [] ["MempoolSyncDone"] + , Namespace [] ["MempoolAttemptAdd"] + , Namespace [] ["MempoolLedgerNotFound"] + , Namespace [] ["MempoolLedgerFound"] ] -------------------------------------------------------------------------------- diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs index 46db0abab62..a0dbdb96803 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs @@ -38,6 +38,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text +import GHC.Conc (labelThread, myThreadId) import Text.Printf (printf) {- HLINT ignore "Use =<<" -} @@ -49,7 +50,7 @@ startPeerTracer -> Int -> IO () startPeerTracer tr nodeKern delayMilliseconds = do - as <- async peersThread + as <- async $ myThreadId >>= flip labelThread "PeersCapturing" >> peersThread link as where peersThread :: IO () diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Resources.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Resources.hs index b82b2eddf2d..8da1f50fab5 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Resources.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Resources.hs @@ -10,6 +10,8 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async (async) import Control.Monad (forM_, forever) import Control.Monad.Class.MonadAsync (link) +import GHC.Conc (labelThread, myThreadId) + import "contra-tracer" Control.Tracer startResourceTracer @@ -17,7 +19,7 @@ startResourceTracer -> Int -> IO () startResourceTracer tr delayMilliseconds = do - as <- async resourceThread + as <- async (myThreadId >>= flip labelThread "ResourceCapturing" >> resourceThread) link as where resourceThread :: IO () @@ -25,5 +27,3 @@ startResourceTracer tr delayMilliseconds = do mbrs <- readResourceStats forM_ mbrs $ \rs -> traceWith tr rs threadDelay (delayMilliseconds * 1000) - forM_ mbrs $ \rs -> traceWith tr rs - threadDelay (delayMilliseconds * 1000) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs index b3d5bb810a9..83b21c4d5e4 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs @@ -25,11 +25,13 @@ import Ouroboros.Network.NodeToNode (RemoteAddress) import Ouroboros.Consensus.Block (SlotNo (..)) import Ouroboros.Consensus.HardFork.Combinator -import Ouroboros.Consensus.Ledger.Abstract (IsLedger) +import Ouroboros.Consensus.Ledger.Abstract (EmptyMK) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, ledgerState) +import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Node (NodeKernel (..)) import Ouroboros.Consensus.Node.Tracers import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.API as LedgerDB import Cardano.Node.Queries (LedgerQueries (..), NodeKernelData (..)) import Cardano.Slotting.Slot (fromWithOrigin) @@ -49,12 +51,9 @@ data TraceStartLeadershipCheckPlus = } forgeTracerTransform :: - ( IsLedger (LedgerState blk) + ( LedgerSupportsProtocol blk , LedgerQueries blk -#if __GLASGOW_HASKELL__ >= 906 - , AF.HasHeader blk -#endif - , AF.HasHeader (Header blk)) + ) => NodeKernelData blk -> Trace IO (ForgeTracerType blk) -> IO (Trace IO (ForgeTracerType blk)) @@ -65,7 +64,7 @@ forgeTracerTransform nodeKern (Trace tr) = query <- mapNodeKernelDataIO (\nk -> (,,) - <$> nkQueryLedger (ledgerUtxoSize . ledgerState) nk + <$> fmap (maybe 0 LedgerDB.ledgerTableSize) (ChainDB.getStatistics (getChainDB nk)) <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk <*> nkQueryChain fragmentChainDensity nk) nodeKern @@ -84,8 +83,7 @@ forgeTracerTransform nodeKern (Trace tr) = pure (lc, Left control)) nkQueryLedger :: - IsLedger (LedgerState blk) - => (ExtLedgerState blk -> a) + (ExtLedgerState blk EmptyMK -> a) -> NodeKernel IO RemoteAddress LocalConnectionId blk -> IO a nkQueryLedger f NodeKernel{getChainDB} = diff --git a/cardano-node/src/Cardano/Tracing/Config.hs b/cardano-node/src/Cardano/Tracing/Config.hs index fb93f72115a..eb206857c09 100644 --- a/cardano-node/src/Cardano/Tracing/Config.hs +++ b/cardano-node/src/Cardano/Tracing/Config.hs @@ -159,6 +159,7 @@ type TraceLocalTxMonitorProtocol = ("TraceLocalTxMonitorProtocol" :: Symbol) type TraceLocalTxSubmissionProtocol = ("TraceLocalTxSubmissionProtocol" :: Symbol) type TraceLocalTxSubmissionServer = ("TraceLocalTxSubmissionServer" :: Symbol) type TraceMempool = ("TraceMempool" :: Symbol) +type TraceBackingStore = ("TraceBackingStore" :: Symbol) type TraceMux = ("TraceMux" :: Symbol) type TraceLocalMux = ("TraceLocalMux" :: Symbol) type TracePeerSelection = ("TracePeerSelection" :: Symbol) @@ -232,6 +233,7 @@ data TraceSelection , traceLocalTxSubmissionProtocol :: OnOff TraceLocalTxSubmissionProtocol , traceLocalTxSubmissionServer :: OnOff TraceLocalTxSubmissionServer , traceMempool :: OnOff TraceMempool + , traceBackingStore :: OnOff TraceBackingStore , traceMux :: OnOff TraceMux , tracePeerSelection :: OnOff TracePeerSelection , tracePeerSelectionCounters :: OnOff TracePeerSelectionCounters @@ -295,6 +297,7 @@ data PartialTraceSelection , pTraceLocalTxSubmissionProtocol :: Last (OnOff TraceLocalTxSubmissionProtocol) , pTraceLocalTxSubmissionServer :: Last (OnOff TraceLocalTxSubmissionServer) , pTraceMempool :: Last (OnOff TraceMempool) + , pTraceBackingStore :: Last (OnOff TraceBackingStore) , pTraceMux :: Last (OnOff TraceMux) , pTracePeerSelection :: Last (OnOff TracePeerSelection) , pTracePeerSelectionCounters :: Last (OnOff TracePeerSelectionCounters) @@ -359,6 +362,7 @@ instance FromJSON PartialTraceSelection where <*> parseTracer (Proxy @TraceLocalTxSubmissionProtocol) v <*> parseTracer (Proxy @TraceLocalTxSubmissionServer) v <*> parseTracer (Proxy @TraceMempool) v + <*> parseTracer (Proxy @TraceBackingStore) v <*> parseTracer (Proxy @TraceMux) v <*> parseTracer (Proxy @TracePeerSelection) v <*> parseTracer (Proxy @TracePeerSelectionCounters) v @@ -420,6 +424,7 @@ defaultPartialTraceConfiguration = , pTraceLocalTxSubmissionProtocol = pure $ OnOff False , pTraceLocalTxSubmissionServer = pure $ OnOff False , pTraceMempool = pure $ OnOff True + , pTraceBackingStore = pure $ OnOff False , pTraceMux = pure $ OnOff True , pTracePeerSelection = pure $ OnOff True , pTracePeerSelectionCounters = pure $ OnOff True @@ -483,6 +488,7 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio traceLocalTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceLocalTxSubmissionProtocol) pTraceLocalTxSubmissionProtocol traceLocalTxSubmissionServer <- proxyLastToEither (Proxy @TraceLocalTxSubmissionServer) pTraceLocalTxSubmissionServer traceMempool <- proxyLastToEither (Proxy @TraceMempool) pTraceMempool + traceBackingStore <- proxyLastToEither (Proxy @TraceBackingStore) pTraceBackingStore traceMux <- proxyLastToEither (Proxy @TraceMux) pTraceMux tracePeerSelection <- proxyLastToEither (Proxy @TracePeerSelection) pTracePeerSelection tracePeerSelectionCounters <- proxyLastToEither (Proxy @TracePeerSelectionCounters) pTracePeerSelectionCounters @@ -539,6 +545,7 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio , traceLocalTxSubmissionProtocol = traceLocalTxSubmissionProtocol , traceLocalTxSubmissionServer = traceLocalTxSubmissionServer , traceMempool = traceMempool + , traceBackingStore = traceBackingStore , traceMux = traceMux , tracePeerSelection = tracePeerSelection , tracePeerSelectionCounters = tracePeerSelectionCounters @@ -599,6 +606,7 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio traceLocalTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceLocalTxSubmissionProtocol) pTraceLocalTxSubmissionProtocol traceLocalTxSubmissionServer <- proxyLastToEither (Proxy @TraceLocalTxSubmissionServer) pTraceLocalTxSubmissionServer traceMempool <- proxyLastToEither (Proxy @TraceMempool) pTraceMempool + traceBackingStore <- proxyLastToEither (Proxy @TraceBackingStore) pTraceBackingStore traceMux <- proxyLastToEither (Proxy @TraceMux) pTraceMux tracePeerSelection <- proxyLastToEither (Proxy @TracePeerSelection) pTracePeerSelection tracePeerSelectionCounters <- proxyLastToEither (Proxy @TracePeerSelectionCounters) pTracePeerSelectionCounters @@ -655,6 +663,7 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio , traceLocalTxSubmissionProtocol = traceLocalTxSubmissionProtocol , traceLocalTxSubmissionServer = traceLocalTxSubmissionServer , traceMempool = traceMempool + , traceBackingStore = traceBackingStore , traceMux = traceMux , tracePeerSelection = tracePeerSelection , tracePeerSelectionCounters = tracePeerSelectionCounters diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs index ef2c3d373b4..e12d0120475 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs @@ -20,6 +20,7 @@ module Cardano.Tracing.OrphanInstances.Consensus () where import Cardano.Node.Tracing.Tracers.ConsensusStartupException (ConsensusStartupException (..)) +import Ouroboros.Network.Block (MaxSlotNo(..)) import Cardano.Prelude (maximumDef) import Cardano.Slotting.Slot (fromWithOrigin) import Cardano.Tracing.OrphanInstances.Common @@ -62,6 +63,8 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (ChunkN import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB import Ouroboros.Consensus.Storage.LedgerDB (PushGoal (..), PushStart (..), Pushing (..)) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots as LedgerDB +import Ouroboros.Consensus.Storage.LedgerDB.API (TraceValidateEvent (..)) import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl as VolDb import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Enclose @@ -122,7 +125,6 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where ChainDB.IgnoreInvalidBlock {} -> Info ChainDB.AddedBlockToQueue {} -> Debug ChainDB.PoppedBlockFromQueue {} -> Debug - ChainDB.BlockInTheFuture {} -> Info ChainDB.AddedBlockToVolatileDB {} -> Debug ChainDB.TryAddToCurrentChain {} -> Debug ChainDB.TrySwitchToAFork {} -> Info @@ -141,15 +143,14 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where ChainDB.ChainSelectionForFutureBlock{} -> Debug ChainDB.PipeliningEvent {} -> Debug - getSeverityAnnotation (ChainDB.TraceLedgerReplayEvent ev) = case ev of - LedgerDB.ReplayFromGenesis {} -> Info - LedgerDB.ReplayFromSnapshot {} -> Info - LedgerDB.ReplayedBlock {} -> Info - - getSeverityAnnotation (ChainDB.TraceSnapshotEvent ev) = case ev of - LedgerDB.TookSnapshot {} -> Info - LedgerDB.DeletedSnapshot {} -> Debug - LedgerDB.InvalidSnapshot {} -> Error + getSeverityAnnotation (ChainDB.TraceLedgerDBEvent ev) = case ev of + LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of + LedgerDB.TookSnapshot {} -> Info + LedgerDB.DeletedSnapshot {} -> Debug + LedgerDB.InvalidSnapshot {} -> Error + LedgerDB.LedgerReplayEvent {} -> Info + LedgerDB.LedgerDBForkerEvent {} -> Debug + LedgerDB.LedgerDBFlavorImplEvent {} -> Debug getSeverityAnnotation (ChainDB.TraceCopyToImmutableDBEvent ev) = case ev of ChainDB.CopiedBlockToImmutableDB {} -> Debug @@ -163,7 +164,7 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where ChainDB.OpenedDB {} -> Info ChainDB.ClosedDB {} -> Info ChainDB.OpenedImmutableDB {} -> Info - ChainDB.OpenedVolatileDB -> Info + ChainDB.OpenedVolatileDB {} -> Info ChainDB.OpenedLgrDB -> Info ChainDB.StartedOpeningDB -> Info ChainDB.StartedOpeningImmutableDB -> Info @@ -213,6 +214,7 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where VolDb.BlockAlreadyHere{} -> Debug VolDb.Truncate{} -> Error VolDb.InvalidFileNames{} -> Warning + VolDb.DBClosed{} -> Info instance HasSeverityAnnotation (LedgerEvent blk) where getSeverityAnnotation (LedgerUpdate _) = Notice @@ -245,7 +247,16 @@ instance HasSeverityAnnotation (TraceChainSyncServerEvent blk) where instance HasPrivacyAnnotation (TraceEventMempool blk) instance HasSeverityAnnotation (TraceEventMempool blk) where - getSeverityAnnotation _ = Info + getSeverityAnnotation TraceMempoolAddedTx{} = Info + getSeverityAnnotation TraceMempoolRejectedTx{} = Info + getSeverityAnnotation TraceMempoolRemoveTxs{} = Debug + getSeverityAnnotation TraceMempoolManuallyRemovedTxs{} = Warning + getSeverityAnnotation TraceMempoolAttemptingSync = Debug + getSeverityAnnotation TraceMempoolSyncNotNeeded{} = Debug + getSeverityAnnotation TraceMempoolSyncDone = Debug + getSeverityAnnotation TraceMempoolAttemptingAdd{} = Debug + getSeverityAnnotation TraceMempoolLedgerFound{} = Debug + getSeverityAnnotation TraceMempoolLedgerNotFound{} = Debug instance HasPrivacyAnnotation () instance HasSeverityAnnotation () where @@ -324,7 +335,8 @@ instance (StandardHash blk, Show peer) instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk), - ToJSON (GenTxId blk), LedgerSupportsMempool blk) + ToJSON (GenTxId blk), LedgerSupportsMempool blk, + ConvertRawHash blk) => Transformable Text IO (TraceEventMempool blk) where trTransformer = trStructured @@ -493,8 +505,6 @@ instance ( ConvertRawHash blk "Popping block from queue" FallingEdgeWith pt -> "Popped block from queue: " <> renderRealPointAsPhrase pt - ChainDB.BlockInTheFuture pt slot -> - "Ignoring block from future: " <> renderRealPointAsPhrase pt <> ", slot " <> condenseT slot ChainDB.StoreButDontChange pt -> "Ignoring block: " <> renderRealPointAsPhrase pt ChainDB.TryAddToCurrentChain pt -> @@ -513,7 +523,7 @@ instance ( ConvertRawHash blk ChainDB.InvalidBlock err pt -> "Invalid block " <> renderRealPointAsPhrase pt <> ": " <> showT err ChainDB.ValidCandidate c -> - "Valid candidate " <> renderPointAsPhrase (AF.headPoint c) + "Valid candidate spanning from " <> renderPointAsPhrase (AF.lastPoint c) <> " to " <> renderPointAsPhrase (AF.headPoint c) ChainDB.CandidateContainsFutureBlocks c hdrs -> "Candidate contains blocks from near future: " <> renderPointAsPhrase (AF.headPoint c) <> ", slots " <> @@ -522,7 +532,7 @@ instance ( ConvertRawHash blk "Candidate contains blocks from future exceeding clock skew limit: " <> renderPointAsPhrase (AF.headPoint c) <> ", slots " <> Text.intercalate ", " (map (renderPoint . headerPoint) hdrs) - ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> + ChainDB.UpdateLedgerDbTraceEvent (StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> let fromSlot = unSlotNo $ realPointSlot start atSlot = unSlotNo $ realPointSlot curr atDiff = atSlot - fromSlot @@ -543,34 +553,40 @@ instance ( ConvertRawHash blk ChainDB.TrapTentativeHeader hdr -> "Discovered trap tentative header " <> renderPointAsPhrase (blockPoint hdr) ChainDB.OutdatedTentativeHeader hdr -> "Tentative header is now outdated" <> renderPointAsPhrase (blockPoint hdr) - ChainDB.TraceLedgerReplayEvent ev -> case ev of - LedgerDB.ReplayFromGenesis _replayTo -> - "Replaying ledger from genesis" - LedgerDB.ReplayFromSnapshot _ tip' _ _ -> - "Replaying ledger from snapshot at " <> - renderRealPointAsPhrase tip' - LedgerDB.ReplayedBlock pt _ledgerEvents (LedgerDB.ReplayStart replayFrom) (LedgerDB.ReplayGoal replayTo) -> - let fromSlot = withOrigin 0 Prelude.id $ unSlotNo <$> pointSlot replayFrom - atSlot = unSlotNo $ realPointSlot pt - atDiff = atSlot - fromSlot - toSlot = withOrigin 0 Prelude.id $ unSlotNo <$> pointSlot replayTo - toDiff = toSlot - fromSlot - in - "Replayed block: slot " - <> showT atSlot - <> " out of " - <> showT toSlot - <> ". Progress: " - <> showProgressT (fromIntegral atDiff) (fromIntegral toDiff) - <> "%" - ChainDB.TraceSnapshotEvent ev -> case ev of - LedgerDB.InvalidSnapshot snap failure -> - "Invalid snapshot " <> showT snap <> showT failure - LedgerDB.TookSnapshot snap pt -> - "Took ledger snapshot " <> showT snap <> - " at " <> renderRealPointAsPhrase pt - LedgerDB.DeletedSnapshot snap -> - "Deleted old snapshot " <> showT snap + ChainDB.TraceLedgerDBEvent ev -> case ev of + LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of + LedgerDB.InvalidSnapshot snap failure -> + "Invalid snapshot " <> showT snap <> showT failure + LedgerDB.TookSnapshot snap pt -> + "Took ledger snapshot " <> showT snap <> + " at " <> renderRealPointAsPhrase pt + LedgerDB.DeletedSnapshot snap -> + "Deleted old snapshot " <> showT snap + LedgerDB.LedgerReplayEvent ev' -> case ev' of + LedgerDB.TraceReplayStartEvent ev'' -> case ev'' of + LedgerDB.ReplayFromGenesis -> + "Replaying ledger from genesis" + LedgerDB.ReplayFromSnapshot _ (LedgerDB.ReplayStart tip') -> + "Replaying ledger from snapshot at " <> + renderPointAsPhrase tip' + LedgerDB.TraceReplayProgressEvent + (LedgerDB.ReplayedBlock pt _ledgerEvents (LedgerDB.ReplayStart replayFrom) (LedgerDB.ReplayGoal replayTo)) -> + let fromSlot = withOrigin 0 Prelude.id $ unSlotNo <$> pointSlot replayFrom + atSlot = unSlotNo $ realPointSlot pt + atDiff = atSlot - fromSlot + toSlot = withOrigin 0 Prelude.id $ unSlotNo <$> pointSlot replayTo + toDiff = toSlot - fromSlot + in + "Replayed block: slot " + <> showT atSlot + <> " out of " + <> showT toSlot + <> ". Progress: " + <> showProgressT (fromIntegral atDiff) (fromIntegral toDiff) + <> "%" + LedgerDB.LedgerDBForkerEvent ev' -> showT ev' + LedgerDB.LedgerDBFlavorImplEvent ev' -> showT ev' + ChainDB.TraceCopyToImmutableDBEvent ev -> case ev of ChainDB.CopiedBlockToImmutableDB pt -> "Copied block " <> renderPointAsPhrase pt <> " to the ImmutableDB" @@ -595,7 +611,9 @@ instance ( ConvertRawHash blk ChainDB.OpenedImmutableDB immTip chunk -> "Opened imm db with immutable tip at " <> renderPointAsPhrase immTip <> " and chunk " <> showT chunk - ChainDB.OpenedVolatileDB -> "Opened vol db" + ChainDB.OpenedVolatileDB mx -> "Opened " <> case mx of + NoMaxSlotNo -> "empty Volatile DB" + MaxSlotNo mxx -> "Volatile DB with max slot seen " <> showT mxx ChainDB.OpenedLgrDB -> "Opened lgr db" ChainDB.TraceFollowerEvent ev -> case ev of ChainDB.NewFollower -> "New follower was created" @@ -607,10 +625,10 @@ instance ( ConvertRawHash blk ChainDB.InitalChainSelected -> "Initial chain selected" ChainDB.InitChainSelValidation e -> case e of ChainDB.InvalidBlock _err _pt -> "Invalid block found during Initial chain selection, truncating the candidate and retrying to select a best candidate." - ChainDB.ValidCandidate af -> "Valid candidate at tip " <> renderPointAsPhrase (AF.lastPoint af) + ChainDB.ValidCandidate af -> "Valid candidate spanning from " <> renderPointAsPhrase (AF.lastPoint af) <> " to " <> renderPointAsPhrase (AF.headPoint af) ChainDB.CandidateContainsFutureBlocks {} -> "Found a candidate containing future blocks during Initial chain selection, truncating the candidate and retrying to select a best candidate." ChainDB.CandidateContainsFutureBlocksExceedingClockSkew {} -> "Found a candidate containing future blocks exceeding clock skew during Initial chain selection, truncating the candidate and retrying to select a best candidate." - ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> + ChainDB.UpdateLedgerDbTraceEvent (StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> let fromSlot = unSlotNo $ realPointSlot start atSlot = unSlotNo $ realPointSlot curr atDiff = atSlot - fromSlot @@ -708,6 +726,7 @@ instance ( ConvertRawHash blk VolDb.BlockAlreadyHere bh -> "Block " <> showT bh <> " was already in the Volatile DB." VolDb.Truncate e pth offs -> "Truncating the file at " <> showT pth <> " at offset " <> showT offs <> ": " <> showT e VolDb.InvalidFileNames fs -> "Invalid Volatile DB files: " <> showT fs + VolDb.DBClosed{} -> "Closed Volatile DB." where showProgressT :: Int -> Int -> Text showProgressT chunkNo outOf = pack (showFFloat (Just 2) (100 * fromIntegral chunkNo / fromIntegral outOf :: Float) mempty) @@ -883,10 +902,6 @@ instance ( ConvertRawHash blk , case edgePt of RisingEdge -> "risingEdge" .= True FallingEdgeWith pt -> "block" .= toObject verb pt ] - ChainDB.BlockInTheFuture pt slot -> - mconcat [ "kind" .= String "TraceAddBlockEvent.BlockInTheFuture" - , "block" .= toObject verb pt - , "slot" .= toObject verb slot ] ChainDB.StoreButDontChange pt -> mconcat [ "kind" .= String "TraceAddBlockEvent.StoreButDontChange" , "block" .= toObject verb pt ] @@ -945,7 +960,7 @@ instance ( ConvertRawHash blk mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.CandidateContainsFutureBlocksExceedingClockSkew" , "block" .= renderPointForVerbosity verb (AF.headPoint c) , "headers" .= map (renderPointForVerbosity verb . headerPoint) hdrs ] - ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> + ChainDB.UpdateLedgerDbTraceEvent (StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.UpdateLedgerDb" , "startingBlock" .= renderRealPoint start , "currentBlock" .= renderRealPoint curr @@ -987,33 +1002,39 @@ instance ( ConvertRawHash blk chainLengthΔ :: AF.AnchoredFragment (Header blk) -> AF.AnchoredFragment (Header blk) -> Int chainLengthΔ = on (-) (fromWithOrigin (-1) . fmap (fromIntegral . unBlockNo) . AF.headBlockNo) - toObject MinimalVerbosity (ChainDB.TraceLedgerReplayEvent _ev) = mempty -- no output - toObject verb (ChainDB.TraceLedgerReplayEvent ev) = case ev of - LedgerDB.ReplayFromGenesis _replayTo -> - mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayFromGenesis" ] - LedgerDB.ReplayFromSnapshot snap tip' _replayFrom _replayTo -> - mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayFromSnapshot" - , "snapshot" .= toObject verb snap - , "tip" .= show tip' ] - LedgerDB.ReplayedBlock pt _ledgerEvents _ (LedgerDB.ReplayGoal replayTo) -> - mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayedBlock" - , "slot" .= unSlotNo (realPointSlot pt) - , "tip" .= withOrigin 0 unSlotNo (pointSlot replayTo) ] - - toObject MinimalVerbosity (ChainDB.TraceSnapshotEvent _ev) = mempty -- no output - toObject verb (ChainDB.TraceSnapshotEvent ev) = case ev of - LedgerDB.TookSnapshot snap pt -> - mconcat [ "kind" .= String "TraceSnapshotEvent.TookSnapshot" - , "snapshot" .= toObject verb snap - , "tip" .= show pt ] - LedgerDB.DeletedSnapshot snap -> - mconcat [ "kind" .= String "TraceSnapshotEvent.DeletedSnapshot" - , "snapshot" .= toObject verb snap ] - LedgerDB.InvalidSnapshot snap failure -> - mconcat [ "kind" .= String "TraceSnapshotEvent.InvalidSnapshot" - , "snapshot" .= toObject verb snap - , "failure" .= show failure ] - + toObject MinimalVerbosity (ChainDB.TraceLedgerDBEvent _ev) = mempty -- no output + toObject verb (ChainDB.TraceLedgerDBEvent ev) = case ev of + LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of + LedgerDB.TookSnapshot snap pt -> + mconcat [ "kind" .= String "TraceLedgerDBEvent.LedgerDBSnapshotEvent.TookSnapshot" + , "snapshot" .= toObject verb snap + , "tip" .= show pt ] + LedgerDB.DeletedSnapshot snap -> + mconcat [ "kind" .= String "TraceLedgerDBEvent.LedgerDBSnapshotEvent.DeletedSnapshot" + , "snapshot" .= toObject verb snap ] + LedgerDB.InvalidSnapshot snap failure -> + mconcat [ "kind" .= String "TraceLedgerDBEvent.LedgerDBSnapshotEvent.InvalidSnapshot" + , "snapshot" .= toObject verb snap + , "failure" .= show failure ] + LedgerDB.LedgerReplayEvent ev' -> case ev' of + LedgerDB.TraceReplayStartEvent ev'' -> case ev'' of + LedgerDB.ReplayFromGenesis -> + mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayFromGenesis" ] + LedgerDB.ReplayFromSnapshot snap tip' -> + mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayFromSnapshot" + , "snapshot" .= toObject verb snap + , "tip" .= show tip' ] + LedgerDB.TraceReplayProgressEvent (LedgerDB.ReplayedBlock pt _ledgerEvents _ (LedgerDB.ReplayGoal replayTo)) -> + mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayedBlock" + , "slot" .= unSlotNo (realPointSlot pt) + , "tip" .= withOrigin 0 unSlotNo (pointSlot replayTo) ] + LedgerDB.LedgerDBForkerEvent (LedgerDB.TraceForkerEventWithKey k ev') -> + mconcat [ "kind" .= String "LedgerDBForkerEvent" + , "key" .= show k + , "event" .= show ev' ] + LedgerDB.LedgerDBFlavorImplEvent ev' -> + mconcat [ "kind" .= String "LedgerDBFlavorImplEvent" + , "event" .= show ev' ] toObject verb (ChainDB.TraceCopyToImmutableDBEvent ev) = case ev of ChainDB.CopiedBlockToImmutableDB pt -> mconcat [ "kind" .= String "TraceCopyToImmutableDBEvent.CopiedBlockToImmutableDB" @@ -1051,7 +1072,7 @@ instance ( ConvertRawHash blk mconcat [ "kind" .= String "TraceOpenEvent.OpenedImmutableDB" , "immtip" .= toObject verb immTip , "epoch" .= String ((pack . show) epoch) ] - ChainDB.OpenedVolatileDB -> + ChainDB.OpenedVolatileDB {} -> mconcat [ "kind" .= String "TraceOpenEvent.OpenedVolatileDB" ] ChainDB.OpenedLgrDB -> mconcat [ "kind" .= String "TraceOpenEvent.OpenedLgrDB" ] @@ -1087,7 +1108,7 @@ instance ( ConvertRawHash blk , "block" .= renderPointForVerbosity verb (AF.headPoint c) , "headers" .= map (renderPointForVerbosity verb . headerPoint) hdrs ] ChainDB.UpdateLedgerDbTraceEvent - (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr) ) -> + (StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr) ) -> mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.UpdateLedgerDbTraceEvent.StartedPushingBlockToTheLedgerDb" , "startingBlock" .= renderRealPoint start , "currentBlock" .= renderRealPoint curr @@ -1200,6 +1221,7 @@ instance ( ConvertRawHash blk mconcat [ "kind" .= String "TraceVolatileDBEvent.InvalidFileNames" , "files" .= String (Text.pack . show $ map show fsPaths) ] + VolDb.DBClosed -> mconcat [ "kind" .= String "TraceVolatileDBEvent.DBClosed" ] instance ConvertRawHash blk => ToObject (ImmDB.TraceChunkValidation blk ChunkNo) where toObject verb ev = case ev of @@ -1312,7 +1334,8 @@ instance ConvertRawHash blk <> [ "risingEdge" .= True | RisingEdge <- [enclosing] ] instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk), - ToJSON (GenTxId blk), LedgerSupportsMempool blk + ToJSON (GenTxId blk), LedgerSupportsMempool blk, + ConvertRawHash blk ) => ToObject (TraceEventMempool blk) where toObject verb (TraceMempoolAddedTx tx _mpSzBefore mpSzAfter) = mconcat @@ -1352,6 +1375,34 @@ instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk), , "txsInvalidated" .= map (toObject verb . txForgetValidated) txs1 , "mempoolSize" .= toObject verb mpSz ] + toObject _ TraceMempoolAttemptingSync = + mconcat + [ "kind" .= String "TraceMempoolAttemptingSync" + ] + toObject verb (TraceMempoolSyncNotNeeded t _) = + mconcat + [ "kind" .= String "TraceMempoolSyncNotNeeded" + , "tip" .= toObject verb t + ] + toObject _ TraceMempoolSyncDone = + mconcat + [ "kind" .= String "TraceMempoolSyncDone" + ] + toObject verb (TraceMempoolAttemptingAdd tx) = + mconcat + [ "kind" .= String "TraceMempoolAttemptingAdd" + , "tx" .= toObject verb tx + ] + toObject verb (TraceMempoolLedgerFound p) = + mconcat + [ "kind" .= String "TraceMempoolLedgerFound" + , "tip" .= toObject verb p + ] + toObject verb (TraceMempoolLedgerNotFound p) = + mconcat + [ "kind" .= String "TraceMempoolLedgerNotFound" + , "tip" .= toObject verb p + ] instance ToObject MempoolSize where toObject _verb MempoolSize{msNumTxs, msNumBytes} = diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index f777e0a36ad..f336d0b97b4 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -639,7 +639,7 @@ instance (applyTxErr ~ ApplyTxErr blk, ToObject localPeer) => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (LocalTxSubmission (GenTx blk) applyTxErr))) where trTransformer = trStructured -instance (LocalStateQuery.ShowQuery (BlockQuery blk), ToObject localPeer) +instance (forall fp. LocalStateQuery.ShowQuery (BlockQuery blk fp), ToObject localPeer) => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)))) where trTransformer = trStructured diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 497e4879d0e..9b0acac9e8c 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -186,16 +186,8 @@ indexGCType :: ChainDB.TraceGCEvent a -> Int indexGCType ChainDB.ScheduledGC{} = 1 indexGCType ChainDB.PerformedGC{} = 2 -indexReplType :: ChainDB.TraceReplayEvent a -> Int -indexReplType LedgerDB.ReplayFromGenesis{} = 1 -indexReplType LedgerDB.ReplayFromSnapshot{} = 2 -indexReplType LedgerDB.ReplayedBlock{} = 3 - instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where -- equivalent by type and severity - isEquivalent (WithSeverity s1 (ChainDB.TraceLedgerReplayEvent ev1)) - (WithSeverity s2 (ChainDB.TraceLedgerReplayEvent ev2)) = - s1 == s2 && indexReplType ev1 == indexReplType ev2 isEquivalent (WithSeverity s1 (ChainDB.TraceGCEvent ev1)) (WithSeverity s2 (ChainDB.TraceGCEvent ev2)) = s1 == s2 && indexGCType ev1 == indexGCType ev2 @@ -215,6 +207,12 @@ instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where (WithSeverity _s2 (ChainDB.TraceCopyToImmutableDBEvent _)) = True isEquivalent (WithSeverity _s1 (ChainDB.TraceCopyToImmutableDBEvent _)) (WithSeverity _s2 (ChainDB.TraceCopyToImmutableDBEvent _)) = True + isEquivalent (WithSeverity _s1 (ChainDB.TraceLedgerDBEvent + (LedgerDB.LedgerReplayEvent + (LedgerDB.TraceReplayProgressEvent _)))) + (WithSeverity _s2 (ChainDB.TraceLedgerDBEvent + (LedgerDB.LedgerReplayEvent + (LedgerDB.TraceReplayProgressEvent _)))) = True isEquivalent (WithSeverity _s1 (ChainDB.TraceInitChainSelEvent ev1)) (WithSeverity _s2 (ChainDB.TraceInitChainSelEvent ev2)) = case (ev1, ev2) of @@ -227,11 +225,12 @@ instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where _ -> False isEquivalent _ _ = False -- the types to be elided - doelide (WithSeverity _ (ChainDB.TraceLedgerReplayEvent _)) = True + doelide (WithSeverity _ (ChainDB.TraceLedgerDBEvent + (LedgerDB.LedgerReplayEvent + (LedgerDB.TraceReplayProgressEvent _)))) = True doelide (WithSeverity _ (ChainDB.TraceGCEvent _)) = True doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.IgnoreBlockOlderThanK _))) = False doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.IgnoreInvalidBlock _ _))) = False - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.BlockInTheFuture _ _))) = False doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.StoreButDontChange _))) = False doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.TrySwitchToAFork _ _))) = False doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.SwitchedToAFork{}))) = False @@ -261,7 +260,9 @@ instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where return (Just ev, count) conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceGCEvent _)) (_old, count) = return (Just ev, count) - conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceLedgerReplayEvent (LedgerDB.ReplayedBlock {}))) (_old, count) = do + conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceLedgerDBEvent + (LedgerDB.LedgerReplayEvent + (LedgerDB.TraceReplayProgressEvent _)))) (_old, count) = do return (Just ev, count) conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceInitChainSelEvent (ChainDB.InitChainSelValidation @@ -276,7 +277,9 @@ instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where else (Just ev, count) conteliding _ _ _ _ = return (Nothing, 0) - reportelided _tverb _tr (WithSeverity _ (ChainDB.TraceLedgerReplayEvent (LedgerDB.ReplayedBlock{}))) _count = pure () + reportelided _tverb _tr (WithSeverity _ (ChainDB.TraceLedgerDBEvent + (LedgerDB.LedgerReplayEvent + (LedgerDB.TraceReplayProgressEvent _)))) _count = pure () reportelided t tr ev count = defaultelidedreporting t tr ev count instance (StandardHash header, Eq peer) => ElidingTracer @@ -780,11 +783,11 @@ traceBlockFetchServerMetrics -> STM.TVar SlotNo -> Tracer IO (TraceLabelPeer peer (TraceBlockFetchServerEvent blk)) -> Tracer IO (TraceLabelPeer peer (TraceBlockFetchServerEvent blk)) -traceBlockFetchServerMetrics trMeta meta tBlocksServed tLocalUp tMaxSlotNo tracer = Tracer bsTracer +traceBlockFetchServerMetrics trMeta meta tBlocksServed tLocalUp tMaxSlotNo tracer = Tracer bfsTracer where - bsTracer :: TraceLabelPeer peer (TraceBlockFetchServerEvent blk) -> IO () - bsTracer e@(TraceLabelPeer _p (TraceBlockFetchServerSendBlock p)) = do + bfsTracer :: TraceLabelPeer peer (TraceBlockFetchServerEvent blk) -> IO () + bfsTracer e@(TraceLabelPeer _p (TraceBlockFetchServerSendBlock p)) = do traceWith tracer e (served, mbLocalUpstreamyness) <- atomically $ do @@ -1186,24 +1189,31 @@ notifyTxsProcessed fStats tr = Tracer $ \case mempoolMetricsTraceTransformer :: Trace IO a -> Tracer IO (TraceEventMempool blk) mempoolMetricsTraceTransformer tr = Tracer $ \mempoolEvent -> do let tr' = appendName "metrics" tr - (_n, tot) = case mempoolEvent of - TraceMempoolAddedTx _tx0 _ tot0 -> (1, tot0) - TraceMempoolRejectedTx _tx0 _ tot0 -> (1, tot0) - TraceMempoolRemoveTxs txs0 tot0 -> (length txs0, tot0) - TraceMempoolManuallyRemovedTxs txs0 txs1 tot0 -> ( length txs0 + length txs1, tot0) - logValue1 :: LOContent a - logValue1 = LogValue "txsInMempool" $ PureI $ fromIntegral (msNumTxs tot) - logValue2 :: LOContent a - logValue2 = LogValue "mempoolBytes" $ PureI $ fromIntegral (msNumBytes tot) - meta <- mkLOMeta Critical Confidential - traceNamedObject tr' (meta, logValue1) - traceNamedObject tr' (meta, logValue2) + mNTot = case mempoolEvent of + TraceMempoolAddedTx _tx0 _ tot0 -> Just (1, tot0) + TraceMempoolRejectedTx _tx0 _ tot0 -> Just (1, tot0) + TraceMempoolRemoveTxs txs0 tot0 -> Just (length txs0, tot0) + TraceMempoolManuallyRemovedTxs txs0 txs1 tot0 -> Just ( length txs0 + length txs1, tot0) + _ -> Nothing + maybe + (pure ()) + (\(_n, tot) -> do + let logValue1 :: LOContent a + logValue1 = LogValue "txsInMempool" $ PureI $ fromIntegral (msNumTxs tot) + logValue2 :: LOContent a + logValue2 = LogValue "mempoolBytes" $ PureI $ fromIntegral (msNumBytes tot) + meta <- mkLOMeta Critical Confidential + traceNamedObject tr' (meta, logValue1) + traceNamedObject tr' (meta, logValue2) + ) + mNTot mempoolTracer :: ( ToJSON (GenTxId blk) , ToObject (ApplyTxErr blk) , ToObject (GenTx blk) , LedgerSupportsMempool blk + , ConvertRawHash blk ) => TraceSelection -> Trace IO Text @@ -1218,6 +1228,7 @@ mempoolTracer tc tracer fStats = Tracer $ \ev -> do mpTracer :: ( ToJSON (GenTxId blk) , ToObject (ApplyTxErr blk) , ToObject (GenTx blk) + , ConvertRawHash blk , LedgerSupportsMempool blk ) => TraceSelection -> Trace IO Text -> Tracer IO (TraceEventMempool blk) @@ -1311,7 +1322,7 @@ forgeStateInfoTracer p _ts tracer = Tracer $ \ev -> do nodeToClientTracers' :: ( ToObject localPeer - , ShowQuery (BlockQuery blk) + , forall fp. ShowQuery (BlockQuery blk fp) ) => TraceSelection -> TracingVerbosity diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index 20d8c99119f..0c254309b64 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -6,6 +6,7 @@ module Test.Cardano.Node.POM ) where import Cardano.Crypto.ProtocolMagic (RequiresNetworkMagic (..)) +import Cardano.Node.Configuration.LedgerDB import Cardano.Node.Configuration.POM import Cardano.Node.Configuration.Socket import Cardano.Node.Handlers.Shutdown @@ -14,6 +15,8 @@ import Cardano.Tracing.Config (PartialTraceOptions (..), defaultPartia partialTraceSelectionToEither) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (NumOfDiskSnapshots (..), +import Ouroboros.Consensus.Storage.LedgerDB + (FlushFrequency (DefaultFlushFrequency), QueryBatchSize (DefaultQueryBatchSize), SnapshotInterval (..)) import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), @@ -144,6 +147,9 @@ testPartialYamlConfig = , pncTargetNumberOfActiveBigLedgerPeers = mempty , pncEnableP2P = Last (Just DisabledP2PMode) , pncPeerSharing = Last (Just PeerSharingDisabled) + , pncLedgerDBBackend = Last (Just InMemory) + , pncFlushFrequency = Last (Just DefaultFlushFrequency) + , pncQueryBatchSize = Last (Just DefaultQueryBatchSize) } -- | Example partial configuration theoretically created @@ -184,6 +190,9 @@ testPartialCliConfig = , pncTargetNumberOfActiveBigLedgerPeers = mempty , pncEnableP2P = Last (Just DisabledP2PMode) , pncPeerSharing = Last (Just PeerSharingDisabled) + , pncLedgerDBBackend = Last (Just InMemory) + , pncFlushFrequency = Last (Just DefaultFlushFrequency) + , pncQueryBatchSize = Last (Just DefaultQueryBatchSize) } -- | Expected final NodeConfiguration @@ -230,6 +239,9 @@ eExpectedConfig = do , ncTargetNumberOfActiveBigLedgerPeers = 5 , ncEnableP2P = SomeNetworkP2PMode Consensus.DisabledP2PMode , ncPeerSharing = PeerSharingDisabled + , ncLedgerDBBackend = InMemory + , ncFlushFrequency = DefaultFlushFrequency + , ncQueryBatchSize = DefaultQueryBatchSize } -- ----------------------------------------------------------------------------- From edb5012b8381c28f72c4df3b0b0672dc79fb0c0d Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 4 Mar 2024 15:28:16 +0100 Subject: [PATCH 02/26] WIP args --- .../Cardano/Node/Configuration/LedgerDB.hs | 23 ++- .../src/Cardano/Node/Configuration/POM.hs | 49 ++++- cardano-node/src/Cardano/Node/Parsers.hs | 66 +++++-- cardano-node/src/Cardano/Node/Run.hs | 167 +++++++++--------- nix/haskell.nix | 1 + 5 files changed, 196 insertions(+), 110 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs index 3ccd7408371..76d7ed37c71 100644 --- a/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs +++ b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs @@ -4,16 +4,22 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Node.Configuration.LedgerDB ( - BackingStoreSelectorFlag(..) + LedgerDbSelectorFlag(..) , Gigabytes , toBytes , defaultLMDBLimits + , selectorToArgs ) where import Prelude import qualified Data.Aeson.Types as Aeson (FromJSON) import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB (LMDBLimits (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Args +import Ouroboros.Consensus.Util.Args +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import Data.SOP.Dict -- | Choose the LedgerDB Backend -- @@ -25,11 +31,12 @@ import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB -- - 'LMDB': uses less memory but is somewhat slower. -- -- See 'Ouroboros.Consnesus.Storage.LedgerDB.OnDisk.BackingStoreSelector'. -data BackingStoreSelectorFlag = - LMDB (Maybe Gigabytes) -- ^ A map size can be specified, this is the maximum +data LedgerDbSelectorFlag = + V1LMDB (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. - | InMemory + | V1InMemory + | V2InMemory deriving (Eq, Show) -- | A number of gigabytes. @@ -87,3 +94,11 @@ defaultLMDBLimits = LMDBLimits { , lmdbMaxDatabases = 10 , lmdbMaxReaders = 16 } + +selectorToArgs :: LedgerDbSelectorFlag -> V1.FlushFrequency -> V1.QueryBatchSize -> Complete LedgerDbFlavorArgs IO +selectorToArgs V1InMemory a b = LedgerDbFlavorArgsV1 $ V1.V1Args a b V1.InMemoryBackingStoreArgs +selectorToArgs V2InMemory _ _ = LedgerDbFlavorArgsV2 $ V2.V2Args V2.InMemoryHandleArgs +selectorToArgs (V1LMDB l) a b= + LedgerDbFlavorArgsV1 + $ V1.V1Args a b + $ V1.LMDBBackingStoreArgs (maybe id (\ll lim -> lim { lmdbMapSize = toBytes ll }) l $ defaultLMDBLimits) Dict diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 190c2f682fe..e4f5210b3bd 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -35,9 +35,9 @@ import Cardano.Tracing.OrphanInstances.Network () import Ouroboros.Consensus.Mempool (MempoolCapacityBytes (..), MempoolCapacityBytesOverride (..)) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (SnapshotInterval (..)) import Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..), QueryBatchSize (..)) -import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (SnapshotInterval (..)) import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) @@ -134,7 +134,7 @@ data NodeConfiguration -- LedgerDB configuration , ncSnapshotInterval :: !SnapshotInterval - , ncLedgerDBBackend :: !BackingStoreSelectorFlag + , ncLedgerDBBackend :: !LedgerDbSelectorFlag , ncFlushFrequency :: !FlushFrequency , ncQueryBatchSize :: !QueryBatchSize @@ -168,6 +168,11 @@ data NodeConfiguration -- Enable Peer Sharing , ncPeerSharing :: PeerSharing + + -- SSD options for LMDB/Snapshot storing + , ncSsdDatabaseDir :: FilePath + , ncSsdSnapshotState :: !Bool + , ncSsdSnapshotTables :: !Bool } deriving (Eq, Show) @@ -208,7 +213,7 @@ data PartialNodeConfiguration -- LedgerDB configuration , pncSnapshotInterval :: !(Last SnapshotInterval) - , pncLedgerDBBackend :: !(Last BackingStoreSelectorFlag) + , pncLedgerDBBackend :: !(Last LedgerDbSelectorFlag) , pncFlushFrequency :: !(Last FlushFrequency) , pncQueryBatchSize :: !(Last QueryBatchSize) @@ -235,6 +240,11 @@ data PartialNodeConfiguration -- Peer Sharing , pncPeerSharing :: !(Last PeerSharing) + + -- SSD options for LMDB/Snapshot storing + , pncSsdDatabaseDir :: Last FilePath + , pncSsdSnapshotState :: !(Last Bool) + , pncSsdSnapshotTables :: !(Last Bool) } deriving (Eq, Generic, Show) instance AdjustFilePaths PartialNodeConfiguration where @@ -333,6 +343,11 @@ instance FromJSON PartialNodeConfiguration where -- DISABLED BY DEFAULT pncPeerSharing <- Last <$> v .:? "PeerSharing" .!= Just PeerSharingDisabled + -- SSD options for LMDB/Snapshot storing + pncSsdDatabaseDir <- Last <$> v .:? "SsdDatabaseDir" + pncSsdSnapshotState <- Last <$> v .:? "SsdSnapshotState" + pncSsdSnapshotTables <- Last <$> v .:? "SsdSnapshotTables" + pure PartialNodeConfiguration { pncProtocolConfig , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty pncSocketPath @@ -369,6 +384,9 @@ instance FromJSON PartialNodeConfiguration where , pncTargetNumberOfActiveBigLedgerPeers , pncEnableP2P , pncPeerSharing + , pncSsdDatabaseDir + , pncSsdSnapshotState + , pncSsdSnapshotTables } where parseMempoolCapacityBytesOverride v = parseNoOverride <|> parseOverride @@ -388,10 +406,11 @@ instance FromJSON PartialNodeConfiguration where parseLedgerDBBackend v = do maybeString :: Maybe String <- v .:? "LedgerDBBackend" case maybeString of - Just "InMemory" -> return $ Just InMemory - Just "LMDB" -> do + Just "V1InMemory" -> return $ Just V1InMemory + Just "V2InMemory" -> return $ Just V2InMemory + Just "V1LMDB" -> do mapSize :: Maybe Gigabytes <- v .:? "LMDBMapSize" - return . Just . LMDB $ mapSize + return . Just . V1LMDB $ mapSize Nothing -> return Nothing Just whatever -> fail $ "Malformed LedgerDBBackend" <> whatever @@ -535,7 +554,7 @@ defaultPartialNodeConfiguration = , pncTraceForwardSocket = mempty , pncMaybeMempoolCapacityOverride = mempty , pncSnapshotInterval = Last $ Just DefaultSnapshotInterval - , pncLedgerDBBackend = Last $ Just InMemory + , pncLedgerDBBackend = Last $ Just V2InMemory , pncFlushFrequency = Last $ Just DefaultFlushFrequency , pncQueryBatchSize = Last $ Just DefaultQueryBatchSize , pncProtocolIdleTimeout = Last (Just 5) @@ -558,6 +577,9 @@ defaultPartialNodeConfiguration = , pncTargetNumberOfActiveBigLedgerPeers = Last (Just 5) , pncEnableP2P = Last (Just DisabledP2PMode) , pncPeerSharing = Last (Just PeerSharingDisabled) + , pncSsdDatabaseDir = Last (Just "mainnet/ledgerdb/") + , pncSsdSnapshotState = Last (Just False) + , pncSsdSnapshotTables = Last (Just False) } lastOption :: Parser a -> Parser (Last a) @@ -631,6 +653,16 @@ makeNodeConfiguration pnc = do lastToEither "Missing PeerSharing" $ pncPeerSharing pnc + ssdDatabaseDir <- + lastToEither "Missing SsdDatabaseDir" + $ pncSsdDatabaseDir pnc + ssdSnapshotState <- + lastToEither "Missing SsdSnapshotState" + $ pncSsdSnapshotState pnc + ssdSnapshotTables <- + lastToEither "Missing SsdSnapshotTables" + $ pncSsdSnapshotTables pnc + -- TODO: This is not mandatory experimentalProtocols <- lastToEither "Missing ExperimentalProtocolsEnabled" $ @@ -680,6 +712,9 @@ makeNodeConfiguration pnc = do EnabledP2PMode -> SomeNetworkP2PMode Consensus.EnabledP2PMode DisabledP2PMode -> SomeNetworkP2PMode Consensus.DisabledP2PMode , ncPeerSharing + , ncSsdDatabaseDir = ssdDatabaseDir + , ncSsdSnapshotState = ssdSnapshotState + , ncSsdSnapshotTables = ssdSnapshotTables } ncProtocol :: NodeConfiguration -> Protocol diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index b4ef8cf9418..2c5417faf52 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -12,6 +12,7 @@ module Cardano.Node.Parsers ) where import Cardano.Logging.Types +import Cardano.Node.Configuration.LedgerDB import Cardano.Node.Configuration.NodeAddress (File (..), NodeHostIPv4Address (NodeHostIPv4Address), NodeHostIPv6Address (NodeHostIPv6Address), PortNumber, SocketPath) @@ -22,6 +23,9 @@ import Cardano.Node.Types import Cardano.Prelude (ConvertText (..)) import Ouroboros.Consensus.Mempool (MempoolCapacityBytes (..), MempoolCapacityBytesOverride (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (SnapshotInterval (..)) +import Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..), + QueryBatchSize (..)) import Data.Foldable import Data.Maybe (fromMaybe) @@ -35,12 +39,6 @@ import qualified Options.Applicative.Help as OptI import System.Posix.Types (Fd (..)) import Text.Read (readMaybe) -import Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..), - QueryBatchSize (..)) -import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (SnapshotInterval (..)) - -import Cardano.Node.Configuration.LedgerDB - nodeCLIParser :: Parser PartialNodeConfiguration nodeCLIParser = subparser ( commandGroup "Run the node" @@ -87,6 +85,11 @@ nodeRunParser = do pncFlushFrequency <- lastOption parseFlushFrequency pncQueryBatchSize <- lastOption parseQueryBatchSize + -- Storing to SSD configuration + ssdDatabaseDir <- lastOption parseSsdDatabaseDir + ssdSnapshotState <- lastOption parseSsdSnapshotState + ssdSnapshotTables <- lastOption parseSsdSnapshotTables + pure $ PartialNodeConfiguration { pncSocketConfig = Last . Just $ SocketConfig @@ -136,6 +139,9 @@ nodeRunParser = do , pncTargetNumberOfActiveBigLedgerPeers = mempty , pncEnableP2P = mempty , pncPeerSharing = mempty + , pncSsdDatabaseDir = ssdDatabaseDir + , pncSsdSnapshotState = ssdSnapshotState + , pncSsdSnapshotTables = ssdSnapshotTables } parseSocketPath :: Text -> Parser SocketPath @@ -234,21 +240,30 @@ parseMempoolCapacityOverride = parseOverride <|> parseNoOverride <> help "Don't override the mempool capacity" ) -parseLedgerDBBackend :: Parser BackingStoreSelectorFlag -parseLedgerDBBackend = parseInMemory <|> parseLMDB <*> optional parseMapSize +parseLedgerDBBackend :: Parser LedgerDbSelectorFlag +parseLedgerDBBackend = parseV1InMemory <|> parseV2InMemory <|> parseLMDB <*> optional parseMapSize where - parseInMemory :: Parser BackingStoreSelectorFlag - parseInMemory = - flag' InMemory ( long "in-memory-ledger-db-backend" - <> help "Use the InMemory ledger DB backend. \ + parseV1InMemory :: Parser LedgerDbSelectorFlag + parseV1InMemory = + flag' V1InMemory ( long "v1-in-memory-ledger-db-backend" + <> help "Use the V1 InMemory ledger DB backend. \ + \ Incompatible with `--lmdb-ledger-db-backend`. \ + \ The node uses the in-memory backend by default \ + \ if no ``--*-db-backend`` flags are set." + ) + + parseV2InMemory :: Parser LedgerDbSelectorFlag + parseV2InMemory = + flag' V2InMemory ( long "v2-in-memory-ledger-db-backend" + <> help "Use the V2 InMemory ledger DB backend. \ \ Incompatible with `--lmdb-ledger-db-backend`. \ \ The node uses the in-memory backend by default \ \ if no ``--*-db-backend`` flags are set." ) - parseLMDB :: Parser (Maybe Gigabytes -> BackingStoreSelectorFlag) + parseLMDB :: Parser (Maybe Gigabytes -> LedgerDbSelectorFlag) parseLMDB = - flag' LMDB ( long "lmdb-ledger-db-backend" + flag' V1LMDB ( long "v1-lmdb-ledger-db-backend" <> help "Use the LMDB ledger DB backend. By default, the \ \ mapsize (maximum database size) of the backend \ \ is set to 16 Gigabytes. Warning: if the database \ @@ -404,6 +419,29 @@ parseSnapshotInterval = fmap (RequestedSnapshotInterval . secondsToDiffTime) par <> help "Snapshot Interval (in seconds)" ) +parseSsdDatabaseDir :: Parser FilePath +parseSsdDatabaseDir = + strOption + ( long "ssd-database-dir" + <> metavar "FILEPATH" + <> help "Directory where the LMDB is stored." + <> completer (bashCompleter "file") + ) + +parseSsdSnapshotState :: Parser Bool +parseSsdSnapshotState = + switch ( + long "ssd-snapshot-state" + <> help "Store serialization of the ledger state in the SSD dir." + ) + +parseSsdSnapshotTables :: Parser Bool +parseSsdSnapshotTables = + switch ( + long "ssd-snapshot-tables" + <> help "Store the copied LMDB tables in the SSD dir." + ) + -- | Produce just the brief help header for a given CLI option parser, -- without the options. parserHelpHeader :: String -> Opt.Parser a -> OptI.Doc diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 8e9b4c552e5..fcae92a84eb 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -8,8 +8,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unused-imports #-} @@ -22,14 +22,70 @@ module Cardano.Node.Run , checkVRFFilePermissions ) where -import qualified Ouroboros.Consensus.Storage.LedgerDB.Impl.Args as LDBArgs import Cardano.Api (File (..), FileDirection (..)) import qualified Cardano.Api as Api +import Cardano.BM.Data.LogItem (LogObject (..)) +import Cardano.BM.Data.Tracer (ToLogObject (..), TracingVerbosity (..)) +import Cardano.BM.Data.Transformers (setHostname) +import Cardano.BM.Trace +import qualified Cardano.Crypto.Init as Crypto +import Cardano.Node.Configuration.LedgerDB +import Cardano.Node.Configuration.Logging (LoggingLayer (..), createLoggingLayer, + nodeBasicInfo, shutdownLoggingLayer) +import Cardano.Node.Configuration.NodeAddress +import Cardano.Node.Configuration.POM (NodeConfiguration (..), + PartialNodeConfiguration (..), SomeNetworkP2PMode (..), TimeoutOverride (..), + defaultPartialNodeConfiguration, makeNodeConfiguration, parseNodeConfigurationFP) +import Cardano.Node.Configuration.Socket (SocketOrSocketInfo (..), + gatherConfiguredSockets, getSocketOrSocketInfoAddr) +import qualified Cardano.Node.Configuration.Topology as TopologyNonP2P +import Cardano.Node.Configuration.TopologyP2P +import qualified Cardano.Node.Configuration.TopologyP2P as TopologyP2P +import Cardano.Node.Handlers.Shutdown +import Cardano.Node.Protocol (ProtocolInstantiationError (..), mkConsensusProtocol) +import Cardano.Node.Protocol.Byron (ByronProtocolInstantiationError (CredentialsError)) +import Cardano.Node.Protocol.Cardano (CardanoProtocolInstantiationError (..)) +import Cardano.Node.Protocol.Shelley (PraosLeaderCredentialsError (..), + ShelleyProtocolInstantiationError (PraosLeaderCredentialsError)) +import Cardano.Node.Protocol.Types +import Cardano.Node.Queries +import Cardano.Node.Startup +import Cardano.Node.TraceConstraints (TraceConstraints) +import Cardano.Node.Tracing.API +import Cardano.Node.Tracing.StateRep (NodeState (NodeKernelOnline)) +import Cardano.Node.Tracing.Tracers.Startup (getStartupInfo) +import Cardano.Node.Types import Cardano.Prelude (FatalError (..), bool, (:~:) (..)) - -import Data.Bits -import Data.IP (toSockAddr) +import Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..)) +import Cardano.Tracing.Tracers +import qualified Ouroboros.Consensus.Config as Consensus +import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..)) +import Ouroboros.Consensus.Node (NetworkP2PMode (..), RunNodeArgs (..), + StdRunNodeArgs (..), stdChainSyncTimeout) +import qualified Ouroboros.Consensus.Node as Node (getChainDB, run) +import Ouroboros.Consensus.Node.NetworkProtocolVersion +import Ouroboros.Consensus.Node.ProtocolInfo +import qualified Ouroboros.Consensus.Node.Tracers as Consensus +import qualified Ouroboros.Consensus.Storage.LedgerDB.Impl.Args as LDBArgs +import Ouroboros.Consensus.Storage.LedgerDB.V2.Args +import Ouroboros.Consensus.Util.Args +import Ouroboros.Consensus.Util.Orphans () +import qualified Ouroboros.Network.Diffusion as Diffusion +import qualified Ouroboros.Network.Diffusion.NonP2P as NonP2P +import qualified Ouroboros.Network.Diffusion.P2P as P2P +import Ouroboros.Network.NodeToClient (LocalAddress (..), LocalSocket (..)) +import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), ConnectionId, + PeerSelectionTargets (..), RemoteAddress) +import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type (UseLedgerPeers) +import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) +import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, WarmValency) +import Ouroboros.Network.Protocol.ChainSync.Codec +import Ouroboros.Network.Subscription (DnsSubscriptionTarget (..), + IPSubscriptionTarget (..)) import Control.Concurrent (killThread, mkWeakThreadId, myThreadId) import Control.Concurrent.Class.MonadSTM.Strict @@ -41,7 +97,9 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Except.Extra (left) import "contra-tracer" Control.Tracer +import Data.Bits import Data.Either (partitionEithers) +import Data.IP (toSockAddr) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) @@ -68,74 +126,8 @@ import System.Posix.Types (FileMode) import System.Win32.File #endif -import Cardano.BM.Data.LogItem (LogObject (..)) -import Cardano.BM.Data.Tracer (ToLogObject (..), TracingVerbosity (..)) -import Cardano.BM.Data.Transformers (setHostname) -import Cardano.BM.Trace import Paths_cardano_node (version) -import qualified Cardano.Crypto.Init as Crypto - -import Cardano.Node.Configuration.Logging (LoggingLayer (..), createLoggingLayer, - nodeBasicInfo, shutdownLoggingLayer) -import Cardano.Node.Configuration.NodeAddress -import Cardano.Node.Configuration.POM (NodeConfiguration (..), - PartialNodeConfiguration (..), SomeNetworkP2PMode (..), TimeoutOverride (..), - defaultPartialNodeConfiguration, makeNodeConfiguration, parseNodeConfigurationFP) -import Cardano.Node.Startup -import Cardano.Node.Tracing.API -import Cardano.Node.Tracing.StateRep (NodeState (NodeKernelOnline)) -import Cardano.Node.Tracing.Tracers.Startup (getStartupInfo) -import Cardano.Node.Types -import Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..)) - -import qualified Ouroboros.Consensus.Config as Consensus -import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..)) -import Ouroboros.Consensus.Node (NetworkP2PMode (..), - RunNodeArgs (..), StdRunNodeArgs (..), stdChainSyncTimeout) -import qualified Ouroboros.Consensus.Node as Node (getChainDB, run) -import Ouroboros.Consensus.Node.NetworkProtocolVersion -import qualified Ouroboros.Consensus.Node.Tracers as Consensus -import Ouroboros.Consensus.Node.ProtocolInfo -import Ouroboros.Consensus.Util.Orphans () -import qualified Ouroboros.Network.Diffusion as Diffusion -import qualified Ouroboros.Network.Diffusion.NonP2P as NonP2P -import qualified Ouroboros.Network.Diffusion.P2P as P2P -import Ouroboros.Network.NodeToClient (LocalAddress (..), LocalSocket (..)) -import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), ConnectionId, - PeerSelectionTargets (..), RemoteAddress) -import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) -import Ouroboros.Network.Protocol.ChainSync.Codec -import Ouroboros.Network.Subscription (DnsSubscriptionTarget (..), - IPSubscriptionTarget (..)) -import Ouroboros.Network.PeerSelection.Bootstrap - (UseBootstrapPeers (..)) - -import Cardano.Node.Configuration.Socket (SocketOrSocketInfo (..), - gatherConfiguredSockets, getSocketOrSocketInfoAddr) -import qualified Cardano.Node.Configuration.Topology as TopologyNonP2P -import Cardano.Node.Configuration.TopologyP2P -import qualified Cardano.Node.Configuration.TopologyP2P as TopologyP2P -import Cardano.Node.Handlers.Shutdown -import Cardano.Node.Protocol (ProtocolInstantiationError (..), mkConsensusProtocol) -import Cardano.Node.Protocol.Byron (ByronProtocolInstantiationError (CredentialsError)) -import Cardano.Node.Protocol.Cardano (CardanoProtocolInstantiationError (..)) -import Cardano.Node.Protocol.Shelley (PraosLeaderCredentialsError (..), - ShelleyProtocolInstantiationError (PraosLeaderCredentialsError)) -import Cardano.Node.Protocol.Types -import Cardano.Node.Queries -import Cardano.Node.TraceConstraints (TraceConstraints) -import Cardano.Tracing.Tracers -import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) -import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, WarmValency) -import Ouroboros.Network.PeerSelection.LedgerPeers.Type (UseLedgerPeers) -import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable) -import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers) - -import Cardano.Node.Configuration.LedgerDB -import Ouroboros.Consensus.Storage.LedgerDB.V2.Args -import Ouroboros.Consensus.Util.Args - {- HLINT ignore "Fuse concatMap/map" -} {- HLINT ignore "Redundant <$>" -} {- HLINT ignore "Use fewer imports" -} @@ -380,6 +372,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do Exception.throwIO err dbPath <- canonDbPath nc + ssdPath <- canonSsdPath nc let diffusionArguments :: Diffusion.Arguments Socket RemoteAddress LocalSocket LocalAddress @@ -480,10 +473,6 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do (readTVar publicRootsVar) (readTVar useLedgerVar) (readTVar useBootstrapVar) - - srnL :: Complete LedgerDbFlavorArgs IO - srnL = V2Args InMemoryHandleArgs - in Node.run nodeArgs { @@ -507,7 +496,9 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , srnMaybeMempoolCapacityOverride = ncMaybeMempoolCapacityOverride nc , srnChainSyncTimeout = customizeChainSyncTimeout , srnSnapshotInterval = ncSnapshotInterval nc - , srnLdbFlavorArgs = LDBArgs.LedgerDbFlavorArgsV2 srnL + , srnLdbFlavorArgs = selectorToArgs (ncLedgerDBBackend nc) (ncFlushFrequency nc) (ncQueryBatchSize nc) + , srnPutInSSD = (ncSsdSnapshotTables nc, ncSsdSnapshotState nc) + , srnSSDPath = ssdPath } DisabledP2PMode -> do nt <- TopologyNonP2P.readTopologyFileOrError nc @@ -547,9 +538,6 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , rnPeerSharing = ncPeerSharing nc , rnGetUseBootstrapPeers = pure DontUseBootstrapPeers } - - srnL :: Complete LedgerDbFlavorArgs IO - srnL = V2Args InMemoryHandleArgs #ifdef UNIX -- initial `SIGHUP` handler; it only warns that neither updating of -- topology is supported nor updating block forging is yet possible. @@ -584,7 +572,9 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , srnChainSyncTimeout = customizeChainSyncTimeout , srnMaybeMempoolCapacityOverride = ncMaybeMempoolCapacityOverride nc , srnSnapshotInterval = ncSnapshotInterval nc - , srnLdbFlavorArgs = LDBArgs.LedgerDbFlavorArgsV2 srnL + , srnLdbFlavorArgs = selectorToArgs (ncLedgerDBBackend nc) (ncFlushFrequency nc) (ncQueryBatchSize nc) + , srnPutInSSD = (ncSsdSnapshotTables nc, ncSsdSnapshotState nc) + , srnSSDPath = ssdPath } where @@ -781,11 +771,18 @@ updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLed -------------------------------------------------------------------------------- canonDbPath :: NodeConfiguration -> IO FilePath -canonDbPath NodeConfiguration{ncDatabaseFile = DbFile dbFp} = do - fp <- canonicalizePath =<< makeAbsolute dbFp - createDirectoryIfMissing True fp - return fp - +canonDbPath NodeConfiguration{ncDatabaseFile = DbFile dbFp} = + canonPath dbFp + +canonSsdPath :: NodeConfiguration -> IO FilePath +canonSsdPath NodeConfiguration{ncSsdDatabaseDir} = + canonPath ncSsdDatabaseDir + +canonPath :: FilePath -> IO FilePath +canonPath fp = do + cfp <- canonicalizePath =<< makeAbsolute fp + createDirectoryIfMissing True cfp + return cfp -- | Make sure the VRF private key file is readable only -- by the current process owner the node is running under. diff --git a/nix/haskell.nix b/nix/haskell.nix index 437a1755124..60d05131cd0 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -42,6 +42,7 @@ let # These programs will be available inside the nix-shell. nativeBuildInputs = with pkgs.pkgsBuildBuild; [ + lmdb nix-prefetch-git pkg-config hlint From d2bc4d834ab712498b909f186eb6d54eb24bf1c6 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 25 Mar 2024 16:08:54 +0100 Subject: [PATCH 03/26] Update packages --- cabal.project | 42 +++++++++++++++++++++++++++++------------- 1 file changed, 29 insertions(+), 13 deletions(-) diff --git a/cabal.project b/cabal.project index a45dc7554f2..090a4917e2d 100644 --- a/cabal.project +++ b/cabal.project @@ -13,8 +13,8 @@ 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 2024-03-20T14:55:30Z - , cardano-haskell-packages 2024-03-20T14:22:58Z + , hackage.haskell.org 2024-03-25T10:39:21Z + , cardano-haskell-packages 2024-03-22T16:27:41Z packages: cardano-git-rev @@ -32,15 +32,6 @@ packages: trace-resources trace-forward - ../ouroboros-consensus/ouroboros-consensus - ../ouroboros-consensus/ouroboros-consensus-cardano - ../ouroboros-consensus/ouroboros-consensus-diffusion - ../ouroboros-consensus/ouroboros-consensus-protocol - ../ouroboros-consensus/sop-extras - ../ouroboros-consensus/strict-sop-core - - ../cardano-api/cardano-api - program-options ghc-options: -Werror @@ -73,7 +64,32 @@ package plutus-scripts-bench source-repository-package type: git location: https://github.com/jasagredo/latex-svg - tag: 05dc866baadcdd04a23ed1a488440372f97afb70 - --sha256: 1amaipl1f516m4yh9x02cqsbv50riszmbdjdmvfpw19vspv1szsx + tag: c52c9905cb043ddb430c93b41ce431a7506a300d + --sha256: 0h9yrlvmyi32zlr0cj2nx8ik0y2cg5ckcxq4lgq5vvjyl6lhzrbk subdir: latex-svg-image + +if impl(ghc >= 9.6) + allow-newer: + cardano-lmdb-simple:bytestring + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus + tag: 5b4dd265f8c75a27c51797f114b3ce7e308b72aa + --sha256: 0736i06v6wwl5krlybqiwswy1mn0986zrs904dvc0718424gnb85 + subdir: + ouroboros-consensus + ouroboros-consensus-cardano + ouroboros-consensus-diffusion + ouroboros-consensus-protocol + sop-extras + strict-sop-core + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-api + tag: 9c2a821cfcbb4cffca8c2ce830b1574f7bb4afda + --sha256: 0r4whqj16zxfykaw6nyb3fcpvb6qi519sz6lv30baijl1wndvrfa + subdir: + cardano-api From 4d72e00a6fb51bf445e06fd34acc8f807fbfce6e Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 25 Mar 2024 16:30:40 +0100 Subject: [PATCH 04/26] Make tests build --- .../src/Cardano/Node/Configuration/POM.hs | 4 +-- cardano-node/test/Test/Cardano/Node/POM.hs | 26 ++++++++++++------- .../src/Cardano/Logging/DocuGenerator.hs | 6 ++--- 3 files changed, 21 insertions(+), 15 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index e4f5210b3bd..383e91b0e1c 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -170,7 +170,7 @@ data NodeConfiguration , ncPeerSharing :: PeerSharing -- SSD options for LMDB/Snapshot storing - , ncSsdDatabaseDir :: FilePath + , ncSsdDatabaseDir :: !FilePath , ncSsdSnapshotState :: !Bool , ncSsdSnapshotTables :: !Bool } deriving (Eq, Show) @@ -242,7 +242,7 @@ data PartialNodeConfiguration , pncPeerSharing :: !(Last PeerSharing) -- SSD options for LMDB/Snapshot storing - , pncSsdDatabaseDir :: Last FilePath + , pncSsdDatabaseDir :: !(Last FilePath) , pncSsdSnapshotState :: !(Last Bool) , pncSsdSnapshotTables :: !(Last Bool) } deriving (Eq, Generic, Show) diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index 0c254309b64..d69ca7d713b 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -14,10 +14,10 @@ import Cardano.Node.Types import Cardano.Tracing.Config (PartialTraceOptions (..), defaultPartialTraceConfiguration, partialTraceSelectionToEither) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) -import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (NumOfDiskSnapshots (..), -import Ouroboros.Consensus.Storage.LedgerDB - (FlushFrequency (DefaultFlushFrequency), QueryBatchSize (DefaultQueryBatchSize), - SnapshotInterval (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots + (SnapshotInterval (..)) +import Ouroboros.Consensus.Storage.LedgerDB.V1.Args + import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode (InitiatorAndResponderDiffusionMode)) @@ -119,7 +119,6 @@ testPartialYamlConfig = , pncShutdownConfig = Last Nothing , pncStartAsNonProducingNode = Last $ Just False , pncDiffusionMode = Last Nothing - , pncNumOfDiskSnapshots = Last Nothing , pncSnapshotInterval = mempty , pncExperimentalProtocolsEnabled = Last Nothing , pncMaxConcurrencyBulkSync = Last Nothing @@ -147,9 +146,12 @@ testPartialYamlConfig = , pncTargetNumberOfActiveBigLedgerPeers = mempty , pncEnableP2P = Last (Just DisabledP2PMode) , pncPeerSharing = Last (Just PeerSharingDisabled) - , pncLedgerDBBackend = Last (Just InMemory) + , pncLedgerDBBackend = Last (Just V2InMemory) , pncFlushFrequency = Last (Just DefaultFlushFrequency) , pncQueryBatchSize = Last (Just DefaultQueryBatchSize) + , pncSsdSnapshotState = Last (Just False) + , pncSsdDatabaseDir = Last Nothing + , pncSsdSnapshotTables = Last (Just False) } -- | Example partial configuration theoretically created @@ -164,7 +166,6 @@ testPartialCliConfig = , pncTopologyFile = mempty , pncDatabaseFile = mempty , pncDiffusionMode = mempty - , pncNumOfDiskSnapshots = Last Nothing , pncSnapshotInterval = Last . Just . RequestedSnapshotInterval $ secondsToDiffTime 100 , pncExperimentalProtocolsEnabled = Last $ Just True , pncProtocolFiles = Last . Just $ ProtocolFilepaths Nothing Nothing Nothing Nothing Nothing Nothing @@ -190,9 +191,12 @@ testPartialCliConfig = , pncTargetNumberOfActiveBigLedgerPeers = mempty , pncEnableP2P = Last (Just DisabledP2PMode) , pncPeerSharing = Last (Just PeerSharingDisabled) - , pncLedgerDBBackend = Last (Just InMemory) + , pncLedgerDBBackend = Last (Just V2InMemory) , pncFlushFrequency = Last (Just DefaultFlushFrequency) , pncQueryBatchSize = Last (Just DefaultQueryBatchSize) + , pncSsdSnapshotState = Last (Just False) + , pncSsdDatabaseDir = Last Nothing + , pncSsdSnapshotTables = Last (Just False) } -- | Expected final NodeConfiguration @@ -211,7 +215,6 @@ eExpectedConfig = do , ncValidateDB = True , ncProtocolConfig = testNodeProtocolConfiguration , ncDiffusionMode = InitiatorAndResponderDiffusionMode - , ncNumOfDiskSnapshots = DefaultNumOfDiskSnapshots , ncSnapshotInterval = RequestedSnapshotInterval $ secondsToDiffTime 100 , ncExperimentalProtocolsEnabled = True , ncMaxConcurrencyBulkSync = Nothing @@ -239,9 +242,12 @@ eExpectedConfig = do , ncTargetNumberOfActiveBigLedgerPeers = 5 , ncEnableP2P = SomeNetworkP2PMode Consensus.DisabledP2PMode , ncPeerSharing = PeerSharingDisabled - , ncLedgerDBBackend = InMemory + , ncLedgerDBBackend = V2InMemory , ncFlushFrequency = DefaultFlushFrequency , ncQueryBatchSize = DefaultQueryBatchSize + , ncSsdDatabaseDir = "mainnet/ledgerdb/" + , ncSsdSnapshotState = False + , ncSsdSnapshotTables = False } -- ----------------------------------------------------------------------------- diff --git a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs index ad5b11ea103..6e35bddb6ef 100644 --- a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs +++ b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs @@ -216,15 +216,15 @@ documentTracer tracer = do propertiesBuilder LogDoc {..} = case ldSeverityCoded of Just s -> fromText "Severity: " <> asCode (fromString (show s)) <> "\n" - Nothing -> fromText "Severity missing" <> "\n" + Nothing -> fromText "Severity missing: " <> "\n" <> case ldPrivacyCoded of Just p -> fromText "Privacy: " <> asCode (fromString (show p)) <> "\n" - Nothing -> fromText "Privacy missing" <> "\n" + Nothing -> fromText "Privacy missing: " <> "\n" <> case ldDetailsCoded of Just d -> fromText "Details: " <> asCode (fromString (show d)) <> "\n" - Nothing -> fromText "Details missing" <> "\n" + Nothing -> fromText "Details missing: " <> "\n" propertiesWarning :: LogDoc ->[InconsistencyWarning] propertiesWarning LogDoc {..} = From 29c7c408d2c1e2492fad80eb7bf1aa0cc4a52595 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 26 Mar 2024 12:39:01 +0100 Subject: [PATCH 05/26] Update cabal.project refs --- cabal.project | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index 090a4917e2d..a2da49a0a4b 100644 --- a/cabal.project +++ b/cabal.project @@ -76,8 +76,8 @@ if impl(ghc >= 9.6) source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: 5b4dd265f8c75a27c51797f114b3ce7e308b72aa - --sha256: 0736i06v6wwl5krlybqiwswy1mn0986zrs904dvc0718424gnb85 + tag: ef26a50893c65f346ea0a3b865632b014692db3f + --sha256: 0c3pd7zdriid7n6a5n86f2c009lygls10qjawmdiih8rvpvr51d3 subdir: ouroboros-consensus ouroboros-consensus-cardano @@ -89,7 +89,7 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: 9c2a821cfcbb4cffca8c2ce830b1574f7bb4afda - --sha256: 0r4whqj16zxfykaw6nyb3fcpvb6qi519sz6lv30baijl1wndvrfa + tag: cf6e015c1829dc5e54b8baec4f16f6f0b3d25f53 + --sha256: 1cqsim1ka2949p64096mz7j44sx23rfnq88bns2k39fyf2h19r1h subdir: cardano-api From 7709ac8cde33ca9c04aada4829da844a6e0e9635 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Thu, 4 Apr 2024 17:07:21 +0200 Subject: [PATCH 06/26] Update cabal.project refs --- cabal.project | 10 +++++----- flake.lock | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/cabal.project b/cabal.project index a2da49a0a4b..dc88b3728fe 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- you need to run if you change them index-state: , hackage.haskell.org 2024-03-25T10:39:21Z - , cardano-haskell-packages 2024-03-22T16:27:41Z + , cardano-haskell-packages 2024-04-04T11:57:10Z packages: cardano-git-rev @@ -76,8 +76,8 @@ if impl(ghc >= 9.6) source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: ef26a50893c65f346ea0a3b865632b014692db3f - --sha256: 0c3pd7zdriid7n6a5n86f2c009lygls10qjawmdiih8rvpvr51d3 + tag: a31e7705fc42a39389d90299c77498dac77e546e + --sha256: 0f6vz6rh3zzqz52hzzydqvgw5hj6ii0fhvhs901sylzhl4d21jw1 subdir: ouroboros-consensus ouroboros-consensus-cardano @@ -89,7 +89,7 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: cf6e015c1829dc5e54b8baec4f16f6f0b3d25f53 - --sha256: 1cqsim1ka2949p64096mz7j44sx23rfnq88bns2k39fyf2h19r1h + tag: 0fb8ae595e7b0ae644c4724aa4b63594d1e53877 + --sha256: 01yy747i9bwf6jhfmww8bgf2jz86plw9j42hmfz2zbq3cl72qfsj subdir: cardano-api diff --git a/flake.lock b/flake.lock index 9b0014d755c..75694bc6fb1 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1710945682, - "narHash": "sha256-xp1txUjrtCuKHAy0nvz/lu0MlNdNnzvP8l2p9MFB73Y=", + "lastModified": 1712241301, + "narHash": "sha256-Np3AKeg8JuT53MaoA9HAP3Rk+mzFJR05LbmamXtpeXM=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "8df2bf06e4525ec39c106cd2593e3c5fd7f2b081", + "rev": "91e98f31ae16e5a5833224c8ac46532fb72964a4", "type": "github" }, "original": { From 6b2f2d270b0f65fc0af8c0562231a766c0e17cfc Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Thu, 4 Apr 2024 17:16:38 +0200 Subject: [PATCH 07/26] Add lmdb to CI --- .github/workflows/haskell.yml | 13 +++++++++++++ .github/workflows/lmdb.pc | 11 ----------- 2 files changed, 13 insertions(+), 11 deletions(-) delete mode 100644 .github/workflows/lmdb.pc diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 81581785612..3bae2ac75ef 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -75,6 +75,19 @@ jobs: with: use-sodium-vrf: true # default is true + - name: Linux install lmdb + if: matrix.os == 'ubuntu-latest' + run: sudo apt install liblmdb-dev + + - name: Mac install lmdb + if: matrix.os == 'macos-latest' + run: brew install lmdb + + - name: Windows install lmdb + if: matrix.os == 'windows-latest' + shell: 'C:/msys64/usr/bin/bash.exe -e {0}' + run: /usr/bin/pacman --noconfirm -S mingw-w64-x86_64-lmdb + - uses: actions/checkout@v3 - name: Cabal update diff --git a/.github/workflows/lmdb.pc b/.github/workflows/lmdb.pc deleted file mode 100644 index fc4838ed478..00000000000 --- a/.github/workflows/lmdb.pc +++ /dev/null @@ -1,11 +0,0 @@ -prefix=/usr/local -exec_prefix=${prefix} -libdir=${exec_prefix}/lib -includedir=${exec_prefix}/include - -Name: liblmdb -Description: Lightning Memory-Mapped Database -URL: https://symas.com/products/lightning-memory-mapped-database/ -Version: 0.9.29 -Libs: -L${libdir} -llmdb -Cflags: -I${includedir} \ No newline at end of file From 9e2ba4b344c1f3ec353c3f4aeeb0426fdcb8bfdc Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Thu, 4 Apr 2024 17:40:59 +0200 Subject: [PATCH 08/26] Update cabal.project refs --- cabal.project | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index dc88b3728fe..1f0a3d148f4 100644 --- a/cabal.project +++ b/cabal.project @@ -76,8 +76,8 @@ if impl(ghc >= 9.6) source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: a31e7705fc42a39389d90299c77498dac77e546e - --sha256: 0f6vz6rh3zzqz52hzzydqvgw5hj6ii0fhvhs901sylzhl4d21jw1 + tag: 02d6f44179cbffd573a15c0bd8a7e8d5de43690e + --sha256: 1h67ln5r5xzs2yiwld0pplym6iga458wh653z4z2s4k7g7a2i3rq subdir: ouroboros-consensus ouroboros-consensus-cardano @@ -89,7 +89,7 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: 0fb8ae595e7b0ae644c4724aa4b63594d1e53877 - --sha256: 01yy747i9bwf6jhfmww8bgf2jz86plw9j42hmfz2zbq3cl72qfsj + tag: ffadb947c711b9fc89123ba653b5b567006f1138 + --sha256: 12bd8qrhyqs0l7hyilwcqg5m18119lwgqxazbs8hxc20alg9gs5f subdir: cardano-api From 1595dc85eb42398d97d38bd90238a889f36338d2 Mon Sep 17 00:00:00 2001 From: Renate Eilers Date: Wed, 27 Mar 2024 16:19:25 +0100 Subject: [PATCH 09/26] Replace SnapshotInterval with SnapshotPolicyArgs --- .../src/Cardano/Node/Configuration/POM.hs | 16 ++++++++++---- cardano-node/src/Cardano/Node/Parsers.hs | 22 ++++++++++++++----- cardano-node/src/Cardano/Node/Run.hs | 11 +++++++--- 3 files changed, 37 insertions(+), 12 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 383e91b0e1c..d3df082bc41 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -35,7 +35,8 @@ import Cardano.Tracing.OrphanInstances.Network () import Ouroboros.Consensus.Mempool (MempoolCapacityBytes (..), MempoolCapacityBytesOverride (..)) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) -import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (SnapshotInterval (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (NumOfDiskSnapshots (..), + SnapshotInterval (..)) import Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..), QueryBatchSize (..)) import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode (..)) @@ -133,6 +134,7 @@ data NodeConfiguration , ncMaybeMempoolCapacityOverride :: !(Maybe MempoolCapacityBytesOverride) -- LedgerDB configuration + , ncNumOfDiskSnapshots :: !NumOfDiskSnapshots , ncSnapshotInterval :: !SnapshotInterval , ncLedgerDBBackend :: !LedgerDbSelectorFlag , ncFlushFrequency :: !FlushFrequency @@ -212,6 +214,7 @@ data PartialNodeConfiguration , pncMaybeMempoolCapacityOverride :: !(Last MempoolCapacityBytesOverride) -- LedgerDB configuration + , pncNumOfDiskSnapshots :: !(Last NumOfDiskSnapshots) , pncSnapshotInterval :: !(Last SnapshotInterval) , pncLedgerDBBackend :: !(Last LedgerDbSelectorFlag) , pncFlushFrequency :: !(Last FlushFrequency) @@ -306,6 +309,7 @@ instance FromJSON PartialNodeConfiguration where pncMaybeMempoolCapacityOverride <- Last <$> parseMempoolCapacityBytesOverride v -- LedgerDB configuration + pncNumOfDiskSnapshots <- Last . fmap RequestedNumOfDiskSnapshots <$> v .:? "NumOfDiskSnapshots" pncSnapshotInterval <- Last . fmap RequestedSnapshotInterval <$> v .:? "SnapshotInterval" pncLedgerDBBackend <- Last <$> parseLedgerDBBackend v pncFlushFrequency <- Last . fmap RequestedFlushFrequency <$> v .:? "FlushFrequency" @@ -367,6 +371,7 @@ instance FromJSON PartialNodeConfiguration where , pncShutdownConfig = mempty , pncStartAsNonProducingNode = Last $ Just False , pncMaybeMempoolCapacityOverride + , pncNumOfDiskSnapshots , pncSnapshotInterval , pncLedgerDBBackend , pncFlushFrequency @@ -553,6 +558,7 @@ defaultPartialNodeConfiguration = , pncTraceConfig = mempty , pncTraceForwardSocket = mempty , pncMaybeMempoolCapacityOverride = mempty + , pncNumOfDiskSnapshots = Last $ Just DefaultNumOfDiskSnapshots , pncSnapshotInterval = Last $ Just DefaultSnapshotInterval , pncLedgerDBBackend = Last $ Just V2InMemory , pncFlushFrequency = Last $ Just DefaultFlushFrequency @@ -597,6 +603,7 @@ makeNodeConfiguration pnc = do logMetrics <- lastToEither "Missing LogMetrics" $ pncLogMetrics pnc traceConfig <- first Text.unpack $ partialTraceSelectionToEither $ pncTraceConfig pnc diffusionMode <- lastToEither "Missing DiffusionMode" $ pncDiffusionMode pnc + numOfDiskSnapshots <- lastToEither "Missing NumOfDiskSnapshots" $ pncNumOfDiskSnapshots pnc snapshotInterval <- lastToEither "Missing SnapshotInterval" $ pncSnapshotInterval pnc shutdownConfig <- lastToEither "Missing ShutdownConfig" $ pncShutdownConfig pnc socketConfig <- lastToEither "Missing SocketConfig" $ pncSocketConfig pnc @@ -654,13 +661,13 @@ makeNodeConfiguration pnc = do $ pncPeerSharing pnc ssdDatabaseDir <- - lastToEither "Missing SsdDatabaseDir" + lastToEither "Missing SsdDatabaseDir" $ pncSsdDatabaseDir pnc ssdSnapshotState <- - lastToEither "Missing SsdSnapshotState" + lastToEither "Missing SsdSnapshotState" $ pncSsdSnapshotState pnc ssdSnapshotTables <- - lastToEither "Missing SsdSnapshotTables" + lastToEither "Missing SsdSnapshotTables" $ pncSsdSnapshotTables pnc -- TODO: This is not mandatory @@ -693,6 +700,7 @@ makeNodeConfiguration pnc = do else TracingOff , ncTraceForwardSocket = getLast $ pncTraceForwardSocket pnc , ncMaybeMempoolCapacityOverride = getLast $ pncMaybeMempoolCapacityOverride pnc + , ncNumOfDiskSnapshots = numOfDiskSnapshots , ncSnapshotInterval = snapshotInterval , ncLedgerDBBackend , ncFlushFrequency diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index 2c5417faf52..719ad68147c 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -23,7 +23,8 @@ import Cardano.Node.Types import Cardano.Prelude (ConvertText (..)) import Ouroboros.Consensus.Mempool (MempoolCapacityBytes (..), MempoolCapacityBytesOverride (..)) -import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (SnapshotInterval (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (NumOfDiskSnapshots (..), + SnapshotInterval (..)) import Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..), QueryBatchSize (..)) @@ -80,10 +81,11 @@ nodeRunParser = do maybeMempoolCapacityOverride <- lastOption parseMempoolCapacityOverride -- LedgerDB configuration - snapshotInterval <- lastOption parseSnapshotInterval - ledgerDBBackend <- lastOption parseLedgerDBBackend - pncFlushFrequency <- lastOption parseFlushFrequency - pncQueryBatchSize <- lastOption parseQueryBatchSize + numOfDiskSnapshots <- lastOption parseNumOfDiskSnapshots + snapshotInterval <- lastOption parseSnapshotInterval + ledgerDBBackend <- lastOption parseLedgerDBBackend + pncFlushFrequency <- lastOption parseFlushFrequency + pncQueryBatchSize <- lastOption parseQueryBatchSize -- Storing to SSD configuration ssdDatabaseDir <- lastOption parseSsdDatabaseDir @@ -122,6 +124,7 @@ nodeRunParser = do , pncTraceConfig = mempty , pncTraceForwardSocket = traceForwardSocket , pncMaybeMempoolCapacityOverride = maybeMempoolCapacityOverride + , pncNumOfDiskSnapshots = numOfDiskSnapshots , pncSnapshotInterval = snapshotInterval , pncLedgerDBBackend = ledgerDBBackend , pncFlushFrequency @@ -409,6 +412,15 @@ parseStartAsNonProducingNode = ] ] +parseNumOfDiskSnapshots :: Parser NumOfDiskSnapshots +parseNumOfDiskSnapshots = fmap RequestedNumOfDiskSnapshots parseNum + where + parseNum = Opt.option auto + ( long "num-of-disk-snapshots" + <> metavar "NUMOFDISKSNAPSHOTS" + <> help "Number of ledger snapshots stored on disk." + ) + -- TODO revisit because it sucks parseSnapshotInterval :: Parser SnapshotInterval parseSnapshotInterval = fmap (RequestedSnapshotInterval . secondsToDiffTime) parseDifftime diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index fcae92a84eb..78365896824 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -62,7 +62,7 @@ import Cardano.Tracing.Tracers import qualified Ouroboros.Consensus.Config as Consensus import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..)) import Ouroboros.Consensus.Node (NetworkP2PMode (..), RunNodeArgs (..), - StdRunNodeArgs (..), stdChainSyncTimeout) + SnapshotPolicyArgs (..), StdRunNodeArgs (..), stdChainSyncTimeout) import qualified Ouroboros.Consensus.Node as Node (getChainDB, run) import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo @@ -495,7 +495,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , srnTraceChainDB = chainDBTracer tracers , srnMaybeMempoolCapacityOverride = ncMaybeMempoolCapacityOverride nc , srnChainSyncTimeout = customizeChainSyncTimeout - , srnSnapshotInterval = ncSnapshotInterval nc + , srnSnapshotPolicyArgs = snapshotPolicyArgs , srnLdbFlavorArgs = selectorToArgs (ncLedgerDBBackend nc) (ncFlushFrequency nc) (ncQueryBatchSize nc) , srnPutInSSD = (ncSsdSnapshotTables nc, ncSsdSnapshotState nc) , srnSSDPath = ssdPath @@ -571,7 +571,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , srnTraceChainDB = chainDBTracer tracers , srnChainSyncTimeout = customizeChainSyncTimeout , srnMaybeMempoolCapacityOverride = ncMaybeMempoolCapacityOverride nc - , srnSnapshotInterval = ncSnapshotInterval nc + , srnSnapshotPolicyArgs = snapshotPolicyArgs , srnLdbFlavorArgs = selectorToArgs (ncLedgerDBBackend nc) (ncFlushFrequency nc) (ncQueryBatchSize nc) , srnPutInSSD = (ncSsdSnapshotTables nc, ncSsdSnapshotState nc) , srnSSDPath = ssdPath @@ -634,6 +634,11 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do Nothing -> id Just version_ -> Map.takeWhileAntitone (<= version_) + snapshotPolicyArgs :: SnapshotPolicyArgs + snapshotPolicyArgs = + SnapshotPolicyArgs + (ncSnapshotInterval nc) + (ncNumOfDiskSnapshots nc) -------------------------------------------------------------------------------- -- SIGHUP Handlers -------------------------------------------------------------------------------- From 734c5b368e23ad267902de0ace9afa4915b04487 Mon Sep 17 00:00:00 2001 From: Renate Eilers Date: Fri, 5 Apr 2024 13:46:35 +0200 Subject: [PATCH 10/26] Update NewEpochState with tables --- .../src/Testnet/Components/Query.hs | 21 ++----------------- .../Testnet/Test/Cli/Conway/DRepRetirement.hs | 2 +- .../Gov/ProposeNewConstitutionSPO.hs | 2 +- 3 files changed, 4 insertions(+), 21 deletions(-) diff --git a/cardano-testnet/src/Testnet/Components/Query.hs b/cardano-testnet/src/Testnet/Components/Query.hs index 9359a7ae4a0..cd8c871afb7 100644 --- a/cardano-testnet/src/Testnet/Components/Query.hs +++ b/cardano-testnet/src/Testnet/Components/Query.hs @@ -19,29 +19,23 @@ module Testnet.Components.Query ) where import Cardano.Api as Api -import Cardano.Api.Shelley (ShelleyLedgerEra, fromShelleyTxIn, fromShelleyTxOut) import Cardano.CLI.Types.Output -import qualified Cardano.Ledger.Shelley.LedgerState as L -import qualified Cardano.Ledger.UTxO as L import Control.Exception.Safe (MonadCatch) import Control.Monad import Control.Monad.Trans.Resource import Data.Aeson -import Data.Bifunctor (bimap) import Data.IORef import Data.List (sortOn) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import qualified Data.Map.Strict as Map import Data.Maybe (listToMaybe) import Data.Ord (Down (..)) import Data.Text (Text) import qualified Data.Text as T import Data.Type.Equality import GHC.Stack -import Lens.Micro ((^.)) import System.Directory (doesFileExist, removeFile) import qualified Testnet.Process.Run as H @@ -142,20 +136,9 @@ findAllUtxos -> ShelleyBasedEra era -> m (Map TxIn (TxOut CtxUTxO era)) findAllUtxos epochStateView sbe = withFrozenCallStack $ do - AnyNewEpochState sbe' newEpochState <- getEpochState epochStateView + AnyNewEpochState sbe' _ tbs <- getEpochState epochStateView Refl <- H.leftFail $ assertErasEqual sbe sbe' - pure $ fromLedgerUTxO $ newEpochState ^. L.nesEsL . L.esLStateL . L.lsUTxOStateL . L.utxosUtxoL - where - fromLedgerUTxO - :: () - => L.UTxO (ShelleyLedgerEra era) - -> Map TxIn (TxOut CtxUTxO era) - fromLedgerUTxO (L.UTxO utxo) = - shelleyBasedEraConstraints sbe - $ Map.fromList - . map (bimap fromShelleyTxIn (fromShelleyTxOut sbe)) - . Map.toList - $ utxo + pure $ getUTxOValues sbe' tbs -- | Retrieve utxos from the epoch state view for an address. findUtxosWithAddress diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Conway/DRepRetirement.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Conway/DRepRetirement.hs index 7afa54d9ac8..392912b8c6c 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Conway/DRepRetirement.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Conway/DRepRetirement.hs @@ -239,7 +239,7 @@ waitDRepsNumber' :: -> m (Maybe [L.DRepState StandardCrypto]) -- ^ The DReps when the expected number of DReps was attained. waitDRepsNumber' nodeConfigFile socketPath maxEpoch expectedDRepsNb = do result <- runExceptT $ foldEpochState nodeConfigFile socketPath QuickValidation maxEpoch Nothing - $ \(AnyNewEpochState actualEra newEpochState) -> do + $ \(AnyNewEpochState actualEra newEpochState _) -> do case testEquality sbe actualEra of Just Refl -> do let dreps = Map.elems $ shelleyBasedEraConstraints sbe newEpochState diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/LedgerEvents/Gov/ProposeNewConstitutionSPO.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/LedgerEvents/Gov/ProposeNewConstitutionSPO.hs index 9c45463ace7..6f1a4a2d109 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/LedgerEvents/Gov/ProposeNewConstitutionSPO.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/LedgerEvents/Gov/ProposeNewConstitutionSPO.hs @@ -239,7 +239,7 @@ getConstitutionProposal -> m (Maybe (L.GovActionId StandardCrypto)) getConstitutionProposal nodeConfigFile socketPath maxEpoch = do result <- runExceptT $ foldEpochState nodeConfigFile socketPath QuickValidation maxEpoch Nothing - $ \(AnyNewEpochState actualEra newEpochState) -> + $ \(AnyNewEpochState actualEra newEpochState _) -> caseShelleyToBabbageOrConwayEraOnwards (error $ "Expected Conway era onwards, got state in " <> docToString (pretty actualEra)) (\cEra -> conwayEraOnwardsConstraints cEra $ do From 123b5b6fddd2f77a02149e892da8af2d40b53712 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 5 Apr 2024 13:55:41 +0200 Subject: [PATCH 11/26] Update consensus refs and CHaP --- cabal.project | 10 +++++----- flake.lock | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/cabal.project b/cabal.project index 1f0a3d148f4..0a879584982 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- you need to run if you change them index-state: , hackage.haskell.org 2024-03-25T10:39:21Z - , cardano-haskell-packages 2024-04-04T11:57:10Z + , cardano-haskell-packages 2024-04-05T11:01:53Z packages: cardano-git-rev @@ -76,8 +76,8 @@ if impl(ghc >= 9.6) source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: 02d6f44179cbffd573a15c0bd8a7e8d5de43690e - --sha256: 1h67ln5r5xzs2yiwld0pplym6iga458wh653z4z2s4k7g7a2i3rq + tag: 33881548e70d619e652cb5334e31ee59ceefcc55 + --sha256: 1a64976szdvp0vmpjm974l955i18cjzqgcbyfgwjma8zh07r4347 subdir: ouroboros-consensus ouroboros-consensus-cardano @@ -89,7 +89,7 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: ffadb947c711b9fc89123ba653b5b567006f1138 - --sha256: 12bd8qrhyqs0l7hyilwcqg5m18119lwgqxazbs8hxc20alg9gs5f + tag: dd72904df7127cc74f0c9ae2af5b486aa0449409 + --sha256: 1r4lqggs7h6f6whpsz3ms83y4lcgar8qmvm2pnp1cydf2n86i020 subdir: cardano-api diff --git a/flake.lock b/flake.lock index 75694bc6fb1..145e83a8b23 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1712241301, - "narHash": "sha256-Np3AKeg8JuT53MaoA9HAP3Rk+mzFJR05LbmamXtpeXM=", + "lastModified": 1712315807, + "narHash": "sha256-RdUQH5Wvm6jda6kM+rVgiz/qfpUXDJ2cXjIXdweh6NQ=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "91e98f31ae16e5a5833224c8ac46532fb72964a4", + "rev": "c6ae66cd05e72715d474da8f5469946b5db374ca", "type": "github" }, "original": { From 18691b86fb80028408c929c15a8a620b2030909c Mon Sep 17 00:00:00 2001 From: Renate Eilers Date: Fri, 5 Apr 2024 14:29:48 +0200 Subject: [PATCH 12/26] Fix missing NumOfDiskSnapshots field in POM test --- cardano-node/test/Test/Cardano/Node/POM.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index d69ca7d713b..e1ddf8b4d13 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -15,7 +15,7 @@ import Cardano.Tracing.Config (PartialTraceOptions (..), defaultPartia partialTraceSelectionToEither) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots - (SnapshotInterval (..)) + (NumOfDiskSnapshots (..), SnapshotInterval (..)) import Ouroboros.Consensus.Storage.LedgerDB.V1.Args import Ouroboros.Network.Block (SlotNo (..)) @@ -119,6 +119,7 @@ testPartialYamlConfig = , pncShutdownConfig = Last Nothing , pncStartAsNonProducingNode = Last $ Just False , pncDiffusionMode = Last Nothing + , pncNumOfDiskSnapshots = mempty , pncSnapshotInterval = mempty , pncExperimentalProtocolsEnabled = Last Nothing , pncMaxConcurrencyBulkSync = Last Nothing @@ -166,6 +167,7 @@ testPartialCliConfig = , pncTopologyFile = mempty , pncDatabaseFile = mempty , pncDiffusionMode = mempty + , pncNumOfDiskSnapshots = Last . Just . RequestedNumOfDiskSnapshots $ 3 , pncSnapshotInterval = Last . Just . RequestedSnapshotInterval $ secondsToDiffTime 100 , pncExperimentalProtocolsEnabled = Last $ Just True , pncProtocolFiles = Last . Just $ ProtocolFilepaths Nothing Nothing Nothing Nothing Nothing Nothing @@ -215,6 +217,7 @@ eExpectedConfig = do , ncValidateDB = True , ncProtocolConfig = testNodeProtocolConfiguration , ncDiffusionMode = InitiatorAndResponderDiffusionMode + , ncNumOfDiskSnapshots = RequestedNumOfDiskSnapshots 3 , ncSnapshotInterval = RequestedSnapshotInterval $ secondsToDiffTime 100 , ncExperimentalProtocolsEnabled = True , ncMaxConcurrencyBulkSync = Nothing From 513fa9e349890645331a331fd075cce76329e0e7 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 5 Apr 2024 15:31:17 +0200 Subject: [PATCH 13/26] Invalidate cabal cache --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 3bae2ac75ef..9cdc999349c 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -38,7 +38,7 @@ jobs: env: # Modify this value to "invalidate" the cabal cache. - CABAL_CACHE_VERSION: "2024-02-29" + CABAL_CACHE_VERSION: "2024-04-05" concurrency: group: > From 82305f7e52e7866de603181cf7b442a379e0f724 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 5 Apr 2024 16:45:41 +0200 Subject: [PATCH 14/26] Update cabal.project refs and CHaP --- cabal.project | 22 +++++----------------- flake.lock | 6 +++--- 2 files changed, 8 insertions(+), 20 deletions(-) diff --git a/cabal.project b/cabal.project index 0a879584982..5468cd72f9a 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- you need to run if you change them index-state: , hackage.haskell.org 2024-03-25T10:39:21Z - , cardano-haskell-packages 2024-04-05T11:01:53Z + , cardano-haskell-packages 2024-04-05T13:36:27Z packages: cardano-git-rev @@ -61,23 +61,11 @@ package plutus-scripts-bench -- `smtp-mail` should depend on `crypton-connection` rather than `connection`! -source-repository-package - type: git - location: https://github.com/jasagredo/latex-svg - tag: c52c9905cb043ddb430c93b41ce431a7506a300d - --sha256: 0h9yrlvmyi32zlr0cj2nx8ik0y2cg5ckcxq4lgq5vvjyl6lhzrbk - subdir: - latex-svg-image - -if impl(ghc >= 9.6) - allow-newer: - cardano-lmdb-simple:bytestring - source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: 33881548e70d619e652cb5334e31ee59ceefcc55 - --sha256: 1a64976szdvp0vmpjm974l955i18cjzqgcbyfgwjma8zh07r4347 + tag: 9e7d827b1e06de326e6e303c91b7d3d9d5402552 + --sha256: 1928whrs6fv7lvzqhhjxid38hxpq6gp62ghd9cqw38v2v765dpfx subdir: ouroboros-consensus ouroboros-consensus-cardano @@ -89,7 +77,7 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: dd72904df7127cc74f0c9ae2af5b486aa0449409 - --sha256: 1r4lqggs7h6f6whpsz3ms83y4lcgar8qmvm2pnp1cydf2n86i020 + tag: 5e6b14102d628892bd90e5bb59d45830c3cba613 + --sha256: 1myh0kpm2w8s7c4mqxlch920ab7d1rr003a7rh4wr0zq2x8n7lai subdir: cardano-api diff --git a/flake.lock b/flake.lock index 145e83a8b23..7a1306027dd 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1712315807, - "narHash": "sha256-RdUQH5Wvm6jda6kM+rVgiz/qfpUXDJ2cXjIXdweh6NQ=", + "lastModified": 1712325757, + "narHash": "sha256-cOyalvthxBQzErM4UfsHmvIfmgXF0vUw7FK5txfTZoQ=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "c6ae66cd05e72715d474da8f5469946b5db374ca", + "rev": "d4205c96eeb139c87fcf2dc78627d867ab851acd", "type": "github" }, "original": { From 0b9a3d6cc95bae006b11d97622cad5b954f5711a Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 5 Apr 2024 17:05:15 +0200 Subject: [PATCH 15/26] Update cabal.project refs --- .github/workflows/haskell.yml | 2 +- cabal.project | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 9cdc999349c..f97ba9b517f 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -38,7 +38,7 @@ jobs: env: # Modify this value to "invalidate" the cabal cache. - CABAL_CACHE_VERSION: "2024-04-05" + CABAL_CACHE_VERSION: "2024-04-05-2" concurrency: group: > diff --git a/cabal.project b/cabal.project index 5468cd72f9a..72b4429e746 100644 --- a/cabal.project +++ b/cabal.project @@ -64,8 +64,8 @@ package plutus-scripts-bench source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: 9e7d827b1e06de326e6e303c91b7d3d9d5402552 - --sha256: 1928whrs6fv7lvzqhhjxid38hxpq6gp62ghd9cqw38v2v765dpfx + tag: 6b52504b882e1767f53bb37df4365c58014bea09 + --sha256: 1jc2n0h7a9569617r2ds4a8bi4j20xlgsnmgqn10cdjfbq3j74fk subdir: ouroboros-consensus ouroboros-consensus-cardano @@ -77,7 +77,7 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: 5e6b14102d628892bd90e5bb59d45830c3cba613 - --sha256: 1myh0kpm2w8s7c4mqxlch920ab7d1rr003a7rh4wr0zq2x8n7lai + tag: c98b480098094e86aab43d5478b264032fd02da7 + --sha256: 07x7k7pk16ihidp44n2khsv8cs8zxid27xlnjdxy6sy9l08hi4qk subdir: cardano-api From fe5a0dbf60ce3296be336cdb9ffc0c91a376df25 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 8 Apr 2024 10:33:36 +0200 Subject: [PATCH 16/26] Bump refs, stylish, hlint --- cabal.project | 8 ++++---- .../src/Cardano/Node/Configuration/LedgerDB.hs | 15 +++++++-------- cardano-node/src/Cardano/Node/Queries.hs | 16 ++++++++-------- .../src/Cardano/Node/Tracing/StateRep.hs | 8 +++----- .../src/Cardano/Node/Tracing/Tracers/ChainDB.hs | 7 +++---- cardano-node/test/Test/Cardano/Node/POM.hs | 5 ++--- 6 files changed, 27 insertions(+), 32 deletions(-) diff --git a/cabal.project b/cabal.project index 72b4429e746..8e49a14689a 100644 --- a/cabal.project +++ b/cabal.project @@ -64,8 +64,8 @@ package plutus-scripts-bench source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: 6b52504b882e1767f53bb37df4365c58014bea09 - --sha256: 1jc2n0h7a9569617r2ds4a8bi4j20xlgsnmgqn10cdjfbq3j74fk + tag: 144666d22235fc441fda615a7c7990f4e301d176 + --sha256: 07qd9alk2ck1a5piv6ax79pvv10618939npqpvi6qmv59bmpx7a8 subdir: ouroboros-consensus ouroboros-consensus-cardano @@ -77,7 +77,7 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: c98b480098094e86aab43d5478b264032fd02da7 - --sha256: 07x7k7pk16ihidp44n2khsv8cs8zxid27xlnjdxy6sy9l08hi4qk + tag: be6c05f5f007ad9320da182fbde86983a7945905 + --sha256: 1xk73x1xzpz4rsqz6sv6mxzp24a57d5j6hq3r6zvjkf3g4xph2r1 subdir: cardano-api diff --git a/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs index 76d7ed37c71..f5bb85eb8c5 100644 --- a/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs +++ b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs @@ -11,15 +11,14 @@ module Cardano.Node.Configuration.LedgerDB ( , selectorToArgs ) where -import Prelude - -import qualified Data.Aeson.Types as Aeson (FromJSON) -import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB (LMDBLimits (..)) -import Ouroboros.Consensus.Storage.LedgerDB.Impl.Args -import Ouroboros.Consensus.Util.Args +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Args 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 Data.SOP.Dict +import Ouroboros.Consensus.Util.Args + +import qualified Data.Aeson.Types as Aeson (FromJSON) +import Data.SOP.Dict -- | Choose the LedgerDB Backend -- @@ -101,4 +100,4 @@ selectorToArgs V2InMemory _ _ = LedgerDbFlavorArgsV2 $ V2.V2Args V2.InMemoryHand selectorToArgs (V1LMDB l) a b= LedgerDbFlavorArgsV1 $ V1.V1Args a b - $ V1.LMDBBackingStoreArgs (maybe id (\ll lim -> lim { lmdbMapSize = toBytes ll }) l $ defaultLMDBLimits) Dict + $ V1.LMDBBackingStoreArgs (maybe id (\ll lim -> lim { lmdbMapSize = toBytes ll }) l defaultLMDBLimits) Dict diff --git a/cardano-node/src/Cardano/Node/Queries.hs b/cardano-node/src/Cardano/Node/Queries.hs index 561cff85f85..0a9e661ba88 100644 --- a/cardano-node/src/Cardano/Node/Queries.hs +++ b/cardano-node/src/Cardano/Node/Queries.hs @@ -36,14 +36,6 @@ module Cardano.Node.Queries , fromSMaybe ) where -import Control.Monad.STM (atomically) -import Data.ByteString (ByteString) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import qualified Data.Map.Strict as Map -import Data.SOP -import Data.SOP.Functors -import Data.Word (Word64) - import qualified Cardano.Chain.Block as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto.Hash as Crypto @@ -82,6 +74,14 @@ import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.NodeToClient (LocalConnectionId) import Ouroboros.Network.NodeToNode (RemoteAddress, RemoteConnectionId) +import Control.Monad.STM (atomically) +import Data.ByteString (ByteString) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.Map.Strict as Map +import Data.SOP +import Data.SOP.Functors +import Data.Word (Word64) + -- -- * TxId -> ByteString projection -- diff --git a/cardano-node/src/Cardano/Node/Tracing/StateRep.hs b/cardano-node/src/Cardano/Node/Tracing/StateRep.hs index 3553a5bcad5..0197b9f4529 100644 --- a/cardano-node/src/Cardano/Node/Tracing/StateRep.hs +++ b/cardano-node/src/Cardano/Node/Tracing/StateRep.hs @@ -25,14 +25,14 @@ import Cardano.Logging import Cardano.Node.Handlers.Shutdown (ShutdownTrace) import Cardano.Node.Protocol.Types (SomeConsensusProtocol (..)) import qualified Cardano.Node.Startup as Startup -import Cardano.Slotting.Slot (EpochNo, SlotNo (..), WithOrigin) +import Cardano.Slotting.Slot (EpochNo, SlotNo (..), WithOrigin, withOrigin) import Cardano.Tracing.OrphanInstances.Network () import qualified Ouroboros.Consensus.Block.RealPoint as RP import qualified Ouroboros.Consensus.Node.NetworkProtocolVersion as NPV import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal -import qualified Ouroboros.Consensus.Storage.LedgerDB as LgrDb import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.LedgerDB as LgrDb import Ouroboros.Network.Block (pointSlot) import Control.DeepSeq (NFData) @@ -41,8 +41,6 @@ import Data.Text (Text) import Data.Time.Clock import Data.Time.Clock.POSIX import GHC.Generics (Generic) -import Cardano.Slotting.Slot (withOrigin) -import Cardano.Tracing.OrphanInstances.Network () deriving instance FromJSON ChunkNo @@ -222,7 +220,7 @@ traceNodeStateChainDB _scp tr ev = case ev' of LedgerDB.TraceReplayStartEvent ev'' -> case ev'' of LgrDb.ReplayFromGenesis -> - traceWith tr $ NodeReplays $ ReplayFromGenesis + traceWith tr $ NodeReplays ReplayFromGenesis LgrDb.ReplayFromSnapshot _ (LgrDb.ReplayStart rs) -> traceWith tr $ NodeReplays $ ReplayFromSnapshot (withOrigin undefined id $ pointSlot rs) LedgerDB.TraceReplayProgressEvent ev'' -> case ev'' of diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 80c0fe198c4..8c8eb4f478d 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -19,8 +19,6 @@ import Cardano.Node.Tracing.Era.Shelley () import Cardano.Node.Tracing.Formatting () import Cardano.Node.Tracing.Render import Cardano.Prelude (maximumDef) - -import Ouroboros.Network.Block (MaxSlotNo(..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.HeaderValidation (HeaderEnvelopeError (..), HeaderError (..), OtherHeaderEnvelopeError) @@ -40,6 +38,7 @@ import qualified Ouroboros.Consensus.Storage.VolatileDB as VolDB import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.Enclose import qualified Ouroboros.Network.AnchoredFragment as AF +import Ouroboros.Network.Block (MaxSlotNo (..)) import Data.Aeson (Value (String), toJSON, (.=)) import Data.Int (Int64) @@ -1462,8 +1461,8 @@ instance MetaTrace (LedgerDB.TraceLedgerDBEvent blk) where severityFor (Namespace out ("Snapshot" : tl)) Nothing = severityFor (Namespace out tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) Nothing severityFor (Namespace _out ("Replay" : _tl)) Nothing = Just Info - severityFor (Namespace _out (["Forker"])) Nothing = Just Debug - severityFor (Namespace _out (["Flavor"])) Nothing = Just Debug + severityFor (Namespace _out ["Forker"]) Nothing = Just Debug + severityFor (Namespace _out ["Flavor"]) Nothing = Just Debug severityFor _ _ = Nothing documentFor (Namespace o ("Snapshot" : tl)) = diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index e1ddf8b4d13..43228a38a78 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -14,10 +14,9 @@ import Cardano.Node.Types import Cardano.Tracing.Config (PartialTraceOptions (..), defaultPartialTraceConfiguration, partialTraceSelectionToEither) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) -import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots - (NumOfDiskSnapshots (..), SnapshotInterval (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (NumOfDiskSnapshots (..), + SnapshotInterval (..)) import Ouroboros.Consensus.Storage.LedgerDB.V1.Args - import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode (InitiatorAndResponderDiffusionMode)) From 772d00322897cf98e4dd66f44d6c1a21fd353a50 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 9 Apr 2024 12:43:58 +0200 Subject: [PATCH 17/26] WIP --- cabal.project | 3 +- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 399 +++++++++++++++--- 2 files changed, 336 insertions(+), 66 deletions(-) diff --git a/cabal.project b/cabal.project index 8e49a14689a..1d50e06de90 100644 --- a/cabal.project +++ b/cabal.project @@ -31,6 +31,7 @@ packages: trace-dispatcher trace-resources trace-forward + ../ouroboros-consensus/ouroboros-consensus program-options ghc-options: -Werror @@ -67,7 +68,7 @@ source-repository-package tag: 144666d22235fc441fda615a7c7990f4e301d176 --sha256: 07qd9alk2ck1a5piv6ax79pvv10618939npqpvi6qmv59bmpx7a8 subdir: - ouroboros-consensus +-- ouroboros-consensus ouroboros-consensus-cardano ouroboros-consensus-diffusion ouroboros-consensus-protocol diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 8c8eb4f478d..762a3d98310 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -39,6 +39,8 @@ import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.Enclose import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (MaxSlotNo (..)) +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 import Data.Aeson (Value (String), toJSON, (.=)) import Data.Int (Int64) @@ -1424,28 +1426,15 @@ instance ( StandardHash blk , ConvertRawHash blk) => LogFormatting (LedgerDB.TraceLedgerDBEvent blk) where - forMachine dtals (LedgerDB.LedgerDBSnapshotEvent ev) = - mconcat [ "kind" .= String "SnapshotEvent" - , "event" .= forMachine dtals ev - ] - forMachine dtals (LedgerDB.LedgerReplayEvent ev) = - mconcat [ "kind" .= String "ReplayEvent" - , "event" .= forMachine dtals ev - ] - forMachine _dtals (LedgerDB.LedgerDBForkerEvent (LedgerDB.TraceForkerEventWithKey k ev)) = - mconcat [ "kind" .= String "ForkerEvent" - , "key" .= show k - , "event" .= show ev - ] - forMachine _dtals (LedgerDB.LedgerDBFlavorImplEvent ev) = - mconcat [ "kind" .= String "FlavorEvent" - , "event" .= show ev - ] + forMachine dtals (LedgerDB.LedgerDBSnapshotEvent ev) = forMachine dtals ev + forMachine dtals (LedgerDB.LedgerReplayEvent ev) = forMachine dtals ev + forMachine dtals (LedgerDB.LedgerDBForkerEvent ev) = forMachine dtals ev + forMachine dtals (LedgerDB.LedgerDBFlavorImplEvent ev) = forMachine dtals ev forHuman (LedgerDB.LedgerDBSnapshotEvent ev) = forHuman ev forHuman (LedgerDB.LedgerReplayEvent ev) = forHuman ev - forHuman (LedgerDB.LedgerDBForkerEvent (LedgerDB.TraceForkerEventWithKey k ev)) = "Forker " <> showT k <> ": " <> showT ev - forHuman (LedgerDB.LedgerDBFlavorImplEvent ev) = showT ev + forHuman (LedgerDB.LedgerDBForkerEvent ev) = forHuman ev + forHuman (LedgerDB.LedgerDBFlavorImplEvent ev) = forHuman ev instance MetaTrace (LedgerDB.TraceLedgerDBEvent blk) where @@ -1453,25 +1442,48 @@ instance MetaTrace (LedgerDB.TraceLedgerDBEvent blk) where nsPrependInner "Snapshot" (namespaceFor ev) namespaceFor (LedgerDB.LedgerReplayEvent ev) = nsPrependInner "Replay" (namespaceFor ev) - namespaceFor (LedgerDB.LedgerDBForkerEvent _ev) = - Namespace [] ["Forker"] - namespaceFor (LedgerDB.LedgerDBFlavorImplEvent _ev) = - Namespace [] ["Flavor"] + namespaceFor (LedgerDB.LedgerDBForkerEvent ev) = + nsPrependInner "Forker" (namespaceFor ev) + namespaceFor (LedgerDB.LedgerDBFlavorImplEvent ev) = + nsPrependInner "Flavor" (namespaceFor ev) severityFor (Namespace out ("Snapshot" : tl)) Nothing = severityFor (Namespace out tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) Nothing - severityFor (Namespace _out ("Replay" : _tl)) Nothing = Just Info - severityFor (Namespace _out ["Forker"]) Nothing = Just Debug - severityFor (Namespace _out ["Flavor"]) Nothing = Just Debug + severityFor (Namespace out ("Snapshot" : tl)) (Just (LedgerDB.LedgerDBSnapshotEvent ev)) = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) (Just ev) + severityFor (Namespace out ("Replay" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) Nothing + severityFor (Namespace out ("Replay" : tl)) (Just (LedgerDB.LedgerReplayEvent ev)) = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) (Just ev) + severityFor (Namespace out ("Forker" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace LedgerDB.TraceForkerEventWithKey) Nothing + severityFor (Namespace out ("Forker" : tl)) (Just (LedgerDB.LedgerDBForkerEvent ev)) = + severityFor (Namespace out tl :: Namespace LedgerDB.TraceForkerEventWithKey) (Just ev) + severityFor (Namespace out ("Flavor" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace LedgerDB.FlavorImplSpecificTrace) Nothing + severityFor (Namespace out ("Flavor" : tl)) (Just (LedgerDB.LedgerDBFlavorImplEvent ev)) = + severityFor (Namespace out tl :: Namespace LedgerDB.FlavorImplSpecificTrace) (Just ev) severityFor _ _ = Nothing documentFor (Namespace o ("Snapshot" : tl)) = documentFor (Namespace o tl :: Namespace (LedgerDB.TraceSnapshotEvent blk)) + documentFor (Namespace o ("Replay" : tl)) = + documentFor (Namespace o tl :: Namespace (LedgerDB.TraceReplayEvent blk)) + documentFor (Namespace o ("Forker" : tl)) = + documentFor (Namespace o tl :: Namespace LedgerDB.TraceForkerEventWithKey) + documentFor (Namespace o ("Flavor" : tl)) = + documentFor (Namespace o tl :: Namespace LedgerDB.FlavorImplSpecificTrace) documentFor _ = Nothing allNamespaces = map (nsPrependInner "Snapshot") (allNamespaces :: [Namespace (LedgerDB.TraceSnapshotEvent blk)]) + ++ map (nsPrependInner "Replay") + (allNamespaces :: [Namespace (LedgerDB.TraceReplayEvent blk)]) + ++ map (nsPrependInner "Forker") + (allNamespaces :: [Namespace (LedgerDB.TraceForkerEventWithKey)]) + ++ map (nsPrependInner "Flavor") + (allNamespaces :: [Namespace (LedgerDB.FlavorImplSpecificTrace)]) instance ( StandardHash blk , ConvertRawHash blk) @@ -1523,11 +1535,19 @@ instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where , Namespace [] ["InvalidSnapshot"] ] - -------------------------------------------------------------------------------- -- LedgerDB TraceReplayEvent -------------------------------------------------------------------------------- +instance (StandardHash blk, ConvertRawHash blk) + => LogFormatting (LedgerDB.TraceReplayEvent blk) where + + forHuman (LedgerDB.TraceReplayStartEvent ev') = forHuman ev' + forHuman (LedgerDB.TraceReplayProgressEvent ev') = forHuman ev' + + forMachine dtal (LedgerDB.TraceReplayStartEvent ev') = forMachine dtal ev' + forMachine dtal (LedgerDB.TraceReplayProgressEvent ev') = forMachine dtal ev' + instance (StandardHash blk, ConvertRawHash blk) => LogFormatting (LedgerDB.TraceReplayStartEvent blk) where forHuman LedgerDB.ReplayFromGenesis = @@ -1541,16 +1561,7 @@ instance (StandardHash blk, ConvertRawHash blk) forMachine dtal (LedgerDB.ReplayFromSnapshot snap tip') = mconcat [ "kind" .= String "ReplayFromSnapshot" , "snapshot" .= forMachine dtal snap - , "tip" .= show tip' ] - -instance (StandardHash blk, ConvertRawHash blk) - => LogFormatting (LedgerDB.TraceReplayEvent blk) where - - forHuman (LedgerDB.TraceReplayStartEvent ev') = forHuman ev' - forHuman (LedgerDB.TraceReplayProgressEvent ev') = forHuman ev' - - forMachine dtal (LedgerDB.TraceReplayStartEvent ev') = forMachine dtal ev' - forMachine dtal (LedgerDB.TraceReplayProgressEvent ev') = forMachine dtal ev' + , "tip" .= showT tip' ] instance (StandardHash blk, ConvertRawHash blk) => LogFormatting (LedgerDB.TraceReplayProgressEvent blk) where @@ -1582,38 +1593,40 @@ instance (StandardHash blk, ConvertRawHash blk) , "slot" .= unSlotNo (realPointSlot pt) , "tip" .= withOrigin 0 unSlotNo (pointSlot replayTo) ] -instance MetaTrace (LedgerDB.TraceReplayStartEvent blk) where - namespaceFor LedgerDB.ReplayFromGenesis {} = Namespace [] ["ReplayFromGenesis"] - namespaceFor LedgerDB.ReplayFromSnapshot {} = Namespace [] ["ReplayFromSnapshot"] - - severityFor (Namespace _ ["ReplayFromGenesis"]) _ = Just Info - severityFor (Namespace _ ["ReplayFromSnapshot"]) _ = Just Info +instance MetaTrace (LedgerDB.TraceReplayEvent blk) where + namespaceFor (LedgerDB.TraceReplayStartEvent ev) = + nsPrependInner "ReplayStart" (namespaceFor ev) + namespaceFor (LedgerDB.TraceReplayProgressEvent ev) = + nsPrependInner "ReplayProgress" (namespaceFor ev) + + severityFor (Namespace out ("ReplayStart" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayStartEvent blk)) Nothing + severityFor (Namespace out ("ReplayStart" : tl)) (Just (LedgerDB.TraceReplayStartEvent ev)) = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayStartEvent blk)) (Just ev) + severityFor (Namespace out ("ReplayProgress" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayProgressEvent blk)) Nothing + severityFor (Namespace out ("ReplayProgress" : tl)) (Just (LedgerDB.TraceReplayProgressEvent ev)) = + severityFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayProgressEvent blk)) (Just ev) severityFor _ _ = Nothing - documentFor (Namespace _ ["ReplayFromGenesis"]) = Just $ mconcat - [ "There were no LedgerDB snapshots on disk, so we're replaying all" - , " blocks starting from Genesis against the initial ledger." - , " The @replayTo@ parameter corresponds to the block at the tip of the" - , " ImmDB, i.e., the last block to replay." - ] - documentFor (Namespace _ ["ReplayFromSnapshot"]) = Just $ mconcat - [ "There was a LedgerDB snapshot on disk corresponding to the given tip." - , " We're replaying more recent blocks against it." - , " The @replayTo@ parameter corresponds to the block at the tip of the" - , " ImmDB, i.e., the last block to replay." - ] + documentFor (Namespace out ("ReplayStart" : tl)) = + documentFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayStartEvent blk)) + documentFor (Namespace out ("ReplayProgress" : tl)) = + documentFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayProgressEvent blk)) documentFor _ = Nothing - allNamespaces = [Namespace [] ["ReplayFromGenesis"] - , Namespace [] ["ReplayFromSnapshot"] - ] + allNamespaces = + map (nsPrependInner "ReplayStart") + (allNamespaces :: [Namespace (LedgerDB.TraceReplayStartEvent blk)]) + ++ map (nsPrependInner "ReplayProgress") + (allNamespaces :: [Namespace (LedgerDB.TraceReplayProgressEvent blk)]) -instance MetaTrace (LedgerDB.TraceReplayEvent blk) where - namespaceFor LedgerDB.TraceReplayStartEvent {} = Namespace [] ["ReplayStart"] - namespaceFor LedgerDB.TraceReplayProgressEvent {} = Namespace [] ["ReplayProgress"] +instance MetaTrace (LedgerDB.TraceReplayStartEvent blk) where + namespaceFor LedgerDB.ReplayFromGenesis {} = Namespace [] ["ReplayFromGenesis"] + namespaceFor LedgerDB.ReplayFromSnapshot {} = Namespace [] ["ReplayFromSnapshot"] - severityFor (Namespace _ ["ReplayStart"]) _ = Just Info - severityFor (Namespace _ ["ReplayProgress"]) _ = Just Info + severityFor (Namespace _ ["ReplayFromGenesis"]) _ = Just Info + severityFor (Namespace _ ["ReplayFromSnapshot"]) _ = Just Info severityFor _ _ = Nothing documentFor (Namespace _ ["ReplayFromGenesis"]) = Just $ mconcat @@ -1630,7 +1643,8 @@ instance MetaTrace (LedgerDB.TraceReplayEvent blk) where ] documentFor _ = Nothing - allNamespaces = [Namespace [] ["ReplayFromGenesis"] + allNamespaces = + [ Namespace [] ["ReplayFromGenesis"] , Namespace [] ["ReplayFromSnapshot"] ] @@ -1654,13 +1668,268 @@ instance MetaTrace (LedgerDB.TraceReplayProgressEvent blk) where [ Namespace [] ["ReplayedBlock"] ] +-------------------------------------------------------------------------------- +-- Forker events +-------------------------------------------------------------------------------- + +instance LogFormatting LedgerDB.TraceForkerEventWithKey where + forMachine dtals (LedgerDB.TraceForkerEventWithKey k ev) = + (\ev' -> mconcat [ "key" .= showT k, "event" .= ev' ]) $ forMachine dtals ev + forHuman (LedgerDB.TraceForkerEventWithKey k ev) = + "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.ForkerReadStatistics = mempty + forMachine _dtals LedgerDB.ForkerPushStart = mempty + forMachine _dtals LedgerDB.ForkerPushEnd = mempty + + 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 pus" + forHuman LedgerDB.ForkerPushEnd = mempty + +instance MetaTrace LedgerDB.TraceForkerEventWithKey where + namespaceFor = undefined + severityFor = undefined + documentFor = undefined + allNamespaces = undefined + +-------------------------------------------------------------------------------- +-- Flavor specific trace +-------------------------------------------------------------------------------- + +instance LogFormatting LedgerDB.FlavorImplSpecificTrace where + forMachine dtal (LedgerDB.FlavorImplSpecificTraceV1 ev) = forMachine dtal ev + forMachine dtal (LedgerDB.FlavorImplSpecificTraceV2 ev) = forMachine dtal ev + + forHuman (LedgerDB.FlavorImplSpecificTraceV1 ev) = forHuman ev + forHuman (LedgerDB.FlavorImplSpecificTraceV2 ev) = forHuman ev + +instance MetaTrace LedgerDB.FlavorImplSpecificTrace where + namespaceFor (LedgerDB.FlavorImplSpecificTraceV1 ev) = + nsPrependInner "V1" (namespaceFor ev) + namespaceFor (LedgerDB.FlavorImplSpecificTraceV2 ev) = + nsPrependInner "V2" (namespaceFor ev) + + severityFor (Namespace out ("V1" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTrace) Nothing + severityFor (Namespace out ("V1" : tl)) (Just (LedgerDB.FlavorImplSpecificTraceV1 ev)) = + severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTrace) (Just ev) + severityFor (Namespace out ("V2" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace V2.FlavorImplSpecificTrace) Nothing + severityFor (Namespace out ("V2" : tl)) (Just (LedgerDB.FlavorImplSpecificTraceV2 ev)) = + severityFor (Namespace out tl :: Namespace V2.FlavorImplSpecificTrace) (Just ev) + severityFor _ _ = Nothing + + documentFor (Namespace out ("V1" : tl)) = + documentFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTrace) + documentFor (Namespace out ("V2" : tl)) = + documentFor (Namespace out tl :: Namespace V2.FlavorImplSpecificTrace) + documentFor _ = Nothing + + allNamespaces = + map (nsPrependInner "V1") + (allNamespaces :: [Namespace V1.FlavorImplSpecificTrace]) + ++ map (nsPrependInner "V2") + (allNamespaces :: [Namespace V2.FlavorImplSpecificTrace]) + +-------------------------------------------------------------------------------- +-- V1 +-------------------------------------------------------------------------------- + +instance LogFormatting V1.FlavorImplSpecificTrace where + forMachine dtal (V1.FlavorImplSpecificTraceInMemory ev) = forMachine dtal ev + forMachine dtal (V1.FlavorImplSpecificTraceOnDisk ev) = forMachine dtal ev + + forHuman (V1.FlavorImplSpecificTraceInMemory ev) = forHuman ev + forHuman (V1.FlavorImplSpecificTraceOnDisk ev) = forHuman ev + +instance LogFormatting V1.FlavorImplSpecificTraceInMemory where + forMachine _dtal V1.InMemoryBackingStoreInitialise = mempty + forMachine dtal (V1.InMemoryBackingStoreTrace ev) = forMachine dtal ev + + forHuman V1.InMemoryBackingStoreInitialise = "Initializing in-memory backing store" + forHuman (V1.InMemoryBackingStoreTrace ev) = forHuman ev + +instance LogFormatting V1.FlavorImplSpecificTraceOnDisk where + forMachine _dtal (V1.OnDiskBackingStoreInitialise limits) = + mconcat [ "limits" .= showT limits ] + forMachine dtal (V1.OnDiskBackingStoreTrace ev) = forMachine dtal ev + + forHuman (V1.OnDiskBackingStoreInitialise limits) = "Initializing on-disk backing store with limits " <> showT limits + forHuman (V1.OnDiskBackingStoreTrace ev) = forHuman ev + +instance LogFormatting V1.BackingStoreTrace where + forMachine _dtals V1.BSOpening = mempty + forMachine _dtals (V1.BSOpened p) = + maybe mempty (\p' -> mconcat [ "path" .= showT p' ]) p + forMachine _dtals (V1.BSInitialisingFromCopy p) = + mconcat [ "path" .= showT p ] + forMachine _dtals (V1.BSInitialisedFromCopy p) = + mconcat [ "path" .= showT p ] + forMachine _dtals (V1.BSInitialisingFromValues sl) = + mconcat [ "slot" .= showT sl ] + forMachine _dtals (V1.BSInitialisedFromValues sl) = + mconcat [ "slot" .= showT sl ] + forMachine _dtals V1.BSClosing = mempty + forMachine _dtals V1.BSAlreadyClosed = mempty + forMachine _dtals V1.BSClosed = mempty + forMachine _dtals (V1.BSCopying p) = + mconcat [ "path" .= showT p ] + forMachine _dtals (V1.BSCopied p) = + mconcat [ "path" .= showT p ] + forMachine _dtals V1.BSCreatingValueHandle = mempty + forMachine _dtals V1.BSCreatedValueHandle = mempty + forMachine _dtals (V1.BSWriting s) = + mconcat [ "slot" .= showT s ] + forMachine _dtals (V1.BSWritten s1 s2) = + mconcat [ "old" .= showT s1, "new" .= showT s2 ] + forMachine _dtals (V1.BSValueHandleTrace i _ev) = + maybe mempty (\i' -> mconcat ["idx" .= showT i']) i + +instance LogFormatting V1.BackingStoreValueHandleTrace where + forMachine _dtals V1.BSVHClosing = mempty + forMachine _dtals V1.BSVHAlreadyClosed = mempty + forMachine _dtals V1.BSVHClosed = mempty + forMachine _dtals V1.BSVHRangeReading = mempty + forMachine _dtals V1.BSVHRangeRead = mempty + forMachine _dtals V1.BSVHReading = mempty + forMachine _dtals V1.BSVHRead = mempty + 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.BSOpened = undefined -- !(Maybe FS.FsPath) + namespaceFor V1.BSInitia{} = undefined --lisingFromCopy !FS.FsPath + namespaceFor V1.BSInitialisedFromCopy {} = undefined -- !FS.FsPath + namespaceFor V1.BSInitialisingFromVal{} = undefined --ues !(WithOrigin SlotNo) + namespaceFor V1.BSInitialisedFromValues {} = undefined -- !(WithOrigin SlotNo) + namespaceFor V1.BSClosing + = -- nam{}espundefined --aceFor V1.BSAlready = Closed + namespaceFor V1.BSClosed + = undefined -- -- namespaceFor V1.BSCopyin = g !FS.FsPath + namespaceFor V1.BSCopied = undefined -- !FS.FsPath + namespaceFor V1.BSCreati = undefined --ngValueHandle + namespaceFor V1.BSValueHa{}ndlundefined --eTrace = !(Maybe Int) !BackingStoreValueHandleTrace + namespaceFor V1.BSCreate{}dVaundefined --lueHand = le + namespaceFor V1.BSWriting = undefined -- !SlotNo + namespaceFor V1.BSWritten = {} undefined -- !(WithOrigin SlotNo) !SlotNo + namespaceFor V1.ance Meta = Trace V1.Baundefined --ckingStoreValueHandleTrace where + un-----------------------{}-----defined ------------------------------------------------------ + + +{} severityFor _ _ = undefined + documentFor _ _ = undefined + allNamespaces = undefinedd-------------------------------efined --------------------------------------------------- + +instance LogFormatting V2.FlavorImplSpecificTrace where + forMachine _dtal V2.FlavorImplSpecificTraceInMemory = + mconcat [ "kind" .= String "FlavorImplSpecificTraceInMemory" ] + forMachine _dtal V2.FlavorImplSpecificTraceOnDisk = + mconcat [ "kind" .= String "FlavorImplSpecificTraceOnDisk" ] + + forHuman V2.FlavorImplSpecificTraceInMemory = undefined + forHuman V2.FlavorImplSpecificTraceOnDisk = undefined + +instance MetaTrace V2.FlavorImplSpecificTrace where + namespaceFor V2.FlavorImplSpecificTraceInMemory = _ + namespaceFor V2.FlavorImplSpecificTraceOnDisk + -------------------------------------------------------------------------------- -- ImmDB.TraceEvent -------------------------------------------------------------------------------- instance (ConvertRawHash blk, StandardHash blk) => LogFormatting (ImmDB.TraceEvent blk) where - forMachine _dtal ImmDB.NoValidLastLocation = + forMachine _dtal ImmDB.NoValidLastLocation = mconcat [ "kind" .= String "NoValidLastLocation" ] forMachine _dtal (ImmDB.ValidatedLastLocation chunkNo immTip) = mconcat [ "kind" .= String "ValidatedLastLocation" From d73bf1d1ceee4e4e6a7ec95dfaf1d6aaaf77dc97 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 9 Apr 2024 13:03:52 +0200 Subject: [PATCH 18/26] Implement Forker traces --- .gitignore | 1 + .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 91 +++++++++++-------- 2 files changed, 54 insertions(+), 38 deletions(-) diff --git a/.gitignore b/.gitignore index 5f9e7137522..32dffbd5d4a 100644 --- a/.gitignore +++ b/.gitignore @@ -18,6 +18,7 @@ dist/ result* /launch-* stack.yaml.lock +.ghcid /.cache /db diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 762a3d98310..eaf9dbb390b 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -1698,14 +1698,61 @@ instance LogFormatting LedgerDB.TraceForkerEvent where 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 pus" - forHuman LedgerDB.ForkerPushEnd = mempty + forHuman LedgerDB.ForkerPushStart = "Started to push" + forHuman LedgerDB.ForkerPushEnd = "Pushed" instance MetaTrace LedgerDB.TraceForkerEventWithKey where - namespaceFor = undefined - severityFor = undefined - documentFor = undefined - allNamespaces = undefined + namespaceFor (LedgerDB.TraceForkerEventWithKey _ ev) = + nsCast $ namespaceFor ev + severityFor ns (Just (LedgerDB.TraceForkerEventWithKey _ ev)) = + severityFor (nsCast ns) (Just ev) + severityFor (Namespace out tl) Nothing = + severityFor (Namespace out tl :: Namespace LedgerDB.TraceForkerEvent) Nothing + documentFor = documentFor @LedgerDB.TraceForkerEvent . nsCast + allNamespaces = map nsCast $ allNamespaces @LedgerDB.TraceForkerEvent + +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.ForkerReadStatistics = Namespace [] ["Statistics"] + namespaceFor LedgerDB.ForkerPushStart = Namespace [] ["StartPush"] + namespaceFor LedgerDB.ForkerPushEnd = Namespace [] ["FinishPush"] + + 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 _ ("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 _ = Nothing + + allNamespaces = [ + Namespace [] ["Open"] + , Namespace [] ["CloseUncommitted"] + , Namespace [] ["CloseCommitted"] + , Namespace [] ["StartRead"] + , Namespace [] ["FinishRead"] + , Namespace [] ["StartRangeRead"] + , Namespace [] ["FinishRangeRead"] + , Namespace [] ["Statistics"] + , Namespace [] ["StartPush"] + , Namespace [] ["FinishPush"] + ] -------------------------------------------------------------------------------- -- Flavor specific trace @@ -1887,41 +1934,9 @@ instance MetaTrace V1.FlavorImplSpecificTraceOnDisk where (allNamespaces :: [Namespace V1.BackingStoreTrace]) instance MetaTrace V1.BackingStoreTrace where - namespaceFor V1.BSOpened = undefined -- !(Maybe FS.FsPath) - namespaceFor V1.BSInitia{} = undefined --lisingFromCopy !FS.FsPath - namespaceFor V1.BSInitialisedFromCopy {} = undefined -- !FS.FsPath - namespaceFor V1.BSInitialisingFromVal{} = undefined --ues !(WithOrigin SlotNo) - namespaceFor V1.BSInitialisedFromValues {} = undefined -- !(WithOrigin SlotNo) - namespaceFor V1.BSClosing - = -- nam{}espundefined --aceFor V1.BSAlready = Closed - namespaceFor V1.BSClosed - = undefined -- -- namespaceFor V1.BSCopyin = g !FS.FsPath - namespaceFor V1.BSCopied = undefined -- !FS.FsPath - namespaceFor V1.BSCreati = undefined --ngValueHandle - namespaceFor V1.BSValueHa{}ndlundefined --eTrace = !(Maybe Int) !BackingStoreValueHandleTrace - namespaceFor V1.BSCreate{}dVaundefined --lueHand = le - namespaceFor V1.BSWriting = undefined -- !SlotNo - namespaceFor V1.BSWritten = {} undefined -- !(WithOrigin SlotNo) !SlotNo - namespaceFor V1.ance Meta = Trace V1.Baundefined --ckingStoreValueHandleTrace where - un-----------------------{}-----defined ------------------------------------------------------ - - -{} severityFor _ _ = undefined - documentFor _ _ = undefined - allNamespaces = undefinedd-------------------------------efined --------------------------------------------------- - instance LogFormatting V2.FlavorImplSpecificTrace where - forMachine _dtal V2.FlavorImplSpecificTraceInMemory = - mconcat [ "kind" .= String "FlavorImplSpecificTraceInMemory" ] - forMachine _dtal V2.FlavorImplSpecificTraceOnDisk = - mconcat [ "kind" .= String "FlavorImplSpecificTraceOnDisk" ] - - forHuman V2.FlavorImplSpecificTraceInMemory = undefined - forHuman V2.FlavorImplSpecificTraceOnDisk = undefined instance MetaTrace V2.FlavorImplSpecificTrace where - namespaceFor V2.FlavorImplSpecificTraceInMemory = _ - namespaceFor V2.FlavorImplSpecificTraceOnDisk -------------------------------------------------------------------------------- -- ImmDB.TraceEvent From 7c2cea14a224ec3acabfee280ad63a7f381cbad8 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 9 Apr 2024 15:24:51 +0200 Subject: [PATCH 19/26] Update consensus ref --- cabal.project | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index 1d50e06de90..d7a0fa7a0f5 100644 --- a/cabal.project +++ b/cabal.project @@ -31,7 +31,6 @@ packages: trace-dispatcher trace-resources trace-forward - ../ouroboros-consensus/ouroboros-consensus program-options ghc-options: -Werror @@ -65,10 +64,10 @@ package plutus-scripts-bench source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: 144666d22235fc441fda615a7c7990f4e301d176 - --sha256: 07qd9alk2ck1a5piv6ax79pvv10618939npqpvi6qmv59bmpx7a8 + tag: 2953920b81ebaf2aa3d5e19c6d66b7b73219f73b + --sha256: 0sa0s35xxm6rb823yn09128bgv052qhr6s25gndrywyshj667317 subdir: --- ouroboros-consensus + ouroboros-consensus ouroboros-consensus-cardano ouroboros-consensus-diffusion ouroboros-consensus-protocol From 584a3a5d5a4c3d44004fdfcf51e63d5ba5a36514 Mon Sep 17 00:00:00 2001 From: Renate Eilers Date: Tue, 9 Apr 2024 16:27:34 +0200 Subject: [PATCH 20/26] Add instances for BackingStoreTrace --- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 183 ++++++++++++++++-- 1 file changed, 170 insertions(+), 13 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index eaf9dbb390b..ddcf875bb9e 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -34,13 +34,13 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (chunkN import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.Impl.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.VolatileDB as VolDB import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.Enclose import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (MaxSlotNo (..)) -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 import Data.Aeson (Value (String), toJSON, (.=)) import Data.Int (Int64) @@ -1673,11 +1673,11 @@ instance MetaTrace (LedgerDB.TraceReplayProgressEvent blk) where -------------------------------------------------------------------------------- instance LogFormatting LedgerDB.TraceForkerEventWithKey where - forMachine dtals (LedgerDB.TraceForkerEventWithKey k ev) = + forMachine dtals (LedgerDB.TraceForkerEventWithKey k ev) = (\ev' -> mconcat [ "key" .= showT k, "event" .= ev' ]) $ forMachine dtals ev - forHuman (LedgerDB.TraceForkerEventWithKey k ev) = + forHuman (LedgerDB.TraceForkerEventWithKey k ev) = "Forker " <> showT k <> ": " <> forHuman ev - + instance LogFormatting LedgerDB.TraceForkerEvent where forMachine _dtals LedgerDB.ForkerOpen = mempty forMachine _dtals LedgerDB.ForkerCloseUncommitted = mempty @@ -1702,7 +1702,7 @@ instance LogFormatting LedgerDB.TraceForkerEvent where forHuman LedgerDB.ForkerPushEnd = "Pushed" instance MetaTrace LedgerDB.TraceForkerEventWithKey where - namespaceFor (LedgerDB.TraceForkerEventWithKey _ ev) = + namespaceFor (LedgerDB.TraceForkerEventWithKey _ ev) = nsCast $ namespaceFor ev severityFor ns (Just (LedgerDB.TraceForkerEventWithKey _ ev)) = severityFor (nsCast ns) (Just ev) @@ -1725,7 +1725,7 @@ instance MetaTrace LedgerDB.TraceForkerEvent where severityFor _ _ = Just Debug - documentFor (Namespace _ ("Open" : _tl)) = Just + documentFor (Namespace _ ("Open" : _tl)) = Just "A forker is being opened" documentFor (Namespace _ ("CloseUncommitted" : _tl)) = Just $ mconcat [ "A forker was closed without being committed." @@ -1846,7 +1846,6 @@ instance LogFormatting V1.BackingStoreTrace where mconcat [ "old" .= showT s1, "new" .= showT s2 ] forMachine _dtals (V1.BSValueHandleTrace i _ev) = maybe mempty (\i' -> mconcat ["idx" .= showT i']) i - instance LogFormatting V1.BackingStoreValueHandleTrace where forMachine _dtals V1.BSVHClosing = mempty forMachine _dtals V1.BSVHAlreadyClosed = mempty @@ -1910,9 +1909,9 @@ instance MetaTrace V1.FlavorImplSpecificTraceInMemory where (allNamespaces :: [Namespace V1.BackingStoreTrace]) instance MetaTrace V1.FlavorImplSpecificTraceOnDisk where - namespaceFor V1.OnDiskBackingStoreInitialise{} = + namespaceFor V1.OnDiskBackingStoreInitialise{} = Namespace [] ["Initialise"] - namespaceFor (V1.OnDiskBackingStoreTrace ev) = + namespaceFor (V1.OnDiskBackingStoreTrace ev) = nsPrependInner "BackingStoreEvent" (namespaceFor ev) severityFor (Namespace _ ("Initialise" : _)) _ = Just Debug @@ -1933,9 +1932,167 @@ instance MetaTrace V1.FlavorImplSpecificTraceOnDisk where : map (nsPrependInner "BackingStoreEvent") (allNamespaces :: [Namespace V1.BackingStoreTrace]) -instance MetaTrace V1.BackingStoreTrace where +instance MetaTrace V1.BackingStoreTrace where + namespaceFor V1.BSOpening = Namespace [] ["Opening"] + namespaceFor V1.BSOpened{} = Namespace [] ["Opened"] + namespaceFor V1.BSInitialisingFromCopy{} = + Namespace [] ["InitialisingFromCopy"] + namespaceFor V1.BSInitialisedFromCopy{} = + Namespace [] ["InitialisedFromCopy"] + namespaceFor V1.BSInitialisingFromValues{} = + Namespace [] ["InitialisingFromValues"] + namespaceFor V1.BSInitialisedFromValues{} = + Namespace [] ["InitialisedFromValues"] + namespaceFor V1.BSClosing = Namespace [] ["Closing"] + namespaceFor V1.BSAlreadyClosed = Namespace [] ["AlreadyClosed"] + namespaceFor V1.BSClosed = Namespace [] ["Closed"] + namespaceFor V1.BSCopying{} = Namespace [] ["Copying"] + namespaceFor V1.BSCopied{} = Namespace [] ["Copied"] + namespaceFor V1.BSCreatingValueHandle = Namespace [] ["CreatingValueHandle"] + namespaceFor V1.BSCreatedValueHandle = Namespace [] ["CreatedValueHandle"] + namespaceFor (V1.BSValueHandleTrace _ bsValueHandleTrace) = + nsPrependInner "ValueHandleTrace" (namespaceFor bsValueHandleTrace) + namespaceFor V1.BSWriting{} = Namespace [] ["Writing"] + namespaceFor V1.BSWritten{} = Namespace [] ["Written"] + + severityFor (Namespace _ ("Opening" : _)) _ = Just Debug + severityFor (Namespace _ ("Opened" : _)) _ = Just Debug + severityFor (Namespace _ ("InitialisingFromCopy" : _)) _ = Just Debug + severityFor (Namespace _ ("InitialisedFromCopy" : _)) _ = Just Debug + severityFor (Namespace _ ("InitialisingFromValues" : _)) _ = Just Debug + severityFor (Namespace _ ("InitialisedFromValues" : _)) _ = Just Debug + severityFor (Namespace _ ("Closing" : _)) _ = Just Debug + severityFor (Namespace _ ("AlreadyClosed" : _)) _ = Just Debug + severityFor (Namespace _ ("Closed" : _)) _ = Just Debug + severityFor (Namespace _ ("Copying" : _)) _ = Just Debug + severityFor (Namespace _ ("Copied" : _)) _ = Just Debug + severityFor (Namespace _ ("CreatingValueHandle" : _)) _ = Just Debug + severityFor (Namespace _ ("CreatedValueHandle" : _)) _ = Just Debug + severityFor (Namespace out ("ValueHandleTrace" : t1)) Nothing = + severityFor + (Namespace out t1 :: Namespace V1.BackingStoreValueHandleTrace) + Nothing + severityFor + (Namespace out ("ValueHandleTrace" : t1)) + (Just (V1.BSValueHandleTrace _ bsValueHandleTrace)) = + severityFor + (Namespace out t1 :: Namespace V1.BackingStoreValueHandleTrace) + (Just bsValueHandleTrace) + severityFor (Namespace _ ("Writing" : _)) _ = Just Debug + severityFor (Namespace _ ("Written" : _)) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ("Opening" : _ )) = Just + "Opening backing store" + documentFor (Namespace _ ("Opened" : _ )) = Just + "Backing store opened" + documentFor (Namespace _ ("InitialisingFromCopy" : _ )) = Just + "Initialising backing store from copy" + documentFor (Namespace _ ("InitialisedFromCopy" : _ )) = Just + "Backing store initialised from copy" + documentFor (Namespace _ ("InitialisingFromValues" : _ )) = Just + "Initialising backing store from values" + documentFor (Namespace _ ("InitialisedFromValues" : _ )) = Just + "Backing store initialised from values" + documentFor (Namespace _ ("Closing" : _ )) = Just + "Closing backing store" + documentFor (Namespace _ ("AlreadyClosed" : _ )) = Just + "Backing store is already closed" + documentFor (Namespace _ ("Closed" : _ )) = Just + "Backing store closed" + documentFor (Namespace _ ("Copying" : _ )) = Just + "Copying backing store" + documentFor (Namespace _ ("Copied" : _ )) = Just + "Backing store copied" + documentFor (Namespace _ ("CreatingValueHandle" : _ )) = Just + "Creating value handle for backing store" + documentFor (Namespace _ ("CreatedValueHandle" : _ )) = Just + "Value handle for backing store created" + documentFor (Namespace out ("ValueHandleTrace" : t1 )) = + documentFor (Namespace out t1 :: Namespace V1.BackingStoreValueHandleTrace) + documentFor (Namespace _ ("Writing" : _ )) = Just + "Writing backing store" + documentFor (Namespace _ ("Written" : _ )) = Just + "Backing store written" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["Opening"] + , Namespace [] ["Opened"] + , Namespace [] ["InitialisingFromCopy"] + , Namespace [] ["InitialisedFromCopy"] + , Namespace [] ["InitialisingFromValues"] + , Namespace [] ["InitialisedFromValues"] + , Namespace [] ["Closing"] + , Namespace [] ["AlreadyClosed"] + , Namespace [] ["Closed"] + , Namespace [] ["Copying"] + , Namespace [] ["Copied"] + , Namespace [] ["CreatingValueHandle"] + , Namespace [] ["CreatedValueHandle"] + , Namespace [] ["Writing"] + , Namespace [] ["Written"] + ] ++ map (nsPrependInner "ValueHandleTrace") + (allNamespaces :: [Namespace V1.BackingStoreValueHandleTrace]) + + +instance MetaTrace V1.BackingStoreValueHandleTrace where + namespaceFor V1.BSVHClosing = Namespace [] ["Closing"] + namespaceFor V1.BSVHAlreadyClosed = Namespace [] ["AlreadyClosed"] + namespaceFor V1.BSVHClosed = Namespace [] ["Closed"] + namespaceFor V1.BSVHRangeReading = Namespace [] ["RangeReading"] + namespaceFor V1.BSVHRangeRead = Namespace [] ["RangeRead"] + namespaceFor V1.BSVHReading = Namespace [] ["Reading"] + namespaceFor V1.BSVHRead = Namespace [] ["Read"] + namespaceFor V1.BSVHStatting = Namespace [] ["Statting"] + namespaceFor V1.BSVHStatted = Namespace [] ["Statted"] + + severityFor (Namespace _ ("Closing" : _ )) _ = Just Debug + severityFor (Namespace _ ("AlreadyClosed" : _ )) _ = Just Debug + severityFor (Namespace _ ("Closed" : _ )) _ = Just Debug + severityFor (Namespace _ ("RangeReading" : _ )) _ = Just Debug + severityFor (Namespace _ ("RangeRead" : _ )) _ = Just Debug + severityFor (Namespace _ ("Reading" : _ )) _ = Just Debug + severityFor (Namespace _ ("Read" : _ )) _ = Just Debug + severityFor (Namespace _ ("Statting" : _ )) _ = Just Debug + severityFor (Namespace _ ("Statted" : _ )) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ("Closing" : _ )) = Just + "Closing backing store value handle" + documentFor (Namespace _ ("AlreadyClosed" : _ )) = Just + "Backing store value handle already clsoed" + documentFor (Namespace _ ("Closed" : _ )) = Just + "Backing store value handle closed" + documentFor (Namespace _ ("RangeReading" : _ )) = Just + "Reading range for backing store value handle" + documentFor (Namespace _ ("RangeRead" : _ )) = Just + "Range for backing store value handle read" + documentFor (Namespace _ ("Reading" : _ )) = Just + "Reading backing store value handle" + documentFor (Namespace _ ("Read" : _ )) = Just + "Backing store value handle read" + documentFor (Namespace _ ("Statting" : _ )) = Just + "Statting backing store value handle" + documentFor (Namespace _ ("Statted" : _ )) = Just + "Backing store value handle statted" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["Closing"] + , Namespace [] ["AlreadyClosed"] + , Namespace [] ["Closed"] + , Namespace [] ["RangeReading"] + , Namespace [] ["RangeRead"] + , Namespace [] ["Reading"] + , Namespace [] ["Read"] + , Namespace [] ["Statting"] + , Namespace [] ["Statted"] + ] + + instance LogFormatting V2.FlavorImplSpecificTrace where - + instance MetaTrace V2.FlavorImplSpecificTrace where -------------------------------------------------------------------------------- @@ -1944,7 +2101,7 @@ instance MetaTrace V2.FlavorImplSpecificTrace where instance (ConvertRawHash blk, StandardHash blk) => LogFormatting (ImmDB.TraceEvent blk) where - forMachine _dtal ImmDB.NoValidLastLocation = + forMachine _dtal ImmDB.NoValidLastLocation = mconcat [ "kind" .= String "NoValidLastLocation" ] forMachine _dtal (ImmDB.ValidatedLastLocation chunkNo immTip) = mconcat [ "kind" .= String "ValidatedLastLocation" From 777aa4ade21367c87ce42266a72b176ca6904094 Mon Sep 17 00:00:00 2001 From: Fraser Murray Date: Wed, 10 Apr 2024 11:30:47 +0100 Subject: [PATCH 21/26] LogFormatting and MetaTrace instances for V2.FlavorImplSpecificTrace --- cabal.project | 4 +-- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 34 ++++++++++++++++++- 2 files changed, 35 insertions(+), 3 deletions(-) diff --git a/cabal.project b/cabal.project index d7a0fa7a0f5..a72d8b22ba0 100644 --- a/cabal.project +++ b/cabal.project @@ -64,8 +64,8 @@ package plutus-scripts-bench source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: 2953920b81ebaf2aa3d5e19c6d66b7b73219f73b - --sha256: 0sa0s35xxm6rb823yn09128bgv052qhr6s25gndrywyshj667317 + tag: a7a4c7edf369f33b910e508099edc06b47a571e7 + --sha256: 0ngkafqkddiawhffhjasp2yx1yviwqw5yjfvv9wg9f2lbddnaar1 subdir: ouroboros-consensus ouroboros-consensus-cardano diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index ddcf875bb9e..c33cfd85b3d 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -2090,10 +2090,42 @@ instance MetaTrace V1.BackingStoreValueHandleTrace where , Namespace [] ["Statted"] ] - instance LogFormatting V2.FlavorImplSpecificTrace where + forMachine _dtal V2.FlavorImplSpecificTraceInMemory = + mconcat [ "kind" .= String "InMemory" ] + forMachine _dtal V2.FlavorImplSpecificTraceOnDisk = + mconcat [ "kind" .= String "OnDisk" ] + + forHuman V2.FlavorImplSpecificTraceInMemory = + "An in-memory backing store event was traced" + forHuman V2.FlavorImplSpecificTraceOnDisk = + "An on-disk backing store event was traced" instance MetaTrace V2.FlavorImplSpecificTrace where + namespaceFor V2.FlavorImplSpecificTraceInMemory = + Namespace [] ["InMemory"] + namespaceFor V2.FlavorImplSpecificTraceOnDisk = + Namespace [] ["OnDisk"] + + severityFor (Namespace _ ["InMemory"]) _ = Just Info + severityFor (Namespace _ ["OnDisk"]) _ = Just Info + severityFor _ _ = Nothing + + -- suspicious + privacyFor (Namespace _ ["InMemory"]) _ = Just Public + privacyFor (Namespace _ ["OnDisk"]) _ = Just Public + privacyFor _ _ = Just Public + + documentFor (Namespace _ ["InMemory"]) = + Just "An in-memory backing store event" + documentFor (Namespace _ ["OnDisk"]) = + Just "An on-disk backing store event" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["InMemory"] + , Namespace [] ["OnDisk"] + ] -------------------------------------------------------------------------------- -- ImmDB.TraceEvent From c9be96ddedad89a013f7ee354c3703261568a515 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Wed, 10 Apr 2024 13:51:27 +0200 Subject: [PATCH 22/26] Do not break ellision by forkers Co-authored-by: Fraser Murray --- cardano-node/src/Cardano/Tracing/Tracers.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 9b0acac9e8c..5119a982c12 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -213,6 +213,15 @@ instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where (WithSeverity _s2 (ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerReplayEvent (LedgerDB.TraceReplayProgressEvent _)))) = True + -- HACK: we never want any of the forker or flavor events to break the elision. + -- + -- when a forker event arrives, it will be compared as @(ev `isEquivalent`)@, but once it is + -- processed the next time it will be compared as @(`isEquivalent` ev)@, hence the flipped + -- versions below this comment + isEquivalent (WithSeverity _s1 (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBForkerEvent{})) _ = True + isEquivalent (WithSeverity _s1 (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBFlavorImplEvent{})) _ = True + isEquivalent _ (WithSeverity _s1 (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBForkerEvent{})) = True + isEquivalent _ (WithSeverity _s1 (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBFlavorImplEvent{})) = True isEquivalent (WithSeverity _s1 (ChainDB.TraceInitChainSelEvent ev1)) (WithSeverity _s2 (ChainDB.TraceInitChainSelEvent ev2)) = case (ev1, ev2) of @@ -228,6 +237,10 @@ instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where doelide (WithSeverity _ (ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerReplayEvent (LedgerDB.TraceReplayProgressEvent _)))) = True + doelide (WithSeverity _ (ChainDB.TraceLedgerDBEvent + LedgerDB.LedgerDBForkerEvent{})) = True + doelide (WithSeverity _ (ChainDB.TraceLedgerDBEvent + LedgerDB.LedgerDBFlavorImplEvent{})) = True doelide (WithSeverity _ (ChainDB.TraceGCEvent _)) = True doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.IgnoreBlockOlderThanK _))) = False doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.IgnoreInvalidBlock _ _))) = False @@ -264,6 +277,10 @@ instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where (LedgerDB.LedgerReplayEvent (LedgerDB.TraceReplayProgressEvent _)))) (_old, count) = do return (Just ev, count) + conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBForkerEvent{})) (_old, count) = do + return (Just ev, count) + conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBFlavorImplEvent{})) (_old, count) = do + return (Just ev, count) conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceInitChainSelEvent (ChainDB.InitChainSelValidation (ChainDB.UpdateLedgerDbTraceEvent From c02f23dac739bfae181cb40509d310754019c3b4 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Wed, 10 Apr 2024 14:11:35 +0200 Subject: [PATCH 23/26] Fix namespaces --- .../src/Cardano/Node/Tracing/Tracers/ChainDB.hs | 10 ++-------- trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs | 8 +++----- 2 files changed, 5 insertions(+), 13 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index c33cfd85b3d..ee84b2dc930 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -263,7 +263,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where detailsFor (Namespace out ("LedgerEvent" : tl)) (Just (ChainDB.TraceLedgerDBEvent ev')) = detailsFor (Namespace out tl) (Just ev') detailsFor (Namespace out ("LedgerEvent" : tl)) Nothing = - detailsFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) Nothing + detailsFor (Namespace out tl :: Namespace (LedgerDB.TraceLedgerDBEvent blk)) Nothing detailsFor (Namespace out ("ImmDbEvent" : tl)) (Just (ChainDB.TraceImmutableDBEvent ev')) = detailsFor (Namespace out tl) (Just ev') detailsFor (Namespace out ("ImmDbEvent" : tl)) Nothing = @@ -290,8 +290,6 @@ instance MetaTrace (ChainDB.TraceEvent blk) where metricsDocFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) metricsDocFor (Namespace out ("LedgerEvent" : tl)) = metricsDocFor (Namespace out tl :: Namespace (LedgerDB.TraceLedgerDBEvent blk)) - metricsDocFor (Namespace out ("LedgerReplay" : tl)) = - metricsDocFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) metricsDocFor (Namespace out ("ImmDbEvent" : tl)) = metricsDocFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) metricsDocFor (Namespace out ("VolatileDbEvent" : tl)) = @@ -314,8 +312,6 @@ instance MetaTrace (ChainDB.TraceEvent blk) where documentFor (Namespace out tl :: Namespace (ChainDB.TraceIteratorEvent blk)) documentFor (Namespace out ("LedgerEvent" : tl)) = documentFor (Namespace out tl :: Namespace (LedgerDB.TraceLedgerDBEvent blk)) - documentFor (Namespace out ("LedgerReplay" : tl)) = - documentFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) documentFor (Namespace out ("ImmDbEvent" : tl)) = documentFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) documentFor (Namespace out ("VolatileDbEvent" : tl)) = @@ -339,8 +335,6 @@ instance MetaTrace (ChainDB.TraceEvent blk) where (allNamespaces :: [Namespace (ChainDB.TraceIteratorEvent blk)]) ++ map (nsPrependInner "LedgerEvent") (allNamespaces :: [Namespace (LedgerDB.TraceLedgerDBEvent blk)]) - ++ map (nsPrependInner "LedgerReplay") - (allNamespaces :: [Namespace (LedgerDB.TraceReplayEvent blk)]) ++ map (nsPrependInner "ImmDbEvent") (allNamespaces :: [Namespace (ImmDB.TraceEvent blk)]) ++ map (nsPrependInner "VolatileDbEvent") @@ -1517,7 +1511,7 @@ instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where namespaceFor LedgerDB.InvalidSnapshot {} = Namespace [] ["InvalidSnapshot"] severityFor (Namespace _ ["TookSnapshot"]) _ = Just Info - severityFor (Namespace _ ["DeletedSnpshot"]) _ = Just Debug + severityFor (Namespace _ ["DeletedSnapshot"]) _ = Just Debug severityFor (Namespace _ ["InvalidSnapshot"]) _ = Just Error severityFor _ _ = Nothing diff --git a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs index 6e35bddb6ef..a7456d3b11f 100644 --- a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs +++ b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs @@ -230,15 +230,15 @@ documentTracer tracer = do propertiesWarning LogDoc {..} = case ldSeverityCoded of Just _s -> [] - Nothing -> map (\ns -> pack "Severity missing" <> nsRawToText ns) ldNamespace + Nothing -> map (\ns -> pack "Severity missing: " <> nsRawToText ns) ldNamespace <> case ldPrivacyCoded of Just _p -> [] - Nothing -> map (\ns -> pack "Privacy missing" <> nsRawToText ns) ldNamespace + Nothing -> map (\ns -> pack "Privacy missing: " <> nsRawToText ns) ldNamespace <> case ldDetailsCoded of Just _d -> [] - Nothing -> map (\ns -> pack "Details missing" <> nsRawToText ns) ldNamespace + Nothing -> map (\ns -> pack "Details missing: " <> nsRawToText ns) ldNamespace configBuilder :: LogDoc -> Builder configBuilder LogDoc {..} = @@ -617,5 +617,3 @@ accentuated t = if t == "" addAccent t' = if t' == "" then ">" else "> " <> t' - - From d934a4e8f661085e2d58b61c5c00eeaa5d6b5837 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 15 Apr 2024 12:11:30 +0200 Subject: [PATCH 24/26] Update cabal.project refs --- cabal.project | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index a72d8b22ba0..967b9109fa5 100644 --- a/cabal.project +++ b/cabal.project @@ -64,8 +64,8 @@ package plutus-scripts-bench source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: a7a4c7edf369f33b910e508099edc06b47a571e7 - --sha256: 0ngkafqkddiawhffhjasp2yx1yviwqw5yjfvv9wg9f2lbddnaar1 + tag: e1a9eccc44c039ba57e09ea4631bcb5353a52e19 + --sha256: 0hvlb77r37gvhr63kfsypfpm3cf9sarq3b09c812xv4a6vx8msjw subdir: ouroboros-consensus ouroboros-consensus-cardano @@ -77,7 +77,7 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: be6c05f5f007ad9320da182fbde86983a7945905 - --sha256: 1xk73x1xzpz4rsqz6sv6mxzp24a57d5j6hq3r6zvjkf3g4xph2r1 + tag: a0c348722c2d6fe77d807caf8ec705c6be77122b + --sha256: 0m8xf9hih1y8mkq69pl58h6m1vxmxrrgy8jbwyr3hfxw522m0swi subdir: cardano-api From de208db4a0a04b8345e124ecc94abe060edd5bfe Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Thu, 23 May 2024 13:15:21 +0200 Subject: [PATCH 25/26] update cabal.project --- cabal.project | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 967b9109fa5..e2506adef59 100644 --- a/cabal.project +++ b/cabal.project @@ -64,7 +64,7 @@ package plutus-scripts-bench source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: e1a9eccc44c039ba57e09ea4631bcb5353a52e19 + tag: a0cfa958b7e9e071e49a2cf492204dab8be9f16c --sha256: 0hvlb77r37gvhr63kfsypfpm3cf9sarq3b09c812xv4a6vx8msjw subdir: ouroboros-consensus @@ -74,6 +74,14 @@ source-repository-package sop-extras strict-sop-core +source-repository-package + type: git + location: https://github.com/input-output-hk/anti-diffs + tag: aae3f1978a820384dbdb64d7beed1800ead8f7db + --sha256: sha256-t0Ykc4AkGnPNkLB13Kltl3sMw6U09ZsbXFlsK9PNtKU= + subdir: + diff-containers + source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api From e289e2bb438b14650a209e9aa077f9b8b3f96311 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 24 May 2024 13:01:44 +0200 Subject: [PATCH 26/26] Update refs --- cabal.project | 18 +++++------------- flake.lock | 6 +++--- 2 files changed, 8 insertions(+), 16 deletions(-) diff --git a/cabal.project b/cabal.project index e2506adef59..61f78372396 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- you need to run if you change them index-state: , hackage.haskell.org 2024-03-25T10:39:21Z - , cardano-haskell-packages 2024-04-05T13:36:27Z + , cardano-haskell-packages 2024-05-24T09:29:56Z packages: cardano-git-rev @@ -64,8 +64,8 @@ package plutus-scripts-bench source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: a0cfa958b7e9e071e49a2cf492204dab8be9f16c - --sha256: 0hvlb77r37gvhr63kfsypfpm3cf9sarq3b09c812xv4a6vx8msjw + tag: 858fbd77bca6c423a44feef41e31adaf0400e267 + --sha256: 0bxxvw96nsg22pmxxlf1fzr7g09xi6b60frvjngrwidlsv31nf2q subdir: ouroboros-consensus ouroboros-consensus-cardano @@ -74,18 +74,10 @@ source-repository-package sop-extras strict-sop-core -source-repository-package - type: git - location: https://github.com/input-output-hk/anti-diffs - tag: aae3f1978a820384dbdb64d7beed1800ead8f7db - --sha256: sha256-t0Ykc4AkGnPNkLB13Kltl3sMw6U09ZsbXFlsK9PNtKU= - subdir: - diff-containers - source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: a0c348722c2d6fe77d807caf8ec705c6be77122b - --sha256: 0m8xf9hih1y8mkq69pl58h6m1vxmxrrgy8jbwyr3hfxw522m0swi + tag: 239a713e8fdfca85ae4516e94d6cb8971ec6ca0f + --sha256: 1i4sc446w9mggpxf78zkglk34mjafwhyrmp3fvb7mkkk9347ziwd subdir: cardano-api diff --git a/flake.lock b/flake.lock index 7a1306027dd..47ef208dd2b 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1712325757, - "narHash": "sha256-cOyalvthxBQzErM4UfsHmvIfmgXF0vUw7FK5txfTZoQ=", + "lastModified": 1716544578, + "narHash": "sha256-Z9J23IQjRu4gKOI+jj6Rm8Bnza3CYHXLRLhNNg7QVkU=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "d4205c96eeb139c87fcf2dc78627d867ab851acd", + "rev": "19b29505e8d0a5bdd264db8911f88fcaa8a93090", "type": "github" }, "original": {