db-analyser --store-ledger: fix two bugs (#1512)

Suppose that `s0 < s1 < s2` are slots with blocks in the ImmutableDB,
and no other slot `s` with `s0 < s < s2` has a block, and suppose that
we run `db-analyser --store-ledger s2`. It is now expected that we store
a ledger snapshot for slot `s2`, which was the case before #1412.
However:

- With `--v1-in-mem` or `--lmdb`, we store a ledger snapshot for slot
`s1`.
 - With `--v2-in-mem`, we store a ledger snapshot for slot `s0`.

This PR fixes two unrelated bugs causing this (one specific to the V2
LedgerDB), see the individual commits. Now, in all cases, we store a
ledger snapshot for slot `s2`.

Applied the `no changelog` label as only testing/internal code is
affected.

Author: amesgen

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs

@@ -394,15 +394,15 @@ storeLedgerStateAt slotNo ledgerAppMode env = do
       LedgerDB.forkerClose frk
       case runExcept $ tickThenXApply OmitLedgerEvents ledgerCfg blk (oldLedger `withLedgerTables` tbs) of
         Right newLedger -> do
-          when (blockSlot blk >= slotNo) $ storeLedgerState newLedger
+          LedgerDB.push internal newLedger
+          when (blockSlot blk >= slotNo) storeLedgerState
           when (blockSlot blk > slotNo) $ issueWarning blk
           when ((unBlockNo $ blockNo blk) `mod` 1000 == 0) $ reportProgress blk
-          LedgerDB.push internal newLedger
           LedgerDB.tryFlush initLedgerDB
           return (continue blk, ())
         Left err -> do
           traceWith tracer $ LedgerErrorEvent (blockPoint blk) err
-          storeLedgerState (oldLedger `withLedgerTables` tbs)
+          storeLedgerState
           pure (Stop, ())
 
     tickThenXApply = case ledgerAppMode of
@@ -419,14 +419,13 @@ storeLedgerStateAt slotNo ledgerAppMode env = do
     reportProgress blk = let event = BlockSlotEvent (blockNo blk) (blockSlot blk) (blockHash blk)
                          in traceWith tracer event
 
-    storeLedgerState :: ExtLedgerState blk mk -> IO ()
-    storeLedgerState ledgerState = case pointSlot pt of
+    storeLedgerState :: IO ()
+    storeLedgerState =
+      IOLike.atomically (pointSlot <$> LedgerDB.currentPoint initLedgerDB) >>= \case
         NotOrigin slot -> do
           LedgerDB.takeSnapshotNOW internal LedgerDB.TakeAtVolatileTip (Just "db-analyser")
           traceWith tracer $ SnapshotStoredEvent slot
         Origin -> pure ()
-      where
-        pt = headerStatePoint $ headerState ledgerState
 
 countBlocks ::
      forall blk .

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

@@ -180,8 +180,8 @@ mkInternals ::
 mkInternals bss h = TestInternals {
       takeSnapshotNOW = \whereTo suff -> getEnv h $ \env -> do
           st <- (case whereTo of
-            TakeAtVolatileTip  -> anchorHandle
-            TakeAtImmutableTip -> currentHandle) <$> readTVarIO (ldbSeq env)
+            TakeAtImmutableTip -> anchorHandle
+            TakeAtVolatileTip  -> currentHandle) <$> readTVarIO (ldbSeq env)
           Monad.void $ takeSnapshot
                 (configCodec . getExtLedgerCfg . ledgerDbCfg $ ldbCfg env)
                 (LedgerDBSnapshotEvent >$< ldbTracer env)