Modify onDiskShouldTakeSnapshot by adding a RequestedInterval as a pa…

…rameter

This is merely introducing a parameter that will override a k * 2
value that was used before this commit introduced the
RequestedInterval.
This parameter will be exposed as a flag to the node operator

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs

@@ -245,7 +245,7 @@ copyAndSnapshotRunner
   -> Word64 -- ^ Number of immutable blocks replayed on ledger DB startup
   -> m Void
 copyAndSnapshotRunner cdb@CDB{..} gcSchedule replayed =
-    if onDiskShouldTakeSnapshot Nothing replayed then do
+    if onDiskShouldTakeSnapshot Nothing replayed Nothing then do
       updateLedgerSnapshots cdb
       now <- getMonotonicTime
       loop (Just now) 0
@@ -273,7 +273,7 @@ copyAndSnapshotRunner cdb@CDB{..} gcSchedule replayed =
       let distance' = distance + numToWrite
           elapsed   = (\prev -> now `diffTime` prev) <$> mPrevSnapshot
 
-      if onDiskShouldTakeSnapshot elapsed distance' then do
+      if onDiskShouldTakeSnapshot elapsed distance' Nothing then do
         updateLedgerSnapshots cdb
         loop (Just now) 0
       else

ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/DiskPolicy.hs

@@ -7,6 +7,7 @@
 module Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (
     DiskPolicy(..)
   , defaultDiskPolicy
+  , RequestedInterval(..)
   ) where
 
 import           Data.Time.Clock (secondsToDiffTime)
@@ -17,6 +18,11 @@ import           Control.Monad.Class.MonadTime
 
 import           Ouroboros.Consensus.Config.SecurityParam
 
+
+newtype RequestedInterval = RequestedInterval
+  { unRequestedInterval :: Word64
+  }
+
 -- | On-disk policy
 --
 -- We only write ledger states that are older than @k@ blocks to disk (that is,
@@ -60,8 +66,11 @@ data DiskPolicy = DiskPolicy {
       --   policy to decide to take a snapshot /on node startup/ if a lot of
       --   blocks had to be replayed.
       --
+      -- * How often snapshot should be taken, regardless of number of blocks
+      --   processed
+      --
       -- See also 'defaultDiskPolicy'
-    , onDiskShouldTakeSnapshot :: Maybe DiffTime -> Word64 -> Bool
+    , onDiskShouldTakeSnapshot :: Maybe DiffTime -> Word64 -> Maybe RequestedInterval -> Bool
     }
   deriving NoThunks via OnlyCheckWhnf DiskPolicy
 
@@ -85,10 +94,19 @@ defaultDiskPolicy (SecurityParam k) = DiskPolicy {..}
     onDiskNumSnapshots :: Word
     onDiskNumSnapshots = 2
 
-    onDiskShouldTakeSnapshot :: Maybe DiffTime -> Word64 -> Bool
-    onDiskShouldTakeSnapshot (Just timeSinceLast) blocksSinceLast =
-           timeSinceLast >= secondsToDiffTime (fromIntegral (k * 2))
-        || (   blocksSinceLast >= 50_000
-            && timeSinceLast > 6 * secondsToDiffTime 60)
-    onDiskShouldTakeSnapshot Nothing blocksSinceLast =
-           blocksSinceLast >= k
+    onDiskShouldTakeSnapshot ::
+         Maybe DiffTime
+      -> Word64
+      -> Maybe RequestedInterval
+      -> Bool
+    onDiskShouldTakeSnapshot Nothing blocksSinceLast _ = blocksSinceLast >= k
+    onDiskShouldTakeSnapshot (Just timeSinceLast) blocksSinceLast maybeRequestedInterval =
+      let snapshotIntervalSeconds      =
+            maybe (k * 2) unRequestedInterval maybeRequestedInterval
+          snapshotInterval             =
+            secondsToDiffTime (fromIntegral snapshotIntervalSeconds)
+          itsBeen50kBlocks             = blocksSinceLast >= 50_000
+          itsBeen6MinSinceLastSnapshot = timeSinceLast > 6 * secondsToDiffTime 60
+      in
+           timeSinceLast >= snapshotInterval
+        || itsBeen50kBlocks && itsBeen6MinSinceLastSnapshot