Leios: add EB announcement diffusion (but don't otherwise leverage them yet)

cabal.project

@@ -56,6 +56,15 @@ source-repository-package
     cardano-diffusion
     network-mux
 
+-- Points to nfrisby-pr93-lookahead-merge-commit tag
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/typed-protocols
+  tag: 9b4627221ae5d649f2303c6926a8dba3f9934658
+  --sha256: sha256-55skVYIR0WjXMwJEirLgF0HFHUpFLBppuV9gvTWqoOI=
+  subdir:
+    typed-protocols
+
 -- Points to ouroboros-ledger/leios-prototype
 source-repository-package
   type: git

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs

@@ -5,12 +5,15 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
+
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Ouroboros.Consensus.Cardano.Block
@@ -214,12 +217,17 @@ module Ouroboros.Consensus.Cardano.Block
   , EraMismatch (..)
   ) where
 
+import Control.Monad.Except (throwError, withExcept)
 import Data.Kind
+import Data.Proxy (Proxy (..))
+import Data.Functor.Product (Product (..))
 import Data.SOP.BasicFunctors
+import Data.SOP.Constraint (All, SListI)
 import Data.SOP.Functors
-import Data.SOP.Index (Index (..))
+import Data.SOP.Index (Index (..), hcizipWith)
+import qualified Data.SOP.Match as Match
 import Data.SOP.Strict
-import Ouroboros.Consensus.Block (BlockProtocol)
+import Ouroboros.Consensus.Block (BlockProtocol, SlotNo)
 import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)
 import Ouroboros.Consensus.HardFork.Combinator
 import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
@@ -245,6 +253,8 @@ import Ouroboros.Consensus.Shelley.Ledger.Ledger
   ( ShelleyPartialLedgerConfig (..)
   )
 import Ouroboros.Consensus.Shelley.Ledger.Leios ()
+import Ouroboros.Consensus.Shelley.Protocol.TPraos ()
+import Ouroboros.Consensus.Shelley.Protocol.Praos ()
 import Ouroboros.Consensus.Storage.LedgerDB (ResolveLeiosBlock (..))
 import Ouroboros.Consensus.TypeFamilyWrappers
 
@@ -1537,6 +1547,7 @@ instance
   , ShelleyCompatible (Praos c) DijkstraEra
   , HasCanonicalTxIn (CardanoEras c)
   , HasHardForkTxOut (CardanoEras c)
+  , CanHardFork (CardanoEras c)
   ) =>
   ResolveLeiosBlock (HardForkBlock (CardanoEras c))
   where
@@ -1596,6 +1607,13 @@ instance
     HeaderDijkstra dHdr -> headerLeiosAnnouncement dHdr
     _ -> Nothing
 
+  -- Compositional dispatch over the era stack (even though in practice only
+  -- Dijkstra carries an announcement, so only its instance is ever exercised).
+  headerElId (HardForkHeader (OneEraHeader ns)) =
+    hcollapse $ hcmap (Proxy @ResolveLeiosBlock) (K . headerElId) ns
+
+  validateAnnouncementChainDepState = update @(CardanoEras c)
+
   headerContainsLeiosCert hdr = case hdr of
     HeaderDijkstra dHdr -> headerContainsLeiosCert dHdr
     _ -> False
@@ -1611,3 +1629,64 @@ instance
         (IS (IS (IS (IS (IS (IS (IS IZ)))))))
         (leiosClosureTxKeySets inner)
     _ -> emptyLedgerTables
+
+-----
+
+-- | We don't want to add the ResolveLeiosBlock sin-bin to SingleEraBlock, so we
+-- use this ad-hoc class instead.
+class    (SingleEraBlock blk, ResolveLeiosBlock blk) => AnnouncementEraBlock blk
+instance (SingleEraBlock blk, ResolveLeiosBlock blk) => AnnouncementEraBlock blk
+
+-- | Adapted from "Ouroboros.Consensus.HardFork.Combinator.Protocol.update"
+update ::
+  forall xs.
+  (CanHardFork xs, All AnnouncementEraBlock xs) =>
+  ConsensusConfig (HardForkProtocol xs) ->
+  OneEraValidateView xs ->
+  SlotNo ->
+  Ticked (HardForkChainDepState xs) ->
+  Except (HardForkValidationErr xs) ()
+update
+  HardForkConsensusConfig{..}
+  (OneEraValidateView view)
+  slot
+  (TickedHardForkChainDepState chainDepState ei) =
+    case State.match view chainDepState of
+      Left mismatch ->
+        throwError $
+          HardForkValidationErrWrongEra . MismatchEraInfo $
+            Match.bihcmap
+              proxySingle
+              singleEraInfo
+              (LedgerEraInfo . chainDepStateInfo . State.currentState)
+              mismatch
+      Right matched ->
+        hcollapse
+          . hcizipWith (Proxy :: Proxy AnnouncementEraBlock) (updateEra ei slot) cfgs
+          $ matched
+   where
+    cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra
+
+-- | Adapted from "Ouroboros.Consensus.HardFork.Combinator.Protocol.updateEra"
+updateEra ::
+  forall xs blk.
+  (SListI xs, SingleEraBlock blk, ResolveLeiosBlock blk) =>
+  EpochInfo (Except PastHorizonException) ->
+  SlotNo ->
+  Index xs blk ->
+  WrapPartialConsensusConfig blk ->
+  Product WrapValidateView (Ticked :.: WrapChainDepState) blk ->
+  K (Except (HardForkValidationErr xs) ()) blk
+updateEra
+  ei
+  slot
+  index
+  cfg
+  (Pair view (Comp chainDepState)) =
+    K $
+      withExcept (injectValidationErr index) $
+          validateAnnouncementChainDepState @blk
+            (completeConsensusConfig' ei cfg)
+            (unwrapValidateView view)
+            slot
+            (unwrapTickedChainDepState chainDepState)

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs

@@ -210,7 +210,7 @@ data instance Header (ShelleyBlock proto era) = ShelleyHeader
   deriving Generic
 
 deriving instance ShelleyCompatible proto era => Show (Header (ShelleyBlock proto era))
-deriving instance ShelleyCompatible proto era => Eq (Header (ShelleyBlock proto era))
+deriving instance ShelleyCompatible proto era => Eq (Header (ShelleyBlock proto era))   -- TODO sound to use only 'shelleyHeaderHash'?
 deriving instance ShelleyCompatible proto era => NoThunks (Header (ShelleyBlock proto era))
 
 instance

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Leios.hs

@@ -11,12 +11,14 @@
 
 module Ouroboros.Consensus.Shelley.Ledger.Leios () where
 
+import qualified Cardano.Crypto.Hash as Crypto (hashToBytesShort)
 import Cardano.Ledger.Api (Tx)
 import Cardano.Ledger.Binary (decCBOR, decodeFullAnnotator)
 import qualified Cardano.Ledger.Block as Core
 import Cardano.Ledger.Core (TopTx, injectFailure)
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Dijkstra.BlockBody (leiosCertBlockBodyL)
+import Cardano.Ledger.Hashes (KeyHash (..))
 import qualified Cardano.Ledger.Shelley.API as SL
 import Cardano.Ledger.Shelley.Rules (ledgerPpL)
 import qualified Cardano.Ledger.Shelley.UTxO as SL
@@ -31,13 +33,29 @@ import Data.Maybe.Strict (strictMaybeToMaybe)
 import Data.Proxy (Proxy (..))
 import qualified Data.Sequence.Strict as StrictSeq
 import LeiosDemoDb (leiosDbLookupEbClosure)
-import LeiosDemoTypes (EbAnnouncement (..), LeiosPoint (..), RbHash (..))
+import LeiosDemoLogic.Announcements.ElBimap (ElId (MkElId))
+import LeiosDemoTypes
+  ( EbAnnouncement (..)
+  , LeiosPoint (..)
+  , RbHash (..)
+  )
 import Lens.Micro ((.~), (^.))
 import Ouroboros.Consensus.Block (ChainHash (..), blockPrevHash, toRawHash)
 import Ouroboros.Consensus.Ledger.Abstract (getTipSlot)
 import Ouroboros.Consensus.Ledger.SupportsMempool (getTransactionKeySets)
 import Ouroboros.Consensus.Ledger.Tables (stowLedgerTables, unstowLedgerTables)
-import Ouroboros.Consensus.Protocol.Praos (Praos, PraosCrypto, PraosState (..))
+import Ouroboros.Consensus.Protocol.Praos
+  ( ConsensusConfig (..)
+  , Praos
+  , PraosCrypto
+  , PraosParams (..)
+  , PraosState (..)
+  , Ticked (..)
+  , WhetherToUpperBoundOCERT (..)
+  , doValidateKESSignatureWorker
+  , doValidateVRFSignature
+  )
+import Ouroboros.Consensus.Protocol.Praos.Views (plvPoolDistr)
 import Ouroboros.Consensus.Protocol.Praos.Header
   ( Header (..)
   , HeaderBody (..)
@@ -195,6 +213,38 @@ instance
    where
     Header{headerBody} = shelleyHeaderRaw hdr
 
+  headerElId hdr =
+    MkElId
+      headerBody.hbSlotNo
+      (Crypto.hashToBytesShort . unKeyHash . SL.hashKey $ headerBody.hbVk)
+   where
+    Header{headerBody} = shelleyHeaderRaw hdr
+
+  -- The announcement is validated out-of-context against a (possibly lagging)
+  -- immutable tip, so we skip the OCERT counter's upper bound
+  -- ('DoNotUpperBoundOCERT'): a counter ahead of our recorded view is honestly
+  -- explained by that lag. The election proof (VRF) and the signature (KES +
+  -- opcert, including the counter's revocation lower bound) are checked in full.
+  validateAnnouncementChainDepState cfg hv _slot tcs = do
+    -- validate the claimed election
+    doValidateVRFSignature
+      (praosStateEpochNonce cs)
+      pd
+      (praosLeaderF prms)
+      hv
+    -- authenticate the message
+    doValidateKESSignatureWorker
+      DoNotUpperBoundOCERT
+      (praosMaxKESEvo prms)
+      (praosSlotsPerKESPeriod prms)
+      pd
+      (praosStateOCertCounters cs)
+      hv
+   where
+    prms = praosParams cfg
+    cs = tickedPraosStateChainDepState tcs
+    SL.PoolDistr pd _ = plvPoolDistr (tickedPraosStateLedgerView tcs)
+
   protocolStateLeiosAnnouncement st = do
     ann <- strictMaybeToMaybe $ praosStateLeiosAnnouncement st
     pure