cardano-node: Integrate Predictable Ledger State Snapshots

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

@@ -73,8 +73,7 @@ noDeprecatedOptions = DeprecatedOptions []
 
 data LedgerDbConfiguration =
     LedgerDbConfiguration
-      NumOfDiskSnapshots
-      SnapshotInterval
+      SnapshotPolicyArgs
       QueryBatchSize
       LedgerDbSelectorFlag
       DeprecatedOptions

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

@@ -28,6 +28,7 @@ module Cardano.Node.Configuration.POM
 where
 
 import           Cardano.Crypto (RequiresNetworkMagic (..))
+import           Cardano.Ledger.BaseTypes
 import           Cardano.Logging.Types
 import           Cardano.Network.ConsensusMode (ConsensusMode (..), defaultConsensusMode)
 import qualified Cardano.Network.Diffusion.Configuration as Cardano
@@ -46,7 +47,9 @@ import           Ouroboros.Consensus.Node.Genesis (GenesisConfig, GenesisConfigF
                    defaultGenesisConfigFlags, mkGenesisConfig)
 import           Ouroboros.Consensus.Storage.LedgerDB.Args (QueryBatchSize (..))
 import           Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..),
-                   SnapshotInterval (..))
+                   SnapshotDelayRange (..), SnapshotFrequency (..), SnapshotFrequencyArgs (..),
+                   SnapshotPolicyArgs (..), defaultSnapshotPolicyArgs)
+import           Ouroboros.Consensus.Util.Args (OverrideOrDefault (..))
 import           Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..))
 import           Ouroboros.Network.Diffusion.Configuration as Configuration
 import qualified Ouroboros.Network.Diffusion.Configuration as Ouroboros
@@ -484,8 +487,14 @@ instance FromJSON PartialNodeConfiguration where
               Nothing -> return Nothing
 
       parseLedgerDbConfig v = do
-        let snapInterval x = fmap (RequestedSnapshotInterval . secondsToDiffTime) <$> x .:? "SnapshotInterval"
-            snapNum x      = fmap RequestedNumOfDiskSnapshots <$> x .:? "NumOfDiskSnapshots"
+        -- TODO maybe don't silently convert old format (which was in seconds)
+        -- to new format (which is in slots), despite these being the same on
+        -- mainnet?
+        let snapInterval x = do
+              si <- x .:? "SnapshotInterval"
+              when (any (<= 0) si) $ fail $ "Non-positive SnapshotInterval: " <> show si
+              pure $ Override . SlotNo <$> si
+            snapNum x      = fmap (Override . NumOfDiskSnapshots) <$> x .:? "NumOfDiskSnapshots"
 
         mTopLevelSnapInterval <- snapInterval v
         mTopLevelSnapNum <- snapNum v
@@ -499,12 +508,48 @@ instance FromJSON PartialNodeConfiguration where
         mLedgerDB <- v .:? "LedgerDB"
         case mLedgerDB of
            Nothing -> do
-             let si = fromMaybe DefaultSnapshotInterval mTopLevelSnapInterval
-                 sn = fromMaybe DefaultNumOfDiskSnapshots mTopLevelSnapNum
-             return $ Just $ LedgerDbConfiguration sn si DefaultQueryBatchSize V2InMemory deprecatedOpts
+             let si = fromMaybe UseDefault mTopLevelSnapInterval
+                 sn = fromMaybe UseDefault mTopLevelSnapNum
+                 sf = SnapshotFrequencyArgs {
+                     sfaInterval = unsafeNonZero . unSlotNo <$> si
+                   , sfaOffset = UseDefault
+                   , sfaRateLimit = UseDefault
+                   , sfaDelaySnapshotRange = UseDefault
+                   }
+                 spArgs = SnapshotPolicyArgs (SnapshotFrequency sf) sn
+             return $ Just $ LedgerDbConfiguration spArgs DefaultQueryBatchSize V2InMemory deprecatedOpts
            Just ledgerDB -> flip (withObject "LedgerDB") ledgerDB $ \o -> do
-             ldbSnapInterval <- (getLast . (Last mTopLevelSnapInterval <>) . Last <$> snapInterval o) .!= DefaultSnapshotInterval
-             ldbSnapNum      <- (getLast . (Last mTopLevelSnapNum <>) . Last <$> snapNum o)           .!= DefaultNumOfDiskSnapshots
+             -- Parse snapshot options from the "Snapshots" sub-object if present,
+             -- otherwise fall back to the LedgerDB object for backward compatibility.
+             let parseSnapshotOpts s = do
+                   sInterval  <- (getLast . (Last mTopLevelSnapInterval <>) . Last <$> snapInterval s) .!= UseDefault
+                   sNum       <- (getLast . (Last mTopLevelSnapNum <>) . Last <$> snapNum s)           .!= UseDefault
+                   sOffset    <- (fmap Override <$> s .:? "SlotOffset") .!= UseDefault
+                   sRateLimit <- (fmap (Override . secondsToDiffTime) <$> s .:? "RateLimit") .!= UseDefault
+                   sMinDelay  <- s .:? "MinDelay"
+                   sMaxDelay  <- s .:? "MaxDelay"
+                   sDelayRange <-
+                         case (sMinDelay, sMaxDelay) of
+                           (Just minDelay, Just maxDelay) ->
+                             if minDelay <= maxDelay then
+                               pure (Override (SnapshotDelayRange (secondsToDiffTime minDelay) (secondsToDiffTime maxDelay)))
+                             else fail $ "Invalid ledger snapshot delay range, MinDelay > MaxDelay: "
+                                       <> show minDelay <> " > " <> show maxDelay
+                           -- use the default delay range if either min or max is unspecified
+                           _ -> pure UseDefault
+                   let sf = SnapshotFrequencyArgs {
+                           sfaInterval = unsafeNonZero . unSlotNo <$> sInterval
+                         , sfaOffset = sOffset
+                         , sfaRateLimit = sRateLimit
+                         , sfaDelaySnapshotRange = sDelayRange
+                         }
+                   pure $ SnapshotPolicyArgs (SnapshotFrequency sf) sNum
+
+             mSnapshotsVal <- o .:? "Snapshots"
+             spArgs <- case mSnapshotsVal of
+               Nothing -> parseSnapshotOpts o
+               Just sv -> flip (withObject "Snapshots") sv parseSnapshotOpts
+
              qsize           <- (fmap RequestedQueryBatchSize <$> o .:? "QueryBatchSize") .!= DefaultQueryBatchSize
              backend         <- o .:? "Backend" .!= "V2InMemory"
              selector        <- case backend of
@@ -519,7 +564,7 @@ instance FromJSON PartialNodeConfiguration where
                  lsmPath :: Maybe FilePath <- o .:? "LSMDatabasePath"
                  pure $ V2LSM lsmPath
                _ -> fail $ "Malformed LedgerDB Backend: " <> backend
-             pure $ Just $ LedgerDbConfiguration ldbSnapNum ldbSnapInterval qsize selector deprecatedOpts
+             pure $ Just $ LedgerDbConfiguration spArgs qsize selector deprecatedOpts
 
       parseByronProtocol v = do
         primary   <- v .:? "ByronGenesisFile"
@@ -683,8 +728,7 @@ defaultPartialNodeConfiguration =
     , pncLedgerDbConfig =
         Last $ Just $
           LedgerDbConfiguration
-            DefaultNumOfDiskSnapshots
-            DefaultSnapshotInterval
+            defaultSnapshotPolicyArgs
             DefaultQueryBatchSize
             V2InMemory
             noDeprecatedOptions

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

@@ -561,15 +561,11 @@ handleSimpleNode blockType runP tracers nc networkMagic onKernel = do
         Just version_ -> Map.takeWhileAntitone (<= version_)
 
   LedgerDbConfiguration
-    snapInterval
-    numSnaps
+    snapshotPolicyArgs
     queryBatchSize
     ldbBackend
     deprecatedOpts = ncLedgerDbConfig nc
 
-  snapshotPolicyArgs :: SnapshotPolicyArgs
-  snapshotPolicyArgs = SnapshotPolicyArgs numSnaps snapInterval
-
 --------------------------------------------------------------------------------
 -- SIGHUP Handlers
 --------------------------------------------------------------------------------

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

@@ -60,6 +60,7 @@ import           Ouroboros.Network.Block (MaxSlotNo (..))
 import           Data.Aeson (Object, ToJSON, Value (Object, String), object, toJSON, (.=))
 import qualified Data.ByteString.Base16 as B16
 import           Data.Int (Int64)
+import qualified Data.List.NonEmpty as NonEmpty
 import           Data.SOP (All, K (..), hcmap, hcollapse)
 import           Data.Text (Text)
 import qualified Data.Text as Text
@@ -1772,6 +1773,14 @@ instance ( StandardHash blk
           LedgerDB.MetadataBackendMismatch ->
              " Snapshot was created for a different backend. Convert it with `snapshot-converter`."
         _ -> ""
+  forHuman (LedgerDB.SnapshotRequestDelayed _snapshotRequestTime delayBeforeSnapshotting slots) =
+    Text.unwords ["Scheduling to take ledger state snapshots at slots "
+                 , showT (NonEmpty.toList slots)
+                 , ", with a randomised delay of"
+                 , showT delayBeforeSnapshotting
+                 ]
+  forHuman LedgerDB.SnapshotRequestCompleted = "Completed taking a ledger state snapshot"
+
 
   forMachine dtals (LedgerDB.TookSnapshot snap pt enclosedTiming) =
     mconcat [ "kind" .= String "TookSnapshot"
@@ -1786,11 +1795,23 @@ instance ( StandardHash blk
     mconcat [ "kind" .= String "InvalidSnapshot"
             , "snapshot" .= forMachine dtals snap
             , "failure" .= show failure ]
+  forMachine _dtals (LedgerDB.SnapshotRequestDelayed snapshotRequestTime delayBeforeSnapshotting slots) =
+    mconcat [ "kind" .= String "TraceLedgerDBEvent.LedgerDBSnapshotEvent.SnapshotRequestDelayed"
+             , "requestTime" .= show snapshotRequestTime
+             , "delayBeforeSnapshotting " .= show delayBeforeSnapshotting
+             , "slots" .= show slots
+             ]
+  forMachine _dtals (LedgerDB.SnapshotRequestCompleted) =
+    mconcat [ "kind" .= String "TraceLedgerDBEvent.LedgerDBSnapshotEvent.SnapshotRequestCompleted"
+             ]
+
 
 instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where
     namespaceFor LedgerDB.TookSnapshot {} = Namespace [] ["TookSnapshot"]
     namespaceFor LedgerDB.DeletedSnapshot {} = Namespace [] ["DeletedSnapshot"]
     namespaceFor LedgerDB.InvalidSnapshot {} = Namespace [] ["InvalidSnapshot"]
+    namespaceFor LedgerDB.SnapshotRequestDelayed {}  = Namespace [] ["SnapshotRequestDelayed"]
+    namespaceFor LedgerDB.SnapshotRequestCompleted {} = Namespace [] ["SnapshotRequestCompleted"]
 
     severityFor  (Namespace _ ["TookSnapshot"]) _ = Just Info
     severityFor  (Namespace _ ["DeletedSnapshot"]) _ = Just Debug
@@ -1809,6 +1830,10 @@ instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where
          , " seems to be from an old node or different backend, it will"
          , " be deleted"
          ]
+    documentFor (Namespace _ ["SnapshotRequestDelayed"]) = Just
+        "A delayed snapshot requested was issued. The snapshot will be initiated at the specified timestamp, with the specified delay and for the specified slots"
+    documentFor (Namespace _ ["SnapshotRequestCompleted"]) = Just
+        "The delayed snapshot request was completed"
     documentFor _ = Nothing
 
     allNamespaces =

cardano-node/test/Test/Cardano/Node/POM.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -22,17 +23,18 @@ import           Cardano.Rpc.Server.Config (makeRpcConfig)
 import           Ouroboros.Consensus.Node (NodeDatabasePaths (..))
 import           Ouroboros.Consensus.Node.Genesis (disableGenesisConfig)
 import           Ouroboros.Consensus.Storage.LedgerDB.Args
-import           Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..),
-                   SnapshotInterval (..))
+import           Ouroboros.Consensus.Storage.LedgerDB.Snapshots (defaultSnapshotPolicyArgs)
 import           Ouroboros.Network.Block (SlotNo (..))
 import           Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
 import           Ouroboros.Network.TxSubmission.Inbound.V2.Types
 
 import           Data.Bifunctor (first)
+import qualified Data.ByteString.Lazy as LBS
 import           Data.Monoid (Last (..))
 import           Data.String
 import           Data.Text (Text)
 
+import           Data.Aeson (eitherDecode)
 import           Hedgehog (Property, discover, withTests, (===))
 import qualified Hedgehog
 import           Hedgehog.Internal.Property (evalEither, failWith)
@@ -284,12 +286,48 @@ eExpectedConfig = do
     , ncConsensusMode = PraosMode
     , ncGenesisConfig = disableGenesisConfig
     , ncResponderCoreAffinityPolicy = NoResponderCoreAffinity
-    , ncLedgerDbConfig = LedgerDbConfiguration DefaultNumOfDiskSnapshots DefaultSnapshotInterval DefaultQueryBatchSize V2InMemory noDeprecatedOptions
+    , ncLedgerDbConfig = LedgerDbConfiguration defaultSnapshotPolicyArgs DefaultQueryBatchSize V2InMemory noDeprecatedOptions
     , ncRpcConfig
     , ncTxSubmissionLogicVersion = TxSubmissionLogicV1
     , ncTxSubmissionInitDelay = defaultTxSubmissionInitDelay
     }
 
+-- | Test that the legacy flat LedgerDB snapshot config format (options directly
+-- under LedgerDB) parses identically to the new nested Snapshots format.
+--
+-- TODO: this test could be removed once the old format is deprecated.
+prop_legacySnapshotFormat_POM :: Property
+prop_legacySnapshotFormat_POM =
+  withTests 1 . Hedgehog.property $ do
+    let legacyJson = "{ " <> dummyRequiredValues <> ", "
+          <> "\"LedgerDB\": {"
+          <> "  \"Backend\": \"V2InMemory\","
+          <> "  \"SnapshotInterval\": 4320,"
+          <> "  \"NumOfDiskSnapshots\": 2"
+          <> "} }"
+        newJson = "{ " <> dummyRequiredValues <> ", "
+          <> "\"LedgerDB\": {"
+          <> "  \"Backend\": \"V2InMemory\","
+          <> "  \"Snapshots\": {"
+          <> "    \"SnapshotInterval\": 4320,"
+          <> "    \"NumOfDiskSnapshots\": 2"
+          <> "  }"
+          <> "} }"
+    legacyConfig :: PartialNodeConfiguration <- evalEither $ eitherDecode legacyJson
+    newConfig    :: PartialNodeConfiguration <- evalEither $ eitherDecode newJson
+    pncLedgerDbConfig legacyConfig === pncLedgerDbConfig newConfig
+  where
+    dummyRequiredValues :: LBS.ByteString
+    dummyRequiredValues = mconcat
+      [ "\"ByronGenesisFile\": \"x\""
+      , ", \"ShelleyGenesisFile\": \"x\""
+      , ", \"AlonzoGenesisFile\": \"x\""
+      , ", \"ConwayGenesisFile\": \"x\""
+      , ", \"LastKnownBlockVersion-Major\": 0"
+      , ", \"LastKnownBlockVersion-Minor\": 0"
+      , ", \"LastKnownBlockVersion-Alt\": 0"
+      ]
+
 -- -----------------------------------------------------------------------------
 
 tests :: IO Bool

configuration/cardano/mainnet-config-legacy.json

@@ -13,9 +13,11 @@
   "LastKnownBlockVersion-Minor": 0,
   "LedgerDB": {
     "Backend": "V2InMemory",
-    "NumOfDiskSnapshots": 2,
     "QueryBatchSize": 100000,
-    "SnapshotInterval": 4320
+    "Snapshots": {
+      "NumOfDiskSnapshots": 2,
+      "SnapshotInterval": 4320
+    }
   },
   "MaxKnownMajorProtocolVersion": 2,
   "MinNodeVersion": "10.7.0",

configuration/cardano/mainnet-config.json

@@ -13,9 +13,11 @@
   "LastKnownBlockVersion-Minor": 0,
   "LedgerDB": {
     "Backend": "V2InMemory",
-    "NumOfDiskSnapshots": 2,
     "QueryBatchSize": 100000,
-    "SnapshotInterval": 4320
+    "Snapshots": {
+      "NumOfDiskSnapshots": 2,
+      "SnapshotInterval": 4320
+    }
   },
   "MaxKnownMajorProtocolVersion": 2,
   "MinNodeVersion": "10.7.0",

configuration/cardano/mainnet-config.yaml

@@ -80,19 +80,20 @@ ConsensusMode: PraosMode
 # Additional configuration options can be found at:
 # https://ouroboros-consensus.cardano.intersectmbo.org/docs/for-developers/utxo-hd/migrating
 LedgerDB:
-  # The time interval between snapshots, in seconds.
-  SnapshotInterval: 4320
-
-  # The number of disk snapshots to keep.
-  NumOfDiskSnapshots: 2
+  # The backend can either be in memory with `V2InMemory` or on disk with
+  # `V1LMDB`.
+  Backend: V2InMemory
 
   # When querying the store for a big range of UTxOs (such as with
   # QueryUTxOByAddress), the store will be read in batches of this size.
   QueryBatchSize: 100000
 
-  # The backend can either be in memory with `V2InMemory` or on disk with
-  # `V1LMDB`.
-  Backend: V2InMemory
+  Snapshots:
+    # The time interval between snapshots, in seconds.
+    SnapshotInterval: 4320
+
+    # The number of disk snapshots to keep.
+    NumOfDiskSnapshots: 2
 
 ##### Version Information #####
 

configuration/cardano/testnet-template-config-legacy.json

@@ -12,9 +12,11 @@
   "LastKnownBlockVersion-Minor": 1,
   "LedgerDB": {
     "Backend": "V2InMemory",
-    "NumOfDiskSnapshots": 2,
     "QueryBatchSize": 100000,
-    "SnapshotInterval": 216
+    "Snapshots": {
+      "NumOfDiskSnapshots": 2,
+      "SnapshotInterval": 216
+    }
   },
   "MaxConcurrencyDeadline": 4,
   "MaxKnownMajorProtocolVersion": 2,

configuration/cardano/testnet-template-config.json

@@ -13,9 +13,11 @@
   "LastKnownBlockVersion-Minor": 1,
   "LedgerDB": {
     "Backend": "V2InMemory",
-    "NumOfDiskSnapshots": 2,
     "QueryBatchSize": 100000,
-    "SnapshotInterval": 216
+    "Snapshots": {
+      "NumOfDiskSnapshots": 2,
+      "SnapshotInterval": 216
+    }
   },
   "MaxConcurrencyDeadline": 4,
   "MaxKnownMajorProtocolVersion": 2,