diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs index bc9fe60f0f6..25909004587 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs +++ b/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 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/DiskPolicy.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/DiskPolicy.hs index 34e5776f065..85b9f17be91 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/DiskPolicy.hs +++ b/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