Trace slots of delayed snapshots

Author: geo2a

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

@@ -116,6 +116,7 @@ import qualified Data.Aeson as Aeson
 import Data.Aeson.Types (Parser)
 import Data.Functor.Identity
 import qualified Data.List as List
+import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (catMaybes, isJust, mapMaybe, maybeToList)
 import Data.Ord
 import Data.Set (Set)
@@ -711,8 +712,8 @@ data TraceSnapshotEvent blk
   = -- | An on disk snapshot was skipped because it was invalid.
     InvalidSnapshot DiskSnapshot (SnapshotFailure blk)
   | -- | A delayed snapshot requested was issued at a timestamp,
-    --   with a delay and for N snapshots
-    SnapshotRequestDelayed Time DiffTime Int
+    --   with a delay and for ledger states at the specified slot numbers
+    SnapshotRequestDelayed Time DiffTime (NonEmpty SlotNo)
   | -- | A snapshot request was completed
     SnapshotRequestCompleted
   | -- | A snapshot was written to disk.

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

@@ -25,6 +25,7 @@ import Data.Functor ((<&>))
 import Data.Functor.Contravariant ((>$<))
 import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NonEmpty
 import Data.Maybe (isJust, mapMaybe)
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -347,8 +348,12 @@ implTryTakeSnapshot snapManager env copyBlocks snapshotRequestTime getRandomDela
       copyBlocks
 
       delayBeforeSnapshotting <- getRandomDelay (onDiskSnapshotDelayRange (ldbSnapshotPolicy env))
+      let nonEmptySnapshotSlots =
+            case NonEmpty.nonEmpty $ snapshotSlots of
+              Nothing -> error "impossible: empty handles, see pattern-match above"
+              Just slots -> slots
       traceWith (LedgerDBSnapshotEvent >$< ldbTracer env) $
-        SnapshotRequestDelayed snapshotRequestTime delayBeforeSnapshotting (length snapshotSlots)
+        SnapshotRequestDelayed snapshotRequestTime delayBeforeSnapshotting nonEmptySnapshotSlots
       threadDelay delayBeforeSnapshotting
 
       forM_ snapshotSlots $ \slot -> do

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

@@ -7,6 +7,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -26,6 +27,7 @@ import qualified Data.Foldable as Foldable
 import Data.Functor.Contravariant ((>$<))
 import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NonEmpty
 import Data.Maybe (mapMaybe)
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -364,7 +366,7 @@ implTryTakeSnapshot snapManager env copyBlocks snapshotRequestTime getRandomDela
       -- Prune the 'LedgerSeq' such that the resulting anchor state has slot
       -- number @slot@.
       let pruneStrat = LedgerDbPruneBeforeSlot (slot + 1)
-      duplicateStateRef $ anchorHandle $ snd $ prune pruneStrat lseq
+      (slot,) <$> (duplicateStateRef $ anchorHandle $ snd $ prune pruneStrat lseq)
 
   -- look at the list of the ledger tables handles from the previous step and take the snapshots
   case handles of
@@ -373,11 +375,15 @@ implTryTakeSnapshot snapManager env copyBlocks snapshotRequestTime getRandomDela
       copyBlocks
 
       delayBeforeSnapshotting <- getRandomDelay (onDiskSnapshotDelayRange (ldbSnapshotPolicy env))
+      let slotsOfHandles =
+            case NonEmpty.nonEmpty $ map fst handles of
+              Nothing -> error "impossible: empty handles, see pattern-match above"
+              Just slots -> slots
       traceWith (LedgerDBSnapshotEvent >$< ldbTracer env) $
-        SnapshotRequestDelayed snapshotRequestTime delayBeforeSnapshotting (length handles)
+        SnapshotRequestDelayed snapshotRequestTime delayBeforeSnapshotting slotsOfHandles
       threadDelay delayBeforeSnapshotting
 
-      for_ handles $ \h -> do
+      for_ handles $ \(_, h) -> do
         Monad.void $ takeSnapshot snapManager Nothing h
 
       atomically $ writeTVar (ldbLastSnapshotRequestedAt env) (Just $! snapshotRequestTime)