diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 0eabbe0d0ba..e87017ebe5d 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -97,6 +97,19 @@ jobs: with: use-sodium-vrf: true # default is true + - name: Linux install lmdb + if: matrix.sys.os == 'ubuntu-latest' + run: sudo apt install liblmdb-dev + + - name: Mac install lmdb + if: matrix.sys.os == 'macos-13' + run: brew install lmdb + + - name: Windows install lmdb + if: matrix.sys.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 79f819574a1..c594b05c184 100644 --- a/cabal.project +++ b/cabal.project @@ -13,7 +13,7 @@ repository cardano-haskell-packages -- See CONTRIBUTING for information about these, including some Nix commands -- you need to run if you change them index-state: - , hackage.haskell.org 2024-12-24T12:56:48Z + , hackage.haskell.org 2024-12-31T10:16:13Z , cardano-haskell-packages 2025-01-08T16:35:32Z packages: @@ -71,18 +71,77 @@ allow-newer: -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. +-- UTxO-HD for 10.2 +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus.git + tag: 54ac1b2f5bd15f3f0f70e9f4a9ebf3e34792dcf2 + --sha256: sha256-PdzKg4PA6DnzhRVUF2kiBfvf8S+ekXmws73XDXSZdnY= + subdir: + ouroboros-consensus + ouroboros-consensus-cardano + ouroboros-consensus-diffusion + ouroboros-consensus-protocol + sop-extras + strict-sop-core + +-- UTxO-HD for 10.2 source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api.git - tag: f93b1cf1b5f2649e14c42f70a948ca9c2e5edc70 - --sha256: sha256-4+x6GSAJpOUzVuGEuMztdmG5+sSH3uym99YAH6a0Az0= + tag: e3b7712d80fe5721bccf5dccb89e626de12ae419 + --sha256: sha256-Z2/qzlS4JfAtdSOc/V0r3wfbfOq6YWAobgmKKzlesdM= subdir: cardano-api +-- UTxO-HD for 10.2 source-repository-package type: git location: https://github.com/IntersectMBO/cardano-cli.git - tag: abb632ccf5887d53b33fc20283a2c4180b0ecd92 - --sha256: sha256-WSI5zsVON99O9Elm2xqB05KCLHHjgf3Fw6nejdTyMAs= + tag: e3b99e7f70f34e5bed41d2a3bdad23b993735ea6 + --sha256: sha256-m1p+GGICoaU8x7XvEAFgtYHUDTKqFNSOMp7nfqN7s7k= subdir: cardano-cli + +-- mempack support +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-base.git + tag: fb9b71f3bc33f8de673c6427736f09bf7972e81f + subdir: + cardano-crypto-class + --sha256: sha256-ExQ497FDYlmQyZaXOTddU+KraAUHnTAqPiyt055v0+M= + +-- mempack support +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger + tag: c50d89688d9f30ea2dbd01afb19dbcaaf03e3da7 + --sha256: sha256-3OVXLYCKSN4HPd3nsObK2mG8mB28AX46vuMqs+Jn3kw= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/alonzo/test-suite + eras/babbage/impl + eras/babbage/test-suite + eras/conway/impl + eras/conway/test-suite + eras/mary/impl + eras/shelley/impl + eras/shelley/test-suite + eras/shelley-ma/test-suite + libs/cardano-ledger-api + libs/cardano-ledger-core + libs/cardano-ledger-binary + libs/cardano-protocol-tpraos + libs/non-integral + libs/small-steps + libs/cardano-data + libs/set-algebra + libs/vector-map + eras/byron/chain/executable-spec + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/byron/ledger/impl/test + eras/byron/crypto + eras/byron/crypto/test diff --git a/cardano-node/app/cardano-node.hs b/cardano-node/app/cardano-node.hs index c1a938cf552..a550735de7a 100644 --- a/cardano-node/app/cardano-node.hs +++ b/cardano-node/app/cardano-node.hs @@ -35,8 +35,6 @@ main = do case cmd of RunCmd args -> do warnIfSet args pncMaybeMempoolCapacityOverride "mempool-capacity-override" "MempoolCapacityBytesOverride" - warnIfSet args pncNumOfDiskSnapshots "num-of-disk-snapshots" "NumOfDiskSnapshots" - warnIfSet args pncSnapshotInterval "snapshot-interval" "SnapshotInterval" runNode args TraceDocumentation tdc -> runTraceDocumentationCmd tdc VersionCmd -> runVersionCommand @@ -45,15 +43,15 @@ main = do p = Opt.prefs Opt.showHelpOnEmpty warnIfSet :: PartialNodeConfiguration -> (PartialNodeConfiguration -> Last a) -> String -> String -> IO () - warnIfSet args f name key = - maybe - (pure ()) - (\_ -> hPutStrLn stderr $ "WARNING: Option --" ++ name ++ " was set via CLI flags.\ + warnIfSet args f name key = + maybe + (pure ()) + (\_ -> hPutStrLn stderr $ "WARNING: Option --" ++ name ++ " was set via CLI flags.\ \ This CLI flag will be removed in upcoming node releases.\ - \ Please, set this configuration option in the configuration file instead with key " ++ key ++ ".") + \ Please, set this configuration option in the configuration file instead with key " ++ key ++ ".") $ getLast $ f args - + opts :: Opt.ParserInfo Command opts = Opt.info (fmap RunCmd nodeCLIParser diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 382aeaa4231..b0253d52ac6 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 @@ -206,6 +207,9 @@ library , stm <2.5.2 || >=2.5.3 , strict-sop-core , strict-stm + , sop-core + , sop-extras + , text >= 2.0 , time , trace-dispatcher ^>= 2.7.0 , trace-forward ^>= 2.2.8 @@ -269,7 +273,6 @@ test-suite cardano-node-test , ouroboros-network-api , strict-sop-core , text - , time , transformers , vector , yaml 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..dcea1af410a --- /dev/null +++ b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Node.Configuration.LedgerDB ( + LedgerDbConfiguration (..) + , LedgerDbSelectorFlag(..) + , Gigabytes + , selectorToArgs + ) where + +import Ouroboros.Consensus.Storage.LedgerDB.Args +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1 +import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB (LMDBLimits (..)) +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import Ouroboros.Consensus.Util.Args + +import qualified Data.Aeson.Types as Aeson (FromJSON) +import Data.Maybe (fromMaybe) +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. +-- +-- - 'V2InMemory': uses more memory than the minimum requirements but is somewhat +-- faster. +-- +-- - 'V1LMDB': uses less memory but is somewhat slower. +-- +-- - 'V1InMemory': Not intended for production. It is an in-memory reproduction +-- of the LMDB implementation. +data LedgerDbSelectorFlag = + V1LMDB + V1.FlushFrequency + -- ^ The frequency at which changes are flushed to the disk. + (Maybe FilePath) + -- ^ Path for the live tables. + (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 V1.FlushFrequency + | V2InMemory + deriving (Eq, Show) + +data LedgerDbConfiguration = + LedgerDbConfiguration + NumOfDiskSnapshots + SnapshotInterval + QueryBatchSize + LedgerDbSelectorFlag + (Flag "DoDiskSnapshotChecksum") + 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 + } + +defaultLMDBPath :: FilePath +defaultLMDBPath = "mainnet/db/lmdb" + +selectorToArgs :: LedgerDbSelectorFlag -> Complete LedgerDbFlavorArgs IO +selectorToArgs (V1InMemory a) = LedgerDbFlavorArgsV1 $ V1.V1Args a V1.InMemoryBackingStoreArgs +selectorToArgs V2InMemory = LedgerDbFlavorArgsV2 $ V2.V2Args V2.InMemoryHandleArgs +selectorToArgs (V1LMDB a fp l) = + LedgerDbFlavorArgsV1 + $ V1.V1Args a + $ V1.LMDBBackingStoreArgs + (fromMaybe defaultLMDBPath fp) + (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 3b77283d991..a45eee72b4f 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -26,6 +26,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 @@ -39,8 +40,10 @@ import Ouroboros.Consensus.Node (NodeDatabasePaths (..), pattern DoDis import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) import Ouroboros.Consensus.Node.Genesis (GenesisConfig, GenesisConfigFlags (..), defaultGenesisConfigFlags, mkGenesisConfig) -import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (Flag, NumOfDiskSnapshots (..), - SnapshotInterval (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Args (QueryBatchSize (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..), + SnapshotInterval (..), Flag (..)) +import Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..)) import Ouroboros.Network.Diffusion.Configuration as Configuration import Control.Monad (when) @@ -51,7 +54,7 @@ import Data.Maybe import Data.Monoid (Last (..)) import Data.Text (Text) import qualified Data.Text as Text -import Data.Time.Clock (DiffTime) +import Data.Time.Clock (DiffTime, secondsToDiffTime) import Data.Yaml (decodeFileThrow) import GHC.Generics (Generic) import Options.Applicative @@ -105,11 +108,8 @@ data NodeConfiguration -- Protocol-specific parameters: , ncProtocolConfig :: !NodeProtocolConfiguration - -- Node parameters, not protocol-specific: - , ncDiffusionMode :: !DiffusionMode - , ncNumOfDiskSnapshots :: !NumOfDiskSnapshots - , ncSnapshotInterval :: !SnapshotInterval - , ncDoDiskSnapshotChecksum :: !(Flag "DoDiskSnapshotChecksum") + -- Modes + , 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 @@ -137,6 +137,9 @@ data NodeConfiguration , ncMaybeMempoolCapacityOverride :: !(Maybe MempoolCapacityBytesOverride) + -- LedgerDB configuration + , ncLedgerDbConfig :: !LedgerDbConfiguration + -- | Protocol idleness timeout, see -- 'Ouroboros.Network.Diffusion.daProtocolIdleTimeout'. -- @@ -205,9 +208,7 @@ data PartialNodeConfiguration -- Node parameters, not protocol-specific: , pncDiffusionMode :: !(Last DiffusionMode) - , pncNumOfDiskSnapshots :: !(Last NumOfDiskSnapshots) - , pncSnapshotInterval :: !(Last SnapshotInterval) - , pncDoDiskSnapshotChecksum :: !(Last (Flag "DoDiskSnapshotChecksum")) + , pncExperimentalProtocolsEnabled :: !(Last Bool) -- BlockFetch configuration @@ -223,6 +224,9 @@ data PartialNodeConfiguration -- Configuration for testing purposes , pncMaybeMempoolCapacityOverride :: !(Last MempoolCapacityBytesOverride) + -- LedgerDB configuration + , pncLedgerDbConfig :: !(Last LedgerDbConfiguration) + -- Network timeouts , pncProtocolIdleTimeout :: !(Last DiffTime) , pncTimeWaitTimeout :: !(Last DiffTime) @@ -279,12 +283,6 @@ instance FromJSON PartialNodeConfiguration where pncDatabaseFile <- Last <$> v .:? "DatabasePath" pncDiffusionMode <- Last . fmap getDiffusionMode <$> v .:? "DiffusionMode" - pncNumOfDiskSnapshots - <- Last . fmap RequestedNumOfDiskSnapshots <$> v .:? "NumOfDiskSnapshots" - pncSnapshotInterval - <- Last . fmap RequestedSnapshotInterval <$> v .:? "SnapshotInterval" - pncDoDiskSnapshotChecksum - <- Last <$> v .:? "DoDiskSnapshotChecksum" pncExperimentalProtocolsEnabled <- fmap Last $ do mValue <- v .:? "ExperimentalProtocolsEnabled" @@ -326,6 +324,9 @@ instance FromJSON PartialNodeConfiguration where <*> parseHardForkProtocol v pncMaybeMempoolCapacityOverride <- Last <$> parseMempoolCapacityBytesOverride v + -- LedgerDB configuration + pncLedgerDbConfig <- Last <$> parseLedgerDbConfig v + -- Network timeouts pncProtocolIdleTimeout <- Last <$> v .:? "ProtocolIdleTimeout" pncTimeWaitTimeout <- Last <$> v .:? "TimeWaitTimeout" @@ -374,9 +375,6 @@ instance FromJSON PartialNodeConfiguration where pncProtocolConfig , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty pncSocketPath , pncDiffusionMode - , pncNumOfDiskSnapshots - , pncSnapshotInterval - , pncDoDiskSnapshotChecksum , pncExperimentalProtocolsEnabled , pncMaxConcurrencyBulkSync , pncMaxConcurrencyDeadline @@ -392,6 +390,7 @@ instance FromJSON PartialNodeConfiguration where , pncShutdownConfig = mempty , pncStartAsNonProducingNode = Last $ Just False , pncMaybeMempoolCapacityOverride + , pncLedgerDbConfig , pncProtocolIdleTimeout , pncTimeWaitTimeout , pncChainSyncIdleTimeout @@ -427,6 +426,37 @@ instance FromJSON PartialNodeConfiguration where , show invalid ] Nothing -> return Nothing + + parseLedgerDbConfig v = do + maybeString :: Maybe Value <- v .:? "LedgerDB" + case maybeString of + Nothing -> return Nothing + Just vv -> withObject "LedgerDB" (\o -> do + snapNum <- + (fmap RequestedNumOfDiskSnapshots <$> o .:? "NumOfDiskSnapshots") + .!= DefaultNumOfDiskSnapshots + doChecksum <- (fmap Flag <$> o .:? "DoDiskSnapshotChecksum") .!= DoDiskSnapshotChecksum + snapInterval <- + (fmap (RequestedSnapshotInterval . secondsToDiffTime) <$> o .:? "SnapshotInterval") + .!= DefaultSnapshotInterval + qsize <- + (fmap RequestedQueryBatchSize <$> o .:? "QueryBatchSize") + .!= DefaultQueryBatchSize + backend <- o .:? "Backend" .!= "V2InMemory" + selector <- case backend of + "V1InMemory" -> do + flush <- (fmap RequestedFlushFrequency <$> o .:? "FlushFrequency") .!= DefaultFlushFrequency + return $ V1InMemory flush + "V1LMDB" -> do + flush <- (fmap RequestedFlushFrequency <$> o .:? "FlushFrequency") .!= DefaultFlushFrequency + mapSize :: Maybe Gigabytes <- o .:? "MapSize" + lmdbPath :: Maybe FilePath <- o .:? "LiveTablesPath" + return $ V1LMDB flush lmdbPath mapSize + "V2InMemory" -> return V2InMemory + _ -> fail $ "Malformed LedgerDB Backend: " <> backend + pure $ Just $ LedgerDbConfiguration snapNum snapInterval qsize selector doChecksum + ) vv + parseByronProtocol v = do primary <- v .:? "ByronGenesisFile" secondary <- v .:? "GenesisFile" @@ -553,9 +583,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 - , pncDoDiskSnapshotChecksum = Last $ Just DoDiskSnapshotChecksum , pncExperimentalProtocolsEnabled = Last $ Just False , pncTopologyFile = Last . Just $ TopologyFile "configuration/cardano/mainnet-topology.json" , pncProtocolFiles = mempty @@ -569,6 +596,14 @@ defaultPartialNodeConfiguration = , pncTraceConfig = mempty , pncTraceForwardSocket = mempty , pncMaybeMempoolCapacityOverride = mempty + , pncLedgerDbConfig = + Last $ Just $ + LedgerDbConfiguration + DefaultNumOfDiskSnapshots + DefaultSnapshotInterval + DefaultQueryBatchSize + V2InMemory + DoDiskSnapshotChecksum , pncProtocolIdleTimeout = Last (Just 5) , pncTimeWaitTimeout = Last (Just 60) , pncAcceptedConnectionsLimit = @@ -627,9 +662,6 @@ makeNodeConfiguration pnc = do logMetrics <- lastToEither "Missing LogMetrics" $ pncLogMetrics pnc traceConfig <- first Text.unpack $ partialTraceSelectionToEither $ pncTraceConfig pnc diffusionMode <- lastToEither "Missing DiffusionMode" $ pncDiffusionMode pnc - numOfDiskSnapshots <- lastToEither "Missing NumOfDiskSnapshots" $ pncNumOfDiskSnapshots pnc - snapshotInterval <- lastToEither "Missing SnapshotInterval" $ pncSnapshotInterval pnc - doDiskSnapshotChecksum <- lastToEither "Missing DoDiskSnapshotChecksum" $ pncDoDiskSnapshotChecksum pnc shutdownConfig <- lastToEither "Missing ShutdownConfig" $ pncShutdownConfig pnc socketConfig <- lastToEither "Missing SocketConfig" $ pncSocketConfig pnc @@ -672,6 +704,9 @@ makeNodeConfiguration pnc = do ncConsensusMode <- lastToEither "Missing ConsensusMode" $ pncConsensusMode pnc + ncLedgerDbConfig <- + lastToEither "Missing LedgerDb config" + $ pncLedgerDbConfig pnc ncProtocolIdleTimeout <- lastToEither "Missing ProtocolIdleTimeout" $ pncProtocolIdleTimeout pnc @@ -723,9 +758,6 @@ makeNodeConfiguration pnc = do , ncProtocolConfig = protocolConfig , ncSocketConfig = socketConfig , ncDiffusionMode = diffusionMode - , ncNumOfDiskSnapshots = numOfDiskSnapshots - , ncSnapshotInterval = snapshotInterval - , ncDoDiskSnapshotChecksum = doDiskSnapshotChecksum , ncExperimentalProtocolsEnabled = experimentalProtocols , ncMaxConcurrencyBulkSync = getLast $ pncMaxConcurrencyBulkSync pnc , ncMaxConcurrencyDeadline = getLast $ pncMaxConcurrencyDeadline pnc @@ -735,6 +767,7 @@ makeNodeConfiguration pnc = do else TracingOff , ncTraceForwardSocket = getLast $ pncTraceForwardSocket pnc , ncMaybeMempoolCapacityOverride = getLast $ pncMaybeMempoolCapacityOverride pnc + , ncLedgerDbConfig , ncProtocolIdleTimeout , ncTimeWaitTimeout , ncChainSyncIdleTimeout diff --git a/cardano-node/src/Cardano/Node/Orphans.hs b/cardano-node/src/Cardano/Node/Orphans.hs index 6d30abd0211..9b1c747fa60 100644 --- a/cardano-node/src/Cardano/Node/Orphans.hs +++ b/cardano-node/src/Cardano/Node/Orphans.hs @@ -12,7 +12,7 @@ import Cardano.Api () import Ouroboros.Consensus.Node import Ouroboros.Consensus.Node.Genesis (GenesisConfigFlags (..)) -import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (Flag (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (Flag(..)) import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index 2378ad91855..7bbc758ed47 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -22,14 +22,11 @@ import Cardano.Node.Types import Cardano.Prelude (ConvertText (..)) import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Node -import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (NumOfDiskSnapshots (..), - SnapshotInterval (..)) import Data.Foldable import Data.Maybe (fromMaybe) import Data.Monoid (Last (..)) import Data.Text (Text) -import Data.Time.Clock (secondsToDiffTime) import Data.Word (Word32) import Options.Applicative hiding (str) import qualified Options.Applicative as Opt @@ -75,8 +72,6 @@ nodeRunParser = do shutdownOnLimit <- lastOption parseShutdownOn -- Hidden options (to be removed eventually) - numOfDiskSnapshots <- lastOption parseNumOfDiskSnapshots - snapshotInterval <- lastOption parseSnapshotInterval maybeMempoolCapacityOverride <- lastOption parseMempoolCapacityOverride pure $ PartialNodeConfiguration @@ -90,9 +85,6 @@ nodeRunParser = do , pncTopologyFile = TopologyFile <$> topFp , pncDatabaseFile = dbFp , pncDiffusionMode = mempty - , pncNumOfDiskSnapshots = numOfDiskSnapshots - , pncSnapshotInterval = snapshotInterval - , pncDoDiskSnapshotChecksum = mempty , pncExperimentalProtocolsEnabled = mempty , pncProtocolFiles = Last $ Just ProtocolFilepaths { byronCertFile @@ -114,6 +106,7 @@ nodeRunParser = do , pncTraceConfig = mempty , pncTraceForwardSocket = traceForwardSocket , pncMaybeMempoolCapacityOverride = maybeMempoolCapacityOverride + , pncLedgerDbConfig = mempty , pncProtocolIdleTimeout = mempty , pncTimeWaitTimeout = mempty , pncChainSyncIdleTimeout = mempty @@ -232,7 +225,6 @@ parseMempoolCapacityOverride = parseOverride <|> parseNoOverride <> help "[DEPRECATED: Set it in config file] Don't override mempool capacity" ) - parseNodeDatabasePaths :: Parser NodeDatabasePaths parseNodeDatabasePaths = parseDbPath <|> parseMultipleDbPaths @@ -366,25 +358,6 @@ parseStartAsNonProducingNode = ] ] -parseNumOfDiskSnapshots :: Parser NumOfDiskSnapshots -parseNumOfDiskSnapshots = fmap RequestedNumOfDiskSnapshots parseNum - where - parseNum = Opt.option auto - ( long "num-of-disk-snapshots" - <> metavar "NUMOFDISKSNAPSHOTS" - <> help "[DEPRECATED: Set it in config file with key NumOfDiskSnapshots] Number of ledger snapshots stored on disk." - ) - --- TODO revisit because it sucks -parseSnapshotInterval :: Parser SnapshotInterval -parseSnapshotInterval = fmap (RequestedSnapshotInterval . secondsToDiffTime) parseDifftime - where - parseDifftime = Opt.option auto - ( long "snapshot-interval" - <> metavar "SNAPSHOTINTERVAL" - <> help "[DEPRECATED: Set it in config file with key SnapshotInterval] Snapshot Interval (in seconds)" - ) - -- | 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 7ed7de1f277..b25632778ba 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -10,6 +10,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-} @@ -33,6 +34,7 @@ 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 @@ -64,12 +66,16 @@ 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 (DiskPolicyArgs (..), pattern DoDiskSnapshotChecksum, pattern NoDoDiskSnapshotChecksum, NetworkP2PMode (..), - NodeDatabasePaths (..), RunNodeArgs (..), StdRunNodeArgs (..)) +import Ouroboros.Consensus.Node (NetworkP2PMode (..), RunNodeArgs (..), + SnapshotPolicyArgs (..), StdRunNodeArgs (..)) import qualified Ouroboros.Consensus.Node as Node (NodeDatabasePaths (..), getChainDB, run) import Ouroboros.Consensus.Node.Genesis import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo +import qualified Ouroboros.Consensus.Node.Tracers as Consensus +import qualified Ouroboros.Consensus.Storage.LedgerDB.Args as LDBArgs +import Ouroboros.Consensus.Storage.LedgerDB.V2.Args +import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.Orphans () import qualified Ouroboros.Network.Diffusion as Diffusion import qualified Ouroboros.Network.Diffusion.Configuration as Configuration @@ -106,6 +112,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Monoid (Last (..)) import Data.Proxy (Proxy (..)) +import Data.SOP.Dict import Data.Text (Text, breakOn, pack) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -125,8 +132,8 @@ import System.Posix.Types (FileMode) #else import System.Win32.File #endif -import Paths_cardano_node (version) +import Paths_cardano_node (version) {- HLINT ignore "Fuse concatMap/map" -} {- HLINT ignore "Redundant <$>" -} @@ -518,7 +525,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 @@ -528,6 +534,9 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , srnTraceChainDB = chainDBTracer tracers , srnMaybeMempoolCapacityOverride = ncMaybeMempoolCapacityOverride nc , srnChainSyncTimeout = customizeChainSyncTimeout + , srnSnapshotPolicyArgs = snapshotPolicyArgs + , srnQueryBatchSize = queryBatchSize + , srnLdbFlavorArgs = selectorToArgs ldbBackend } DisabledP2PMode -> do nt <- TopologyNonP2P.readTopologyFileOrError nc @@ -589,19 +598,21 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do rnNodeKernelHook nodeArgs registry nodeKernel } StdRunNodeArgs - { srnBfcMaxConcurrencyBulkSync = unMaxConcurrencyBulkSync <$> ncMaxConcurrencyBulkSync nc - , srnBfcMaxConcurrencyDeadline = unMaxConcurrencyDeadline <$> ncMaxConcurrencyDeadline nc - , srnChainDbValidateOverride = ncValidateDB nc - , srnDiskPolicyArgs = diskPolicyArgs - , srnDatabasePath = dbPath - , srnDiffusionArguments = diffusionArguments - , srnDiffusionArgumentsExtra = mkNonP2PArguments ipProducers dnsProducers - , srnDiffusionTracers = diffusionTracers tracers - , srnDiffusionTracersExtra = diffusionTracersExtra tracers - , srnEnableInDevelopmentVersions = ncExperimentalProtocolsEnabled nc - , srnTraceChainDB = chainDBTracer tracers - , srnChainSyncTimeout = customizeChainSyncTimeout + { srnBfcMaxConcurrencyBulkSync = unMaxConcurrencyBulkSync <$> ncMaxConcurrencyBulkSync nc + , srnBfcMaxConcurrencyDeadline = unMaxConcurrencyDeadline <$> ncMaxConcurrencyDeadline nc + , srnChainDbValidateOverride = ncValidateDB nc + , srnDatabasePath = dbPath + , srnDiffusionArguments = diffusionArguments + , srnDiffusionArgumentsExtra = mkNonP2PArguments ipProducers dnsProducers + , srnDiffusionTracers = diffusionTracers tracers + , srnDiffusionTracersExtra = diffusionTracersExtra tracers + , srnEnableInDevelopmentVersions = ncExperimentalProtocolsEnabled nc + , srnTraceChainDB = chainDBTracer tracers + , srnChainSyncTimeout = customizeChainSyncTimeout , srnMaybeMempoolCapacityOverride = ncMaybeMempoolCapacityOverride nc + , srnSnapshotPolicyArgs = snapshotPolicyArgs + , srnQueryBatchSize = queryBatchSize + , srnLdbFlavorArgs = selectorToArgs ldbBackend } where @@ -661,12 +672,10 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do Nothing -> id Just version_ -> Map.takeWhileAntitone (<= version_) - diskPolicyArgs :: DiskPolicyArgs - diskPolicyArgs = - DiskPolicyArgs - (ncSnapshotInterval nc) - (ncNumOfDiskSnapshots nc) - (ncDoDiskSnapshotChecksum nc) + LedgerDbConfiguration snapInterval numSnaps queryBatchSize ldbBackend doChecksum = ncLedgerDbConfig nc + + snapshotPolicyArgs :: SnapshotPolicyArgs + snapshotPolicyArgs = SnapshotPolicyArgs numSnaps snapInterval doChecksum -------------------------------------------------------------------------------- -- SIGHUP Handlers @@ -826,21 +835,20 @@ updateLedgerPeerSnapshot startupTracer readLedgerPeerPath writeVar = do -- Helper functions -------------------------------------------------------------------------------- -canonDbPath :: NodeConfiguration -> IO NodeDatabasePaths +canonDbPath :: NodeConfiguration -> IO Node.NodeDatabasePaths canonDbPath NodeConfiguration{ncDatabaseFile = nodeDatabaseFps} = case nodeDatabaseFps of - OnePathForAllDbs dbFp -> do + Node.OnePathForAllDbs dbFp -> do fp <- canonicalizePath =<< makeAbsolute dbFp createDirectoryIfMissing True fp - return $ OnePathForAllDbs fp + return $ Node.OnePathForAllDbs fp - MultipleDbPaths immutable volatile -> do + Node.MultipleDbPaths immutable volatile -> do canonImmutable <- canonicalizePath =<< makeAbsolute immutable canonVolatile <- canonicalizePath =<< makeAbsolute volatile createDirectoryIfMissing True canonImmutable createDirectoryIfMissing True canonVolatile - return $ MultipleDbPaths canonImmutable canonVolatile - + return $ Node.MultipleDbPaths canonImmutable canonVolatile -- | 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 dca8cd1932a..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 (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 _ (LgrDb.ReplayStart rs) (LgrDb.ReplayGoal rp) -> - traceWith tr $ NodeReplays $ ReplayFromSnapshot (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 171b7daaf3c..2cef74af8f0 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -132,8 +132,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 61f2850a1e9..c3c80f91618 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 fe32e91f5a3..587d668e521 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -33,13 +33,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 (ReplayStart (..), - UpdateLedgerDbTraceEvent (..)) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 import qualified Ouroboros.Consensus.Storage.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 qualified Data.ByteString.Base16 as B16 @@ -92,8 +94,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 forHuman (ChainDB.TraceChainSelStarvationEvent ev) = case ev of @@ -124,9 +125,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 @@ -142,10 +141,9 @@ 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.TraceImmutableDBEvent v) = asMetrics v - asMetrics (ChainDB.TraceVolatileDBEvent v) = asMetrics v + asMetrics (ChainDB.TraceLedgerDBEvent v) = asMetrics v + asMetrics (ChainDB.TraceImmutableDBEvent v) = asMetrics v + asMetrics (ChainDB.TraceVolatileDBEvent v) = asMetrics v instance MetaTrace (ChainDB.TraceEvent blk) where @@ -167,10 +165,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) = @@ -206,14 +202,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.TraceEvent blk)) Nothing severityFor (Namespace out ("ImmDbEvent" : tl)) (Just (ChainDB.TraceImmutableDBEvent ev')) = severityFor (Namespace out tl) (Just ev') severityFor (Namespace out ("ImmDbEvent" : tl)) Nothing = @@ -254,14 +246,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.TraceEvent blk)) Nothing privacyFor (Namespace out ("ImmDbEvent" : tl)) (Just (ChainDB.TraceImmutableDBEvent ev')) = privacyFor (Namespace out tl) (Just ev') privacyFor (Namespace out ("ImmDbEvent" : tl)) Nothing = @@ -302,14 +290,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.TraceEvent blk)) Nothing detailsFor (Namespace out ("ImmDbEvent" : tl)) (Just (ChainDB.TraceImmutableDBEvent ev')) = detailsFor (Namespace out tl) (Just ev') detailsFor (Namespace out ("ImmDbEvent" : tl)) Nothing = @@ -335,9 +319,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.TraceEvent blk)) metricsDocFor (Namespace out ("ImmDbEvent" : tl)) = metricsDocFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) metricsDocFor (Namespace out ("VolatileDbEvent" : tl)) = @@ -368,9 +350,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.TraceEvent blk)) documentFor (Namespace out ("ImmDbEvent" : tl)) = documentFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) documentFor (Namespace out ("VolatileDbEvent" : tl)) = @@ -395,9 +375,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.TraceEvent blk)]) ++ map (nsPrependInner "ImmDbEvent") (allNamespaces :: [Namespace (ImmDB.TraceEvent blk)]) ++ map (nsPrependInner "VolatileDbEvent") @@ -1165,7 +1143,7 @@ instance ( LedgerSupportsProtocol blk forHuman (ChainDB.ValidCandidate c) = "Valid candidate " <> renderPointAsPhrase (AF.headPoint c) forHuman (ChainDB.UpdateLedgerDbTraceEvent - (StartedPushingBlockToTheLedgerDb + (LedgerDB.StartedPushingBlockToTheLedgerDb (LedgerDB.PushStart start) (LedgerDB.PushGoal goal) (LedgerDB.Pushing curr))) = @@ -1186,7 +1164,7 @@ instance ( LedgerSupportsProtocol blk mconcat [ "kind" .= String "ValidCandidate" , "block" .= renderPointForDetails dtal (AF.headPoint c) ] forMachine _dtal (ChainDB.UpdateLedgerDbTraceEvent - (StartedPushingBlockToTheLedgerDb + (LedgerDB.StartedPushingBlockToTheLedgerDb (LedgerDB.PushStart start) (LedgerDB.PushGoal goal) (LedgerDB.Pushing curr))) = @@ -1241,8 +1219,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" @@ -1317,13 +1296,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 = @@ -1536,9 +1515,72 @@ instance MetaTrace (ChainDB.UnknownRange blk) where ] -- -------------------------------------------------------------------------------- --- -- LedgerDB.TraceSnapshotEvent +-- -- LedgerDB.TraceEvent -- -------------------------------------------------------------------------------- +instance ( StandardHash blk + , ConvertRawHash blk) + => LogFormatting (LedgerDB.TraceEvent 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.TraceEvent 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 @@ -1577,18 +1619,19 @@ instance ( StandardHash blk mconcat [ "kind" .= String "TookSnapshot" , "snapshot" .= forMachine dtals snap , "tip" .= show pt - , "enclosedTime" .= enclosedTiming] + , "enclosedTime" .= enclosedTiming + ] forMachine dtals (LedgerDB.DeletedSnapshot snap) = mconcat [ "kind" .= String "DeletedSnapshot" , "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 ] forMachine dtals (LedgerDB.SnapshotMissingChecksum snap) = mconcat [ "kind" .= String "SnapshotMissingChecksum" - , "snapshot" .= forMachine dtals snap - ] + , "snapshot" .= forMachine dtals snap + ] instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where namespaceFor LedgerDB.TookSnapshot {} = Namespace [] ["TookSnapshot"] @@ -1622,18 +1665,36 @@ instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where , Namespace [] ["SnapshotMissingChecksum"] ] - -------------------------------------------------------------------------------- -- LedgerDB TraceReplayEvent -------------------------------------------------------------------------------- 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 (ReplayStart tip') _goal) = - "Replaying ledger from snapshot " <> showT snap <> " at " - <> renderPointAsPhrase tip' + forHuman (LedgerDB.ReplayFromSnapshot snap (LedgerDB.ReplayStart tip')) = + "Replaying ledger from snapshot " <> showT snap <> " at " <> + 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 @@ -1653,12 +1714,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 @@ -1669,13 +1724,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 @@ -1690,6 +1771,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." @@ -1701,11 +1795,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 7fd49d4a615..2b4b9414a22 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -1272,6 +1272,7 @@ instance , LogFormatting (GenTx blk) , ToJSON (GenTxId blk) , LedgerSupportsMempool blk + , ConvertRawHash blk ) => LogFormatting (TraceEventMempool blk) where forMachine dtal (TraceMempoolAddedTx tx _mpSzBefore mpSzAfter) = mconcat @@ -1311,6 +1312,26 @@ instance , "txsInvalidated" .= map (forMachine dtal . txForgetValidated) txs1 , "mempoolSize" .= forMachine dtal mpSz ] + forMachine dtal (TraceMempoolSyncNotNeeded t) = + mconcat + [ "kind" .= String "TraceMempoolSyncNotNeeded" + , "tip" .= forMachine dtal t + ] + 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 + ] forMachine _dtal (TraceMempoolSynced et) = mconcat @@ -1340,6 +1361,10 @@ instance ] asMetrics (TraceMempoolSynced RisingEdge) = [] + asMetrics TraceMempoolSyncNotNeeded {} = [] + asMetrics TraceMempoolAttemptingAdd {} = [] + asMetrics TraceMempoolLedgerFound {} = [] + asMetrics TraceMempoolLedgerNotFound {} = [] instance LogFormatting MempoolSize where forMachine _dtal MempoolSize{msNumTxs, msNumBytes} = @@ -1355,12 +1380,20 @@ instance MetaTrace (TraceEventMempool blk) where namespaceFor TraceMempoolRemoveTxs {} = Namespace [] ["RemoveTxs"] namespaceFor TraceMempoolManuallyRemovedTxs {} = Namespace [] ["ManuallyRemovedTxs"] namespaceFor TraceMempoolSynced {} = Namespace [] ["Synced"] + namespaceFor TraceMempoolSyncNotNeeded {} = Namespace [] ["SyncNotNeeded"] + namespaceFor TraceMempoolAttemptingAdd {} = Namespace [] ["AttemptAdd"] + namespaceFor TraceMempoolLedgerFound {} = Namespace [] ["LedgerFound"] + namespaceFor TraceMempoolLedgerNotFound {} = Namespace [] ["LedgerNotFound"] severityFor (Namespace _ ["AddedTx"]) _ = Just Info severityFor (Namespace _ ["RejectedTx"]) _ = Just Info severityFor (Namespace _ ["RemoveTxs"]) _ = Just Info - severityFor (Namespace _ ["ManuallyRemovedTxs"]) _ = Just Info severityFor (Namespace _ ["Synced"]) _ = Just Debug + severityFor (Namespace _ ["ManuallyRemovedTxs"]) _ = Just Warning + severityFor (Namespace _ ["SyncNotNeeded"]) _ = Just Debug + severityFor (Namespace _ ["AttemptAdd"]) _ = Just Debug + severityFor (Namespace _ ["LedgerFound"]) _ = Just Debug + severityFor (Namespace _ ["LedgerNotFound"]) _ = Just Debug severityFor _ _ = Nothing metricsDocFor (Namespace _ ["AddedTx"]) = @@ -1388,7 +1421,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 @@ -1398,6 +1431,18 @@ instance MetaTrace (TraceEventMempool blk) where ] documentFor (Namespace _ ["ManuallyRemovedTxs"]) = Just "Transactions that have been manually removed from the Mempool." + documentFor (Namespace _ ["SyncNotNeeded"]) = Just + "The mempool and the LedgerDB are in sync already." + documentFor (Namespace _ ["Synced"]) = Just + "The mempool and the LedgerDB are syncing or in sync depending on the enclosed time." + documentFor (Namespace _ ["AttemptAdd"]) = Just + "Mempool is about to try to validate and add a transaction." + documentFor (Namespace _ ["LedgerNotFound"]) = Just $ mconcat + [ "Ledger state requested by the mempool no longer in LedgerDB." + , " Will have to re-sync." + ] + documentFor (Namespace _ ["LedgerFound"]) = Just + "Ledger state requested by the mempool is in the LedgerDB." documentFor _ = Nothing allNamespaces = @@ -1406,6 +1451,10 @@ instance MetaTrace (TraceEventMempool blk) where , Namespace [] ["RemoveTxs"] , Namespace [] ["ManuallyRemovedTxs"] , Namespace [] ["Synced"] + , Namespace [] ["SyncNotNeeded"] + , Namespace [] ["AttemptAdd"] + , Namespace [] ["LedgerNotFound"] + , Namespace [] ["LedgerFound"] ] -------------------------------------------------------------------------------- diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs index 0c7964cc834..20c8ad4d86c 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs @@ -39,6 +39,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 =<<" -} @@ -50,7 +51,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 a978a468003..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 () diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs index b3d5bb810a9..5821d02b5e2 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.Forker 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 b50a3543416..c788a6c46ef 100644 --- a/cardano-node/src/Cardano/Tracing/Config.hs +++ b/cardano-node/src/Cardano/Tracing/Config.hs @@ -161,6 +161,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) @@ -238,6 +239,7 @@ data TraceSelection , traceLocalTxSubmissionProtocol :: OnOff TraceLocalTxSubmissionProtocol , traceLocalTxSubmissionServer :: OnOff TraceLocalTxSubmissionServer , traceMempool :: OnOff TraceMempool + , traceBackingStore :: OnOff TraceBackingStore , traceMux :: OnOff TraceMux , tracePeerSelection :: OnOff TracePeerSelection , tracePeerSelectionCounters :: OnOff TracePeerSelectionCounters @@ -305,6 +307,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) @@ -373,6 +376,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 @@ -438,6 +442,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 @@ -505,6 +510,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 @@ -565,6 +571,7 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio , traceLocalTxSubmissionProtocol = traceLocalTxSubmissionProtocol , traceLocalTxSubmissionServer = traceLocalTxSubmissionServer , traceMempool = traceMempool + , traceBackingStore = traceBackingStore , traceMux = traceMux , tracePeerSelection = tracePeerSelection , tracePeerSelectionCounters = tracePeerSelectionCounters @@ -629,6 +636,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 @@ -689,6 +697,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 219ff94cf73..d0db5ed1a4f 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs @@ -21,6 +21,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 @@ -66,9 +67,9 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmDB import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (ChunkNo (..), chunkNoToInt) import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB -import Ouroboros.Consensus.Storage.LedgerDB (PushGoal (..), PushStart (..), Pushing (..), - ReplayStart (..)) +import Ouroboros.Consensus.Storage.LedgerDB (PushGoal (..), PushStart (..), Pushing (..)) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl as VolDb import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Enclose @@ -164,17 +165,15 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where ChainDB.PoppedReprocessLoEBlocksFromQueue -> Debug 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 - LedgerDB.SnapshotMissingChecksum {} -> Warning + getSeverityAnnotation (ChainDB.TraceLedgerDBEvent ev) = case ev of + LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of + LedgerDB.TookSnapshot {} -> Info + LedgerDB.DeletedSnapshot {} -> Debug + LedgerDB.InvalidSnapshot {} -> Error + LedgerDB.SnapshotMissingChecksum {} -> Warning + LedgerDB.LedgerReplayEvent {} -> Info + LedgerDB.LedgerDBForkerEvent {} -> Debug + LedgerDB.LedgerDBFlavorImplEvent {} -> Debug getSeverityAnnotation (ChainDB.TraceCopyToImmutableDBEvent ev) = case ev of ChainDB.CopiedBlockToImmutableDB {} -> Debug @@ -281,7 +280,15 @@ 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 TraceMempoolSyncNotNeeded{} = Debug + getSeverityAnnotation TraceMempoolSynced{} = Debug + getSeverityAnnotation TraceMempoolAttemptingAdd{} = Debug + getSeverityAnnotation TraceMempoolLedgerFound{} = Debug + getSeverityAnnotation TraceMempoolLedgerNotFound{} = Debug instance HasPrivacyAnnotation () instance HasSeverityAnnotation () where @@ -360,7 +367,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 @@ -555,7 +563,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.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> let fromSlot = unSlotNo $ realPointSlot start atSlot = unSlotNo $ realPointSlot curr @@ -575,47 +583,52 @@ 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 _ (ReplayStart tip') _goal -> - "Replaying ledger from snapshot at " <> - renderPointAsPhrase 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 <> context - where - context = case failure of - LedgerDB.InitFailureRead{} -> - " This is most likely an expected change in the serialization format," - <> " which currently requires a chain replay" - _ -> "" - LedgerDB.SnapshotMissingChecksum snap -> - "Checksum file is missing for snapshot " <> showT snap - - LedgerDB.TookSnapshot snap pt RisingEdge -> - "Taking ledger snapshot " <> showT snap <> - " at " <> renderRealPointAsPhrase pt - LedgerDB.TookSnapshot snap pt (FallingEdgeWith t) -> - "Took ledger snapshot " <> showT snap <> - " at " <> renderRealPointAsPhrase pt <> - ", duration: " <> showT t - 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 <> context + where + context = case failure of + LedgerDB.InitFailureRead{} -> + " This is most likely an expected change in the serialization format," + <> " which currently requires a chain replay" + _ -> "" + LedgerDB.TookSnapshot snap pt RisingEdge -> + "Taking ledger snapshot " <> showT snap <> + " at " <> renderRealPointAsPhrase pt + LedgerDB.TookSnapshot snap pt (FallingEdgeWith t) -> + "Took ledger snapshot " <> showT snap <> + " at " <> renderRealPointAsPhrase pt <> + ", duration: " <> showT t + LedgerDB.DeletedSnapshot snap -> + "Deleted old snapshot " <> showT snap + LedgerDB.SnapshotMissingChecksum snap -> + "Checksum file is missing for 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" @@ -640,8 +653,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" @@ -653,7 +667,7 @@ 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.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> let fromSlot = unSlotNo $ realPointSlot start atSlot = unSlotNo $ realPointSlot curr @@ -1032,39 +1046,45 @@ 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 -> - 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 enclosedTiming -> - mconcat [ "kind" .= String "TraceSnapshotEvent.TookSnapshot" - , "snapshot" .= toObject verb snap - , "tip" .= show pt - , "enclosedTime" .= enclosedTiming - ] - 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 ] - LedgerDB.SnapshotMissingChecksum snap -> - mconcat [ "kind" .= String "TraceSnapshotEvent.SnapshotMissingChecksum" - , "snapshot" .= toObject verb snap - ] - + 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 enclosedTiming -> + mconcat [ "kind" .= String "TraceSnapshotEvent.TookSnapshot" + , "snapshot" .= toObject verb snap + , "tip" .= show pt + , "enclosedTime" .= enclosedTiming + ] + 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.SnapshotMissingChecksum snap -> + mconcat [ "kind" .= String "TraceSnapshotEvent.SnapshotMissingChecksum" + , "snapshot" .= toObject verb snap + ] + 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" @@ -1449,7 +1469,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 @@ -1494,6 +1515,26 @@ instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk), [ "kind" .= String "TraceMempoolSynced" , "enclosingTime" .= et ] + toObject verb (TraceMempoolSyncNotNeeded t) = + mconcat + [ "kind" .= String "TraceMempoolSyncNotNeeded" + , "tip" .= toObject verb t + ] + 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 5c1207df009..9d38e744723 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -685,7 +685,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 @@ -696,7 +696,7 @@ instance (ToObject localPeer) instance ( HasPrivacyAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f) , HasSeverityAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f) - , LocalStateQuery.ShowQuery (BlockQuery blk), ToObject localPeer) + , forall fp. LocalStateQuery.ShowQuery (BlockQuery blk fp), ToObject localPeer) => Transformable Text IO (TraceLabelPeer localPeer (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f)) where trTransformer = trStructured diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index edcdfab451c..d1c497140c0 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -204,16 +204,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 @@ -233,6 +225,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 @@ -245,7 +252,13 @@ 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 @@ -277,7 +290,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 @@ -292,7 +311,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 @@ -856,11 +877,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 @@ -1271,6 +1292,7 @@ mempoolMetricsTraceTransformer tr = Tracer $ \mempoolEvent -> do TraceMempoolRemoveTxs txs0 tot0 -> (length txs0, Just tot0) TraceMempoolManuallyRemovedTxs txs0 txs1 tot0 -> ( length txs0 + length txs1, Just tot0) TraceMempoolSynced _ -> (0, Nothing) + _ -> (0, Nothing) case tot_m of Just tot -> do let logValue1 :: LOContent a @@ -1287,6 +1309,7 @@ mempoolTracer , ToObject (ApplyTxErr blk) , ToObject (GenTx blk) , LedgerSupportsMempool blk + , ConvertRawHash blk ) => TraceSelection -> Trace IO Text @@ -1301,6 +1324,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) @@ -1397,7 +1421,7 @@ nodeToClientTracers' ( HasPrivacyAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State) , HasSeverityAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State) , ToObject (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State) - , ShowQuery (BlockQuery blk) + , forall fp. ShowQuery (BlockQuery blk fp) , ToObject localPeer ) => TraceSelection diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index 106bbc7d241..dd1227bbd64 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -7,6 +7,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 @@ -16,14 +17,14 @@ import Cardano.Tracing.Config (PartialTraceOptions (..), defaultPartia import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) import Ouroboros.Consensus.Node.Genesis (disableGenesisConfig) -import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (NumOfDiskSnapshots (..), +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..), SnapshotInterval (..), pattern DoDiskSnapshotChecksum) +import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.Diffusion.Configuration import Data.Monoid (Last (..)) import Data.Text (Text) -import Data.Time.Clock (secondsToDiffTime) import Hedgehog (Property, discover, withTests, (===)) import qualified Hedgehog @@ -117,9 +118,6 @@ testPartialYamlConfig = , pncShutdownConfig = Last Nothing , pncStartAsNonProducingNode = Last $ Just False , pncDiffusionMode = Last Nothing - , pncNumOfDiskSnapshots = Last Nothing - , pncSnapshotInterval = mempty - , pncDoDiskSnapshotChecksum = Last . Just $ DoDiskSnapshotChecksum , pncExperimentalProtocolsEnabled = Last Nothing , pncMaxConcurrencyBulkSync = Last Nothing , pncMaxConcurrencyDeadline = Last Nothing @@ -153,6 +151,7 @@ testPartialYamlConfig = , pncPeerSharing = Last (Just PeerSharingDisabled) , pncConsensusMode = mempty , pncGenesisConfigFlags = mempty + , pncLedgerDbConfig = mempty } -- | Example partial configuration theoretically created @@ -167,9 +166,6 @@ testPartialCliConfig = , pncTopologyFile = mempty , pncDatabaseFile = mempty , pncDiffusionMode = mempty - , pncNumOfDiskSnapshots = Last Nothing - , pncSnapshotInterval = Last . Just . RequestedSnapshotInterval $ secondsToDiffTime 100 - , pncDoDiskSnapshotChecksum = Last . Just $ DoDiskSnapshotChecksum , pncExperimentalProtocolsEnabled = Last $ Just True , pncProtocolFiles = Last . Just $ ProtocolFilepaths Nothing Nothing Nothing Nothing Nothing Nothing , pncValidateDB = Last $ Just True @@ -201,6 +197,7 @@ testPartialCliConfig = , pncPeerSharing = Last (Just PeerSharingDisabled) , pncConsensusMode = Last (Just PraosMode) , pncGenesisConfigFlags = mempty + , pncLedgerDbConfig = mempty } -- | Expected final NodeConfiguration @@ -219,9 +216,6 @@ eExpectedConfig = do , ncValidateDB = True , ncProtocolConfig = testNodeProtocolConfiguration , ncDiffusionMode = InitiatorAndResponderDiffusionMode - , ncNumOfDiskSnapshots = DefaultNumOfDiskSnapshots - , ncSnapshotInterval = RequestedSnapshotInterval $ secondsToDiffTime 100 - , ncDoDiskSnapshotChecksum = DoDiskSnapshotChecksum , ncExperimentalProtocolsEnabled = True , ncMaxConcurrencyBulkSync = Nothing , ncMaxConcurrencyDeadline = Nothing @@ -255,6 +249,7 @@ eExpectedConfig = do , ncPeerSharing = PeerSharingDisabled , ncConsensusMode = PraosMode , ncGenesisConfig = disableGenesisConfig + , ncLedgerDbConfig = LedgerDbConfiguration DefaultNumOfDiskSnapshots DefaultSnapshotInterval DefaultQueryBatchSize V2InMemory DoDiskSnapshotChecksum } -- ----------------------------------------------------------------------------- diff --git a/cardano-testnet/src/Testnet/Components/Query.hs b/cardano-testnet/src/Testnet/Components/Query.hs index 2697b150a81..fe1184ebbd4 100644 --- a/cardano-testnet/src/Testnet/Components/Query.hs +++ b/cardano-testnet/src/Testnet/Components/Query.hs @@ -44,7 +44,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 @@ -53,18 +53,15 @@ import qualified Cardano.Ledger.Conway.Governance as L import qualified Cardano.Ledger.Conway.PParams as L import qualified Cardano.Ledger.Shelley.LedgerState as L import qualified Cardano.Ledger.UMap 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) @@ -276,13 +273,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) @@ -302,20 +299,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 @@ -418,7 +404,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 @@ -464,7 +450,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 = convert ceo Refl <- H.leftFail $ assertErasEqual sbe sbe' pure $ conwayEraOnwardsConstraints ceo $ newEpochState ^. L.newEpochStateGovStateL @@ -478,7 +464,7 @@ getTreasuryValue => EpochStateView -> m L.Coin -- ^ The current value of the treasury getTreasuryValue epochStateView = withFrozenCallStack $ do - AnyNewEpochState _ newEpochState <- getEpochState epochStateView + AnyNewEpochState _ newEpochState _ <- getEpochState epochStateView pure $ newEpochState ^. L.nesEpochStateL . L.epochStateTreasuryL -- | Obtain minimum deposit amount for governance action from node @@ -519,7 +505,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 @@ -564,7 +550,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 @@ -598,7 +584,7 @@ getDelegationState :: (H.MonadAssertion m, MonadTest m, MonadIO m) => EpochStateView -> m (L.StakeCredentials StandardCrypto) getDelegationState epochStateView = do - AnyNewEpochState sbe newEpochState <- getEpochState epochStateView + AnyNewEpochState sbe newEpochState _ <- getEpochState epochStateView let pools = shelleyBasedEraConstraints sbe $ newEpochState ^. L.nesEsL . L.esLStateL @@ -607,4 +593,3 @@ getDelegationState epochStateView = do . L.dsUnifiedL pure $ L.toStakeCredentials pools - diff --git a/cardano-testnet/src/Testnet/EpochStateProcessing.hs b/cardano-testnet/src/Testnet/EpochStateProcessing.hs index 762a543ea96..77208e96c74 100644 --- a/cardano-testnet/src/Testnet/EpochStateProcessing.hs +++ b/cardano-testnet/src/Testnet/EpochStateProcessing.hs @@ -36,7 +36,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 @@ -67,7 +67,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 @@ -84,4 +84,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 aa916d3f30a..c0e42685b97 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 8e3f9b414b5..8b703db1c51 100644 --- a/cardano-testnet/src/Testnet/Runtime.hs +++ b/cardano-testnet/src/Testnet/Runtime.hs @@ -318,7 +318,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, ""] @@ -326,7 +326,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, ""] @@ -360,4 +360,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/Cli/Query.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Query.hs index 3ba4db33f7b..a8e4fcc9546 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Query.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Query.hs @@ -489,7 +489,7 @@ hprop_cli_queries = integrationWorkspace "cli-queries" $ \tempAbsBasePath' -> H. makeStakeAddress (fromNetworkMagic $ NetworkMagic $ fromIntegral testnetMagic) (StakeCredentialByKey $ verificationKeyHash delegatorVKey) getTxIx :: forall m era. HasCallStack => MonadTest m => ShelleyBasedEra era -> String -> Coin -> (AnyNewEpochState, SlotNo, BlockNo) -> m (Maybe Int) - getTxIx sbe txId amount (AnyNewEpochState sbe' newEpochState, _, _) = do + getTxIx sbe txId amount (AnyNewEpochState sbe' newEpochState _, _, _) = do Refl <- H.leftFail $ assertErasEqual sbe sbe' shelleyBasedEraConstraints sbe' (do return $ Map.foldlWithKey (\acc (L.TxIn (L.TxId thisTxId) (L.TxIx thisTxIx)) txOut -> 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 cc60d11aa78..063bb52c13c 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 @@ -295,7 +295,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 c7c7623adb8..e150f328e74 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 @@ -250,7 +250,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 @@ -268,4 +268,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 de60bc4d1cd..a64654d8f6e 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 @@ -261,7 +261,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 06793e3a943..6144c7b4cc3 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 @@ -179,7 +179,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 fb1ab8aaa90..a29bd04b314 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 @@ -77,7 +77,7 @@ prop_check_if_treasury_is_growing = integrationRetryWorkspace 2 "growing-treasur H.assertWith treasury (> 0) 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 @@ -99,4 +99,3 @@ prop_check_if_treasury_is_growing = integrationRetryWorkspace 2 "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 6415f302200..933d9b9d8b3 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 @@ -260,7 +260,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 @@ -288,7 +288,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 a7b4a79289e..9d16e212cdd 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 7a2b023d995..a5ff4eae928 100644 --- a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs +++ b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs @@ -221,29 +221,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 {..} =