From eb18a359af0279af8979d8841c7d061edf83d0bb Mon Sep 17 00:00:00 2001
From: KtorZ <matthias.benkort@gmail.com>
Date: Wed, 20 Sep 2023 10:16:54 +0200
Subject: [PATCH 01/15] Add 'AuxLedgerEvent' hook to ledgerDbSwitch

  Now, needs to be threaded down to 'addBlockSync' and up back to
  'runWith' to be usable from the node.

  The goal for now is simply to print ledger events on the console on a
  running node.
---
 .../Consensus/Storage/ChainDB/Impl/ChainSel.hs         |  2 +-
 .../Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs  | 10 ++++++++--
 .../Ouroboros/Consensus/Storage/LedgerDB/Update.hs     |  5 +++--
 3 files changed, 12 insertions(+), 5 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
index 6e48c38025..52d1615f01 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
@@ -1060,7 +1060,7 @@ ledgerValidateCandidate
   -> ChainDiff (Header blk)
   -> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
 ledgerValidateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) =
-    LgrDB.validate lgrDB curLedger blockCache rollback traceUpdate newBlocks >>= \case
+    LgrDB.validate lgrDB curLedger (const (pure ())) blockCache rollback traceUpdate newBlocks >>= \case
       LgrDB.ValidateExceededRollBack {} ->
         -- Impossible: we asked the LgrDB to roll back past the immutable tip,
         -- which is impossible, since the candidates we construct must connect
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
index e2efb04f17..a3153c674f 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
@@ -327,21 +327,27 @@ data ValidateResult blk =
   | ValidateLedgerError      (LedgerDB.AnnLedgerError' blk)
   | ValidateExceededRollBack LedgerDB.ExceededRollback
 
-validate :: forall m blk. (IOLike m, LedgerSupportsProtocol blk, HasCallStack)
+validate :: forall m blk.
+	    ( IOLike m
+	    , LedgerSupportsProtocol blk
+	    , HasCallStack
+	    )
          => LgrDB m blk
          -> LedgerDB' blk
             -- ^ This is used as the starting point for validation, not the one
             -- in the 'LgrDB'.
+	 -> (AuxLedgerEvent (ExtLedgerState blk) -> m ())
          -> BlockCache blk
          -> Word64  -- ^ How many blocks to roll back
          -> (LedgerDB.UpdateLedgerDbTraceEvent blk -> m ())
          -> [Header blk]
          -> m (ValidateResult blk)
-validate LgrDB{..} ledgerDB blockCache numRollbacks trace = \hdrs -> do
+validate LgrDB{..} ledgerDB handleLedgerEvent blockCache numRollbacks trace = \hdrs -> do
     aps <- mkAps hdrs <$> atomically (readTVar varPrevApplied)
     res <- fmap rewrap $ LedgerDB.defaultResolveWithErrors resolveBlock $
              LedgerDB.ledgerDbSwitch
                (LedgerDB.configLedgerDb cfg)
+	       (lift . lift . handleLedgerEvent)
                numRollbacks
                (lift . lift . trace)
                aps
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
index 56d35d1f01..eeccf44f10 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
@@ -314,12 +314,13 @@ ledgerDbPushMany trace cfg aps initDb = (repeatedlyM pushAndTrace) aps initDb
 -- | Switch to a fork
 ledgerDbSwitch :: (ApplyBlock l blk, Monad m, c)
                => LedgerDbCfg l
+	       -> (AuxLedgerEvent l -> m ())
                -> Word64          -- ^ How many blocks to roll back
                -> (UpdateLedgerDbTraceEvent blk -> m ())
                -> [Ap m l blk c]  -- ^ New blocks to apply
                -> LedgerDB l
                -> m (Either ExceededRollback (LedgerDB l))
-ledgerDbSwitch cfg numRollbacks trace newBlocks db =
+ledgerDbSwitch cfg _handleLedgerEvent numRollbacks trace newBlocks db =
     case rollback numRollbacks db of
       Nothing ->
         return $ Left $ ExceededRollback {
@@ -383,7 +384,7 @@ ledgerDbSwitch' :: forall l blk. ApplyBlock l blk
                 => LedgerDbCfg l
                 -> Word64 -> [blk] -> LedgerDB l -> Maybe (LedgerDB l)
 ledgerDbSwitch' cfg n bs db =
-    case runIdentity $ ledgerDbSwitch cfg n (const $ pure ()) (map pureBlock bs) db of
+    case runIdentity $ ledgerDbSwitch cfg (const $ pure ()) n (const $ pure ()) (map pureBlock bs) db of
       Left  ExceededRollback{} -> Nothing
       Right db'                -> Just db'
 

From 852ae3de3575244d2065c4d8ab2633e5f0bcd846 Mon Sep 17 00:00:00 2001
From: KtorZ <matthias.benkort@gmail.com>
Date: Wed, 20 Sep 2023 14:48:07 +0200
Subject: [PATCH 02/15] Finish threading 'handleLedgerEvent' callback through
 the consensus stack

  - I've skipped 'chainSelectionForFutureBlocks' and 'addBlockAsync' which seem not relevant to the use case of streaming events down to clients. Those functions are used in anticipation when preparing blocks to apply from the mempool but should likely not lead to any event notification.
  - Similarly, the handler is set to 'const $ pure ()' on initialization functions which are simply replaying the database.
---
 .../Consensus/Storage/ChainDB/Impl.hs         | 22 +++++----
 .../Storage/ChainDB/Impl/Background.hs        | 15 ++++---
 .../Storage/ChainDB/Impl/ChainSel.hs          | 45 +++++++++++--------
 .../Consensus/Storage/ChainDB/Impl/LgrDB.hs   | 10 ++---
 .../Consensus/Storage/LedgerDB/Init.hs        |  2 +-
 .../Consensus/Storage/LedgerDB/Update.hs      | 32 +++++++------
 6 files changed, 72 insertions(+), 54 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
index 64fc2428ad..3d27814002 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -46,6 +46,8 @@ import           GHC.Stack (HasCallStack)
 import           Ouroboros.Consensus.Block
 import qualified Ouroboros.Consensus.Fragment.Validated as VF
 import           Ouroboros.Consensus.HardFork.Abstract
+import           Ouroboros.Consensus.Ledger.Abstract
+import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.Inspect
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
@@ -85,10 +87,11 @@ withDB
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
      )
-  => ChainDbArgs Identity m blk
+  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  -> ChainDbArgs Identity m blk
   -> (ChainDB m blk -> m a)
   -> m a
-withDB args = bracket (fst <$> openDBInternal args True) API.closeDB
+withDB handleLedgerEvent args = bracket (fst <$> openDBInternal handleLedgerEvent args True) API.closeDB
 
 openDB
   :: forall m blk.
@@ -99,9 +102,11 @@ openDB
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
      )
-  => ChainDbArgs Identity m blk
+  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  -> ChainDbArgs Identity m blk
   -> m (ChainDB m blk)
-openDB args = fst <$> openDBInternal args True
+openDB handleLedgerEvent args =
+  fst <$> openDBInternal handleLedgerEvent args True
 
 openDBInternal
   :: forall m blk.
@@ -112,10 +117,11 @@ openDBInternal
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
      )
-  => ChainDbArgs Identity m blk
+  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  -> ChainDbArgs Identity m blk
   -> Bool -- ^ 'True' = Launch background tasks
   -> m (ChainDB m blk, Internal m blk)
-openDBInternal args launchBgTasks = runWithTempRegistry $ do
+openDBInternal handleLedgerEvent args launchBgTasks = runWithTempRegistry $ do
     lift $ traceWith tracer $ TraceOpenEvent StartedOpeningDB
     lift $ traceWith tracer $ TraceOpenEvent StartedOpeningImmutableDB
     immutableDB <- ImmutableDB.openDB argsImmutableDb $ innerOpenCont ImmutableDB.closeDB
@@ -221,7 +227,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             { intCopyToImmutableDB       = getEnv  h Background.copyToImmutableDB
             , intGarbageCollect          = getEnv1 h Background.garbageCollect
             , intUpdateLedgerSnapshots   = getEnv  h Background.updateLedgerSnapshots
-            , intAddBlockRunner          = getEnv  h Background.addBlockRunner
+            , intAddBlockRunner          = getEnv  h $ Background.addBlockRunner handleLedgerEvent
             , intKillBgThreads           = varKillBgThreads
             }
 
@@ -229,7 +235,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
         (castPoint $ AF.anchorPoint chain)
         (castPoint $ AF.headPoint   chain)
 
-      when launchBgTasks $ Background.launchBgTasks env replayed
+      when launchBgTasks $ Background.launchBgTasks handleLedgerEvent env replayed
 
       return (chainDB, testing, env)
 
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
index 9dcb2bd3e2..817130540e 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
@@ -54,6 +54,7 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.HardFork.Abstract
 import           Ouroboros.Consensus.Ledger.Abstract
+import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.Inspect
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Protocol.Abstract
@@ -87,12 +88,13 @@ launchBgTasks
      , HasHardForkHistory blk
      , LgrDbSerialiseConstraints blk
      )
-  => ChainDbEnv m blk
+  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  -> ChainDbEnv m blk
   -> Word64 -- ^ Number of immutable blocks replayed on ledger DB startup
   -> m ()
-launchBgTasks cdb@CDB{..} replayed = do
+launchBgTasks handleLedgerEvent cdb@CDB{..} replayed = do
     !addBlockThread <- launch "ChainDB.addBlockRunner" $
-      addBlockRunner cdb
+      addBlockRunner handleLedgerEvent cdb
     gcSchedule <- newGcSchedule
     !gcThread <- launch "ChainDB.gcScheduleRunner" $
       gcScheduleRunner gcSchedule $ garbageCollect cdb
@@ -526,12 +528,13 @@ addBlockRunner
      , HasHardForkHistory blk
      , HasCallStack
      )
-  => ChainDbEnv m blk
+  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  -> ChainDbEnv m blk
   -> m Void
-addBlockRunner cdb@CDB{..} = forever $ do
+addBlockRunner handleLedgerEvent cdb@CDB{..} = forever $ do
     let trace = traceWith cdbTracer . TraceAddBlockEvent
     trace $ PoppedBlockFromQueue RisingEdge
     blkToAdd <- getBlockToAdd cdbBlocksToAdd
     trace $ PoppedBlockFromQueue $ FallingEdgeWith $
       blockRealPoint $ blockToAdd blkToAdd
-    addBlockSync cdb blkToAdd
+    addBlockSync handleLedgerEvent cdb blkToAdd
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
index 52d1615f01..4e8116c482 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
@@ -190,7 +190,7 @@ initialChainSelection immutableDB volatileDB lgrDB tracer cfg varInvalid
                     candidates) $
         assert (all (preferAnchoredCandidate bcfg curChain) candidates) $ do
           cse <- chainSelEnv
-          chainSelection cse (Diff.extend <$> candidates)
+          chainSelection (const $ pure ()) cse (Diff.extend <$> candidates)
       where
         curChain = VF.validatedFragment curChainAndLedger
         ledger   = VF.validatedLedger   curChainAndLedger
@@ -261,10 +261,11 @@ addBlockSync
      , HasHardForkHistory blk
      , HasCallStack
      )
-  => ChainDbEnv m blk
+  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  -> ChainDbEnv m blk
   -> BlockToAdd m blk
   -> m ()
-addBlockSync cdb@CDB {..} BlockToAdd { blockToAdd = b, .. } = do
+addBlockSync handleLedgerEvent cdb@CDB {..} BlockToAdd { blockToAdd = b, .. } = do
     (isMember, invalid, curChain) <- atomically $ (,,)
       <$> VolatileDB.getIsMember          cdbVolatileDB
       <*> (forgetFingerprint <$> readTVar cdbInvalid)
@@ -317,7 +318,7 @@ addBlockSync cdb@CDB {..} BlockToAdd { blockToAdd = b, .. } = do
         -- new block. When some future blocks are now older than the current
         -- block, we will do chain selection in a more chronological order.
         void $ chainSelectionForFutureBlocks cdb blockCache
-        chainSelectionForBlock cdb blockCache hdr blockPunish
+        chainSelectionForBlock handleLedgerEvent cdb blockCache hdr blockPunish
 
     deliverProcessed newTip
   where
@@ -388,7 +389,9 @@ chainSelectionForFutureBlocks
      , HasHardForkHistory blk
      , HasCallStack
      )
-  => ChainDbEnv m blk -> BlockCache blk -> m (Point blk)
+  => ChainDbEnv m blk
+  -> BlockCache blk
+  -> m (Point blk)
 chainSelectionForFutureBlocks cdb@CDB{..} blockCache = do
     -- Get 'cdbFutureBlocks' and empty the map in the TVar. It will be
     -- repopulated with the blocks that are still from the future (but not the
@@ -400,7 +403,7 @@ chainSelectionForFutureBlocks cdb@CDB{..} blockCache = do
       return $ Map.elems futureBlocks
     forM_ futureBlockHeaders $ \(hdr, punish) -> do
       traceWith tracer $ ChainSelectionForFutureBlock (headerRealPoint hdr)
-      chainSelectionForBlock cdb blockCache hdr punish
+      chainSelectionForBlock (const $ pure ()) cdb blockCache hdr punish
     atomically $ Query.getTipPoint cdb
   where
     tracer = TraceAddBlockEvent >$< cdbTracer
@@ -445,12 +448,13 @@ chainSelectionForBlock
      , HasHardForkHistory blk
      , HasCallStack
      )
-  => ChainDbEnv m blk
+  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  -> ChainDbEnv m blk
   -> BlockCache blk
   -> Header blk
   -> InvalidBlockPunishment m
   -> m (Point blk)
-chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = do
+chainSelectionForBlock handleLedgerEvent cdb@CDB{..} blockCache hdr punish = do
     (invalid, succsOf, lookupBlockInfo, curChain, tipPoint, ledgerDB)
       <- atomically $ (,,,,,)
           <$> (forgetFingerprint <$> readTVar cdbInvalid)
@@ -597,7 +601,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = do
         case chainDiffs of
           Nothing          -> return curTip
           Just chainDiffs' ->
-            chainSelection chainSelEnv chainDiffs' >>= \case
+            chainSelection handleLedgerEvent chainSelEnv chainDiffs' >>= \case
               Nothing ->
                 return curTip
               Just validatedChainDiff ->
@@ -658,7 +662,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = do
           -- No candidates preferred over the current chain
           Nothing          -> return curTip
           Just chainDiffs' ->
-            chainSelection chainSelEnv chainDiffs' >>= \case
+            chainSelection handleLedgerEvent chainSelEnv chainDiffs' >>= \case
               Nothing                 ->
                 return curTip
               Just validatedChainDiff ->
@@ -877,13 +881,14 @@ chainSelection
      , LedgerSupportsProtocol blk
      , HasCallStack
      )
-  => ChainSelEnv m blk
+  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  -> ChainSelEnv m blk
   -> NonEmpty (ChainDiff (Header blk))
   -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
      -- ^ The (valid) chain diff and corresponding LedgerDB that was selected,
      -- or 'Nothing' if there is no valid chain diff preferred over the current
      -- chain.
-chainSelection chainSelEnv chainDiffs =
+chainSelection handleLedgerEvent chainSelEnv chainDiffs =
     assert (all (preferAnchoredCandidate bcfg curChain . Diff.getSuffix)
                 chainDiffs) $
     assert (all (isJust . Diff.apply curChain)
@@ -912,7 +917,7 @@ chainSelection chainSelEnv chainDiffs =
     go []            = return Nothing
     go (candidate:candidates0) = do
         mTentativeHeader <- setTentativeHeader
-        validateCandidate chainSelEnv candidate >>= \case
+        validateCandidate handleLedgerEvent chainSelEnv candidate >>= \case
           InsufficientSuffix ->
             -- When the body of the tentative block turns out to be invalid, we
             -- have a valid *empty* prefix, as the tentative header fits on top
@@ -1056,11 +1061,12 @@ ledgerValidateCandidate
      , LedgerSupportsProtocol blk
      , HasCallStack
      )
-  => ChainSelEnv m blk
+  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  -> ChainSelEnv m blk
   -> ChainDiff (Header blk)
   -> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
-ledgerValidateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) =
-    LgrDB.validate lgrDB curLedger (const (pure ())) blockCache rollback traceUpdate newBlocks >>= \case
+ledgerValidateCandidate handleLedgerEvent chainSelEnv chainDiff@(ChainDiff rollback suffix) =
+    LgrDB.validate lgrDB curLedger handleLedgerEvent blockCache rollback traceUpdate newBlocks >>= \case
       LgrDB.ValidateExceededRollBack {} ->
         -- Impossible: we asked the LgrDB to roll back past the immutable tip,
         -- which is impossible, since the candidates we construct must connect
@@ -1217,11 +1223,12 @@ validateCandidate
      , LedgerSupportsProtocol blk
      , HasCallStack
      )
-  => ChainSelEnv m blk
+  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  -> ChainSelEnv m blk
   -> ChainDiff (Header blk)
   -> m (ValidationResult blk)
-validateCandidate chainSelEnv chainDiff =
-    ledgerValidateCandidate chainSelEnv chainDiff >>= \case
+validateCandidate handleLedgerEvent chainSelEnv chainDiff =
+    ledgerValidateCandidate handleLedgerEvent chainSelEnv chainDiff >>= \case
       validatedChainDiff
         | ValidatedDiff.rollbackExceedsSuffix validatedChainDiff
         -> return InsufficientSuffix
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
index a3153c674f..3241301159 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
@@ -327,16 +327,12 @@ data ValidateResult blk =
   | ValidateLedgerError      (LedgerDB.AnnLedgerError' blk)
   | ValidateExceededRollBack LedgerDB.ExceededRollback
 
-validate :: forall m blk.
-	    ( IOLike m
-	    , LedgerSupportsProtocol blk
-	    , HasCallStack
-	    )
+validate :: forall m blk. (IOLike m, LedgerSupportsProtocol blk, HasCallStack)
          => LgrDB m blk
          -> LedgerDB' blk
             -- ^ This is used as the starting point for validation, not the one
             -- in the 'LgrDB'.
-	 -> (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+         -> (AuxLedgerEvent (ExtLedgerState blk) -> m ())
          -> BlockCache blk
          -> Word64  -- ^ How many blocks to roll back
          -> (LedgerDB.UpdateLedgerDbTraceEvent blk -> m ())
@@ -347,7 +343,7 @@ validate LgrDB{..} ledgerDB handleLedgerEvent blockCache numRollbacks trace = \h
     res <- fmap rewrap $ LedgerDB.defaultResolveWithErrors resolveBlock $
              LedgerDB.ledgerDbSwitch
                (LedgerDB.configLedgerDb cfg)
-	       (lift . lift . handleLedgerEvent)
+               (lift . lift . handleLedgerEvent)
                numRollbacks
                (lift . lift . trace)
                aps
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs
index b54e3955ce..e9d6ee8307 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs
@@ -208,7 +208,7 @@ initStartingWith tracer cfg streamAPI initDb = do
   where
     push :: blk -> (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64)
     push blk !(!db, !replayed) = do
-        !db' <- ledgerDbPush cfg (ReapplyVal blk) db
+        !db' <- ledgerDbPush cfg (const $ pure ()) (ReapplyVal blk) db
 
         let replayed' :: Word64
             !replayed' = replayed + 1
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
index eeccf44f10..a4c106827a 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
@@ -114,15 +114,18 @@ toRealPoint (Weaken ap)      = toRealPoint ap
 -- We take in the entire 'LedgerDB' because we record that as part of errors.
 applyBlock :: forall m c l blk. (ApplyBlock l blk, Monad m, c)
            => LedgerCfg l
+           -> (AuxLedgerEvent l -> m ())
            -> Ap m l blk c
            -> LedgerDB l -> m l
-applyBlock cfg ap db = case ap of
+applyBlock cfg handleLedgerEvent ap db = case ap of
     ReapplyVal b ->
       return $
         tickThenReapply cfg b l
-    ApplyVal b ->
-      either (throwLedgerError db (blockRealPoint b)) return $ runExcept $
-        tickThenApply cfg b l
+    ApplyVal b -> do
+      result <- either (throwLedgerError db (blockRealPoint b)) return $ runExcept $
+        tickThenApplyLedgerResult cfg b l
+      mapM_ handleLedgerEvent (lrEvents result)
+      return (lrResult result)
     ReapplyRef r  -> do
       b <- doResolveBlock r
       return $
@@ -132,7 +135,7 @@ applyBlock cfg ap db = case ap of
       either (throwLedgerError db r) return $ runExcept $
         tickThenApply cfg b l
     Weaken ap' ->
-      applyBlock cfg ap' db
+      applyBlock cfg handleLedgerEvent ap' db
   where
     l :: l
     l = ledgerDbCurrent db
@@ -293,34 +296,36 @@ data ExceededRollback = ExceededRollback {
 
 ledgerDbPush :: forall m c l blk. (ApplyBlock l blk, Monad m, c)
              => LedgerDbCfg l
+             -> (AuxLedgerEvent l -> m ())
              -> Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
-ledgerDbPush cfg ap db =
+ledgerDbPush cfg handleLedgerEvent ap db =
     (\current' -> pushLedgerState (ledgerDbCfgSecParam cfg) current' db) <$>
-      applyBlock (ledgerDbCfg cfg) ap db
+      applyBlock (ledgerDbCfg cfg) handleLedgerEvent ap db
 
 -- | Push a bunch of blocks (oldest first)
 ledgerDbPushMany ::
      forall m c l blk . (ApplyBlock l blk, Monad m, c)
   => (Pushing blk -> m ())
+  -> (AuxLedgerEvent l -> m ())
   -> LedgerDbCfg l
   -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
-ledgerDbPushMany trace cfg aps initDb = (repeatedlyM pushAndTrace) aps initDb
+ledgerDbPushMany trace handleLedgerEvent cfg aps initDb = (repeatedlyM pushAndTrace) aps initDb
   where
     pushAndTrace ap db = do
       let pushing = Pushing . toRealPoint $ ap
       trace pushing
-      ledgerDbPush cfg ap db
+      ledgerDbPush cfg handleLedgerEvent ap db
 
 -- | Switch to a fork
 ledgerDbSwitch :: (ApplyBlock l blk, Monad m, c)
                => LedgerDbCfg l
-	       -> (AuxLedgerEvent l -> m ())
+               -> (AuxLedgerEvent l -> m ())
                -> Word64          -- ^ How many blocks to roll back
                -> (UpdateLedgerDbTraceEvent blk -> m ())
                -> [Ap m l blk c]  -- ^ New blocks to apply
                -> LedgerDB l
                -> m (Either ExceededRollback (LedgerDB l))
-ledgerDbSwitch cfg _handleLedgerEvent numRollbacks trace newBlocks db =
+ledgerDbSwitch cfg handleLedgerEvent numRollbacks trace newBlocks db =
     case rollback numRollbacks db of
       Nothing ->
         return $ Left $ ExceededRollback {
@@ -334,6 +339,7 @@ ledgerDbSwitch cfg _handleLedgerEvent numRollbacks trace newBlocks db =
           let start   = PushStart . toRealPoint $ firstBlock
               goal    = PushGoal  . toRealPoint . last $ newBlocks
           Right <$> ledgerDbPushMany (trace . (StartedPushingBlockToTheLedgerDb start goal))
+                                     handleLedgerEvent
                                      cfg
                                      newBlocks
                                      db'
@@ -373,12 +379,12 @@ pureBlock = ReapplyVal
 
 ledgerDbPush' :: ApplyBlock l blk
               => LedgerDbCfg l -> blk -> LedgerDB l -> LedgerDB l
-ledgerDbPush' cfg b = runIdentity . ledgerDbPush cfg (pureBlock b)
+ledgerDbPush' cfg b = runIdentity . ledgerDbPush cfg (const $ pure ()) (pureBlock b)
 
 ledgerDbPushMany' :: ApplyBlock l blk
                   => LedgerDbCfg l -> [blk] -> LedgerDB l -> LedgerDB l
 ledgerDbPushMany' cfg bs =
-  runIdentity . ledgerDbPushMany (const $ pure ()) cfg (map pureBlock bs)
+  runIdentity . ledgerDbPushMany (const $ pure ()) (const $ pure ()) cfg (map pureBlock bs)
 
 ledgerDbSwitch' :: forall l blk. ApplyBlock l blk
                 => LedgerDbCfg l

From 971c1c97c080e0077d237b05b7713b71f9347f91 Mon Sep 17 00:00:00 2001
From: KtorZ <matthias.benkort@gmail.com>
Date: Wed, 20 Sep 2023 15:48:43 +0200
Subject: [PATCH 03/15] Bump CHaP and ouroboros-network in
 ouroboros-consensus-diffusion

  So that we can use the newest 'local' ouroboros-consensus-diffusion for building the node, at the same time as our new patch consensus.
---
 cabal.project                                                 | 4 ++--
 .../ouroboros-consensus-diffusion.cabal                       | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/cabal.project b/cabal.project
index 4216599074..cd179280e2 100644
--- a/cabal.project
+++ b/cabal.project
@@ -14,9 +14,9 @@ repository cardano-haskell-packages
 -- update either of these.
 index-state:
   -- Bump this if you need newer packages from Hackage
-  , hackage.haskell.org 2023-04-26T22:25:13Z
+  , hackage.haskell.org 2023-05-10T10:34:57Z
   -- Bump this if you need newer packages from CHaP
-  , cardano-haskell-packages 2023-05-23T16:25:08Z
+  , cardano-haskell-packages 2023-07-21T13:00:00Z
 
 packages:
   ./ouroboros-consensus
diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
index 7964d073d0..31b69efca2 100644
--- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
+++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
@@ -112,7 +112,7 @@ library
     , io-classes                   ^>=1.1
     , mtl                          ^>=2.2
     , ouroboros-consensus          ^>=0.7
-    , ouroboros-network            ^>=0.7
+    , ouroboros-network            ^>=0.8
     , ouroboros-network-api        ^>=0.5
     , ouroboros-network-framework  ^>=0.6
     , ouroboros-network-protocols  ^>=0.5

From 1026b392b41c2445a881f5576e91338c08c1d6e9 Mon Sep 17 00:00:00 2001
From: KtorZ <matthias.benkort@gmail.com>
Date: Wed, 20 Sep 2023 15:49:07 +0200
Subject: [PATCH 04/15] Wire 'handleLedgerEvent' in the diffusion & chainDB
 code.

---
 .../Ouroboros/Consensus/Node.hs               | 20 ++++++++++++++-----
 1 file changed, 15 insertions(+), 5 deletions(-)

diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
index 5f42a3feea..687c9e3f06 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
@@ -71,6 +71,7 @@ import           Ouroboros.Consensus.Config.SupportsNode
 import           Ouroboros.Consensus.Fragment.InFuture (CheckInFuture,
                      ClockSkew)
 import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
+import           Ouroboros.Consensus.Ledger.Basics (AuxLedgerEvent (..))
 import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
 import qualified Ouroboros.Consensus.Network.NodeToClient as NTC
 import qualified Ouroboros.Consensus.Network.NodeToNode as NTN
@@ -180,6 +181,9 @@ data RunNodeArgs m addrNTN addrNTC blk (p2p :: Diffusion.P2P) = RunNodeArgs {
 
       -- | Network PeerSharing miniprotocol willingness flag
     , rnPeerSharing :: PeerSharing
+
+      -- | An event handler to trigger custom action when ledger events are emitted.
+    , rnHandleLedgerEvent :: AuxLedgerEvent (ExtLedgerState blk) -> m ()
     }
 
 -- | Arguments that usually only tests /directly/ specify.
@@ -342,8 +346,13 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                   , ChainDB.cdbVolatileDbValidation  = ValidateAll
                   }
 
-        chainDB <- openChainDB registry inFuture cfg initLedger
-                  llrnChainDbArgsDefaults customiseChainDbArgs'
+        chainDB <- openChainDB rnHandleLedgerEvent
+                               registry
+                               inFuture
+                               cfg
+                               initLedger
+                               llrnChainDbArgsDefaults
+                               customiseChainDbArgs'
 
         continueWithCleanChainDB chainDB $ do
           btime <-
@@ -567,7 +576,8 @@ stdWithCheckedDB pb databasePath networkMagic body = do
 
 openChainDB
   :: forall m blk. (RunNode blk, IOLike m)
-  => ResourceRegistry m
+  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  -> ResourceRegistry m
   -> CheckInFuture m blk
   -> TopLevelConfig blk
   -> ExtLedgerState blk
@@ -576,8 +586,8 @@ openChainDB
   -> (ChainDbArgs Identity m blk -> ChainDbArgs Identity m blk)
       -- ^ Customise the 'ChainDbArgs'
   -> m (ChainDB m blk)
-openChainDB registry inFuture cfg initLedger defArgs customiseArgs =
-    ChainDB.openDB args
+openChainDB handleLedgerEvent registry inFuture cfg initLedger defArgs customiseArgs =
+    ChainDB.openDB handleLedgerEvent args
   where
     args :: ChainDbArgs Identity m blk
     args = customiseArgs $

From 57f56e9623d48f73786a2040fd6d1e3468d84b18 Mon Sep 17 00:00:00 2001
From: Arnaud Bailly <arnaud.bailly@iohk.io>
Date: Wed, 20 Sep 2023 21:12:13 +0200
Subject: [PATCH 05/15] Fix failing tests

---
 .../Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs       | 6 +++++-
 .../Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs   | 2 +-
 .../storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs  | 1 +
 3 files changed, 7 insertions(+), 2 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
index 3241301159..3e13ce23a7 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
@@ -327,7 +327,11 @@ data ValidateResult blk =
   | ValidateLedgerError      (LedgerDB.AnnLedgerError' blk)
   | ValidateExceededRollBack LedgerDB.ExceededRollback
 
-validate :: forall m blk. (IOLike m, LedgerSupportsProtocol blk, HasCallStack)
+validate :: forall m blk.
+            ( IOLike m
+	    , LedgerSupportsProtocol blk
+	    , HasCallStack
+	    )
          => LgrDB m blk
          -> LedgerDB' blk
             -- ^ This is used as the starting point for validation, not the one
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
index 89b8cce1b1..7f480077c0 100644
--- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
@@ -193,7 +193,7 @@ initLgrDB k chain = do
     varDB          <- newTVarIO genesisLedgerDB
     varPrevApplied <- newTVarIO mempty
     let lgrDB = mkLgrDB varDB varPrevApplied resolve args
-    LgrDB.validate lgrDB genesisLedgerDB BlockCache.empty 0 noopTrace
+    LgrDB.validate lgrDB genesisLedgerDB (const $ pure ()) BlockCache.empty 0 noopTrace
       (map getHeader (Chain.toOldestFirst chain)) >>= \case
         LgrDB.ValidateExceededRollBack _ ->
           error "impossible: rollback was 0"
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs
index bc134236b5..8cf08e82e4 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs
@@ -744,6 +744,7 @@ runDB standalone@DB{..} cmd =
             defaultResolveWithErrors dbResolve $
               ledgerDbSwitch
                 dbLedgerDbCfg
+                (const $ pure ())
                 n
                 (const $ pure ())
                 (map ApplyVal bs)

From 34d185e8cf3edc32e71c38ac56daa3b1e9136585 Mon Sep 17 00:00:00 2001
From: Arnaud Bailly <arnaud.bailly@iohk.io>
Date: Thu, 21 Sep 2023 10:02:52 +0200
Subject: [PATCH 06/15] Wrap event handler as a newtype

This is to prepare adding arguments to index events by block hash/slot number
---
 .../Ouroboros/Consensus/Node.hs                |  6 +++---
 .../Ouroboros/Consensus/Ledger/Basics.hs       | 14 ++++++++++++++
 .../Consensus/Storage/ChainDB/Impl.hs          |  6 +++---
 .../Storage/ChainDB/Impl/Background.hs         |  4 ++--
 .../Consensus/Storage/ChainDB/Impl/ChainSel.hs | 14 +++++++-------
 .../Consensus/Storage/ChainDB/Impl/LgrDB.hs    | 10 +++-------
 .../Consensus/Storage/LedgerDB/Init.hs         |  2 +-
 .../Consensus/Storage/LedgerDB/Update.hs       | 18 +++++++++---------
 8 files changed, 42 insertions(+), 32 deletions(-)

diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
index 687c9e3f06..11d061ccb4 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
@@ -71,7 +71,7 @@ import           Ouroboros.Consensus.Config.SupportsNode
 import           Ouroboros.Consensus.Fragment.InFuture (CheckInFuture,
                      ClockSkew)
 import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
-import           Ouroboros.Consensus.Ledger.Basics (AuxLedgerEvent (..))
+import           Ouroboros.Consensus.Ledger.Basics (LedgerEventHandler)
 import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
 import qualified Ouroboros.Consensus.Network.NodeToClient as NTC
 import qualified Ouroboros.Consensus.Network.NodeToNode as NTN
@@ -183,7 +183,7 @@ data RunNodeArgs m addrNTN addrNTC blk (p2p :: Diffusion.P2P) = RunNodeArgs {
     , rnPeerSharing :: PeerSharing
 
       -- | An event handler to trigger custom action when ledger events are emitted.
-    , rnHandleLedgerEvent :: AuxLedgerEvent (ExtLedgerState blk) -> m ()
+    , rnHandleLedgerEvent :: LedgerEventHandler m (ExtLedgerState blk)
     }
 
 -- | Arguments that usually only tests /directly/ specify.
@@ -576,7 +576,7 @@ stdWithCheckedDB pb databasePath networkMagic body = do
 
 openChainDB
   :: forall m blk. (RunNode blk, IOLike m)
-  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  => LedgerEventHandler m (ExtLedgerState blk)
   -> ResourceRegistry m
   -> CheckInFuture m blk
   -> TopLevelConfig blk
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
index b81fd75d52..8ef281b8db 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveFunctor     #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE TypeFamilies      #-}
 
 -- | Definition is 'IsLedger'
@@ -19,6 +20,9 @@ module Ouroboros.Consensus.Ledger.Basics (
   , castLedgerResult
   , embedLedgerResult
   , pureLedgerResult
+  , LedgerEventHandler(..)
+  , discardEvent
+  , natHandler
     -- * Definition of a ledger independent of a choice of block
   , IsLedger (..)
   , LedgerCfg
@@ -165,6 +169,16 @@ class ( -- Requirements on the ledger state itself
 applyChainTick :: IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
 applyChainTick = lrResult ..: applyChainTickLedgerResult
 
+
+-- | Handler for ledger events
+newtype LedgerEventHandler m l = LedgerEventHandler { handleLedgerEvent :: AuxLedgerEvent l -> m () }
+
+natHandler :: (m () -> n ()) -> LedgerEventHandler m l -> LedgerEventHandler n l
+natHandler nat LedgerEventHandler{handleLedgerEvent} = LedgerEventHandler (nat . handleLedgerEvent)
+
+discardEvent :: Applicative m => LedgerEventHandler m l
+discardEvent = LedgerEventHandler { handleLedgerEvent = const $ pure () }
+
 {-------------------------------------------------------------------------------
   Link block to its ledger
 -------------------------------------------------------------------------------}
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
index 3d27814002..aa482d93e4 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -87,7 +87,7 @@ withDB
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
      )
-  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  => LedgerEventHandler m (ExtLedgerState blk)
   -> ChainDbArgs Identity m blk
   -> (ChainDB m blk -> m a)
   -> m a
@@ -102,7 +102,7 @@ openDB
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
      )
-  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  => LedgerEventHandler m (ExtLedgerState blk)
   -> ChainDbArgs Identity m blk
   -> m (ChainDB m blk)
 openDB handleLedgerEvent args =
@@ -117,7 +117,7 @@ openDBInternal
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
      )
-  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  => LedgerEventHandler m (ExtLedgerState blk)
   -> ChainDbArgs Identity m blk
   -> Bool -- ^ 'True' = Launch background tasks
   -> m (ChainDB m blk, Internal m blk)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
index 817130540e..7a3ab68549 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
@@ -88,7 +88,7 @@ launchBgTasks
      , HasHardForkHistory blk
      , LgrDbSerialiseConstraints blk
      )
-  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  => LedgerEventHandler m (ExtLedgerState blk)
   -> ChainDbEnv m blk
   -> Word64 -- ^ Number of immutable blocks replayed on ledger DB startup
   -> m ()
@@ -528,7 +528,7 @@ addBlockRunner
      , HasHardForkHistory blk
      , HasCallStack
      )
-  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  => LedgerEventHandler m (ExtLedgerState blk)
   -> ChainDbEnv m blk
   -> m Void
 addBlockRunner handleLedgerEvent cdb@CDB{..} = forever $ do
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
index 4e8116c482..1802c5d62f 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
@@ -190,7 +190,7 @@ initialChainSelection immutableDB volatileDB lgrDB tracer cfg varInvalid
                     candidates) $
         assert (all (preferAnchoredCandidate bcfg curChain) candidates) $ do
           cse <- chainSelEnv
-          chainSelection (const $ pure ()) cse (Diff.extend <$> candidates)
+          chainSelection discardEvent cse (Diff.extend <$> candidates)
       where
         curChain = VF.validatedFragment curChainAndLedger
         ledger   = VF.validatedLedger   curChainAndLedger
@@ -261,7 +261,7 @@ addBlockSync
      , HasHardForkHistory blk
      , HasCallStack
      )
-  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  => LedgerEventHandler m (ExtLedgerState blk)
   -> ChainDbEnv m blk
   -> BlockToAdd m blk
   -> m ()
@@ -403,7 +403,7 @@ chainSelectionForFutureBlocks cdb@CDB{..} blockCache = do
       return $ Map.elems futureBlocks
     forM_ futureBlockHeaders $ \(hdr, punish) -> do
       traceWith tracer $ ChainSelectionForFutureBlock (headerRealPoint hdr)
-      chainSelectionForBlock (const $ pure ()) cdb blockCache hdr punish
+      chainSelectionForBlock discardEvent cdb blockCache hdr punish
     atomically $ Query.getTipPoint cdb
   where
     tracer = TraceAddBlockEvent >$< cdbTracer
@@ -448,7 +448,7 @@ chainSelectionForBlock
      , HasHardForkHistory blk
      , HasCallStack
      )
-  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  => LedgerEventHandler m (ExtLedgerState blk)
   -> ChainDbEnv m blk
   -> BlockCache blk
   -> Header blk
@@ -881,7 +881,7 @@ chainSelection
      , LedgerSupportsProtocol blk
      , HasCallStack
      )
-  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  => LedgerEventHandler m (ExtLedgerState blk)
   -> ChainSelEnv m blk
   -> NonEmpty (ChainDiff (Header blk))
   -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
@@ -1061,7 +1061,7 @@ ledgerValidateCandidate
      , LedgerSupportsProtocol blk
      , HasCallStack
      )
-  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  => LedgerEventHandler m (ExtLedgerState blk)
   -> ChainSelEnv m blk
   -> ChainDiff (Header blk)
   -> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
@@ -1223,7 +1223,7 @@ validateCandidate
      , LedgerSupportsProtocol blk
      , HasCallStack
      )
-  => (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+  => LedgerEventHandler m (ExtLedgerState blk)
   -> ChainSelEnv m blk
   -> ChainDiff (Header blk)
   -> m (ValidationResult blk)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
index 3e13ce23a7..091ff9d72f 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
@@ -327,16 +327,12 @@ data ValidateResult blk =
   | ValidateLedgerError      (LedgerDB.AnnLedgerError' blk)
   | ValidateExceededRollBack LedgerDB.ExceededRollback
 
-validate :: forall m blk.
-            ( IOLike m
-	    , LedgerSupportsProtocol blk
-	    , HasCallStack
-	    )
+validate :: forall m blk. (IOLike m, LedgerSupportsProtocol blk, HasCallStack)
          => LgrDB m blk
          -> LedgerDB' blk
             -- ^ This is used as the starting point for validation, not the one
             -- in the 'LgrDB'.
-         -> (AuxLedgerEvent (ExtLedgerState blk) -> m ())
+         -> LedgerEventHandler m (ExtLedgerState blk)
          -> BlockCache blk
          -> Word64  -- ^ How many blocks to roll back
          -> (LedgerDB.UpdateLedgerDbTraceEvent blk -> m ())
@@ -347,7 +343,7 @@ validate LgrDB{..} ledgerDB handleLedgerEvent blockCache numRollbacks trace = \h
     res <- fmap rewrap $ LedgerDB.defaultResolveWithErrors resolveBlock $
              LedgerDB.ledgerDbSwitch
                (LedgerDB.configLedgerDb cfg)
-               (lift . lift . handleLedgerEvent)
+               (natHandler lift $ natHandler lift $ handleLedgerEvent)
                numRollbacks
                (lift . lift . trace)
                aps
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs
index e9d6ee8307..f81b2125fa 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs
@@ -208,7 +208,7 @@ initStartingWith tracer cfg streamAPI initDb = do
   where
     push :: blk -> (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64)
     push blk !(!db, !replayed) = do
-        !db' <- ledgerDbPush cfg (const $ pure ()) (ReapplyVal blk) db
+        !db' <- ledgerDbPush cfg discardEvent (ReapplyVal blk) db
 
         let replayed' :: Word64
             !replayed' = replayed + 1
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
index a4c106827a..5e5b0b38a4 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
@@ -114,10 +114,10 @@ toRealPoint (Weaken ap)      = toRealPoint ap
 -- We take in the entire 'LedgerDB' because we record that as part of errors.
 applyBlock :: forall m c l blk. (ApplyBlock l blk, Monad m, c)
            => LedgerCfg l
-           -> (AuxLedgerEvent l -> m ())
+           -> LedgerEventHandler m l
            -> Ap m l blk c
            -> LedgerDB l -> m l
-applyBlock cfg handleLedgerEvent ap db = case ap of
+applyBlock cfg eventHandler@LedgerEventHandler{handleLedgerEvent} ap db = case ap of
     ReapplyVal b ->
       return $
         tickThenReapply cfg b l
@@ -135,7 +135,7 @@ applyBlock cfg handleLedgerEvent ap db = case ap of
       either (throwLedgerError db r) return $ runExcept $
         tickThenApply cfg b l
     Weaken ap' ->
-      applyBlock cfg handleLedgerEvent ap' db
+      applyBlock cfg eventHandler ap' db
   where
     l :: l
     l = ledgerDbCurrent db
@@ -296,7 +296,7 @@ data ExceededRollback = ExceededRollback {
 
 ledgerDbPush :: forall m c l blk. (ApplyBlock l blk, Monad m, c)
              => LedgerDbCfg l
-             -> (AuxLedgerEvent l -> m ())
+             -> LedgerEventHandler m l
              -> Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
 ledgerDbPush cfg handleLedgerEvent ap db =
     (\current' -> pushLedgerState (ledgerDbCfgSecParam cfg) current' db) <$>
@@ -306,7 +306,7 @@ ledgerDbPush cfg handleLedgerEvent ap db =
 ledgerDbPushMany ::
      forall m c l blk . (ApplyBlock l blk, Monad m, c)
   => (Pushing blk -> m ())
-  -> (AuxLedgerEvent l -> m ())
+  -> LedgerEventHandler m l
   -> LedgerDbCfg l
   -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
 ledgerDbPushMany trace handleLedgerEvent cfg aps initDb = (repeatedlyM pushAndTrace) aps initDb
@@ -319,7 +319,7 @@ ledgerDbPushMany trace handleLedgerEvent cfg aps initDb = (repeatedlyM pushAndTr
 -- | Switch to a fork
 ledgerDbSwitch :: (ApplyBlock l blk, Monad m, c)
                => LedgerDbCfg l
-               -> (AuxLedgerEvent l -> m ())
+               -> LedgerEventHandler m l
                -> Word64          -- ^ How many blocks to roll back
                -> (UpdateLedgerDbTraceEvent blk -> m ())
                -> [Ap m l blk c]  -- ^ New blocks to apply
@@ -379,18 +379,18 @@ pureBlock = ReapplyVal
 
 ledgerDbPush' :: ApplyBlock l blk
               => LedgerDbCfg l -> blk -> LedgerDB l -> LedgerDB l
-ledgerDbPush' cfg b = runIdentity . ledgerDbPush cfg (const $ pure ()) (pureBlock b)
+ledgerDbPush' cfg b = runIdentity . ledgerDbPush cfg discardEvent (pureBlock b)
 
 ledgerDbPushMany' :: ApplyBlock l blk
                   => LedgerDbCfg l -> [blk] -> LedgerDB l -> LedgerDB l
 ledgerDbPushMany' cfg bs =
-  runIdentity . ledgerDbPushMany (const $ pure ()) (const $ pure ()) cfg (map pureBlock bs)
+  runIdentity . ledgerDbPushMany (const $ pure ()) discardEvent cfg (map pureBlock bs)
 
 ledgerDbSwitch' :: forall l blk. ApplyBlock l blk
                 => LedgerDbCfg l
                 -> Word64 -> [blk] -> LedgerDB l -> Maybe (LedgerDB l)
 ledgerDbSwitch' cfg n bs db =
-    case runIdentity $ ledgerDbSwitch cfg (const $ pure ()) n (const $ pure ()) (map pureBlock bs) db of
+    case runIdentity $ ledgerDbSwitch cfg discardEvent n (const $ pure ()) (map pureBlock bs) db of
       Left  ExceededRollback{} -> Nothing
       Right db'                -> Just db'
 

From 68260b6df4685d96e491c38998b8fa9cbb0f86dc Mon Sep 17 00:00:00 2001
From: Arnaud Bailly <arnaud.bailly@iohk.io>
Date: Thu, 21 Sep 2023 10:17:34 +0200
Subject: [PATCH 07/15] Inject header hash and slotno into ledger events
 handler

---
 .../Ouroboros/Consensus/Ledger/Basics.hs                   | 7 ++++---
 .../Ouroboros/Consensus/Storage/LedgerDB/Update.hs         | 2 +-
 2 files changed, 5 insertions(+), 4 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
index 8ef281b8db..70ebd42293 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
@@ -171,13 +171,14 @@ applyChainTick = lrResult ..: applyChainTickLedgerResult
 
 
 -- | Handler for ledger events
-newtype LedgerEventHandler m l = LedgerEventHandler { handleLedgerEvent :: AuxLedgerEvent l -> m () }
+newtype LedgerEventHandler m l =
+  LedgerEventHandler { handleLedgerEvent :: HeaderHash l -> SlotNo -> AuxLedgerEvent l -> m () }
 
 natHandler :: (m () -> n ()) -> LedgerEventHandler m l -> LedgerEventHandler n l
-natHandler nat LedgerEventHandler{handleLedgerEvent} = LedgerEventHandler (nat . handleLedgerEvent)
+natHandler nat LedgerEventHandler{handleLedgerEvent} = LedgerEventHandler (\ h s -> nat . handleLedgerEvent h s)
 
 discardEvent :: Applicative m => LedgerEventHandler m l
-discardEvent = LedgerEventHandler { handleLedgerEvent = const $ pure () }
+discardEvent = LedgerEventHandler { handleLedgerEvent = \ _ _ _ -> pure () }
 
 {-------------------------------------------------------------------------------
   Link block to its ledger
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
index 5e5b0b38a4..b24f1f12be 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
@@ -124,7 +124,7 @@ applyBlock cfg eventHandler@LedgerEventHandler{handleLedgerEvent} ap db = case a
     ApplyVal b -> do
       result <- either (throwLedgerError db (blockRealPoint b)) return $ runExcept $
         tickThenApplyLedgerResult cfg b l
-      mapM_ handleLedgerEvent (lrEvents result)
+      mapM_ (handleLedgerEvent (headerFieldHash $ getHeaderFields b) (headerFieldSlot $ getHeaderFields b)) (lrEvents result)
       return (lrResult result)
     ReapplyRef r  -> do
       b <- doResolveBlock r

From 26cfb9666efd78692912fbdcc41e927f64f282ae Mon Sep 17 00:00:00 2001
From: Arnaud Bailly <arnaud.bailly@iohk.io>
Date: Thu, 21 Sep 2023 14:07:37 +0200
Subject: [PATCH 08/15] Fix more tests

---
 .../src/tools/Cardano/Tools/DBAnalyser/Run.hs                 | 3 ++-
 .../src/tools/Cardano/Tools/DBSynthesizer/Run.hs              | 3 ++-
 .../src/diffusion-testlib/Test/ThreadNet/Network.hs           | 2 +-
 .../Test/Consensus/MiniProtocol/BlockFetch/Client.hs          | 3 ++-
 .../Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs     | 3 ++-
 .../Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs      | 3 ++-
 .../Test/Ouroboros/Storage/ChainDB/StateMachine.hs            | 3 ++-
 .../storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs    | 4 +++-
 8 files changed, 16 insertions(+), 8 deletions(-)

diff --git a/ouroboros-consensus-cardano/src/tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/tools/Cardano/Tools/DBAnalyser/Run.hs
index c9e1b756f3..d1476a3215 100644
--- a/ouroboros-consensus-cardano/src/tools/Cardano/Tools/DBAnalyser/Run.hs
+++ b/ouroboros-consensus-cardano/src/tools/Cardano/Tools/DBAnalyser/Run.hs
@@ -16,6 +16,7 @@ import qualified Debug.Trace as Debug
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
+import           Ouroboros.Consensus.Ledger.Basics
 import           Ouroboros.Consensus.Ledger.Extended
 import qualified Ouroboros.Consensus.Ledger.SupportsMempool as LedgerSupportsMempool
                      (HasTxs)
@@ -105,7 +106,7 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo
             putStrLn $ "ImmutableDB tip: " ++ show tipPoint
             pure result
         SelectChainDB ->
-          ChainDB.withDB chainDbArgs $ \chainDB -> do
+          ChainDB.withDB discardEvent chainDbArgs $ \chainDB -> do
             result <- runAnalysis analysis $ AnalysisEnv {
                 cfg
               , initLedger = genesisLedger
diff --git a/ouroboros-consensus-cardano/src/tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/tools/Cardano/Tools/DBSynthesizer/Run.hs
index 21f37b6c84..7c30fdb59a 100644
--- a/ouroboros-consensus-cardano/src/tools/Cardano/Tools/DBSynthesizer/Run.hs
+++ b/ouroboros-consensus-cardano/src/tools/Cardano/Tools/DBSynthesizer/Run.hs
@@ -23,6 +23,7 @@ import           Data.Bool (bool)
 import           Data.ByteString as BS (ByteString, readFile)
 import           Ouroboros.Consensus.Config (configSecurityParam, configStorage)
 import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture (dontCheck)
+import           Ouroboros.Consensus.Ledger.Basics (discardEvent)
 import qualified Ouroboros.Consensus.Node as Node (mkChainDbArgs,
                      stdMkChainDbHasFS)
 import qualified Ouroboros.Consensus.Node.InitStorage as Node
@@ -131,7 +132,7 @@ synthesize DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} (Some
                 putStrLn $ "--> opening ChainDB on file system with mode: " ++ show synthOpenMode
                 preOpenChainDB synthOpenMode confDbDir
                 let dbTracer = nullTracer
-                ChainDB.withDB dbArgs {ChainDB.cdbTracer = dbTracer} $ \chainDB -> do
+                ChainDB.withDB discardEvent dbArgs {ChainDB.cdbTracer = dbTracer} $ \chainDB -> do
                     slotNo <- do
                         tip <- atomically (ChainDB.getTipPoint chainDB)
                         pure $ case pointSlot tip of
diff --git a/ouroboros-consensus-diffusion/src/diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/diffusion-testlib/Test/ThreadNet/Network.hs
index 24500c92fb..03d00ba1a7 100644
--- a/ouroboros-consensus-diffusion/src/diffusion-testlib/Test/ThreadNet/Network.hs
+++ b/ouroboros-consensus-diffusion/src/diffusion-testlib/Test/ThreadNet/Network.hs
@@ -800,7 +800,7 @@ runThreadNetwork systemTime ThreadNetworkArgs
             nodeInfoDBs
             coreNodeId
       chainDB <- snd <$>
-        allocate registry (const (ChainDB.openDB chainDbArgs)) ChainDB.closeDB
+        allocate registry (const (ChainDB.openDB discardEvent chainDbArgs)) ChainDB.closeDB
 
       let customForgeBlock ::
                BlockForging m blk
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs
index fd3730d115..27e9ebb7ff 100644
--- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs
@@ -34,6 +34,7 @@ import           Data.Traversable (for)
 import           Network.TypedProtocol.Codec (AnyMessageAndAgency (..))
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.Ledger.Basics (discardEvent)
 import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface
 import           Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..))
 import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
@@ -248,7 +249,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do
         (_, (chainDB, ChainDBImpl.Internal{intAddBlockRunner})) <-
           allocate
             registry
-            (\_ -> ChainDBImpl.openDBInternal chainDbArgs False)
+            (\_ -> ChainDBImpl.openDBInternal discardEvent chainDbArgs False)
             (ChainDB.closeDB . fst)
         _ <- forkLinkedThread registry "AddBlockRunner" intAddBlockRunner
 
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
index 7f480077c0..14a4be0fb5 100644
--- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
+++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
@@ -29,6 +29,7 @@ import           Ouroboros.Consensus.BlockchainTime
 import           Ouroboros.Consensus.Config
 import qualified Ouroboros.Consensus.HardFork.History as HardFork
 import           Ouroboros.Consensus.Ledger.Extended
+import           Ouroboros.Consensus.Ledger.Basics(discardEvent)
 import           Ouroboros.Consensus.Ledger.Query (Query (..))
 import           Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server
 import           Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..))
@@ -193,7 +194,7 @@ initLgrDB k chain = do
     varDB          <- newTVarIO genesisLedgerDB
     varPrevApplied <- newTVarIO mempty
     let lgrDB = mkLgrDB varDB varPrevApplied resolve args
-    LgrDB.validate lgrDB genesisLedgerDB (const $ pure ()) BlockCache.empty 0 noopTrace
+    LgrDB.validate lgrDB genesisLedgerDB discardEvent BlockCache.empty 0 noopTrace
       (map getHeader (Chain.toOldestFirst chain)) >>= \case
         LgrDB.ValidateExceededRollBack _ ->
           error "impossible: rollback was 0"
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs
index bb8b346b41..79f2a569c4 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs
@@ -30,6 +30,7 @@ import qualified Data.Set as Set
 import           Data.Time.Clock (secondsToDiffTime)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.Ledger.Basics (discardEvent)
 import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
 import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
 import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as Punishment
@@ -178,7 +179,7 @@ runFollowerPromptnessTest FollowerPromptnessTestSetup{..} = withRegistry \regist
         (_, (chainDB, ChainDBImpl.Internal{intAddBlockRunner})) <-
           allocate
             registry
-            (\_ -> ChainDBImpl.openDBInternal chainDbArgs False)
+            (\_ -> ChainDBImpl.openDBInternal discardEvent chainDbArgs False)
             (ChainDB.closeDB . fst)
         _ <- forkLinkedThread registry "AddBlockRunner" intAddBlockRunner
         pure chainDB
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
index 6f077fa5fb..5f2d2aa1b7 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
@@ -107,6 +107,7 @@ import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
 import           Ouroboros.Consensus.HardFork.Abstract
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
+import           Ouroboros.Consensus.Ledger.Basics
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.Inspect
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
@@ -365,7 +366,7 @@ open
   :: (IOLike m, TestConstraints blk)
   => ChainDbArgs Identity m blk -> m (ChainDBState m blk)
 open args = do
-    (chainDB, internal) <- openDBInternal args False
+    (chainDB, internal) <- openDBInternal discardEvent args False
     addBlockAsync       <- async (intAddBlockRunner internal)
     link addBlockAsync
     return ChainDBState { chainDB, internal, addBlockAsync }
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs
index 8cf08e82e4..ecadbb24a3 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs
@@ -62,6 +62,7 @@ import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.Abstract
+import           Ouroboros.Consensus.Ledger.Basics
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Storage.LedgerDB
 import           Ouroboros.Consensus.Util
@@ -734,6 +735,7 @@ runDB standalone@DB{..} cmd =
             defaultThrowLedgerErrors $
               ledgerDbPush
                 dbLedgerDbCfg
+                discardEvent
                 (ApplyVal b)
                 db
     go _ (Switch n bs) = do
@@ -744,7 +746,7 @@ runDB standalone@DB{..} cmd =
             defaultResolveWithErrors dbResolve $
               ledgerDbSwitch
                 dbLedgerDbCfg
-                (const $ pure ())
+                discardEvent
                 n
                 (const $ pure ())
                 (map ApplyVal bs)

From 808b7f699efe5b128068465a3c57f9111d9748b3 Mon Sep 17 00:00:00 2001
From: Konstantinos Lambrou-Latreille <konstantinos.lambrou@iohk.io>
Date: Wed, 4 Oct 2023 09:10:29 -0400
Subject: [PATCH 09/15] WIP: does not compile

---
 .../ouroboros-consensus-diffusion.cabal                     | 2 +-
 .../Ouroboros/Consensus/Ledger/Basics.hs                    | 6 +++---
 .../Ouroboros/Consensus/Storage/LedgerDB/Update.hs          | 6 +++++-
 3 files changed, 9 insertions(+), 5 deletions(-)

diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
index 31b69efca2..7964d073d0 100644
--- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
+++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
@@ -112,7 +112,7 @@ library
     , io-classes                   ^>=1.1
     , mtl                          ^>=2.2
     , ouroboros-consensus          ^>=0.7
-    , ouroboros-network            ^>=0.8
+    , ouroboros-network            ^>=0.7
     , ouroboros-network-api        ^>=0.5
     , ouroboros-network-framework  ^>=0.6
     , ouroboros-network-protocols  ^>=0.5
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
index 70ebd42293..0675adc852 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
@@ -172,13 +172,13 @@ applyChainTick = lrResult ..: applyChainTickLedgerResult
 
 -- | Handler for ledger events
 newtype LedgerEventHandler m l =
-  LedgerEventHandler { handleLedgerEvent :: HeaderHash l -> SlotNo -> AuxLedgerEvent l -> m () }
+  LedgerEventHandler { handleLedgerEvent :: ChainHash l -> HeaderHash l -> SlotNo -> AuxLedgerEvent l -> m () }
 
 natHandler :: (m () -> n ()) -> LedgerEventHandler m l -> LedgerEventHandler n l
-natHandler nat LedgerEventHandler{handleLedgerEvent} = LedgerEventHandler (\ h s -> nat . handleLedgerEvent h s)
+natHandler nat LedgerEventHandler{handleLedgerEvent} = LedgerEventHandler (\ph h s -> nat . handleLedgerEvent ph h s)
 
 discardEvent :: Applicative m => LedgerEventHandler m l
-discardEvent = LedgerEventHandler { handleLedgerEvent = \ _ _ _ -> pure () }
+discardEvent = LedgerEventHandler { handleLedgerEvent = \_ _ _ _ -> pure () }
 
 {-------------------------------------------------------------------------------
   Link block to its ledger
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
index b24f1f12be..572423d7e6 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
@@ -124,7 +124,11 @@ applyBlock cfg eventHandler@LedgerEventHandler{handleLedgerEvent} ap db = case a
     ApplyVal b -> do
       result <- either (throwLedgerError db (blockRealPoint b)) return $ runExcept $
         tickThenApplyLedgerResult cfg b l
-      mapM_ (handleLedgerEvent (headerFieldHash $ getHeaderFields b) (headerFieldSlot $ getHeaderFields b)) (lrEvents result)
+      forM_ (lrEvents result) $
+        handleLedgerEvent
+          (headerPrevHash b) -- TODO This line doesn't work with: "Reduction stack overflow; size = 201"
+          (headerFieldHash $ getHeaderFields b)
+          (headerFieldSlot $ getHeaderFields b)
       return (lrResult result)
     ReapplyRef r  -> do
       b <- doResolveBlock r

From e39f52488024d22ed10fad94c1e9cfe37ea8e520 Mon Sep 17 00:00:00 2001
From: Konstantinos Lambrou-Latreille <konstantinos.lambrou@iohk.io>
Date: Wed, 4 Oct 2023 13:58:59 -0400
Subject: [PATCH 10/15] Added previous block header hash and current block no
 to LedgerEventHandler

---
 .../Ouroboros/Consensus/Ledger/Abstract.hs    |  1 +
 .../Ouroboros/Consensus/Ledger/Basics.hs      | 25 ++++++++++++-------
 .../Consensus/Storage/ChainDB/Impl.hs         |  6 ++---
 .../Storage/ChainDB/Impl/Background.hs        |  4 +--
 .../Storage/ChainDB/Impl/ChainSel.hs          | 10 ++++----
 .../Consensus/Storage/ChainDB/Impl/LgrDB.hs   |  2 +-
 .../Consensus/Storage/LedgerDB/Update.hs      | 13 +++++-----
 .../Ouroboros/Storage/ChainDB/StateMachine.hs |  1 -
 .../Test/Ouroboros/Storage/LedgerDB/OnDisk.hs |  1 -
 9 files changed, 35 insertions(+), 28 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs
index 51708f2d60..3eee9818ee 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs
@@ -75,6 +75,7 @@ class ( IsLedger l
       , HeaderHash l ~ HeaderHash blk
       , HasHeader blk
       , HasHeader (Header blk)
+      , GetPrevHash blk
       ) => ApplyBlock l blk where
 
   -- | Apply a block to the ledger state.
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
index 0675adc852..7c5af9c828 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
@@ -169,16 +169,23 @@ class ( -- Requirements on the ledger state itself
 applyChainTick :: IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
 applyChainTick = lrResult ..: applyChainTickLedgerResult
 
-
 -- | Handler for ledger events
-newtype LedgerEventHandler m l =
-  LedgerEventHandler { handleLedgerEvent :: ChainHash l -> HeaderHash l -> SlotNo -> AuxLedgerEvent l -> m () }
-
-natHandler :: (m () -> n ()) -> LedgerEventHandler m l -> LedgerEventHandler n l
-natHandler nat LedgerEventHandler{handleLedgerEvent} = LedgerEventHandler (\ph h s -> nat . handleLedgerEvent ph h s)
-
-discardEvent :: Applicative m => LedgerEventHandler m l
-discardEvent = LedgerEventHandler { handleLedgerEvent = \_ _ _ _ -> pure () }
+newtype LedgerEventHandler m l blk =
+  LedgerEventHandler
+    { handleLedgerEvent
+        :: ChainHash blk -- Previous block header hash
+        -> HeaderHash l -- Block header hash of the applied block
+        -> SlotNo -- Slot number of the applied block
+        -> BlockNo -- Applied block number
+        -> AuxLedgerEvent l -- Resulting 'AuxLedgerEvent' after applying `applyBlock`.
+        -> m ()
+    }
+
+natHandler :: (m () -> n ()) -> LedgerEventHandler m l blk -> LedgerEventHandler n l blk
+natHandler nat LedgerEventHandler{handleLedgerEvent} = LedgerEventHandler (\ph h s bn -> nat . handleLedgerEvent ph h s bn)
+
+discardEvent :: Applicative m => LedgerEventHandler m l blk
+discardEvent = LedgerEventHandler { handleLedgerEvent = \_ _ _ _ _ -> pure () }
 
 {-------------------------------------------------------------------------------
   Link block to its ledger
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
index aa482d93e4..0f477dd30f 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -87,7 +87,7 @@ withDB
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
      )
-  => LedgerEventHandler m (ExtLedgerState blk)
+  => LedgerEventHandler m (ExtLedgerState blk) blk
   -> ChainDbArgs Identity m blk
   -> (ChainDB m blk -> m a)
   -> m a
@@ -102,7 +102,7 @@ openDB
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
      )
-  => LedgerEventHandler m (ExtLedgerState blk)
+  => LedgerEventHandler m (ExtLedgerState blk) blk
   -> ChainDbArgs Identity m blk
   -> m (ChainDB m blk)
 openDB handleLedgerEvent args =
@@ -117,7 +117,7 @@ openDBInternal
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
      )
-  => LedgerEventHandler m (ExtLedgerState blk)
+  => LedgerEventHandler m (ExtLedgerState blk) blk
   -> ChainDbArgs Identity m blk
   -> Bool -- ^ 'True' = Launch background tasks
   -> m (ChainDB m blk, Internal m blk)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
index 7a3ab68549..6237313e73 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs
@@ -88,7 +88,7 @@ launchBgTasks
      , HasHardForkHistory blk
      , LgrDbSerialiseConstraints blk
      )
-  => LedgerEventHandler m (ExtLedgerState blk)
+  => LedgerEventHandler m (ExtLedgerState blk) blk
   -> ChainDbEnv m blk
   -> Word64 -- ^ Number of immutable blocks replayed on ledger DB startup
   -> m ()
@@ -528,7 +528,7 @@ addBlockRunner
      , HasHardForkHistory blk
      , HasCallStack
      )
-  => LedgerEventHandler m (ExtLedgerState blk)
+  => LedgerEventHandler m (ExtLedgerState blk) blk
   -> ChainDbEnv m blk
   -> m Void
 addBlockRunner handleLedgerEvent cdb@CDB{..} = forever $ do
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
index 1802c5d62f..40e8e7fd33 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
@@ -261,7 +261,7 @@ addBlockSync
      , HasHardForkHistory blk
      , HasCallStack
      )
-  => LedgerEventHandler m (ExtLedgerState blk)
+  => LedgerEventHandler m (ExtLedgerState blk) blk
   -> ChainDbEnv m blk
   -> BlockToAdd m blk
   -> m ()
@@ -448,7 +448,7 @@ chainSelectionForBlock
      , HasHardForkHistory blk
      , HasCallStack
      )
-  => LedgerEventHandler m (ExtLedgerState blk)
+  => LedgerEventHandler m (ExtLedgerState blk) blk
   -> ChainDbEnv m blk
   -> BlockCache blk
   -> Header blk
@@ -881,7 +881,7 @@ chainSelection
      , LedgerSupportsProtocol blk
      , HasCallStack
      )
-  => LedgerEventHandler m (ExtLedgerState blk)
+  => LedgerEventHandler m (ExtLedgerState blk) blk
   -> ChainSelEnv m blk
   -> NonEmpty (ChainDiff (Header blk))
   -> m (Maybe (ValidatedChainDiff (Header blk) (LedgerDB' blk)))
@@ -1061,7 +1061,7 @@ ledgerValidateCandidate
      , LedgerSupportsProtocol blk
      , HasCallStack
      )
-  => LedgerEventHandler m (ExtLedgerState blk)
+  => LedgerEventHandler m (ExtLedgerState blk) blk
   -> ChainSelEnv m blk
   -> ChainDiff (Header blk)
   -> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
@@ -1223,7 +1223,7 @@ validateCandidate
      , LedgerSupportsProtocol blk
      , HasCallStack
      )
-  => LedgerEventHandler m (ExtLedgerState blk)
+  => LedgerEventHandler m (ExtLedgerState blk) blk
   -> ChainSelEnv m blk
   -> ChainDiff (Header blk)
   -> m (ValidationResult blk)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
index 091ff9d72f..dc2054295f 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
@@ -332,7 +332,7 @@ validate :: forall m blk. (IOLike m, LedgerSupportsProtocol blk, HasCallStack)
          -> LedgerDB' blk
             -- ^ This is used as the starting point for validation, not the one
             -- in the 'LgrDB'.
-         -> LedgerEventHandler m (ExtLedgerState blk)
+         -> LedgerEventHandler m (ExtLedgerState blk) blk
          -> BlockCache blk
          -> Word64  -- ^ How many blocks to roll back
          -> (LedgerDB.UpdateLedgerDbTraceEvent blk -> m ())
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
index 572423d7e6..69c3ad2c09 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
@@ -114,7 +114,7 @@ toRealPoint (Weaken ap)      = toRealPoint ap
 -- We take in the entire 'LedgerDB' because we record that as part of errors.
 applyBlock :: forall m c l blk. (ApplyBlock l blk, Monad m, c)
            => LedgerCfg l
-           -> LedgerEventHandler m l
+           -> LedgerEventHandler m l blk
            -> Ap m l blk c
            -> LedgerDB l -> m l
 applyBlock cfg eventHandler@LedgerEventHandler{handleLedgerEvent} ap db = case ap of
@@ -126,9 +126,10 @@ applyBlock cfg eventHandler@LedgerEventHandler{handleLedgerEvent} ap db = case a
         tickThenApplyLedgerResult cfg b l
       forM_ (lrEvents result) $
         handleLedgerEvent
-          (headerPrevHash b) -- TODO This line doesn't work with: "Reduction stack overflow; size = 201"
+          (headerPrevHash $ getHeader b)
           (headerFieldHash $ getHeaderFields b)
           (headerFieldSlot $ getHeaderFields b)
+          (headerFieldBlockNo $ getHeaderFields b)
       return (lrResult result)
     ReapplyRef r  -> do
       b <- doResolveBlock r
@@ -300,7 +301,7 @@ data ExceededRollback = ExceededRollback {
 
 ledgerDbPush :: forall m c l blk. (ApplyBlock l blk, Monad m, c)
              => LedgerDbCfg l
-             -> LedgerEventHandler m l
+             -> LedgerEventHandler m l blk
              -> Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
 ledgerDbPush cfg handleLedgerEvent ap db =
     (\current' -> pushLedgerState (ledgerDbCfgSecParam cfg) current' db) <$>
@@ -310,7 +311,7 @@ ledgerDbPush cfg handleLedgerEvent ap db =
 ledgerDbPushMany ::
      forall m c l blk . (ApplyBlock l blk, Monad m, c)
   => (Pushing blk -> m ())
-  -> LedgerEventHandler m l
+  -> LedgerEventHandler m l blk
   -> LedgerDbCfg l
   -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
 ledgerDbPushMany trace handleLedgerEvent cfg aps initDb = (repeatedlyM pushAndTrace) aps initDb
@@ -323,7 +324,7 @@ ledgerDbPushMany trace handleLedgerEvent cfg aps initDb = (repeatedlyM pushAndTr
 -- | Switch to a fork
 ledgerDbSwitch :: (ApplyBlock l blk, Monad m, c)
                => LedgerDbCfg l
-               -> LedgerEventHandler m l
+               -> LedgerEventHandler m l blk
                -> Word64          -- ^ How many blocks to roll back
                -> (UpdateLedgerDbTraceEvent blk -> m ())
                -> [Ap m l blk c]  -- ^ New blocks to apply
@@ -342,7 +343,7 @@ ledgerDbSwitch cfg handleLedgerEvent numRollbacks trace newBlocks db =
         (firstBlock:_) -> do
           let start   = PushStart . toRealPoint $ firstBlock
               goal    = PushGoal  . toRealPoint . last $ newBlocks
-          Right <$> ledgerDbPushMany (trace . (StartedPushingBlockToTheLedgerDb start goal))
+          Right <$> ledgerDbPushMany (trace . StartedPushingBlockToTheLedgerDb start goal)
                                      handleLedgerEvent
                                      cfg
                                      newBlocks
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
index 5f2d2aa1b7..1d4a13eec8 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
@@ -107,7 +107,6 @@ import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
 import           Ouroboros.Consensus.HardFork.Abstract
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
-import           Ouroboros.Consensus.Ledger.Basics
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.Inspect
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs
index ecadbb24a3..c0c65338ba 100644
--- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs
+++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs
@@ -62,7 +62,6 @@ import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.Abstract
-import           Ouroboros.Consensus.Ledger.Basics
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Storage.LedgerDB
 import           Ouroboros.Consensus.Util

From c47837788c96d67c01babcb0e272c4d5ad596df3 Mon Sep 17 00:00:00 2001
From: Konstantinos Lambrou-Latreille <konstantinos.lambrou@iohk.io>
Date: Wed, 4 Oct 2023 14:13:10 -0400
Subject: [PATCH 11/15] Changed LedgerEventHandler to emit a list of
 AuxLedgerEvents so that clients can now if a rollback occurred, or if they
 missed an event.

---
 .../Ouroboros/Consensus/Ledger/Basics.hs             |  2 +-
 .../Ouroboros/Consensus/Storage/LedgerDB/Update.hs   | 12 ++++++------
 2 files changed, 7 insertions(+), 7 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
index 7c5af9c828..1646c161c0 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs
@@ -177,7 +177,7 @@ newtype LedgerEventHandler m l blk =
         -> HeaderHash l -- Block header hash of the applied block
         -> SlotNo -- Slot number of the applied block
         -> BlockNo -- Applied block number
-        -> AuxLedgerEvent l -- Resulting 'AuxLedgerEvent' after applying `applyBlock`.
+        -> [AuxLedgerEvent l] -- Resulting 'AuxLedgerEvent's after applying `applyBlock`.
         -> m ()
     }
 
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
index 69c3ad2c09..8d04f68c96 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs
@@ -124,12 +124,12 @@ applyBlock cfg eventHandler@LedgerEventHandler{handleLedgerEvent} ap db = case a
     ApplyVal b -> do
       result <- either (throwLedgerError db (blockRealPoint b)) return $ runExcept $
         tickThenApplyLedgerResult cfg b l
-      forM_ (lrEvents result) $
-        handleLedgerEvent
-          (headerPrevHash $ getHeader b)
-          (headerFieldHash $ getHeaderFields b)
-          (headerFieldSlot $ getHeaderFields b)
-          (headerFieldBlockNo $ getHeaderFields b)
+      handleLedgerEvent
+        (headerPrevHash $ getHeader b)
+        (headerFieldHash $ getHeaderFields b)
+        (headerFieldSlot $ getHeaderFields b)
+        (headerFieldBlockNo $ getHeaderFields b)
+        (lrEvents result)
       return (lrResult result)
     ReapplyRef r  -> do
       b <- doResolveBlock r

From 8c139ede8cb13a830818a4092227d6a501f52449 Mon Sep 17 00:00:00 2001
From: Konstantinos Lambrou-Latreille <konstantinos.lambrou@iohk.io>
Date: Wed, 4 Oct 2023 16:00:26 -0400
Subject: [PATCH 12/15] Allow ouroboros-network-0.8.x

---
 .../ouroboros-consensus-diffusion.cabal                         | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
index 7964d073d0..cce18736fd 100644
--- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
+++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
@@ -112,7 +112,7 @@ library
     , io-classes                   ^>=1.1
     , mtl                          ^>=2.2
     , ouroboros-consensus          ^>=0.7
-    , ouroboros-network            ^>=0.7
+    , ouroboros-network            >=0.7 && <0.8 || ^>=0.8
     , ouroboros-network-api        ^>=0.5
     , ouroboros-network-framework  ^>=0.6
     , ouroboros-network-protocols  ^>=0.5

From 2fe143f6750180aac22c13d64efa5f0caabe4d89 Mon Sep 17 00:00:00 2001
From: Konstantinos Lambrou-Latreille <konstantinos.lambrou@iohk.io>
Date: Thu, 5 Oct 2023 15:49:53 -0400
Subject: [PATCH 13/15] Fix broken ouroboros-consensus-diffusion with missing
 'blk' type parameter for LedgerEventHandler

---
 .../ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
index 11d061ccb4..5a49ff8d11 100644
--- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
+++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs
@@ -183,7 +183,7 @@ data RunNodeArgs m addrNTN addrNTC blk (p2p :: Diffusion.P2P) = RunNodeArgs {
     , rnPeerSharing :: PeerSharing
 
       -- | An event handler to trigger custom action when ledger events are emitted.
-    , rnHandleLedgerEvent :: LedgerEventHandler m (ExtLedgerState blk)
+    , rnHandleLedgerEvent :: LedgerEventHandler m (ExtLedgerState blk) blk
     }
 
 -- | Arguments that usually only tests /directly/ specify.
@@ -576,7 +576,7 @@ stdWithCheckedDB pb databasePath networkMagic body = do
 
 openChainDB
   :: forall m blk. (RunNode blk, IOLike m)
-  => LedgerEventHandler m (ExtLedgerState blk)
+  => LedgerEventHandler m (ExtLedgerState blk) blk
   -> ResourceRegistry m
   -> CheckInFuture m blk
   -> TopLevelConfig blk

From 1ffb2fa2df0254824e3bac399af5191067632a0b Mon Sep 17 00:00:00 2001
From: Arnaud Bailly <arnaud.bailly@iohk.io>
Date: Thu, 26 Oct 2023 15:38:47 +0200
Subject: [PATCH 14/15] Incorporate design document

fix #440
---
 docs/DONOTMERGE/pr-402.md | 114 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 114 insertions(+)
 create mode 100644 docs/DONOTMERGE/pr-402.md

diff --git a/docs/DONOTMERGE/pr-402.md b/docs/DONOTMERGE/pr-402.md
new file mode 100644
index 0000000000..e113c211a4
--- /dev/null
+++ b/docs/DONOTMERGE/pr-402.md
@@ -0,0 +1,114 @@
+# How to provide ledger events to client apps
+
+## Introduction
+
+On Thursday Oct 12, we discussed [PR #402](https://github.com/input-output-hk/ouroboros-consensus/pull/402) during the Consensus Office Hours.
+@KtorZ @koslambrou @kderme @nfrisby @amesgen did most of the talking.
+UTxO HD came up, so @jasagredo likely also would have been in that list if he hadn't been on a bank holiday.
+
+This document captures the key points of the discussion.
+
+## Executive summary
+
+- The Consensus Team considers this PR itself innocuous, because we don't anticipate it being difficult to review or to maintain or to design around (famous last words?).
+- However, there is one axis along which we think it is under-specified, and so our above judgement would be revisited after _the exact necessary semantics_ of `rnHandleLedgerEvent`  are better identified.
+- During the call we discussed some possible semantics of `rnHandleLedgerEvent`.
+  The "simple" one (which _we think_ this PR currently satisfies) would be easy for Consensus to maintain, but offloads a significant amount of complexity to the ultimate client.
+  The "complex" one relieves the clients of that burden, but would require a significantly larger PR here.
+- We are concerned that the "simple" semantics would let us merge this PR, but then _eventually_ no one would actually use the `rnHandleLedgerEvent` interface because the required client complexity is too hard.
+  We are hesitant to expand the Consensus interface (even with the "simple" semantics) if there's a clearly-plausible path to it becoming dead code in the near-future (there's only so much dev power available, it should ideally be allocated to long-lived aka "long-term" solutions).
+
+## Requirements
+
+Any complete solution for the needs of the relevant client applications _must_ handle all three of the following tasks.
+
+- staying synced with a node when its selection gains some blocks
+- staying synced with a node when its selection loses some blocks, aka rollbacks
+- becoming synced with a node
+- block-producing nodes must be able to completely disable this feature, with no residual cost
+
+The primary desiderata are as follows.
+
+- The client can be implemented in any language (ie without having to re-implement the ledger rules, which are currently only available in Haskell).
+- The client has access to the per-block ledger events, or at least the ones known to be desirable (eg calculated rewards and calculated stake distributions).
+- The client need not hold its own copy of the ledger state in memory.
+  (UTxO HD is related, but does not necessarily completely remove this concern.)
+
+## Solution Space
+
+Today's primary options are as follows.
+
+- Use ChainSync to follow the chain, and maintain a second copy of the ledger state.
+    - REQUIREMENT VIOLATION: This can only be implemented in Haskell.
+    - REQUIREMENT VIOLATION: This violates the desideratum regarding holding second copy of the ledger state in memory.
+      As of UTxO HD, the major portions of those two ledger states would be on disk instead of memory, but there'd still need to be two copies (later development could _maybe_ allow sharing the disk part).
+    - To handle rollbacks, the client would also need to maintain its own copy of Consensus's `LedgerDB` abstraction.
+    - (The [`foldBlocks`](https://input-output-hk.github.io/cardano-node/cardano-api/lib/Cardano-Api-LedgerState.html#v:foldBlocks) approach does this, but only for the immutable chain.)
+
+- Piggy-back on a `db-sync` instance.
+    - REQUIREMENT VIOLATION: This violates the desideratum regarding holding second copy of the ledger state in memory.
+    - @kderme remarked that he and @jasagredo charted a path towards using UTxO HD to ameliorate the memory cost, as sketched in the ChainSync option above.
+    - @KtorZ remarked that `db-sync` currently requires hundreds of gigabytes of disk, so that is also client app burden for this approach.
+
+- Rely on PR #402's `rnHandleLedgerEvent` et al.
+    - REQUIREMENT VIOLATION: This violates the desideratum about becoming synced with a node.
+      The only workaround at the moment is to restart the node and force it to re-apply whichver historical blocks the client needs to process.
+      Moreover, currently, the only way to force the node to do so is to delete certains parts of its on-disk state!
+    - To handle rollbacks, the client would also need to maintain something akin to Consensus's `LedgerDB` abstraction, but more lightweight since its elements need not be entire Cardano ledger states.
+    - @kderme also remarked that `db-sync` only uses the ledger events for so much, and so still relies on the ledger state itself for the rest; this suggests that the blocks and their ledger events alone might not suffice for clients.
+
+The envisioned longer-term solutions are as follows.
+
+- Enrich the node to permanently store ledger events alongside blocks.
+    - Then the ChainSync approach above could simply serve ledger events alongside the blocks.
+    - This solution would very explicitly violate the design principles of the node, since this is non-trivial logic in the node that is absolutely not required for the core functionality of the blockchain itself.
+    - Also: what happens if the specification of ledger events for some block changes (eg a new ledger event is added)?
+
+- If a client is already maintaing the UTxO map (as does `db-sync`), then the release of UTxO HD might allow that app to avoid the UTxO-related heap costs of the ledger state---it could implement its own UTxO HD `BackingStore`.
+    - REQUIREMENT VIOLATION: This can only be implemented in Haskell.
+
+- Release a minimal proxy that uses the existing ChainSync approach above in order to maintain a database mapping blocks (ie slot and hash) to ledger events.
+    - This technically violates the second copy of ledger state in memory requirement.
+      However, the database should be reused among clients, which would amortize that RAM cost.
+    - This proxy and its database would be another point of failure in the client's architecture.
+          - However, the tool's code and its deployment scripts should be _very_ simple.
+            And the overall community could maintain redundant instances for the sake of resiliency.
+          - Still, the running client app would need to trust the database.
+    - Also: what happens if the specification of ledger events for some block changes (eg a new ledger event is added)?
+
+## Action Items
+
+All of these relate to the solution based on PR #402.
+
+- @KtorZ will write up documentation for client-app developers to read that explains the system's guarantees, which are the requirements for the Cardano code.
+    - @nfrisby asked that it be roughly divided into four parts: burdens on the Ledger Team (eg they will likely need to handle requests to extend/refine ledger events), burdens on the Consensus Team (eg maintaining sufficient behavior of `rnHandleLedgerEvent`), burdens on the Node Team (eg the new TCP endpoint), and everything else---to whatever extent would not interfere with that document remaining useful to the client app developer.
+    - @nfrisby didn't ask this during the call but should have: requirements on the user code (eg don't DoS that TCP endpoint!).
+    - One point of emphasis in that document would be guidance for how the client should recognize and handle rollbacks.
+      Such logic in the client is required unless the only ledger event parts the client needs are "stable", in which case rollbacks can't change them.
+    - @kderme also suggested that this should explain how we foresee the ledger events themselves evolving (eg do client developers open PR's against `cardano-ledger`?).
+      (So far, all ledger events have arisen from the `db-sync` Team requesting them.)
+
+- The Ledger Team should be consulted regarding how the ledger events will evolve once they become so much more accessible to the community.
+  (See the content @kderme suggested for the document in the first action item.)
+
+- If all anticipated clients only require stable ledger events, then perhaps there's an even simpler point in the solution space.
+  (See the rollback-insensitive/stable content for the document in the first action item.)
+
+- We posited providing an alternative tool (roughly akin to a `db-analyser` pass) that could allow the client to obtain the ledger events of historical blocks without forcing the node to re-apply them.
+  Instead of terminating the node, hacking its disk-state, and restarting the node, the client would instead "terminate the node, run this tool, restart the node".
+  Note that the tool only needs to process blocks from the ImmutableDB, since the node always re-applies VolatileDB blocks when it restarts.
+  It therefore should be relatively simple, but a prototype would be wise.
+
+  The tool would also maintain a ledger state, but crucially the node and the tool would never run at the same time.
+  If the historical block of interest is older than any of the node's ledger state snapshot files, then it would have to re-apply all blocks since Genesis, which can take hours.
+  That should be tenable, as along as the client therefore avoids falling out of sync often.
+  (TODO maybe the client could somehow keep the node's latest ledger state snapshot files while it was in sync alive, for later use when invoking the tool?)
+
+  It would be preferable to provide this tool instead of making it easier to abuse the node for the sake of re-calculating the ledger events of historical blocks.
+
+  In this variation of PR #402 et al, the specification of `rnHandleLedgerEvent` is something like "If the TCP stream of events is idle, then the events for at least every block on the current chain have been previously emitted by this node process."
+  That should be easy enough for the Consensus design to ensure moving forward, since the Consensus Layer itself currently must reapply blocks when it switches to a different chain, even if it had previously selected-and-switched-away-from those blocks---it doesn't cache anything about them except the crypto checks (ie re-apply versus apply).
+
+- Esgen noted that perhaps the same out-of-sync recovery tool could be used to handle an unexpectedly-deep rollback.
+  The client would still have to handle rollbacks any common depth (eg up to 10 blocks), but perhaps that's significantly easier to do than handling rollbacks up to k=2160, since deep rollbacks have so far been rare on Cardano mainnet.
+  Especially in languages other than Haskel, it might be burdensome for the LedgerDB-esque abstraction to rely on sharing to avoid multiplying the client's state's heap size by the depth of handle-able roll back.

From ab428677af19569fbabf2b018fd79b11bf9cc6ac Mon Sep 17 00:00:00 2001
From: Arnaud Bailly <arnaud.bailly@iohk.io>
Date: Thu, 26 Oct 2023 16:18:10 +0200
Subject: [PATCH 15/15] Rename file to something more descriptive

---
 docs/DONOTMERGE/{pr-402.md => publish-ledger-events.md} | 0
 1 file changed, 0 insertions(+), 0 deletions(-)
 rename docs/DONOTMERGE/{pr-402.md => publish-ledger-events.md} (100%)

diff --git a/docs/DONOTMERGE/pr-402.md b/docs/DONOTMERGE/publish-ledger-events.md
similarity index 100%
rename from docs/DONOTMERGE/pr-402.md
rename to docs/DONOTMERGE/publish-ledger-events.md