ChainDB q-s-m: do not copy blocks to ImmutableDB on snapshot

Author: geo2a

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs

@@ -466,11 +466,18 @@ run cfg env@ChainDBEnv{varDB, ..} cmd =
     PersistBlks -> ignore <$> persistBlks DoNotGarbageCollect internal
     PersistBlksThenGC -> ignore <$> persistBlks GarbageCollect internal
     UpdateLedgerSnapshots -> do
-      -- TODO(geo2a): for now, we don't copy the immutable blocks when taking
-      -- a ledger state snapshot, because the model does not faithfully implement
-      -- this behaviour
-      let copyImmutableBlocks = pure ()
-      ignore <$> intTryTakeSnapshot internal copyImmutableBlocks (\_ -> pure 0)
+      -- In these tests, we don't copy the immutable blocks when taking
+      -- a ledger state snapshot, because the model cannot yet faithfully implement
+      -- this behaviour. In production, the snapshots are taken conditionally, and the
+      -- 'tryTakeSnapshot' routine will only copy blocks only if it does take a snapshot.
+      -- The model can only always either copy or not, unconditionally, as it does not
+      -- implement the snapshot decision logic.
+      --
+      -- TODO(geo2a): re-enable copying when the model has a notion of ledge state
+      --              snapshots and can conditionally copy to ImmutableDB.
+      -- let copyImmutableBlocks = persistBlks GarbageCollect internal
+      let noCopyImmutableBlocks = pure ()
+      ignore <$> intTryTakeSnapshot internal noCopyImmutableBlocks (\_ -> pure 0)
     WipeVolatileDB -> Point <$> wipeVolatileDB st
  where
   mbGCedAllComponents = MbGCedAllComponents . MaybeGCedBlock True

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs

@@ -121,9 +121,6 @@ tests =
         [ testGroup
             "Chain not long enough to take a snapshot, so blocks are not persisted into ImmutableDB and are lost."
             [testCase "system" $ runSystemIO updateLedgerSnapshots_WipeVolatileDB_withoutSnapshot]
-        , testGroup
-            "Chain is long enough to take a snapshot, blocks are copied into ImmutableDB."
-            [testCase "system" $ runSystemIO updateLedgerSnapshots_WipeVolatileDB_withSnapshot]
         ]
     ]
 
@@ -342,9 +339,6 @@ waitForImmutableBlock_emptySlot = do
 -- ImmutableDB when the snapshot policy selects slots for snapshotting. When the
 -- immutable chain is too short, no blocks should be flushed, and WipeVolatileDB
 -- should recover to the tip of the (empty) ImmutableDB.
---
--- See 'updateLedgerSnapshots_WipeVolatileDB_withSnapshot' for the scenario where
--- the snapshot is taken.
 updateLedgerSnapshots_WipeVolatileDB_withoutSnapshot ::
   forall m.
   ( Block m ~ TestBlock
@@ -367,30 +361,6 @@ updateLedgerSnapshots_WipeVolatileDB_withoutSnapshot = do
  where
   fork0 = TestBody 1 True Nothing
 
--- | See 'updateLedgerSnapshots_WipeVolatileDB_withoutSnapshot' for details.
-updateLedgerSnapshots_WipeVolatileDB_withSnapshot ::
-  forall m.
-  ( Block m ~ TestBlock
-  , SupportsUnitTest m
-  , MonadError TestFailure m
-  ) =>
-  m ()
-updateLedgerSnapshots_WipeVolatileDB_withSnapshot = do
-  b1 <- addBlock $ firstBlock 1 $ fork0
-  b2 <- addBlock $ mkNextBlock b1 3 $ fork0
-  b3 <- addBlock $ mkNextBlock b2 5 $ fork0
-  b4 <- addBlock $ mkNextBlock b3 7 $ fork0
-  _ <- addBlock $ mkNextBlock b4 9 $ fork0
-
-  updateLedgerSnapshots
-
-  tip <- wipeVolatileDB
-  tip
-    /= genesisPoint
-      `orFailWith` ("Expected ChainDB non-Origin tip after wiping VolatileDB, got: " <> show tip)
- where
-  fork0 = TestBody 1 True Nothing
-
 {-------------------------------------------------------------------------------
   Helpers and testing infrastructure
 -------------------------------------------------------------------------------}