Leios prototype: Fix PastHorizon errors in syncing

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs

@@ -507,7 +507,15 @@ mkHandlers
                     anc <- case Leios.mkAnnouncingHeader hdr of
                       Nothing -> throwIO Leios.ExnLeiosBlockAnnouncementMissing
                       Just x -> pure x
-                    immLedger <- atomically $ ChainDB.getImmutableLedger getChainDB
+                    -- The volatile tip dates the announcement (longest forecast
+                    -- horizon), the immutable tip judges OCIN revocation (only
+                    -- a state that cannot roll back may revoke). Read together
+                    -- so the two cannot disagree about the same chain.
+                    (volLedger, immLedger) <-
+                      atomically $
+                        (,)
+                          <$> ChainDB.getCurrentLedger getChainDB
+                          <*> ChainDB.getImmutableLedger getChainDB
                     (latestPruneSlot, peerSt0) <- Prim.readMutVar peerStateVar
                     res <-
                       runExceptT $
@@ -516,9 +524,11 @@ mkHandlers
                           Leios.ancElId
                           ( \ancH ->
                               Leios.announcementValidity
+                                kernelTracer
                                 systemTime
                                 chainSyncFutureCheck
                                 getTopLevelConfig
+                                volLedger
                                 immLedger
                                 (Leios.ancHeader ancH)
                           )

ouroboros-consensus/src/ouroboros-consensus/LeiosDemoLogic.hs

@@ -127,6 +127,9 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types
   , systemTimeCurrent
   )
 import Ouroboros.Consensus.Config (TopLevelConfig, configLedger)
+import Ouroboros.Consensus.HardFork.History
+  ( PastHorizonException (PastHorizon)
+  )
 import Ouroboros.Consensus.Ledger.Abstract (getTipSlot)
 import Ouroboros.Consensus.Ledger.Basics (EmptyMK)
 import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, ledgerState)
@@ -1629,6 +1632,14 @@ instance Exception ExnLeiosBlockAnnouncementMissing
 -- Chronos) — blocking the per-peer handler is acceptable, as a (near-)future
 -- announcement is the peer's fault.
 --
+-- A slot past the forecast horizon is /not/ the peer's fault, so it must not
+-- disconnect them: it means our own ledger is too far behind to date the
+-- announcement, which is the ordinary state of affairs while syncing. The
+-- verdict is 'VerdictIgnore' and 'TraceLeiosAnnouncementPastHorizon' records it.
+-- The horizon comes from the volatile tip rather than the immutable one for the
+-- same reason — it is the longest forecast we have, and every slot it buys is a
+-- peer we do not drop.
+--
 -- If the announcement is valid and 'FreshOCIN', the verdict carries its data and
 -- whether to relay it downstream (see 'ShouldRelay' and
 -- 'maxAnnouncementAgeSend'). If it is valid but 'StaleOCIN' (its opcert counter
@@ -1638,48 +1649,59 @@ instance Exception ExnLeiosBlockAnnouncementMissing
 -- relaying it.
 announcementValidity ::
   (IOLike m, LedgerSupportsProtocol blk, ResolveLeiosBlock blk) =>
+  Tracer m TraceLeiosKernel ->
   SystemTime m ->
   InFutureCheck.SomeHeaderInFutureCheck m blk ->
   TopLevelConfig blk ->
+  -- | The volatile tip's ledger state, for the in-future check: it forecasts
+  -- furthest, and a shorter horizon costs us peers.
+  ExtLedgerState blk EmptyMK ->
+  -- | The immutable tip's ledger state, for the OCIN revocation check: a
+  -- revocation only counts once it cannot be rolled back.
   ExtLedgerState blk EmptyMK ->
   Header blk ->
   m
     ( AnnouncementVerdict
         (AnnouncementInvalidity blk)
         (ShouldRelay, RelativeTime, NominalDiffTime, (LeiosPoint, BytesSize))
     )
-announcementValidity systemTime futureCheck cfg immLedger hdr = do
-  onset <- case futureCheck of
+announcementValidity tracer systemTime futureCheck cfg volLedger immLedger hdr = do
+  mbOnset <- case futureCheck of
     InFutureCheck.SomeHeaderInFutureCheck hifc -> do
       arrival <- InFutureCheck.recordHeaderArrival hifc hdr
-      judgment <-
-        either throwIO pure $
-          runExcept $
-            InFutureCheck.judgeHeaderArrival
-              hifc
-              (configLedger cfg)
-              (ledgerState immLedger)
-              arrival
-      arrivalResult <- InFutureCheck.handleHeaderArrival hifc judgment
-      either throwIO pure (runExcept arrivalResult)
-  -- The in-future check has delayed this thread until 'onset' if the
-  -- slot was near-future, so 'now' is at or after 'onset' and the age
-  -- is non-negative.
-  now <- systemTimeCurrent systemTime
-  let age = diffRelTime now onset
-  pure $
-    -- Only this function holds the wall clock, so it owns the too-old check.
-    if age > maxAnnouncementAgeRecv
-      then VerdictTooOld
-      else
-        let shouldRelay =
-              if age <= maxAnnouncementAgeSend
-                then DoRelay
-                else DoNotRelay
-         in case validateAnnouncementHeader cfg immLedger hdr of
-              Left inv -> VerdictInvalid inv
-              Right (StaleOCIN, _v) -> VerdictIgnore
-              Right (FreshOCIN, v) -> VerdictProcess (shouldRelay, onset, age, v)
+      case runExcept $
+        InFutureCheck.judgeHeaderArrival
+          hifc
+          (configLedger cfg)
+          (ledgerState volLedger)
+          arrival of
+        Left PastHorizon{} -> do
+          traceWith tracer $ TraceLeiosAnnouncementPastHorizon (blockSlot hdr)
+          pure Nothing
+        Right judgment -> do
+          arrivalResult <- InFutureCheck.handleHeaderArrival hifc judgment
+          Just <$> either throwIO pure (runExcept arrivalResult)
+  case mbOnset of
+    Nothing -> pure VerdictIgnore
+    Just onset -> do
+      -- The in-future check has delayed this thread until 'onset' if the
+      -- slot was near-future, so 'now' is at or after 'onset' and the age
+      -- is non-negative.
+      now <- systemTimeCurrent systemTime
+      let age = diffRelTime now onset
+      pure $
+        -- Only this function holds the wall clock, so it owns the too-old check.
+        if age > maxAnnouncementAgeRecv
+          then VerdictTooOld
+          else
+            let shouldRelay =
+                  if age <= maxAnnouncementAgeSend
+                    then DoRelay
+                    else DoNotRelay
+             in case validateAnnouncementHeader cfg immLedger hdr of
+                  Left inv -> VerdictInvalid inv
+                  Right (StaleOCIN, _v) -> VerdictIgnore
+                  Right (FreshOCIN, v) -> VerdictProcess (shouldRelay, onset, age, v)
 
 -- | Record a validated, newly-announced EB body as missing, unless its already
 -- pruned\/tracked\/acquired

ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs

@@ -1386,6 +1386,10 @@ data TraceLeiosKernel
   | TraceLeiosDb TraceLeiosDb
   | -- | A forged RB both certifies an EB and announce a new one
     TraceLeiosCertifiedAndAnnounced {atSlot :: SlotNo, rbHash :: RbHash}
+  | -- | An EB announcement whose slot our ledger cannot place on the wall clock,
+    -- because it is beyond the forecast horizon. Ordinary while syncing: the
+    -- announcement describes the network's tip and we are far behind it.
+    TraceLeiosAnnouncementPastHorizon {atSlot :: SlotNo}
   | -- | The node accepted a new EB announcement, deduplicated across all peers
     -- and its own block forging (see 'AnnouncementSource').
     TraceLeiosAnnouncementAccepted
@@ -1681,6 +1685,11 @@ traceLeiosKernelToObject = \case
       , "slotNo" .= slotNo
       , "rbHash" .= prettyRbHash rbHash
       ]
+  TraceLeiosAnnouncementPastHorizon{atSlot} ->
+    mconcat
+      [ "kind" .= Aeson.String "LeiosAnnouncementPastHorizon"
+      , "slotNo" .= atSlot
+      ]
   TraceLeiosAnnouncementAccepted announcementSource equivocation acc mbAge ->
     mconcat $
       [ "kind" .= Aeson.String "LeiosAnnouncementAccepted"