From d07d123da171ee7c8514f0f394a0bc6a00b2789f Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 28 May 2024 17:56:04 +0200 Subject: [PATCH] UTXO-HD 9.0 --- .github/workflows/haskell.yml | 15 +- .gitignore | 7 +- cabal.project | 29 + cardano-node/cardano-node.cabal | 4 + .../Cardano/Node/Configuration/LedgerDB.hs | 103 +++ .../src/Cardano/Node/Configuration/POM.hs | 112 ++- cardano-node/src/Cardano/Node/Parsers.hs | 111 ++- cardano-node/src/Cardano/Node/Queries.hs | 22 +- cardano-node/src/Cardano/Node/Run.hs | 108 ++- .../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 | 732 +++++++++++++++--- .../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 | 25 +- cardano-node/src/Cardano/Tracing/Config.hs | 9 + .../Tracing/OrphanInstances/Consensus.hs | 204 +++-- .../Tracing/OrphanInstances/Network.hs | 2 +- cardano-node/src/Cardano/Tracing/Tracers.hs | 84 +- cardano-node/test/Test/Cardano/Node/POM.hs | 28 +- .../src/Testnet/Components/Query.hs | 32 +- .../src/Testnet/EpochStateProcessing.hs | 5 +- .../src/Testnet/Process/Cli/SPO.hs | 2 +- cardano-testnet/src/Testnet/Runtime.hs | 5 +- .../Testnet/Test/Gov/CommitteeAddNew.hs | 2 +- .../Cardano/Testnet/Test/Gov/NoConfidence.hs | 3 +- .../Test/Gov/ProposeNewConstitution.hs | 2 +- .../Test/Gov/ProposeNewConstitutionSPO.hs | 2 +- .../Testnet/Test/Gov/TreasuryGrowth.hs | 3 +- .../Testnet/Test/Gov/TreasuryWithdrawal.hs | 4 +- nix/haskell.nix | 1 + .../src/Cardano/Logging/DocuGenerator.hs | 14 +- 34 files changed, 1458 insertions(+), 339 deletions(-) create mode 100644 cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 3b9bf800118..bb62216d1b6 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-24" + CABAL_CACHE_VERSION: "2024-04-28" concurrency: group: > @@ -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@v4 - name: Cabal update diff --git a/.gitignore b/.gitignore index 21b25ac2045..32dffbd5d4a 100644 --- a/.gitignore +++ b/.gitignore @@ -7,9 +7,7 @@ /cabal.project.old configuration/defaults/simpleview/genesis/ configuration/defaults/liveview/genesis/ -dist-newstyle -dist-newstyle/ -dist-profiled/ +dist-* dist/ *~ \#* @@ -20,12 +18,13 @@ dist/ result* /launch-* stack.yaml.lock +.ghcid /.cache /db /db-[0-9] /logs -/mainnet +/mainnet* /profile /launch_* /state-* diff --git a/cabal.project b/cabal.project index cf13cd4ad94..d54d906e354 100644 --- a/cabal.project +++ b/cabal.project @@ -64,3 +64,32 @@ allow-newer: katip:Win32 -- IMPORTANT -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus + tag: 2149c2f2c81089074eb575497e3785b6180f6062 + --sha256: sha256-lR9eVgUtcKs4cxajRnnKIhg91vYW2vbs/Hs/XhaVC5w= + 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: 651092c0c06866b7eab4e2261b3f28fbe8a74542 + --sha256: sha256-5SEGngIqEjXXBsjiZXWkrwMgYVXajuBCIeCDC4h7r+k= + subdir: + cardano-api + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-cli + tag: bd4c66e7921a85d5626b2761e4cd7b41af770b31 + --sha256: sha256-5evW3riN5k8ctsA3hUOvnxoVnvw0A+0J4y1c4/bGSK8= + subdir: + cardano-cli diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index cf91dfcaa1b..02437e3dd74 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 @@ -204,6 +205,9 @@ library , stm , strict-sop-core , strict-stm + , sop-core + , sop-extras + , text >= 2.0 , time , trace-dispatcher ^>= 2.5.8 , trace-forward ^>= 2.2.6 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..f5bb85eb8c5 --- /dev/null +++ b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Node.Configuration.LedgerDB ( + LedgerDbSelectorFlag(..) + , Gigabytes + , toBytes + , defaultLMDBLimits + , selectorToArgs + ) where + +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 Ouroboros.Consensus.Util.Args + +import qualified Data.Aeson.Types as Aeson (FromJSON) +import Data.SOP.Dict + +-- | 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 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. + | V1InMemory + | V2InMemory + 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 + } + +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 0cb4a22c2ef..7e173af71db 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,10 @@ 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 (..), +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (NumOfDiskSnapshots (..), SnapshotInterval (..)) +import Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..), + QueryBatchSize (..)) import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) @@ -102,9 +105,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 +133,13 @@ data NodeConfiguration , ncMaybeMempoolCapacityOverride :: !(Maybe MempoolCapacityBytesOverride) + -- LedgerDB configuration + , ncNumOfDiskSnapshots :: !NumOfDiskSnapshots + , ncSnapshotInterval :: !SnapshotInterval + , ncLedgerDBBackend :: !LedgerDbSelectorFlag + , ncFlushFrequency :: !FlushFrequency + , ncQueryBatchSize :: !QueryBatchSize + -- | Protocol idleness timeout, see -- 'Ouroboros.Network.Diffusion.daProtocolIdleTimeout'. -- @@ -162,6 +170,11 @@ data NodeConfiguration -- Enable Peer Sharing , ncPeerSharing :: PeerSharing + + -- SSD options for LMDB/Snapshot storing + , ncSsdDatabaseDir :: !FilePath + , ncSsdSnapshotState :: !Bool + , ncSsdSnapshotTables :: !Bool } deriving (Eq, Show) @@ -185,8 +198,6 @@ data PartialNodeConfiguration -- Node parameters, not protocol-specific: , pncDiffusionMode :: !(Last DiffusionMode ) - , pncNumOfDiskSnapshots :: !(Last NumOfDiskSnapshots) - , pncSnapshotInterval :: !(Last SnapshotInterval) , pncExperimentalProtocolsEnabled :: !(Last Bool) -- BlockFetch configuration @@ -202,6 +213,13 @@ data PartialNodeConfiguration -- Configuration for testing purposes , pncMaybeMempoolCapacityOverride :: !(Last MempoolCapacityBytesOverride) + -- LedgerDB configuration + , pncNumOfDiskSnapshots :: !(Last NumOfDiskSnapshots) + , pncSnapshotInterval :: !(Last SnapshotInterval) + , pncLedgerDBBackend :: !(Last LedgerDbSelectorFlag) + , pncFlushFrequency :: !(Last FlushFrequency) + , pncQueryBatchSize :: !(Last QueryBatchSize) + -- Network timeouts , pncProtocolIdleTimeout :: !(Last DiffTime) , pncTimeWaitTimeout :: !(Last DiffTime) @@ -225,6 +243,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 @@ -244,10 +267,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 +308,13 @@ instance FromJSON PartialNodeConfiguration where <*> parseHardForkProtocol v 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" + pncQueryBatchSize <- Last . fmap RequestedQueryBatchSize <$> v .:? "QueryBatchSize" + -- Network timeouts pncProtocolIdleTimeout <- Last <$> v .:? "ProtocolIdleTimeout" pncTimeWaitTimeout <- Last <$> v .:? "TimeWaitTimeout" @@ -321,12 +347,15 @@ 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 , pncDiffusionMode - , pncNumOfDiskSnapshots - , pncSnapshotInterval , pncExperimentalProtocolsEnabled , pncMaxConcurrencyBulkSync , pncMaxConcurrencyDeadline @@ -342,6 +371,11 @@ instance FromJSON PartialNodeConfiguration where , pncShutdownConfig = mempty , pncStartAsNonProducingNode = Last $ Just False , pncMaybeMempoolCapacityOverride + , pncNumOfDiskSnapshots + , pncSnapshotInterval + , pncLedgerDBBackend + , pncFlushFrequency + , pncQueryBatchSize , pncProtocolIdleTimeout , pncTimeWaitTimeout , pncChainSyncIdleTimeout @@ -355,6 +389,9 @@ instance FromJSON PartialNodeConfiguration where , pncTargetNumberOfActiveBigLedgerPeers , pncEnableP2P , pncPeerSharing + , pncSsdDatabaseDir + , pncSsdSnapshotState + , pncSsdSnapshotTables } where parseMempoolCapacityBytesOverride v = parseNoOverride <|> parseOverride @@ -370,6 +407,18 @@ instance FromJSON PartialNodeConfiguration where , show invalid ] Nothing -> return Nothing + + parseLedgerDBBackend v = do + maybeString :: Maybe String <- v .:? "LedgerDBBackend" + case maybeString of + Just "V1InMemory" -> return $ Just V1InMemory + Just "V2InMemory" -> return $ Just V2InMemory + Just "V1LMDB" -> do + mapSize :: Maybe Gigabytes <- v .:? "LMDBMapSize" + return . Just . V1LMDB $ mapSize + Nothing -> return Nothing + Just whatever -> fail $ "Malformed LedgerDBBackend" <> whatever + parseByronProtocol v = do primary <- v .:? "ByronGenesisFile" secondary <- v .:? "GenesisFile" @@ -496,8 +545,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 +558,11 @@ defaultPartialNodeConfiguration = , pncTraceConfig = mempty , pncTraceForwardSocket = mempty , pncMaybeMempoolCapacityOverride = mempty + , pncNumOfDiskSnapshots = Last $ Just DefaultNumOfDiskSnapshots + , pncSnapshotInterval = Last $ Just DefaultSnapshotInterval + , pncLedgerDBBackend = Last $ Just V2InMemory + , pncFlushFrequency = Last $ Just DefaultFlushFrequency + , pncQueryBatchSize = Last $ Just DefaultQueryBatchSize , pncProtocolIdleTimeout = Last (Just 5) , pncTimeWaitTimeout = Last (Just 60) , pncAcceptedConnectionsLimit = @@ -531,6 +583,9 @@ defaultPartialNodeConfiguration = , pncTargetNumberOfActiveBigLedgerPeers = Last (Just 5) , pncEnableP2P = Last (Just EnabledP2PMode) , pncPeerSharing = Last (Just PeerSharingDisabled) + , pncSsdDatabaseDir = Last (Just "mainnet/ledgerdb/") + , pncSsdSnapshotState = Last (Just False) + , pncSsdSnapshotTables = Last (Just False) } lastOption :: Parser a -> Parser (Last a) @@ -574,6 +629,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 @@ -596,6 +660,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" $ @@ -617,8 +691,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 +700,11 @@ makeNodeConfiguration pnc = do else TracingOff , ncTraceForwardSocket = getLast $ pncTraceForwardSocket pnc , ncMaybeMempoolCapacityOverride = getLast $ pncMaybeMempoolCapacityOverride pnc + , ncNumOfDiskSnapshots = numOfDiskSnapshots + , ncSnapshotInterval = snapshotInterval + , ncLedgerDBBackend + , ncFlushFrequency + , ncQueryBatchSize , ncProtocolIdleTimeout , ncTimeWaitTimeout , ncChainSyncIdleTimeout @@ -643,6 +720,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 ba82f9f96db..a70a24e9445 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,8 +23,10 @@ import Cardano.Node.Types import Cardano.Prelude (ConvertText (..)) import Ouroboros.Consensus.Mempool (MempoolCapacityBytes (..), MempoolCapacityBytesOverride (..)) -import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (NumOfDiskSnapshots (..), +import Ouroboros.Consensus.Storage.LedgerDB.Impl.Snapshots (NumOfDiskSnapshots (..), SnapshotInterval (..)) +import Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..), + QueryBatchSize (..)) import Data.Foldable import Data.Maybe (fromMaybe) @@ -79,6 +82,16 @@ nodeRunParser = do snapshotInterval <- lastOption parseSnapshotInterval maybeMempoolCapacityOverride <- lastOption parseMempoolCapacityOverride + -- LedgerDB configuration + ledgerDBBackend <- lastOption parseLedgerDBBackend + 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 @@ -90,8 +103,6 @@ nodeRunParser = do , pncTopologyFile = TopologyFile <$> topFp , pncDatabaseFile = DbFile <$> dbFp , pncDiffusionMode = mempty - , pncNumOfDiskSnapshots = numOfDiskSnapshots - , pncSnapshotInterval = snapshotInterval , pncExperimentalProtocolsEnabled = mempty , pncProtocolFiles = Last $ Just ProtocolFilepaths { byronCertFile @@ -113,6 +124,11 @@ nodeRunParser = do , pncTraceConfig = mempty , pncTraceForwardSocket = traceForwardSocket , pncMaybeMempoolCapacityOverride = maybeMempoolCapacityOverride + , pncNumOfDiskSnapshots = numOfDiskSnapshots + , pncSnapshotInterval = snapshotInterval + , pncLedgerDBBackend = ledgerDBBackend + , pncFlushFrequency + , pncQueryBatchSize , pncProtocolIdleTimeout = mempty , pncTimeWaitTimeout = mempty , pncChainSyncIdleTimeout = mempty @@ -126,6 +142,9 @@ nodeRunParser = do , pncTargetNumberOfActiveBigLedgerPeers = mempty , pncEnableP2P = mempty , pncPeerSharing = mempty + , pncSsdDatabaseDir = ssdDatabaseDir + , pncSsdSnapshotState = ssdSnapshotState + , pncSsdSnapshotTables = ssdSnapshotTables } parseSocketPath :: Text -> Parser SocketPath @@ -224,6 +243,69 @@ parseMempoolCapacityOverride = parseOverride <|> parseNoOverride <> help "[DEPRECATED: Set it in config file] Don't override mempool capacity" ) +parseLedgerDBBackend :: Parser LedgerDbSelectorFlag +parseLedgerDBBackend = parseV1InMemory <|> parseV2InMemory <|> parseLMDB <*> optional parseMapSize + where + 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 -> LedgerDbSelectorFlag) + parseLMDB = + 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 \ + \ 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 @@ -349,6 +431,29 @@ parseSnapshotInterval = fmap (RequestedSnapshotInterval . secondsToDiffTime) par <> help "[DEPRECATED: Set it in config file with key SnapshotInterval] 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/Queries.hs b/cardano-node/src/Cardano/Node/Queries.hs index 90e07540827..0b268c66ca3 100644 --- a/cardano-node/src/Cardano/Node/Queries.hs +++ b/cardano-node/src/Cardano/Node/Queries.hs @@ -59,7 +59,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 @@ -79,6 +79,7 @@ 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) -- @@ -229,10 +230,10 @@ instance All GetKESInfo xs => GetKESInfo (HardForkBlock xs) where -- * General ledger -- class LedgerQueries blk where - ledgerUtxoSize :: LedgerState blk -> Int - ledgerDelegMapSize :: LedgerState blk -> Int - ledgerDRepCount :: LedgerState blk -> Int - ledgerDRepMapSize :: LedgerState blk -> Int + ledgerUtxoSize :: LedgerState blk EmptyMK -> Int + ledgerDelegMapSize :: LedgerState blk EmptyMK -> Int + ledgerDRepCount :: LedgerState blk EmptyMK -> Int + ledgerDRepMapSize :: LedgerState blk EmptyMK -> Int instance LedgerQueries Byron.ByronBlock where ledgerUtxoSize = Map.size . Byron.unUTxO . Byron.cvsUtxo . Byron.byronLedgerState @@ -277,10 +278,10 @@ instance LedgerQueries (Shelley.ShelleyBlock protocol era) where instance (LedgerQueries x, NoHardForks x) => LedgerQueries (HardForkBlock '[x]) where - ledgerUtxoSize = ledgerUtxoSize . project - ledgerDelegMapSize = ledgerDelegMapSize . project - ledgerDRepCount = ledgerDRepCount . project - ledgerDRepMapSize = ledgerDRepMapSize . project + ledgerUtxoSize = ledgerUtxoSize . unFlip . project . Flip + ledgerDelegMapSize = ledgerDelegMapSize . unFlip . project . Flip + ledgerDRepCount = ledgerDRepCount . unFlip . project . Flip + ledgerDRepMapSize = ledgerDRepMapSize . unFlip . project . Flip instance LedgerQueries (Cardano.CardanoBlock c) where ledgerUtxoSize = \case @@ -341,8 +342,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 08b0feed168..404a83805b6 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -9,6 +9,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-} @@ -27,10 +28,67 @@ module Cardano.Node.Run 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 (..), + SnapshotPolicyArgs (..), StdRunNodeArgs (..)) +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 @@ -42,12 +100,15 @@ 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) 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 @@ -68,10 +129,6 @@ 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 @@ -93,7 +150,7 @@ 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 (..)) import qualified Ouroboros.Consensus.Node as Node (getChainDB, run) import Ouroboros.Consensus.Node.NetworkProtocolVersion @@ -396,6 +453,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do Exception.throwIO err dbPath <- canonDbPath nc + ssdPath <- canonSsdPath nc publicPeerSelectionVar <- Diffusion.makePublicPeerSelectionStateVar let diffusionArguments :: Diffusion.Arguments IO Socket RemoteAddress @@ -511,7 +569,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 @@ -521,6 +578,10 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , srnTraceChainDB = chainDBTracer tracers , srnMaybeMempoolCapacityOverride = ncMaybeMempoolCapacityOverride nc , srnChainSyncTimeout = customizeChainSyncTimeout + , srnSnapshotPolicyArgs = snapshotPolicyArgs + , srnLdbFlavorArgs = selectorToArgs (ncLedgerDBBackend nc) (ncFlushFrequency nc) (ncQueryBatchSize nc) + , srnPutInSSD = (ncSsdSnapshotTables nc, ncSsdSnapshotState nc) + , srnSSDPath = ssdPath } DisabledP2PMode -> do nt <- TopologyNonP2P.readTopologyFileOrError nc @@ -584,7 +645,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 @@ -594,6 +654,10 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , srnTraceChainDB = chainDBTracer tracers , srnChainSyncTimeout = customizeChainSyncTimeout , srnMaybeMempoolCapacityOverride = ncMaybeMempoolCapacityOverride nc + , srnSnapshotPolicyArgs = snapshotPolicyArgs + , srnLdbFlavorArgs = selectorToArgs (ncLedgerDBBackend nc) (ncFlushFrequency nc) (ncQueryBatchSize nc) + , srnPutInSSD = (ncSsdSnapshotTables nc, ncSsdSnapshotState nc) + , srnSSDPath = ssdPath } where @@ -653,12 +717,11 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do Nothing -> id Just version_ -> Map.takeWhileAntitone (<= version_) - diskPolicyArgs :: DiskPolicyArgs - diskPolicyArgs = - DiskPolicyArgs + snapshotPolicyArgs :: SnapshotPolicyArgs + snapshotPolicyArgs = + SnapshotPolicyArgs (ncSnapshotInterval nc) (ncNumOfDiskSnapshots nc) - -------------------------------------------------------------------------------- -- SIGHUP Handlers -------------------------------------------------------------------------------- @@ -796,11 +859,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/cardano-node/src/Cardano/Node/Tracing/StateRep.hs b/cardano-node/src/Cardano/Node/Tracing/StateRep.hs index bbd32fa6aa3..bc45d6c6252 100644 --- a/cardano-node/src/Cardano/Node/Tracing/StateRep.hs +++ b/cardano-node/src/Cardano/Node/Tracing/StateRep.hs @@ -25,12 +25,13 @@ 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 LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LgrDb import Ouroboros.Network.Block (pointSlot) @@ -59,8 +60,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 +209,23 @@ traceNodeStateChainDB _scp tr ev = traceWith tr $ NodeOpeningDbs $ OpenedImmutableDB (pointSlot p) chunk ChainDB.StartedOpeningVolatileDB -> traceWith tr $ NodeOpeningDbs StartedOpeningVolatileDB - ChainDB.OpenedVolatileDB _maxSlotN -> + 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 2eef28c0d34..0d48b372dd4 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -133,8 +133,9 @@ mkDispatchTracers nodeKernel trBase trForward mbTrEKG trDataPoint trConfig enabl -- 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 46af0cf6250..da40031b4ec 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -32,12 +32,15 @@ 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.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 Data.Aeson (Value (String), object, toJSON, (.=)) import Data.Int (Int64) @@ -86,8 +89,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 +107,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 +121,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 +141,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 +176,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 +218,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 +260,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 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 = @@ -304,9 +289,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 ("LedgerReplay" : tl)) = - metricsDocFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) + metricsDocFor (Namespace out tl :: Namespace (LedgerDB.TraceLedgerDBEvent blk)) metricsDocFor (Namespace out ("ImmDbEvent" : tl)) = metricsDocFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) metricsDocFor (Namespace out ("VolatileDbEvent" : tl)) = @@ -328,9 +311,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 ("LedgerReplay" : tl)) = - documentFor (Namespace out tl :: Namespace (LedgerDB.TraceReplayEvent blk)) + documentFor (Namespace out tl :: Namespace (LedgerDB.TraceLedgerDBEvent blk)) documentFor (Namespace out ("ImmDbEvent" : tl)) = documentFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) documentFor (Namespace out ("VolatileDbEvent" : tl)) = @@ -353,9 +334,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where ++ map (nsPrependInner "IteratorEvent") (allNamespaces :: [Namespace (ChainDB.TraceIteratorEvent blk)]) ++ map (nsPrependInner "LedgerEvent") - (allNamespaces :: [Namespace (LedgerDB.TraceSnapshotEvent blk)]) - ++ map (nsPrependInner "LedgerReplay") - (allNamespaces :: [Namespace (LedgerDB.TraceReplayEvent blk)]) + (allNamespaces :: [Namespace (LedgerDB.TraceLedgerDBEvent blk)]) ++ map (nsPrependInner "ImmDbEvent") (allNamespaces :: [Namespace (ImmDB.TraceEvent blk)]) ++ map (nsPrependInner "VolatileDbEvent") @@ -1084,7 +1063,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))) = @@ -1113,7 +1092,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))) = @@ -1186,8 +1165,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 maxSlotN) = - "Opened vol db with max slot number " <> showT maxSlotN + 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" @@ -1262,13 +1242,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 = @@ -1482,19 +1462,75 @@ 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) = 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 ev) = forHuman ev + forHuman (LedgerDB.LedgerDBFlavorImplEvent ev) = forHuman 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) = + 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 ("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) => 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" @@ -1505,33 +1541,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 _ ["DeletedSnapshot"]) _ = 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"] + ] -------------------------------------------------------------------------------- -- LedgerDB TraceReplayEvent @@ -1539,11 +1584,30 @@ instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where instance (StandardHash blk, ConvertRawHash blk) => LogFormatting (LedgerDB.TraceReplayEvent blk) where - forHuman (LedgerDB.ReplayFromGenesis _replayTo) = + + 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 = "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" .= showT tip' ] + +instance (StandardHash blk, ConvertRawHash blk) + => LogFormatting (LedgerDB.TraceReplayProgressEvent blk) where forHuman (LedgerDB.ReplayedBlock pt _ledgerEvents @@ -1563,12 +1627,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 @@ -1579,13 +1637,39 @@ instance (StandardHash blk, ConvertRawHash blk) , "tip" .= withOrigin 0 unSlotNo (pointSlot replayTo) ] 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 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 = + map (nsPrependInner "ReplayStart") + (allNamespaces :: [Namespace (LedgerDB.TraceReplayStartEvent blk)]) + ++ map (nsPrependInner "ReplayProgress") + (allNamespaces :: [Namespace (LedgerDB.TraceReplayProgressEvent blk)]) + +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 @@ -1600,6 +1684,19 @@ 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.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." @@ -1611,11 +1708,468 @@ instance MetaTrace (LedgerDB.TraceReplayEvent blk) where documentFor _ = Nothing allNamespaces = - [ Namespace [] ["ReplayFromGenesis"] - , Namespace [] ["ReplayFromSnapshot"] - , Namespace [] ["ReplayedBlock"] + [ 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 push" + forHuman LedgerDB.ForkerPushEnd = "Pushed" + +instance MetaTrace LedgerDB.TraceForkerEventWithKey where + 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 +-------------------------------------------------------------------------------- + +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.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 + 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 -------------------------------------------------------------------------------- diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 0f84f4bb238..16e950ac076 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -1051,6 +1051,7 @@ instance , LogFormatting (GenTx blk) , ToJSON (GenTxId blk) , LedgerSupportsMempool blk + , ConvertRawHash blk ) => LogFormatting (TraceEventMempool blk) where forMachine dtal (TraceMempoolAddedTx tx _mpSzBefore mpSzAfter) = mconcat @@ -1090,6 +1091,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) @@ -1099,19 +1128,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} = @@ -1126,11 +1158,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"]) = @@ -1155,7 +1199,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 @@ -1165,6 +1209,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 = @@ -1172,6 +1230,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 f105e58c51b..12ee3416d54 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs @@ -40,6 +40,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 =<<" -} @@ -51,7 +52,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..9bff3b996b7 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)) @@ -63,11 +62,12 @@ forgeTracerTransform nodeKern (Trace tr) = (\case (lc, Right (Left slc@(TraceStartLeadershipCheck slotNo))) -> do query <- mapNodeKernelDataIO - (\nk -> - (,,) - <$> nkQueryLedger (ledgerUtxoSize . ledgerState) nk - <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk - <*> nkQueryChain fragmentChainDensity nk) + (\nk -> do + (deleg, dens) <- (,) + <$> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk + <*> nkQueryChain fragmentChainDensity nk + utxo <- fmap (maybe 0 LedgerDB.ledgerTableSize) (ChainDB.getStatistics $ getChainDB nk) + pure (utxo, deleg, dens)) nodeKern case query of SNothing -> pure (lc, Right (Left slc)) @@ -84,8 +84,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 a051411c5fc..9baba8f90f8 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 @@ -64,6 +65,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 @@ -147,15 +150,14 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where ChainDB.ChainSelectionLoEDebug _ _ -> 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 @@ -260,7 +262,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 @@ -339,7 +350,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 @@ -535,7 +547,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 " <> @@ -544,7 +556,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 @@ -565,34 +577,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" @@ -617,8 +635,9 @@ instance ( ConvertRawHash blk ChainDB.OpenedImmutableDB immTip chunk -> "Opened imm db with immutable tip at " <> renderPointAsPhrase immTip <> " and chunk " <> showT chunk - ChainDB.OpenedVolatileDB maxSlotN -> - "Opened vol db with max slot number " <> showT maxSlotN + 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" @@ -630,10 +649,10 @@ instance ( ConvertRawHash blk ChainDB.InitialChainSelected -> "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 @@ -976,7 +995,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 @@ -1039,33 +1058,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" @@ -1140,7 +1165,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 @@ -1434,7 +1459,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 @@ -1474,6 +1500,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 1b89661c375..8acdeb52582 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -653,7 +653,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 934a5091612..f6b40fdc283 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -200,16 +200,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 @@ -229,6 +221,21 @@ 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 + -- 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 @@ -241,11 +248,16 @@ 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.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 - 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 @@ -275,7 +287,13 @@ 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.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 @@ -290,7 +308,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 @@ -847,11 +867,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 @@ -1253,24 +1273,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 @@ -1285,6 +1312,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) @@ -1378,7 +1406,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 2e16d22037d..8f9c3f457e8 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 @@ -13,8 +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.DiskPolicy (NumOfDiskSnapshots (..), +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)) @@ -116,7 +118,7 @@ testPartialYamlConfig = , pncShutdownConfig = Last Nothing , pncStartAsNonProducingNode = Last $ Just False , pncDiffusionMode = Last Nothing - , pncNumOfDiskSnapshots = Last Nothing + , pncNumOfDiskSnapshots = mempty , pncSnapshotInterval = mempty , pncExperimentalProtocolsEnabled = Last Nothing , pncMaxConcurrencyBulkSync = Last Nothing @@ -144,6 +146,12 @@ testPartialYamlConfig = , pncTargetNumberOfActiveBigLedgerPeers = mempty , pncEnableP2P = Last (Just DisabledP2PMode) , pncPeerSharing = Last (Just PeerSharingDisabled) + , 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 @@ -158,7 +166,7 @@ testPartialCliConfig = , pncTopologyFile = mempty , pncDatabaseFile = mempty , pncDiffusionMode = mempty - , pncNumOfDiskSnapshots = Last Nothing + , 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 @@ -184,6 +192,12 @@ testPartialCliConfig = , pncTargetNumberOfActiveBigLedgerPeers = mempty , pncEnableP2P = Last (Just DisabledP2PMode) , pncPeerSharing = Last (Just PeerSharingDisabled) + , 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 @@ -202,7 +216,7 @@ eExpectedConfig = do , ncValidateDB = True , ncProtocolConfig = testNodeProtocolConfiguration , ncDiffusionMode = InitiatorAndResponderDiffusionMode - , ncNumOfDiskSnapshots = DefaultNumOfDiskSnapshots + , ncNumOfDiskSnapshots = RequestedNumOfDiskSnapshots 3 , ncSnapshotInterval = RequestedSnapshotInterval $ secondsToDiffTime 100 , ncExperimentalProtocolsEnabled = True , ncMaxConcurrencyBulkSync = Nothing @@ -230,6 +244,12 @@ eExpectedConfig = do , ncTargetNumberOfActiveBigLedgerPeers = 5 , ncEnableP2P = SomeNetworkP2PMode Consensus.DisabledP2PMode , ncPeerSharing = PeerSharingDisabled + , ncLedgerDBBackend = V2InMemory + , ncFlushFrequency = DefaultFlushFrequency + , ncQueryBatchSize = DefaultQueryBatchSize + , ncSsdDatabaseDir = "mainnet/ledgerdb/" + , ncSsdSnapshotState = False + , ncSsdSnapshotTables = False } -- ----------------------------------------------------------------------------- diff --git a/cardano-testnet/src/Testnet/Components/Query.hs b/cardano-testnet/src/Testnet/Components/Query.hs index 020e6770ba8..629a7de9ae4 100644 --- a/cardano-testnet/src/Testnet/Components/Query.hs +++ b/cardano-testnet/src/Testnet/Components/Query.hs @@ -41,7 +41,7 @@ module Testnet.Components.Query import Cardano.Api as Api import Cardano.Api.Ledger (Credential, DRepState, EpochInterval (..), KeyRole (DRepRole), StandardCrypto) -import Cardano.Api.Shelley (ShelleyLedgerEra, fromShelleyTxIn, fromShelleyTxOut) +import Cardano.Api.Shelley (ShelleyLedgerEra) import Cardano.Ledger.Api (ConwayGovState) import qualified Cardano.Ledger.Api as L @@ -50,18 +50,15 @@ import qualified Cardano.Ledger.Conway.Governance as L import Cardano.Ledger.Conway.PParams (ConwayEraPParams) import qualified Cardano.Ledger.Conway.PParams as L 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 Control.Monad.Trans.State.Strict (put) -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 import Data.Ord (Down (..)) import Data.Text (Text) @@ -273,13 +270,13 @@ watchEpochStateUpdate -> ((AnyNewEpochState, SlotNo, BlockNo) -> m (Maybe a)) -- ^ The guard function (@Just@ if the condition is met, @Nothing@ otherwise) -> m (Maybe a) watchEpochStateUpdate epochStateView (EpochInterval maxWait) f = withFrozenCallStack $ do - AnyNewEpochState _ newEpochState <- getEpochState epochStateView + AnyNewEpochState _ newEpochState _ <- getEpochState epochStateView let EpochNo currentEpoch = L.nesEL newEpochState go $ currentEpoch + fromIntegral maxWait where go :: Word64 -> m (Maybe a) go timeout = do - newEpochStateDetails@(AnyNewEpochState _ newEpochState', _, _) <- getEpochStateDetails epochStateView pure + newEpochStateDetails@(AnyNewEpochState _ newEpochState' _, _, _) <- getEpochStateDetails epochStateView pure let EpochNo currentEpoch = L.nesEL newEpochState' f newEpochStateDetails >>= \case Just result -> pure (Just result) @@ -299,20 +296,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 @@ -415,7 +401,7 @@ checkDRepState epochStateView@EpochStateView{nodeConfigPath, socketPath} sbe f = currentEpoch <- getCurrentEpochNo epochStateView let terminationEpoch = succ . succ $ currentEpoch result <- H.evalIO . runExceptT $ foldEpochState nodeConfigPath socketPath QuickValidation terminationEpoch Nothing - $ \(AnyNewEpochState actualEra newEpochState) _slotNumber _blockNumber -> do + $ \(AnyNewEpochState actualEra newEpochState _) _slotNumber _blockNumber -> do Refl <- either error pure $ assertErasEqual sbe actualEra let dreps = shelleyBasedEraConstraints sbe newEpochState ^. L.nesEsL @@ -461,7 +447,7 @@ getGovState -> ConwayEraOnwards era -> m (L.ConwayGovState (ShelleyLedgerEra era)) -- ^ The governance state getGovState epochStateView ceo = withFrozenCallStack $ do - AnyNewEpochState sbe' newEpochState <- getEpochState epochStateView + AnyNewEpochState sbe' newEpochState _ <- getEpochState epochStateView let sbe = conwayEraOnwardsToShelleyBasedEra ceo Refl <- H.leftFail $ assertErasEqual sbe sbe' pure $ conwayEraOnwardsConstraints ceo $ newEpochState ^. L.newEpochStateGovStateL @@ -504,7 +490,7 @@ getCurrentEpochNo => EpochStateView -> m EpochNo getCurrentEpochNo epochStateView = withFrozenCallStack $ do - AnyNewEpochState _ newEpochState <- getEpochState epochStateView + AnyNewEpochState _ newEpochState _ <- getEpochState epochStateView pure $ newEpochState ^. L.nesELL -- | Assert that the value pointed by the @lens@ in the epoch state is the same as the @expected@ value @@ -549,7 +535,7 @@ assertNewEpochState epochStateView sbe maxWait lens expected = withFrozenCallSta :: HasCallStack => m value getFromEpochStateForEra = withFrozenCallStack $ getEpochStateDetails epochStateView $ - \(AnyNewEpochState actualEra newEpochState, _, _) -> do + \(AnyNewEpochState actualEra newEpochState _, _, _) -> do Refl <- H.leftFail $ assertErasEqual sbe actualEra pure $ newEpochState ^. lens diff --git a/cardano-testnet/src/Testnet/EpochStateProcessing.hs b/cardano-testnet/src/Testnet/EpochStateProcessing.hs index e75cf72dff8..c48d4b8d494 100644 --- a/cardano-testnet/src/Testnet/EpochStateProcessing.hs +++ b/cardano-testnet/src/Testnet/EpochStateProcessing.hs @@ -37,7 +37,7 @@ maybeExtractGovernanceActionIndex => TxId -- ^ transaction id searched for -> AnyNewEpochState -> Maybe Word16 -maybeExtractGovernanceActionIndex txid (AnyNewEpochState sbe newEpochState) = +maybeExtractGovernanceActionIndex txid (AnyNewEpochState sbe newEpochState _) = caseShelleyToBabbageOrConwayEraOnwards (const $ error "Governance actions only available in Conway era onwards") (\ceo -> conwayEraOnwardsConstraints ceo $ do @@ -68,7 +68,7 @@ waitForGovActionVotes epochStateView maxWait = withFrozenCallStack $ do :: HasCallStack => (AnyNewEpochState, SlotNo, BlockNo) -> m (Maybe ()) - checkForVotes (AnyNewEpochState actualEra newEpochState, _, _) = withFrozenCallStack $ do + checkForVotes (AnyNewEpochState actualEra newEpochState _, _, _) = withFrozenCallStack $ do caseShelleyToBabbageOrConwayEraOnwards (const $ H.note_ "Only Conway era onwards is supported" >> failure) (\ceo -> do @@ -85,4 +85,3 @@ waitForGovActionVotes epochStateView maxWait = withFrozenCallStack $ do else pure $ Just () ) actualEra - diff --git a/cardano-testnet/src/Testnet/Process/Cli/SPO.hs b/cardano-testnet/src/Testnet/Process/Cli/SPO.hs index 5e7ee0cc8ec..7ecc6819ef3 100644 --- a/cardano-testnet/src/Testnet/Process/Cli/SPO.hs +++ b/cardano-testnet/src/Testnet/Process/Cli/SPO.hs @@ -130,7 +130,7 @@ checkStakeKeyRegistered tempAbsP nodeConfigFile sPath terminationEpoch execConfi ] where handler :: StakeAddress -> AnyNewEpochState -> SlotNo -> BlockNo -> StateT DelegationsAndRewards IO ConditionResult - handler (StakeAddress network sCred) (AnyNewEpochState sbe newEpochState) _ _ = + handler (StakeAddress network sCred) (AnyNewEpochState sbe newEpochState _) _ _ = let umap = shelleyBasedEraConstraints sbe $ newEpochState ^. L.nesEsL . L.epochStateUMapL dag = L.filterStakePoolDelegsAndRewards umap $ Set.singleton sCred allStakeCredentials = umap ^. L.umElemsL -- This does not include pointer addresses diff --git a/cardano-testnet/src/Testnet/Runtime.hs b/cardano-testnet/src/Testnet/Runtime.hs index f8c1239b52e..216d395427a 100644 --- a/cardano-testnet/src/Testnet/Runtime.hs +++ b/cardano-testnet/src/Testnet/Runtime.hs @@ -235,7 +235,7 @@ startLedgerNewEpochStateLogging testnetRuntime tmpWorkspace = withFrozenCallStac -> SlotNo -> BlockNo -> StateT (Maybe AnyNewEpochState) IO ConditionResult - handler outputFp diffFp anes@(AnyNewEpochState !sbe !nes) _ (BlockNo blockNo) = handleException $ do + handler outputFp diffFp anes@(AnyNewEpochState !sbe !nes _) _ (BlockNo blockNo) = handleException $ do let prettyNes = shelleyBasedEraConstraints sbe (encodePretty nes) blockLabel = "#### BLOCK " <> show blockNo <> " ####" liftIO . BSC.appendFile outputFp $ BSC.unlines [BSC.pack blockLabel, prettyNes, ""] @@ -243,7 +243,7 @@ startLedgerNewEpochStateLogging testnetRuntime tmpWorkspace = withFrozenCallStac -- store epoch state for logging of differences mPrevEpochState <- get put (Just anes) - forM_ mPrevEpochState $ \(AnyNewEpochState sbe' pnes) -> do + forM_ mPrevEpochState $ \(AnyNewEpochState sbe' pnes _) -> do let prettyPnes = shelleyBasedEraConstraints sbe' (encodePretty pnes) difference = calculateEpochStateDiff prettyPnes prettyNes liftIO . appendFile diffFp $ unlines [blockLabel, difference, ""] @@ -277,4 +277,3 @@ instance (L.EraTxOut ledgerera, L.EraGov ledgerera) => ToJSON (L.NewEpochState l , "rewardUpdate" .= nesRu , "currentStakeDistribution" .= nesPd ] - diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/CommitteeAddNew.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/CommitteeAddNew.hs index 36c2e3b6ac9..39a945c8751 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/CommitteeAddNew.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/CommitteeAddNew.hs @@ -252,7 +252,7 @@ getCommitteeMembers epochStateView ceo = withFrozenCallStack $ do fmap (Map.keys . L.committeeMembers) . H.nothingFail $ strictMaybeToMaybe $ govState ^. L.cgsCommitteeL committeeIsPresent :: (AnyNewEpochState, SlotNo, BlockNo) -> Maybe () -committeeIsPresent (AnyNewEpochState sbe newEpochState, _, _) = +committeeIsPresent (AnyNewEpochState sbe newEpochState _, _, _) = caseShelleyToBabbageOrConwayEraOnwards (const $ error "Constitutional committee does not exist pre-Conway era") (\_ -> do diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs index da81f6efba0..3f7e96e0ddf 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/NoConfidence.hs @@ -244,7 +244,7 @@ hprop_gov_no_confidence = integrationWorkspace "no-confidence" $ \tempAbsBasePat -- | Checks if the committee is empty or not. committeeIsPresent :: Bool -> (AnyNewEpochState, SlotNo, BlockNo) -> Maybe () -committeeIsPresent committeeExists (AnyNewEpochState sbe newEpochState, _, _) = +committeeIsPresent committeeExists (AnyNewEpochState sbe newEpochState _, _, _) = caseShelleyToBabbageOrConwayEraOnwards (const $ error "Constitutional committee does not exist pre-Conway era") (const $ let mCommittee = newEpochState @@ -262,4 +262,3 @@ committeeIsPresent committeeExists (AnyNewEpochState sbe newEpochState, _, _) = else Nothing ) sbe - diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs index 1cc4369423d..76232bce673 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs @@ -221,7 +221,7 @@ filterRatificationState -> String -- ^ Submitted guard rail script hash -> AnyNewEpochState -> Bool -filterRatificationState c guardRailScriptHash (AnyNewEpochState sbe newEpochState) = do +filterRatificationState c guardRailScriptHash (AnyNewEpochState sbe newEpochState _) = do caseShelleyToBabbageOrConwayEraOnwards (const $ error "filterRatificationState: Only conway era supported") diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs index 17eaa4579da..a4bb9708d10 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs @@ -168,7 +168,7 @@ getConstitutionProposal -> m (Maybe (L.GovActionId StandardCrypto)) getConstitutionProposal nodeConfigFile socketPath maxEpoch = do result <- H.evalIO . runExceptT $ foldEpochState nodeConfigFile socketPath QuickValidation maxEpoch Nothing - $ \(AnyNewEpochState actualEra newEpochState) _slotNb _blockNb -> + $ \(AnyNewEpochState actualEra newEpochState _) _slotNb _blockNb -> caseShelleyToBabbageOrConwayEraOnwards (error $ "Expected Conway era onwards, got state in " <> docToString (pretty actualEra)) (\cEra -> conwayEraOnwardsConstraints cEra $ do diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryGrowth.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryGrowth.hs index 6a628afa347..801cfdac988 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryGrowth.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryGrowth.hs @@ -66,7 +66,7 @@ prop_check_if_treasury_is_growing = integrationRetryWorkspace 0 "growing-treasur H.failure where handler :: AnyNewEpochState -> SlotNo -> BlockNo -> StateT (Map EpochNo Integer) IO ConditionResult - handler (AnyNewEpochState _ newEpochState) _slotNo _blockNo = do + handler (AnyNewEpochState _ newEpochState _) _slotNo _blockNo = do let (Coin coin) = newEpochState ^. L.nesEsL . L.esAccountStateL . L.asTreasuryL epochNo = newEpochState ^. L.nesELL -- handler is executed multiple times per epoch, so we keep only the latest treasury value @@ -88,4 +88,3 @@ prop_check_if_treasury_is_growing = integrationRetryWorkspace 0 "growing-treasur [] -> False [_] -> True (x:y:xs) -> x <= y && checkNonDecreasing (y:xs) - diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs index 45b5a819faa..0ccab81a005 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs @@ -264,7 +264,7 @@ getAnyWithdrawals -> m (Maybe (Map (Credential Staking StandardCrypto) Coin)) getAnyWithdrawals nodeConfigFile socketPath maxEpoch = withFrozenCallStack $ do fmap snd . H.leftFailM . evalIO . runExceptT $ foldEpochState nodeConfigFile socketPath FullValidation maxEpoch Nothing - $ \(AnyNewEpochState actualEra newEpochState) -> + $ \(AnyNewEpochState actualEra newEpochState _) -> caseShelleyToBabbageOrConwayEraOnwards (error $ "Expected Conway era onwards, got state in " <> docToString (pretty actualEra)) (\cEra _ _ -> conwayEraOnwardsConstraints cEra $ do @@ -292,7 +292,7 @@ getTreasuryWithdrawalProposal -> m (Maybe (L.GovActionId StandardCrypto)) getTreasuryWithdrawalProposal nodeConfigFile socketPath maxEpoch = withFrozenCallStack $ do fmap snd . H.leftFailM . evalIO . 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 diff --git a/nix/haskell.nix b/nix/haskell.nix index 75bf94df7ee..e1f64ae373d 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 diff --git a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs index ad5b11ea103..a7456d3b11f 100644 --- a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs +++ b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs @@ -216,29 +216,29 @@ 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 {..} = 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' - -