Leios: Prototype voting (#1963)

First PR to add voting capabilities to the `leios-prototype`:

- Naiive N^2 vote diffusion via `LeiosNotify`
- A new `VoteState` that allows to `addVote` and `subscribeVotes`
- A voting thread that votes on completed EB closures
  - Missing: EB too old to vote check
  - Missing: EB validation
- Mocked voting key registration (re-uses KES key bytes)
- No vote validation (yet)
- Threadnet properties that drove the implementation so far
- Fixed re-trigger of EB notifications for already completed closures

Roughly the components that were implemented in this PR:

<img width="2872" height="904" alt="Leios voting (Current)(1)"
src="https://github.com/user-attachments/assets/7e9e032c-d581-4dd1-b30d-9ced05967edc"
/>

**NOTE**: The failing test with seed `(SMGen 15462600834920737326
9156690725779514573,20)` is actually a lucky one that conflates two
`VoterId` from the hacked KES key bytes. It will drive the follow-up PR
that explores commitee selection paths.

Author: ch1bo

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "cardano-blueprint"]
+	path = cardano-blueprint
+	url = git@github.com:cardano-scaling/cardano-blueprint.git

cardano-blueprint

@@ -217,6 +217,7 @@ protocolInfoByron
             , topLevelConfigCodec = mkByronCodecConfig compactedGenesisConfig
             , topLevelConfigStorage = ByronStorageConfig blockConfig
             , topLevelConfigCheckpoints = emptyCheckpointsMap
+            , topLevelConfigVotingKey = Nothing
             }
       , pInfoInitLedger =
           ExtLedgerState

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs

@@ -47,6 +47,7 @@ module Ouroboros.Consensus.Cardano.Node
 
 import Cardano.Binary (DecoderError (..), enforceSize)
 import Cardano.Chain.Slotting (EpochSlots)
+import Cardano.Crypto.KES.Class (rawSerialiseUnsoundPureSignKeyKES)
 import qualified Cardano.Ledger.Api.Era as L
 import qualified Cardano.Ledger.Api.Transition as L
 import qualified Cardano.Ledger.BaseTypes as SL
@@ -812,6 +813,12 @@ protocolInfoCardano paramsCardano
             (Shelley.ShelleyStorageConfig tpraosSlotsPerKESPeriod k)
             (Shelley.ShelleyStorageConfig tpraosSlotsPerKESPeriod k)
       , topLevelConfigCheckpoints = cardanoCheckpoints
+      , -- FIXME: REMOVE THIS. Accesses and re-uses KES signing key material.
+        topLevelConfigVotingKey =
+          Just
+            . rawSerialiseUnsoundPureSignKeyKES
+            . shelleyLeaderCredentialsInitSignKey
+            $ credssShelleyBased !! 0
       }
 
   -- When the initial ledger state is not in the Byron era, register various

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

@@ -232,6 +232,7 @@ protocolInfoTPraosShelleyBased
         , topLevelConfigCodec = ShelleyCodecConfig
         , topLevelConfigStorage = storageConfig
         , topLevelConfigCheckpoints = emptyCheckpointsMap
+        , topLevelConfigVotingKey = Nothing
         }
 
     consensusConfig :: ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs

@@ -125,6 +125,7 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss =
                   , dualStorageConfigAux = ByronSpecStorageConfig
                   }
             , topLevelConfigCheckpoints = emptyCheckpointsMap
+            , topLevelConfigVotingKey = Nothing
             }
       , pInfoInitLedger =
           ExtLedgerState

ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs

@@ -52,8 +52,14 @@ import Data.Sequence.Strict ((|>))
 import qualified Data.Set as Set
 import Data.Word (Word64)
 import LeiosDemoDb (LeiosDbConnection, newLeiosDBInMemoryWith, withLeiosDb)
-import LeiosDemoTypes (LeiosPoint (..), TraceLeiosKernel (..), hashLeiosEb, minCertificationGap)
-import Lens.Micro (each, (%~), (^.), (^..))
+import LeiosDemoTypes
+  ( LeiosPoint (..)
+  , LeiosVote (..)
+  , TraceLeiosKernel (..)
+  , hashLeiosEb
+  , minCertificationGap
+  )
+import Lens.Micro ((%~), (^.))
 import Ouroboros.Consensus.Block (SlotNo (..), blockSlot)
 import Ouroboros.Consensus.Cardano
   ( CardanoBlock
@@ -127,9 +133,8 @@ import Test.ThreadNet.Network
   ( LeiosState (..)
   , NodeOutput (..)
   , TestNodeInitialization (..)
-  , _FromLeios
-  , _FromMempool
-  , _nodeEvent
+  , TraceThreadNet (FromNode)
+  , TraceThreadNetNode (FromLeios, FromLeiosPeer, FromMempool)
   )
 import Test.ThreadNet.TxGen.Cardano (CardanoTxGenExtra (..))
 import Test.ThreadNet.Util.NodeJoinPlan (trivialNodeJoinPlan)
@@ -170,9 +175,11 @@ prop_leios seed =
     , propConsistentChains
     , certificationGapIsCorrect
         .||. length certifyingBlocks <= 1
+    , propVoting
     ]
  where
-  numNodes = 3 :: Integer
+  numNodes = 3 :: Int
+
   numSlots = 200 :: Word64
 
   (testOutput, ProtocolInfo{pInfoConfig, pInfoInitLedger}) =
@@ -184,7 +191,7 @@ prop_leios seed =
 
   includedTxCounts = length . extractTxs <$> forgedBlocks
 
-  leiosTraces = traces ^.. each . _nodeEvent . _FromLeios
+  leiosTraces = [ev | FromNode _ (FromLeios ev) <- traces]
 
   forgedPoints = Map.keysSet forgedEBs
 
@@ -196,7 +203,39 @@ prop_leios seed =
     TraceLeiosBlockTxsAcquired point -> Just point
     _ -> Nothing
 
-  mempoolTraces = traces ^.. each . _nodeEvent . _FromMempool
+  propVoting =
+    conjoin
+      [ length votedPoints > 0
+          & counterexample "never voted"
+      , acquiredPoints `Set.isSubsetOf` votedPoints
+          & counterexample "not voted on all acquired EBs"
+          & prettyCounterexampleList "acquired leios EBs" 120 acquiredPoints
+          & prettyCounterexampleList "voted on EBs" 120 votedPoints
+      , ( Map.keysSet acquiredVotes === votedPoints
+            .&&. all (\voters -> length voters == numNodes) acquiredVotes
+        )
+          & counterexample "created votes not diffused"
+          & prettyCounterexampleMap "acquired votes" 120 acquiredVotes
+          & prettyCounterexampleList "voted on EBs" 120 votedPoints
+          & counterexample
+            ( "peer traces: "
+                <> unlines [show (nid, ev) | FromNode nid (FromLeiosPeer ev) <- traces]
+            )
+          & counterexample
+            ( "kernel traces: "
+                <> unlines [show (nid, ev) | FromNode nid (FromLeios ev) <- traces]
+            )
+      ]
+
+  votedPoints = Set.fromList . flip mapMaybe leiosTraces $ \case
+    TraceLeiosVoted{vote} -> Just vote.point
+    _ -> Nothing
+
+  acquiredVotes = Map.fromListWith mappend . flip mapMaybe leiosTraces $ \case
+    TraceLeiosVoteAcquired{vote} -> Just (vote.point, Set.singleton vote.voterId)
+    _ -> Nothing
+
+  mempoolTraces = [ev | FromNode _ (FromMempool ev) <- traces]
 
   mempoolAddedTxs = flip mapMaybe mempoolTraces $ \case
     TraceMempoolAddedTx tx _ _ -> Just tx
@@ -579,9 +618,13 @@ prettyCounterexampleMap title maxLength m prop =
  where
   prettyMap =
     Map.toList m
-      & map (\(a, b) -> indented 2 . elided maxLength $ show a <> " -> " <> show b)
+      & map (\(a, b) -> indented 2 $ elided kvLength (show a) <> arrowStr <> elided kvLength (show b))
       & unlines
 
+  arrowStr = " -> "
+
+  kvLength = (maxLength - length arrowStr) `div` 2
+
 -- | Pretty print a list of counterexamples, one on each row and eliding long
 -- entries to given maxLength. If maxLength is 0 or negative, no elision is
 -- performed.

ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Leios.hs

@@ -139,7 +139,6 @@ library unstable-diffusion-testlib
     graphviz >=2999.20.1.0,
     io-classes,
     io-sim,
-    microlens,
     mtl,
     ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib},
     ouroboros-consensus-diffusion,

ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal

@@ -51,9 +51,11 @@ import qualified Codec.CBOR.Decoding as CBOR
 import Codec.CBOR.Encoding (Encoding)
 import qualified Codec.CBOR.Encoding as CBOR
 import Codec.CBOR.Read (DeserialiseFailure)
+import Control.Applicative ((<|>))
 import qualified Control.Concurrent.Class.MonadMVar as MVar
 import Control.Concurrent.Class.MonadSTM.Strict (readTChan)
 import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as TVar.Unchecked
+import Control.Monad (forM_)
 import Control.Monad.Class.MonadTime.SI (MonadTime)
 import Control.Monad.Class.MonadTimer.SI (MonadTimer)
 import Control.ResourceRegistry
@@ -65,19 +67,23 @@ import qualified Data.Map as Map
 import Data.Map.Strict (Map)
 import qualified Data.Set as Set
 import Data.Void (Void)
-import LeiosDemoDb (LeiosDbHandle (subscribeEbNotifications))
+import LeiosDemoDb
+  ( LeiosDbHandle (subscribeEbNotifications)
+  , LeiosEbNotification (..)
+  )
 import qualified LeiosDemoDb as LeiosDb
 import qualified LeiosDemoLogic as Leios
 import LeiosDemoOnlyTestFetch
 import LeiosDemoOnlyTestNotify
 import LeiosDemoTypes
   ( LeiosEb
-  , LeiosNotification (..)
   , LeiosPoint (..)
   , LeiosTx
+  , TraceLeiosKernel (..)
   , TraceLeiosPeer (..)
   )
 import qualified LeiosDemoTypes as Leios
+import LeiosVoteState (LeiosVoteState (..), LeiosVoteSubscription (..), subscribeVotes)
 import qualified Network.Mux as Mux
 import Network.TypedProtocol.Codec
 import Network.TypedProtocol.Peer (Peer (Effect))
@@ -96,6 +102,7 @@ import Ouroboros.Consensus.Node.ExitPolicy
 import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.Node.Run
 import Ouroboros.Consensus.Node.Serialisation
+import Ouroboros.Consensus.Node.Tracers (leiosKernelTracer)
 import qualified Ouroboros.Consensus.Node.Tracers as Node
 import Ouroboros.Consensus.NodeKernel
 import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
@@ -332,6 +339,8 @@ mkHandlers
       , hPeerSharingServer = \_version _peer -> peerSharingServer getPeerSharingAPI
       , hLeiosNotifyClient = \_version controlMessageSTM peer -> toLeiosNotifyClientPeerPipelined $ Effect $ do
           let tracer = leiosPeerTracer peer
+              kernelTracer = leiosKernelTracer tracers
+              LeiosVoteState{addVote} = leiosVoteState
           MVar.modifyMVar_ getLeiosPeersVars $ \leiosPeersVars -> do
             x <- Leios.newLeiosPeerVars
             let !leiosPeersVars' = Map.insert (Leios.MkPeerId peer) x leiosPeersVars
@@ -340,7 +349,7 @@ mkHandlers
             leiosNotifyClientPeerPipelined
               ( atomically controlMessageSTM <&> \case
                   Terminate -> Left ()
-                  _ -> Right 300 {- TODO magic number -}
+                  _ -> Right 10 {- TODO magic number -}
               )
               ( pure $ \case
                   MsgLeiosBlockAnnouncement{} -> error "Demo does not send EB announcements!"
@@ -377,15 +386,31 @@ mkHandlers
                       let !offers2' = Set.insert ebHash offers2
                       pure (offers1, offers2')
                     void $ MVar.tryPutMVar getLeiosReady ()
+                  MsgLeiosVotes vs -> do
+                    -- TODO: reduce this trace a bit to the essential
+                    traceWith tracer $ MkTraceLeiosPeer $ "MsgLeiosVotes " <> show vs
+                    mapM_ addVote vs
+                    forM_ vs $ \vote ->
+                      traceWith kernelTracer TraceLeiosVoteAcquired{vote}
               )
       , hLeiosNotifyServer = \_version _peer -> Effect $ do
           chan <- subscribeEbNotifications leiosDB
-          pure . leiosNotifyServerPeer $ do
-            atomically (readTChan chan) >>= \case
-              LeiosOfferBlock point ebSize ->
-                pure $ MsgLeiosBlockOffer point ebSize
-              LeiosOfferBlockTxs point ->
-                pure $ MsgLeiosBlockTxsOffer point
+          let processEbNotification =
+                readTChan chan >>= \case
+                  AcquiredEb point ebSize ->
+                    pure $ MsgLeiosBlockOffer point ebSize
+                  AcquiredEbTxs point ->
+                    pure $ MsgLeiosBlockTxsOffer point
+
+          LeiosVoteSubscription{getNextVote} <- subscribeVotes leiosVoteState
+          let processVote = do
+                vote <- getNextVote
+                -- FIXME: Yields each vote separately
+                pure $ MsgLeiosVotes [vote]
+
+          pure . leiosNotifyServerPeer $
+            atomically $
+              processEbNotification <|> processVote
       , hLeiosFetchClient = \_version controlMessageSTM peer -> toLeiosFetchClientPeerPipelined $ Effect $ do
           reqVar <-
             let loop = do
@@ -427,6 +452,7 @@ mkHandlers
       } = nodeKernel
     NodeKernel
       { leiosDB
+      , leiosVoteState
       , getLeiosPeersVars
       , getLeiosOutstanding
       , getLeiosReady

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

@@ -161,11 +161,14 @@ import System.Random (StdGen)
 
 import Control.Concurrent.Class.MonadMVar (MVar)
 import qualified Control.Concurrent.Class.MonadMVar as MVar
+import Control.Concurrent.Class.MonadSTM.Strict (readTChan)
+import qualified Data.ByteString as BS
 import Data.Map (Map)
 import qualified Data.Map as Map
 import LeiosDemoDb
   ( LeiosDbConnection
   , LeiosDbHandle (..)
+  , LeiosEbNotification (..)
   , leiosDbInsertEbBody
   , leiosDbInsertEbPoint
   , leiosDbInsertTxs
@@ -176,9 +179,12 @@ import LeiosDemoTypes
   ( ForgedLeiosEb
   , LeiosOutstanding
   , LeiosPeerVars
+  , LeiosVote (..)
   , TraceLeiosKernel (..)
+  , VoterId (..)
   )
 import qualified LeiosDemoTypes as Leios
+import LeiosVoteState (LeiosVoteState (..), newLeiosVoteState)
 import Ouroboros.Consensus.Mempool.TxSeq (mSize)
 import qualified Ouroboros.Consensus.Mempool.TxSeq as TxSeq
 
@@ -228,6 +234,7 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel
 
     -- See 'LeiosPeerVars' for the write patterns
     leiosDB :: LeiosDbHandle m
+  , leiosVoteState :: LeiosVoteState m
   , getLeiosPeersVars :: MVar m (Map (Leios.PeerId (ConnectionId addrNTN)) (LeiosPeerVars m))
   , -- Written to by the fetch logic, by the LeiosNotify&LeiosFetch, and by LeiosCopier
     -- clients (TODO and by eviction).
@@ -407,6 +414,7 @@ initNodeKernel
           fetchClientRegistry
           blockFetchConfiguration
 
+    leiosVoteState <- newLeiosVoteState
     getLeiosPeersVars <- MVar.newMVar Map.empty
     getLeiosOutstanding <- MVar.newMVar Leios.emptyLeiosOutstanding -- TODO init from DB
     getLeiosReady <- MVar.newEmptyMVar
@@ -448,6 +456,47 @@ initNodeKernel
           traceWith tracer $ MkTraceLeiosKernel $ "leiosFetchLogic: duration " ++ show duration
           threadDelay $ loopInterval - duration
 
+    void $ forkLinkedThread registry "NodeKernel.leiosVoting" $ do
+      let tracer = leiosKernelTracer tracers
+          LeiosVoteState{addVote} = leiosVoteState
+      -- Access voting key and derive voter id
+      case topLevelConfigVotingKey cfg of
+        Nothing ->
+          traceWith tracer $
+            MkTraceLeiosKernel $
+              "NodeKernel.leiosVoting: disabled because no topLevelConfigVotingKey"
+        Just votingKey -> do
+          -- TODO: derive from committee within ledger state, also move within loop (changes across epochs)
+          -- FIXME: Lucky seed has two identical voter ids. Fix via proper
+          -- committee selection from all registered keys.
+          -- :main -p Leios --quickcheck-replay "(SMGen 15462600834920737326 9156690725779514573,20)"
+          let me = MkVoterId . fromIntegral $ BS.head votingKey
+          -- Subscribe to EBs for which we have the full closure
+          chan <- subscribeEbNotifications leiosDB
+          let getNext f =
+                atomically (readTChan chan) >>= \case
+                  AcquiredEb{} -> pure ()
+                  AcquiredEbTxs point -> f point
+          forever $ do
+            -- TODO: Need to poll available EBs instead? Otherwise we would not vote
+            -- when we switch to a chain only later
+            getNext $ \point -> do
+              let tooOld = const False -- TODO: check not too old; use tip or wall clock time?
+              unless (tooOld point) $ do
+                -- TODO: check whether already voted
+                -- TODO: validate EB closures against selected chain
+                -- TODO: create vote (sign the eb hash)
+                let vote =
+                      MkLeiosVote
+                        { point
+                        , voterId = me
+                        , voteSignature = True
+                        }
+                -- Store vote in memory and notify downstream peers
+                addVote vote
+                traceWith tracer TraceLeiosVoted{vote}
+                traceWith tracer TraceLeiosVoteAcquired{vote}
+
     return
       NodeKernel
         { getChainDB = chainDB
@@ -466,6 +515,7 @@ initNodeKernel
         , getDiffusionPipeliningSupport
         , getBlockchainTime = btime
         , leiosDB
+        , leiosVoteState
         , getLeiosPeersVars
         , getLeiosOutstanding
         , getLeiosReady