From ed4fef3e63daee15682f64e49e2919e64c91561f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 19 May 2026 15:52:50 +0200 Subject: [PATCH 01/62] Updated to tip of ouroboros-network --- cabal.project | 7 +++--- ...19_160418_coot_ouroboros_network_update.md | 25 +++++++++++++++++++ .../Ouroboros/Consensus/Network/NodeToNode.hs | 4 ++- .../Ouroboros/Consensus/Node.hs | 14 ++++++----- .../Ouroboros/Consensus/NodeKernel.hs | 7 ++++++ .../Consensus/PeerSimulator/BlockFetch.hs | 22 +++++++++------- .../Test/Consensus/PeerSimulator/Run.hs | 10 +++++++- .../MiniProtocol/BlockFetch/Client.hs | 11 +++++--- 8 files changed, 75 insertions(+), 25 deletions(-) create mode 100644 changelog.d/20260519_160418_coot_ouroboros_network_update.md diff --git a/cabal.project b/cabal.project index fba97a86d9..b720fd119f 100644 --- a/cabal.project +++ b/cabal.project @@ -44,13 +44,12 @@ if os (windows) constraints: bitvec -simd --- Depend on Network main "main-peras-5202-merged" tagged commit, --- after PR #5202 adding ObjectDiffusion miniprotocol for Peras has been merged +-- ouroboros-network dependency after introducing `bracketKeepAlive` (PR#5371) source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network - tag: main-peras-5202-merged - --sha256: sha256-IDLqfxc12jmYxKYUNC6+Dk2cQBWOpSs/V/SpBgNE63s= + tag: e8d59d8a219563760fc21ba5bc86fab77d886742 + --sha256: sha256-ElgaE5JeDTPfyDQnyZs5ZlOdzlnZYl7z1OgkzCBJjek= subdir: ouroboros-network cardano-diffusion diff --git a/changelog.d/20260519_160418_coot_ouroboros_network_update.md b/changelog.d/20260519_160418_coot_ouroboros_network_update.md new file mode 100644 index 0000000000..e6bb78c113 --- /dev/null +++ b/changelog.d/20260519_160418_coot_ouroboros_network_update.md @@ -0,0 +1,25 @@ + + + + + diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 41c4cbe936..53d85783fb 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -903,6 +903,7 @@ mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucke labelThisThread "BlockFetchClient" bracketFetchClient (getFetchClientRegistry kernel) + (getKeepAliveRegistry kernel) version them $ \clientCtx -> do @@ -1114,7 +1115,8 @@ mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucke dqCtx (KeepAliveInterval 10) - ((), trailing) <- bracketKeepAliveClient (getFetchClientRegistry kernel) them kacApp + ((), trailing) <- + bracketKeepAliveClient (getKeepAliveRegistry kernel) them kacApp return (NoInitiatorResult, trailing) aKeepAliveServer :: 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 7ed9ac7d03..7ab1a67e33 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 @@ -81,7 +81,7 @@ import Cardano.Network.NodeToNode , defaultMiniProtocolParameters ) import Cardano.Network.NodeToNode.Version (getLocalPerasSupport) -import Cardano.Network.PeerSelection (ChurnMode (..), PeerTrustable, UseBootstrapPeers (..)) +import Cardano.Network.PeerSelection (ChurnMode (ChurnMode), PeerTrustable, UseBootstrapPeers (..)) import Cardano.Network.Protocol.ChainSync.Codec.TimeLimits (timeLimitsChainSync) import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Encoding as CBOR @@ -151,6 +151,7 @@ import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime) import Ouroboros.Network.BlockFetch ( BlockFetchConfiguration (..) + , PraosFetchMode (..) ) import qualified Ouroboros.Network.Diffusion as Diffusion import qualified Ouroboros.Network.Diffusion.Policies as Diffusion @@ -599,7 +600,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = rnTxSubmissionInitDelay nodeKernel <- initNodeKernel nodeKernelArgs rnNodeKernelHook registry nodeKernel - churnModeVar <- StrictSTM.newTVarIO ChurnModeNormal + churnModeVar <- StrictSTM.newTVarIO (ChurnMode (Cardano.PraosFetchMode FetchModeDeadline)) churnMetrics <- newPeerMetric Diffusion.peerMetricsConfiguration let consensusDiffusionArgs = Cardano.Diffusion.CardanoConsensusArguments @@ -618,15 +619,16 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = in \newOcs -> do oldOcs <- readTVar varOcs when (newOcs /= oldOcs) $ writeTVar varOcs newOcs - , Cardano.getBlockHash = \targetBlock k -> do + , Cardano.getImmutableBlockPoint = \targetBlock k -> do case targetBlock of - GenesisPoint -> k (pure Nothing) + GenesisPoint -> k (pure (Left Cardano.ImmutableBlockPointGenesisPoint)) (BlockPoint targetSlot (RawBlockHash targetHash)) -> do let targetPoint = RealPoint targetSlot (fromShortRawHash (Proxy @blk) targetHash) ChainDB.waitForImmutableBlock (getChainDB nodeKernel) targetPoint >>= \case - Left{} -> k (pure Nothing) + Left ChainDB.TipIsOrigin -> k (pure (Left Cardano.ImmutableBlockPointTipIsOrigin)) + Left ChainDB.TargetNewerThanTip -> k (pure (Left Cardano.ImmutableBlockPointNotYetImmutable)) Right (RealPoint actualSlot actualHash) -> - k (pure . Just $ BlockPoint actualSlot (RawBlockHash $ toShortRawHash (Proxy @blk) actualHash)) + k (pure . Right $ BlockPoint actualSlot (RawBlockHash $ toShortRawHash (Proxy @blk) actualHash)) } } , Cardano.Diffusion.readUseBootstrapPeers = rnGetUseBootstrapPeers diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index ebbc708ade..65ebc5ab7e 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -173,6 +173,8 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel -- ^ The node's top-level static configuration , getFetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m -- ^ The fetch client registry, used for the block fetch clients. + , getKeepAliveRegistry :: KeepAliveRegistry (ConnectionId addrNTN) m + -- ^ The keep alive registry, used for the block fetch clients. , getFetchMode :: STM m FetchMode -- ^ The fetch mode, used by diffusion. , getGsmState :: STM m GSM.GsmState @@ -272,6 +274,7 @@ initNodeKernel let IS { blockFetchInterface , fetchClientRegistry + , keepAliveRegistry , mempool , peerSharingRegistry , varChainSyncHandles @@ -382,6 +385,7 @@ initNodeKernel (contramap (fmap castTraceFetchClientState) $ blockFetchClientTracer tracers) blockFetchInterface fetchClientRegistry + keepAliveRegistry blockFetchConfiguration void $ @@ -399,6 +403,7 @@ initNodeKernel , getMempool = mempool , getTopLevelConfig = cfg , getFetchClientRegistry = fetchClientRegistry + , getKeepAliveRegistry = keepAliveRegistry , getFetchMode = readFetchMode blockFetchInterface , getGsmState = readTVar varGsmState , getChainSyncHandles = varChainSyncHandles @@ -454,6 +459,7 @@ data InternalState m addrNTN addrNTC blk = IS , blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m , fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m + , keepAliveRegistry :: KeepAliveRegistry (ConnectionId addrNTN) m , varChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk , varGsmState :: StrictTVar m GSM.GsmState , mempool :: Mempool m blk @@ -505,6 +511,7 @@ initInternalState (mempoolTracer tracers) fetchClientRegistry <- newFetchClientRegistry + keepAliveRegistry <- newKeepAliveRegistry let readFetchMode = BlockFetchClientInterface.readFetchModeDefault diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs index d2e5f1e16e..e429d0b4cd 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs @@ -54,6 +54,7 @@ import Ouroboros.Network.BlockFetch ( BlockFetchConfiguration (..) , FetchClientRegistry , GenesisBlockFetchConfiguration (..) + , KeepAliveRegistry , blockFetchLogic , bracketFetchClient , bracketKeepAliveClient @@ -114,9 +115,10 @@ startBlockFetchLogic :: ProtocolInfo blk -> ChainDB m blk -> FetchClientRegistry PeerId (HeaderWithTime blk) blk m -> + KeepAliveRegistry PeerId m -> ChainSyncClientHandleCollection PeerId m blk -> m () -startBlockFetchLogic enableChainSelStarvation registry tracer protocolInfo chainDb fetchClientRegistry csHandlesCol = do +startBlockFetchLogic enableChainSelStarvation registry tracer protocolInfo chainDb fetchClientRegistry keepAliveRegistry csHandlesCol = do let blockFetchConsensusInterface = BlockFetchClientInterface.mkBlockFetchConsensusInterface nullTracer -- FIXME @@ -126,8 +128,8 @@ startBlockFetchLogic enableChainSelStarvation registry tracer protocolInfo chain -- The size of headers in bytes is irrelevant because our tests -- do not serialize the blocks. (\_hdr -> 1000) - -- This is a syncing test, so we use 'FetchModeGenesis'. - (pure FetchModeGenesis) + -- This is a syncing test, so we use 'GenesisFetchMode'. + (pure GenesisFetchMode) DiffusionPipeliningOn bfcGenesisBFConfig = @@ -163,21 +165,22 @@ startBlockFetchLogic enableChainSelStarvation registry tracer protocolInfo chain nullTracer blockFetchConsensusInterface fetchClientRegistry + keepAliveRegistry blockFetchCfg where decisionTracer = TraceOther . ("BlockFetchLogic | " ++) . show >$< tracer startKeepAliveThread :: - forall m peer blk hdr. + forall m peer. (Ord peer, IOLike m) => ResourceRegistry m -> - FetchClientRegistry peer hdr blk m -> + KeepAliveRegistry peer m -> peer -> m () -startKeepAliveThread registry fetchClientRegistry peerId = +startKeepAliveThread registry keepAliveRegistry peerId = void $ forkLinkedThread registry "KeepAlive" $ - bracketKeepAliveClient fetchClientRegistry peerId $ \_ -> + bracketKeepAliveClient keepAliveRegistry peerId $ \_ -> atomically retry runBlockFetchClient :: @@ -187,12 +190,13 @@ runBlockFetchClient :: BlockFetchTimeout -> StateViewTracers blk m -> FetchClientRegistry PeerId (HeaderWithTime blk) blk m -> + KeepAliveRegistry PeerId m -> ControlMessageSTM m -> -- | Send and receive message via the given 'Channel'. Channel m (AnyMessage (BlockFetch blk (Point blk))) -> m () -runBlockFetchClient tracer peerId blockFetchTimeouts StateViewTracers{svtPeerSimulatorResultsTracer} fetchClientRegistry controlMsgSTM channel = do - bracketFetchClient fetchClientRegistry ntnVersion peerId $ \clientCtx -> do +runBlockFetchClient tracer peerId blockFetchTimeouts StateViewTracers{svtPeerSimulatorResultsTracer} fetchClientRegistry keepAliveRegistry controlMsgSTM channel = do + bracketFetchClient fetchClientRegistry keepAliveRegistry ntnVersion peerId $ \clientCtx -> do res <- try $ runPipelinedPeerWithLimits diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index bf9d106caa..78e43cbe4f 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -60,8 +60,10 @@ import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.BlockFetch ( FetchClientRegistry + , KeepAliveRegistry , bracketSyncWithFetchClient , newFetchClientRegistry + , newKeepAliveRegistry ) import Ouroboros.Network.Channel (createConnectedChannels) import Ouroboros.Network.ControlMessage @@ -223,6 +225,7 @@ startBlockFetchConnectionThread :: Tracer m (TraceEvent blk) -> StateViewTracers blk m -> FetchClientRegistry PeerId (HeaderWithTime blk) blk m -> + KeepAliveRegistry PeerId m -> ControlMessageSTM m -> SharedResources m blk -> BlockFetchResources m blk -> @@ -233,6 +236,7 @@ startBlockFetchConnectionThread tracer tracers fetchClientRegistry + keepAliveRegistry controlMsgSTM SharedResources{srPeerId} BlockFetchResources{bfrServer} @@ -246,6 +250,7 @@ startBlockFetchConnectionThread blockFetchTimeouts tracers fetchClientRegistry + keepAliveRegistry controlMsgSTM clientChannel serverThread <- @@ -423,6 +428,7 @@ startNode :: startNode protocolInfo schedulerConfig genesisTest interval = do let handles = psrHandles lrPeerSim fetchClientRegistry <- newFetchClientRegistry + keepAliveRegistry <- newKeepAliveRegistry let chainDbView = CSClient.defaultChainDbView lnChainDb activePeers = Map.toList $ Map.restrictKeys (psrPeers lrPeerSim) (lirActive liveResult) peersStartOrder = psStartOrder ++ sort [pid | (pid, _) <- activePeers, pid `notElem` psStartOrder] @@ -453,13 +459,14 @@ startNode protocolInfo schedulerConfig genesisTest interval = do csjConfig lnStateViewTracers handles - BlockFetch.startKeepAliveThread peerRegistry fetchClientRegistry pid + BlockFetch.startKeepAliveThread peerRegistry keepAliveRegistry pid (bfClient, bfServer) <- startBlockFetchConnectionThread peerRegistry tracer lnStateViewTracers fetchClientRegistry + keepAliveRegistry (pure Continue) prShared prBlockFetch @@ -475,6 +482,7 @@ startNode protocolInfo schedulerConfig genesisTest interval = do protocolInfo lnChainDb fetchClientRegistry + keepAliveRegistry handles for_ lrLoEVar $ \var -> do 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 d99619a784..2a84ff4ea4 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 @@ -66,6 +66,7 @@ import Ouroboros.Network.BlockFetch , bracketKeepAliveClient , bracketSyncWithFetchClient , newFetchClientRegistry + , newKeepAliveRegistry ) import Ouroboros.Network.BlockFetch.Client (blockFetchClient) import Ouroboros.Network.BlockFetch.ConsensusInterface @@ -119,7 +120,7 @@ prop_blockFetch bfcts@BlockFetchClientTestSetup{..} = property $ case blockFetchMode of PraosFetchMode FetchModeDeadline -> all (> 0) bfcoFetchedBlocks PraosFetchMode FetchModeBulkSync -> all (> 0) bfcoFetchedBlocks - FetchModeGenesis -> any (> 0) bfcoFetchedBlocks + GenesisFetchMode -> any (> 0) bfcoFetchedBlocks ] where BlockFetchClientOutcome{..} = runSimOrThrow $ runBlockFetchTest bfcts @@ -152,6 +153,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do varFetchedBlocks <- uncheckedNewTVarM (0 <$ peerUpdates) fetchClientRegistry <- newFetchClientRegistry + keepAliveRegistry <- newKeepAliveRegistry clock <- LogicalClock.new registry $ LogicalClock.sufficientTimeFor $ @@ -177,10 +179,11 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do nullTracer blockFetchConsensusInterface fetchClientRegistry + keepAliveRegistry blockFetchCfg let runBlockFetchClient peerId = - bracketFetchClient fetchClientRegistry ntnVersion peerId \clientCtx -> do + bracketFetchClient fetchClientRegistry keepAliveRegistry ntnVersion peerId \clientCtx -> do let bfClient = blockFetchClient ntnVersion @@ -243,7 +246,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do -- miniprotocol, even if it does not do anything. forkKeepAlive peerId = forkLinkedThread registry "KeepAlive" $ - bracketKeepAliveClient fetchClientRegistry peerId \_ -> + bracketKeepAliveClient keepAliveRegistry peerId \_ -> infiniteDelay blockFetchThreads <- @@ -401,7 +404,7 @@ instance Arbitrary BlockFetchClientTestSetup where elements [ PraosFetchMode FetchModeBulkSync , PraosFetchMode FetchModeDeadline - , FetchModeGenesis + , GenesisFetchMode ] blockFetchCfg <- do let From 6246397309f9dcaa1bd7903e8d7003754ebb8e7c Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 18 May 2026 15:15:18 +0200 Subject: [PATCH 02/62] Update LSM-trees packages - blockio-uring -> 0.2.0.0 - blockio -> 0.2.0.0 - lsm-trees -> 1.1.0.0 - QuickCheck -> 2.18.0.0 - quickcheck-state-machine -> 0.10.4 - fs-sim -> 0.5.0.1 --- cabal.project | 4 ++-- changelog.d/20260430_124955_javier.sagredo.md | 24 +++++++++++++++++++ flake.lock | 12 +++++----- nix/shell.nix | 4 ---- nix/tools.nix | 7 +----- .../Consensus/Shelley/Ledger/Mempool.hs | 5 ++-- ouroboros-consensus.cabal | 8 +++---- .../Test/Util/QuickCheck.hs | 16 +++++++++++++ .../Test/Util/Serialisation/Roundtrip.hs | 3 ++- .../Test/Consensus/Mempool/StateMachine.hs | 7 +++--- .../Storage/ImmutableDB/StateMachine.hs | 8 +++---- .../Storage/LedgerDB/StateMachine.hs | 3 ++- scripts/ci/run-dos2unix.sh | 13 +++++++++- 13 files changed, 80 insertions(+), 34 deletions(-) create mode 100644 changelog.d/20260430_124955_javier.sagredo.md diff --git a/cabal.project b/cabal.project index b720fd119f..0fdc82fef3 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 2026-03-17T01:21:06Z + , hackage.haskell.org 2026-05-18T17:14:36Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2026-04-13T13:33:52Z + , cardano-haskell-packages 2026-05-18T13:56:34Z active-repositories: , :rest diff --git a/changelog.d/20260430_124955_javier.sagredo.md b/changelog.d/20260430_124955_javier.sagredo.md new file mode 100644 index 0000000000..62f2d11c78 --- /dev/null +++ b/changelog.d/20260430_124955_javier.sagredo.md @@ -0,0 +1,24 @@ + + + + +### Patch + +- Updates on the LSM-trees ecosystem: + - blockio-uring 0.1.0.3 -> 0.2.0.0 + - blockio 0.1.1.1 -> 0.2.0.0 + - lsm-trees 1.0.0.1 -> 1.1.0.0 + +- Update to `fs-sim 0.5.0.0`. + +- Update to `QuickCheck 2.18`. diff --git a/flake.lock b/flake.lock index e8cf6b75cb..9f4c5fbbb1 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1776096450, - "narHash": "sha256-8s+VK+POr8jCU5369xihcFGgF6PgN+UkJYKxo1hxBdo=", + "lastModified": 1779114033, + "narHash": "sha256-68Yi51Ps5hwP80M0UXw4GTROmyzRL02PEXDEYfVEB4M=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "4faa15e7a38f5724da07275ffc9fb8f409190f2f", + "rev": "b20f09de9ba3099e0981a3bb9145847e7e2cfc24", "type": "github" }, "original": { @@ -253,11 +253,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1777960911, - "narHash": "sha256-4dBdNFA2DgDsw+iAGXj63w8qEtk3NzCXop0prqPdb1s=", + "lastModified": 1779172532, + "narHash": "sha256-gpH7CeWhkhhVR2ybollB6NM4LkaOOrgmSqVGu7jig6Q=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "802b7e98989df0e790fe2abc37bd799449d13c83", + "rev": "5099214b42826edce22cd8fbc52a0417fed83e29", "type": "github" }, "original": { diff --git a/nix/shell.nix b/nix/shell.nix index d8fcf4157f..a222d87555 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -40,10 +40,6 @@ hsPkgs.shellFor { allow-newer: haddock-library:base ''; }; - hoogle.cabalProjectLocal = '' - if impl(ghc <9.7) - constraints: alfred-margaret <2.1.1.0 || >2.1.1.0 - ''; }; shellHook = '' diff --git a/nix/tools.nix b/nix/tools.nix index c2acea1b76..e6ef03ecd4 100644 --- a/nix/tools.nix +++ b/nix/tools.nix @@ -2,7 +2,7 @@ inputs: final: prev: let inherit (final) lib; - tool-index-state = "2026-04-06T15:25:10Z"; + tool-index-state = "2026-05-08T14:12:57Z"; tool = name: version: other: final.haskell-nix.tool "ghc98" name ({ version = version; @@ -28,11 +28,6 @@ in rev = "f3a230de36a08920f8ad47766b0528b9229b3ce6"; hash = "sha256-WiSq1uBjuSCEW7vp/81a1PVdo/7pf86dqy+R7lDCOdY="; }; - cabalProject = '' - packages: . - constraints: - alfred-margaret <2.1.1.0 - ''; }; cabal-gild = tool "cabal-gild" "1.8.4.1" { compiler-nix-name = "ghc912"; }; diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index e16a473983..464ceb63ad 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -101,6 +101,7 @@ import Data.Word (Word32) import GHC.Generics (Generic) import GHC.Natural (Natural) import Lens.Micro ((^.)) +import Lens.Micro.Extras (view) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Abstract @@ -370,12 +371,12 @@ validateMaybe :: SL.ApplyTxError era -> Maybe a -> V.Validation (TxErrorSG era) a -validateMaybe err mb = V.validate (TxErrorSG err) id mb +validateMaybe err mb = maybe (V.Failure (TxErrorSG err)) V.Success mb runValidation :: V.Validation (TxErrorSG era) a -> Except (SL.ApplyTxError era) a -runValidation = liftEither . (unTxErrorSG +++ id) . V.toEither +runValidation = liftEither . (unTxErrorSG +++ id) . view V.either ----- diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 86af9b10c5..594d5d22b0 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -413,14 +413,14 @@ library lsm build-depends: base, - blockio, + blockio ^>=0.2, bytestring, containers, contra-tracer, filepath, fs-api, io-classes:mtl, - lsm-tree, + lsm-tree ^>=1.1, mempack, mtl, nothunks, @@ -519,7 +519,7 @@ library unstable-consensus-testlib file-embed, filepath, fs-api, - fs-sim ^>=0.4, + fs-sim ^>=0.5, generics-sop, hashable, io-classes:{io-classes, si-timers, strict-mvar, strict-stm}, @@ -1391,7 +1391,7 @@ library cardano strict-sop-core, text, these, - validation, + validation >=1.1.5, library unstable-byronspec import: common-lib diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QuickCheck.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QuickCheck.hs index 5a65e06708..5f93d1b2d0 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QuickCheck.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QuickCheck.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -42,6 +43,9 @@ module Test.Util.QuickCheck -- * Typeclass laws , prop_lawfulEqAndTotalOrd + + -- * Deprecated symbols + , withNumTests ) where import Control.Monad.Except (Except, runExcept) @@ -53,7 +57,19 @@ import Data.SOP.Constraint import Data.SOP.Strict import Ouroboros.Consensus.Util (repeatedly) import Ouroboros.Consensus.Util.Condense (Condense, condense) +#if !MIN_VERSION_QuickCheck(2,18,0) import Test.QuickCheck +#else +import Test.QuickCheck hiding (withNumTests) +import qualified Test.QuickCheck as QC +#endif + +withNumTests :: Testable prop => Int -> prop -> Property +#if !MIN_VERSION_QuickCheck(2,18,0) +withNumTests = withMaxSuccess +#else +withNumTests = QC.withNumTests +#endif {------------------------------------------------------------------------------- Generic QuickCheck utilities diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs index c74709064b..cee3260579 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs @@ -100,6 +100,7 @@ import Test.QuickCheck.Monadic import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.Orphans.Arbitrary () +import qualified Test.Util.QuickCheck as QC import Test.Util.Serialisation.CDDL import Test.Util.Serialisation.Examples (Examples (..), Labelled) import Test.Util.Serialisation.SomeResult (SomeResult (..)) @@ -660,7 +661,7 @@ roundtrip_SerialiseNodeToClient shouldCheckCBORvalidity ccfg = -- require an 'Eq' and 'Show' instance for all ledger config types which -- we'd like to avoid (as the EpochInfo is a record of functions). testProperty "roundtrip (comparing encoding) LedgerConfig" $ - withMaxSuccess 20 $ \(Blind (WithVersion version a)) -> + QC.withNumTests 20 $ \(Blind (WithVersion version a)) -> roundtripComparingEncoding @(LedgerConfig blk) (enc version) (dec version) a , rtWith @(SomeSecond Query blk) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs index 5ba4798eb0..42cfbd37b2 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs @@ -82,6 +82,7 @@ import qualified Test.StateMachine.Types.Rank2 as Rank2 import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.Orphans.ToExpr () +import qualified Test.Util.QuickCheck as QC import Test.Util.ToExpr () {------------------------------------------------------------------------------- @@ -798,17 +799,17 @@ tests = testGroup "QSM" [ testProperty "sequential" $ - withMaxSuccess 1000 $ + QC.withNumTests 1000 $ prop_mempoolSequential testLedgerConfigNoSizeLimits txMaxBytes' testInitLedger $ \i -> fmap (fmap fst . fst) . genTxs i , testGroup "parallel" [ testProperty "atomic" $ - withMaxSuccess 10000 $ + QC.withNumTests 10000 $ prop_mempoolParallel testLedgerConfigNoSizeLimits txMaxBytes' testInitLedger Atomic $ \i -> fmap (fmap fst . fst) . genTxs i , testProperty "non atomic" $ - withMaxSuccess 10 $ + QC.withNumTests 10 $ prop_mempoolParallel testLedgerConfigNoSizeLimits txMaxBytes' testInitLedger NonAtomic $ \i -> fmap (fmap fst . fst) . genTxs i ] diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs index e72d2211c7..d69a0856ae 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs @@ -750,14 +750,14 @@ generateCmd Model{..} = ) ] - chooseWord64 :: Coercible a Word64 => (a, a) -> Gen a - chooseWord64 (start, end) = coerce $ choose @Word64 (coerce start, coerce end) + chooseWord64' :: Coercible a Word64 => (a, a) -> Gen a + chooseWord64' (start, end) = coerce $ choose @Word64 (coerce start, coerce end) chooseSlot :: (SlotNo, SlotNo) -> Gen SlotNo - chooseSlot = chooseWord64 + chooseSlot = chooseWord64' chooseEpoch :: (EpochNo, EpochNo) -> Gen EpochNo - chooseEpoch = chooseWord64 + chooseEpoch = chooseWord64' genCorruption :: Gen Corruption genCorruption = MkCorruption <$> generateCorruptions (NE.fromList dbFiles) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs index 5824e8b2d6..26734bf04d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs @@ -75,6 +75,7 @@ import qualified Test.QuickCheck.Monadic as QC import Test.QuickCheck.StateModel import Test.Tasty import Test.Tasty.QuickCheck (frequency, tabulate, testProperty) +import qualified Test.Util.QuickCheck as QC' import Test.Util.TestBlock hiding ( TestBlock , TestBlockCodecConfig @@ -99,7 +100,7 @@ prop_sequential :: Actions Model -> QC.Property prop_sequential maxSuccess mkTestArguments getDiskDir fsOps actions = - QC.withMaxSuccess maxSuccess $ + QC'.withNumTests maxSuccess $ QC.monadic runner $ Monad.void $ runActions $ diff --git a/scripts/ci/run-dos2unix.sh b/scripts/ci/run-dos2unix.sh index a05a2e2469..4bdaba1086 100755 --- a/scripts/ci/run-dos2unix.sh +++ b/scripts/ci/run-dos2unix.sh @@ -2,4 +2,15 @@ set -euo pipefail -fd -X dos2unix +fdcmd="fd" +if ! command -v "$fdcmd" &> /dev/null; then + # In Ubuntu systems the fd command is called fdfind. + # If 'fd' is not found, try 'fdfind' + fdcmd="fdfind" + if ! command -v "$fdcmd" &> /dev/null; then + echo "Error: Neither 'fd' nor 'fdfind' command found." >&2 + exit 1 + fi +fi + +$fdcmd -X dos2unix From 5b63b5a0f6e9f98eeb7bb8c686887ec378a0629f Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Wed, 20 May 2026 10:21:49 +0200 Subject: [PATCH 03/62] Transient constraints for windows cross-compilation --- cabal.project | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/cabal.project b/cabal.project index 0fdc82fef3..2bb87ac71c 100644 --- a/cabal.project +++ b/cabal.project @@ -44,6 +44,12 @@ if os (windows) constraints: bitvec -simd +constraints: + tasty <1.5.4, + plutus-core ^>=1.61, + plutus-ledger-api ^>=1.61, + plutus-tx ^>=1.61 + -- ouroboros-network dependency after introducing `bracketKeepAlive` (PR#5371) source-repository-package type: git From 1e4115fe6c06d85c0ec0570a0a15921e16705815 Mon Sep 17 00:00:00 2001 From: Piotr Paradzinski Date: Fri, 15 May 2026 20:11:03 +0200 Subject: [PATCH 04/62] Rename Test.Consensus.Node to Test.Consensus.DBLock --- ouroboros-consensus-diffusion/test/consensus-test/Main.hs | 4 ++-- .../test/consensus-test/Test/Consensus/{Node.hs => DBLock.hs} | 4 ++-- ouroboros-consensus.cabal | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) rename ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/{Node.hs => DBLock.hs} (99%) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Main.hs b/ouroboros-consensus-diffusion/test/consensus-test/Main.hs index 9260db8454..7b80992e55 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Main.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Main.hs @@ -1,11 +1,11 @@ module Main (main) where import qualified Test.Consensus.BlockTree.Tests (tests) +import qualified Test.Consensus.DBLock (tests) import qualified Test.Consensus.GSM (tests) import qualified Test.Consensus.Genesis.TestSuite.SmallKey.Tests (tests) import qualified Test.Consensus.Genesis.Tests (tests) import qualified Test.Consensus.HardFork.Combinator (tests) -import qualified Test.Consensus.Node (tests) import qualified Test.Consensus.PeerSimulator.Tests (tests) import qualified Test.Consensus.PointSchedule.Shrinking.Tests (tests) import qualified Test.Consensus.PointSchedule.Tests (tests) @@ -22,7 +22,7 @@ tests :: TestTree tests = testGroup "ouroboros-consensus" - [ Test.Consensus.Node.tests + [ Test.Consensus.DBLock.tests , testGroup "HardFork" [ testGroup diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Node.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/DBLock.hs similarity index 99% rename from ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Node.hs rename to ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/DBLock.hs index 68f8b1575c..a07e478d87 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/DBLock.hs @@ -17,7 +17,7 @@ -- -- This module contains a bunch of unit tests to make sure that these locks and -- markers are created correctly and behave as expected. -module Test.Consensus.Node (tests) where +module Test.Consensus.DBLock (tests) where import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Monad.IOSim (runSimOrThrow) @@ -46,7 +46,7 @@ import Test.Util.QuickCheck (ge) tests :: TestTree tests = testGroup - "Node" + "DBLock" [ testGroup "checkDbMarker" [ testCase "match" test_checkNetworkMagic_match diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 594d5d22b0..8aa0a29356 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1183,6 +1183,7 @@ test-suite consensus-diffusion-test other-modules: Test.Consensus.BlockTree Test.Consensus.BlockTree.Tests + Test.Consensus.DBLock Test.Consensus.Genesis.Setup Test.Consensus.Genesis.Setup.Classifiers Test.Consensus.Genesis.Setup.GenChains @@ -1202,7 +1203,6 @@ test-suite consensus-diffusion-test Test.Consensus.HardFork.Combinator.A Test.Consensus.HardFork.Combinator.B Test.Consensus.Network.AnchoredFragment.Extras - Test.Consensus.Node Test.Consensus.PeerSimulator.BlockFetch Test.Consensus.PeerSimulator.ChainSync Test.Consensus.PeerSimulator.Config From 2b335d601db334db09dbe4c27f4e143089ac1822 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 29 May 2026 15:09:37 +0200 Subject: [PATCH 05/62] Fix typo in roundtrip tests `pShowNeq` was given the same value twice so failures in rountrip tests are very confusing --- .../Test/Util/Serialisation/Roundtrip.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs index cee3260579..b7a66ecd8c 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs @@ -174,7 +174,7 @@ roundtripAnd check enc dec checkCddlValid a = case mkA' bs of Left err -> Left (showByteString bsRem err) Right a' -> - a == a' ?! pShowNeq a a + a == a' ?! pShowNeq a a' cddlValid = monadicIO $ run (checkCddlValid $ Lazy.toStrict bs) >>= \case From 29a3ec332a3365e028a0ce8b1e49b256e7e1d8bb Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 3 Jun 2026 11:10:34 +0200 Subject: [PATCH 06/62] docs website: add search Enable searching the documentation website --- docs/website/docusaurus.config.js | 18 +- docs/website/package.json | 1 + docs/website/yarn.lock | 554 +++++++++++++++++++++++++++++- 3 files changed, 565 insertions(+), 8 deletions(-) diff --git a/docs/website/docusaurus.config.js b/docs/website/docusaurus.config.js index fcc6f54de9..0de177dff3 100644 --- a/docs/website/docusaurus.config.js +++ b/docs/website/docusaurus.config.js @@ -46,7 +46,23 @@ const config = { }, }, - themes: ['@docusaurus/theme-mermaid'], + themes: [ + '@docusaurus/theme-mermaid', + [ + // Local, offline search. Builds a Lunr index at build time and serves it + // as static assets, so it needs no external service. See: + // https://github.com/easyops-cn/docusaurus-search-local + require.resolve('@easyops-cn/docusaurus-search-local'), + /** @type {import('@easyops-cn/docusaurus-search-local').PluginOptions} */ + ({ + hashed: true, + indexBlog: false, + highlightSearchTermsOnTargetPage: true, + explicitSearchResultPath: true, + docsDir: 'contents', + }), + ], + ], presets: [ [ diff --git a/docs/website/package.json b/docs/website/package.json index 1c19a5ee86..472a338c76 100644 --- a/docs/website/package.json +++ b/docs/website/package.json @@ -19,6 +19,7 @@ "@docusaurus/plugin-client-redirects": "3.10.0", "@docusaurus/preset-classic": "^3.10.0", "@docusaurus/theme-mermaid": "^3.10.0", + "@easyops-cn/docusaurus-search-local": "^0.55.2", "@mdx-js/react": "^3.1.1", "clsx": "^2.1.1", "hast-util-is-element": "3.0.0", diff --git a/docs/website/yarn.lock b/docs/website/yarn.lock index 5d1cd100fc..afbb060918 100644 --- a/docs/website/yarn.lock +++ b/docs/website/yarn.lock @@ -1553,6 +1553,26 @@ fs-extra "^11.1.1" tslib "^2.6.0" +"@docusaurus/babel@3.10.1": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/babel/-/babel-3.10.1.tgz#2f714f682117658ba43d308e9b35b6a73a105227" + integrity sha512-DZzFO1K3v/GoEt1fx1DiYHF4en+PuhtQf1AkQJa5zu3CoeKSpr5cpQRUlz3jr0m44wyzmSXu9bVpfir+N4+8bg== + dependencies: + "@babel/core" "^7.25.9" + "@babel/generator" "^7.25.9" + "@babel/plugin-syntax-dynamic-import" "^7.8.3" + "@babel/plugin-transform-runtime" "^7.25.9" + "@babel/preset-env" "^7.25.9" + "@babel/preset-react" "^7.25.9" + "@babel/preset-typescript" "^7.25.9" + "@babel/runtime" "^7.25.9" + "@babel/traverse" "^7.25.9" + "@docusaurus/logger" "3.10.1" + "@docusaurus/utils" "3.10.1" + babel-plugin-dynamic-import-node "^2.3.3" + fs-extra "^11.1.1" + tslib "^2.6.0" + "@docusaurus/bundler@3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/bundler/-/bundler-3.10.0.tgz#878c4c46bfa3434671ea37a43da184238a6aae26" @@ -1583,6 +1603,36 @@ webpack "^5.95.0" webpackbar "^6.0.1" +"@docusaurus/bundler@3.10.1": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/bundler/-/bundler-3.10.1.tgz#82fa5079f3787a67502e25f82d37d05ec5de0cc3" + integrity sha512-HIqQPvbqnnQRe4NsBd1774KRarjXqS6wHsWELtyuSs1gCfvixJO2jUGH/OEBtr1Gvzpw+ze5CjGMvSJ8UE1KUw== + dependencies: + "@babel/core" "^7.25.9" + "@docusaurus/babel" "3.10.1" + "@docusaurus/cssnano-preset" "3.10.1" + "@docusaurus/logger" "3.10.1" + "@docusaurus/types" "3.10.1" + "@docusaurus/utils" "3.10.1" + babel-loader "^9.2.1" + clean-css "^5.3.3" + copy-webpack-plugin "^11.0.0" + css-loader "^6.11.0" + css-minimizer-webpack-plugin "^5.0.1" + cssnano "^6.1.2" + file-loader "^6.2.0" + html-minifier-terser "^7.2.0" + mini-css-extract-plugin "^2.9.2" + null-loader "^4.0.1" + postcss "^8.5.4" + postcss-loader "^7.3.4" + postcss-preset-env "^10.2.1" + terser-webpack-plugin "^5.3.9" + tslib "^2.6.0" + url-loader "^4.1.1" + webpack "^5.95.0" + webpackbar "^7.0.0" + "@docusaurus/core@3.10.0", "@docusaurus/core@^3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/core/-/core-3.10.0.tgz#642e71a0209d62c3f5ef275ed9d74a881f40df39" @@ -1631,6 +1681,54 @@ webpack-dev-server "^5.2.2" webpack-merge "^6.0.1" +"@docusaurus/core@3.10.1": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/core/-/core-3.10.1.tgz#3f8bdb97451b4df14f2a3b39ab0186366fbf8fbe" + integrity sha512-3pf2fXXw0eVk8WnC3T4LIigRDupcpvngpKo9Vy7mYyBhuddc0klDUuZAIfzMoK6z05pdlk6EFC/vBSX43+1O5w== + dependencies: + "@docusaurus/babel" "3.10.1" + "@docusaurus/bundler" "3.10.1" + "@docusaurus/logger" "3.10.1" + "@docusaurus/mdx-loader" "3.10.1" + "@docusaurus/utils" "3.10.1" + "@docusaurus/utils-common" "3.10.1" + "@docusaurus/utils-validation" "3.10.1" + boxen "^6.2.1" + chalk "^4.1.2" + chokidar "^3.5.3" + cli-table3 "^0.6.3" + combine-promises "^1.1.0" + commander "^5.1.0" + core-js "^3.31.1" + detect-port "^1.5.1" + escape-html "^1.0.3" + eta "^2.2.0" + eval "^0.1.8" + execa "^5.1.1" + fs-extra "^11.1.1" + html-tags "^3.3.1" + html-webpack-plugin "^5.6.0" + leven "^3.1.0" + lodash "^4.17.21" + open "^8.4.0" + p-map "^4.0.0" + prompts "^2.4.2" + react-helmet-async "npm:@slorber/react-helmet-async@1.3.0" + react-loadable "npm:@docusaurus/react-loadable@6.0.0" + react-loadable-ssr-addon-v5-slorber "^1.0.3" + react-router "^5.3.4" + react-router-config "^5.1.1" + react-router-dom "^5.3.4" + semver "^7.5.4" + serve-handler "^6.1.7" + tinypool "^1.0.2" + tslib "^2.6.0" + update-notifier "^6.0.2" + webpack "^5.95.0" + webpack-bundle-analyzer "^4.10.2" + webpack-dev-server "^5.2.2" + webpack-merge "^6.0.1" + "@docusaurus/cssnano-preset@3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/cssnano-preset/-/cssnano-preset-3.10.0.tgz#be1b435c33df09d743473d3fadda67b4568dfae3" @@ -1641,6 +1739,16 @@ postcss-sort-media-queries "^5.2.0" tslib "^2.6.0" +"@docusaurus/cssnano-preset@3.10.1": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/cssnano-preset/-/cssnano-preset-3.10.1.tgz#4b6bafeca8bb9423364d2fd6683c28e2f85a4665" + integrity sha512-eNfHGcTKCSq6xmcavAkX3RRclHaE2xRCMParlDXLdXVP01/a2e/jKXMj/0ULnLFQSNwwuI62L0Ge8J+nZsR7UQ== + dependencies: + cssnano-preset-advanced "^6.1.2" + postcss "^8.5.4" + postcss-sort-media-queries "^5.2.0" + tslib "^2.6.0" + "@docusaurus/logger@3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/logger/-/logger-3.10.0.tgz#2bacbd004dd78e3da926dbe8f6fa9a930856575d" @@ -1649,6 +1757,14 @@ chalk "^4.1.2" tslib "^2.6.0" +"@docusaurus/logger@3.10.1": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/logger/-/logger-3.10.1.tgz#34c964e32e18f120e30f80171a38cfefe72cfb4b" + integrity sha512-oPjNFnfJsRCkePVjkGrxWGq4MvJKRQT0r9jOP0eRBTZ7Wr9FAbzdP/Gjs0I2Ss6YRkPoEgygKG112OkE6skvJw== + dependencies: + chalk "^4.1.2" + tslib "^2.6.0" + "@docusaurus/mdx-loader@3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/mdx-loader/-/mdx-loader-3.10.0.tgz#1d4b050d751389ecf38dee48bcb61e53df8ffb82" @@ -1679,6 +1795,36 @@ vfile "^6.0.1" webpack "^5.88.1" +"@docusaurus/mdx-loader@3.10.1": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/mdx-loader/-/mdx-loader-3.10.1.tgz#050ae9bc614158a4ec07a628aa75fa9ae90d7e82" + integrity sha512-GRmeb/wQ+iXRrFwcHBfgQhrJxGElgCsoTWZYDhccjsZVne1p8MK/EpQVIloXttz76TCe78kKD5AEG9n1xc1oxQ== + dependencies: + "@docusaurus/logger" "3.10.1" + "@docusaurus/utils" "3.10.1" + "@docusaurus/utils-validation" "3.10.1" + "@mdx-js/mdx" "^3.0.0" + "@slorber/remark-comment" "^1.0.0" + escape-html "^1.0.3" + estree-util-value-to-estree "^3.0.1" + file-loader "^6.2.0" + fs-extra "^11.1.1" + image-size "^2.0.2" + mdast-util-mdx "^3.0.0" + mdast-util-to-string "^4.0.0" + rehype-raw "^7.0.0" + remark-directive "^3.0.0" + remark-emoji "^4.0.0" + remark-frontmatter "^5.0.0" + remark-gfm "^4.0.0" + stringify-object "^3.3.0" + tslib "^2.6.0" + unified "^11.0.3" + unist-util-visit "^5.0.0" + url-loader "^4.1.1" + vfile "^6.0.1" + webpack "^5.88.1" + "@docusaurus/module-type-aliases@3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/module-type-aliases/-/module-type-aliases-3.10.0.tgz#749928f104d563f11f046bf0c9ab6489a470c7c8" @@ -1692,6 +1838,19 @@ react-helmet-async "npm:@slorber/react-helmet-async@1.3.0" react-loadable "npm:@docusaurus/react-loadable@6.0.0" +"@docusaurus/module-type-aliases@3.10.1": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/module-type-aliases/-/module-type-aliases-3.10.1.tgz#22d39177c296786eb6e0d940699cd590cc93ca77" + integrity sha512-YoOZKUdGlp8xSYhuAkGdSo5Ydkbq4V4eK3sD8v0a2hloxCWdQbNBhkc+Ko9QyjpESc0BYcIGM5iHVAy5hdFV6w== + dependencies: + "@docusaurus/types" "3.10.1" + "@types/history" "^4.7.11" + "@types/react" "*" + "@types/react-router-config" "*" + "@types/react-router-dom" "*" + react-helmet-async "npm:@slorber/react-helmet-async@1.3.0" + react-loadable "npm:@docusaurus/react-loadable@6.0.0" + "@docusaurus/plugin-client-redirects@3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/plugin-client-redirects/-/plugin-client-redirects-3.10.0.tgz#4dd4619817fd69462d1e6d986580343aeb911111" @@ -1756,6 +1915,30 @@ utility-types "^3.10.0" webpack "^5.88.1" +"@docusaurus/plugin-content-docs@^2 || ^3": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/plugin-content-docs/-/plugin-content-docs-3.10.1.tgz#261e0e982e4a937c05b462e3c5729374f433b752" + integrity sha512-2jRVrtzjf8LClGTHQlwlwuD3wQXRx3WEoF7XUarJ8Ou+0onV+SLtejsyfY9JLpfUh9hPhXM4pbBGkyAY4Bi3HQ== + dependencies: + "@docusaurus/core" "3.10.1" + "@docusaurus/logger" "3.10.1" + "@docusaurus/mdx-loader" "3.10.1" + "@docusaurus/module-type-aliases" "3.10.1" + "@docusaurus/theme-common" "3.10.1" + "@docusaurus/types" "3.10.1" + "@docusaurus/utils" "3.10.1" + "@docusaurus/utils-common" "3.10.1" + "@docusaurus/utils-validation" "3.10.1" + "@types/react-router-config" "^5.0.7" + combine-promises "^1.1.0" + fs-extra "^11.1.1" + js-yaml "^4.1.0" + lodash "^4.17.21" + schema-dts "^1.1.2" + tslib "^2.6.0" + utility-types "^3.10.0" + webpack "^5.88.1" + "@docusaurus/plugin-content-pages@3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/plugin-content-pages/-/plugin-content-pages-3.10.0.tgz#7670cbb3c849f434949f542bfdfded1580a13165" @@ -1924,6 +2107,24 @@ tslib "^2.6.0" utility-types "^3.10.0" +"@docusaurus/theme-common@3.10.1": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/theme-common/-/theme-common-3.10.1.tgz#cbfec82b1b107be5c229811ed9caae14a501361c" + integrity sha512-0YtmIeoNo1fIw65LO8+/1dPgmDV86UmhMkow37gzjytuiCSQm9xob6PJy0L4kuQEMTLfUOGvkXvZr7GPrHquMA== + dependencies: + "@docusaurus/mdx-loader" "3.10.1" + "@docusaurus/module-type-aliases" "3.10.1" + "@docusaurus/utils" "3.10.1" + "@docusaurus/utils-common" "3.10.1" + "@types/history" "^4.7.11" + "@types/react" "*" + "@types/react-router-config" "*" + clsx "^2.0.0" + parse-numeric-range "^1.3.0" + prism-react-renderer "^2.3.0" + tslib "^2.6.0" + utility-types "^3.10.0" + "@docusaurus/theme-mermaid@^3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/theme-mermaid/-/theme-mermaid-3.10.0.tgz#6581ccf16d27e4c02fe8c7cf15488862f27be9c8" @@ -1968,6 +2169,14 @@ fs-extra "^11.1.1" tslib "^2.6.0" +"@docusaurus/theme-translations@^2 || ^3": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/theme-translations/-/theme-translations-3.10.1.tgz#c3119a015652290eea560ca45ac775963d6eb75b" + integrity sha512-cLMyaKivjBVWKMJuWqyFVVgtqe8DPJNPkog0bn8W1MDVAKcPdxRFycBfC1We1RaNp7Rdk513bmtW78RR6OBxBw== + dependencies: + fs-extra "^11.1.1" + tslib "^2.6.0" + "@docusaurus/types@3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/types/-/types-3.10.0.tgz#a69232bba74b738fcf4671fd5f0f079366dd3d13" @@ -1984,6 +2193,22 @@ webpack "^5.95.0" webpack-merge "^5.9.0" +"@docusaurus/types@3.10.1": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/types/-/types-3.10.1.tgz#d42837938ae43ca2be0ca47e63e00476b5eb94be" + integrity sha512-XYMK8k1szDCFMw2V+Xyen0g7Kee1sP3dtFnl7vkGkZOkeAJ/oPDQPL8iz4HBKOo/cwU8QeV6onVjMqtP+tFzsw== + dependencies: + "@mdx-js/mdx" "^3.0.0" + "@types/history" "^4.7.11" + "@types/mdast" "^4.0.2" + "@types/react" "*" + commander "^5.1.0" + joi "^17.9.2" + react-helmet-async "npm:@slorber/react-helmet-async@1.3.0" + utility-types "^3.10.0" + webpack "^5.95.0" + webpack-merge "^5.9.0" + "@docusaurus/utils-common@3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/utils-common/-/utils-common-3.10.0.tgz#2a6dc76b312664fca7234d33607c085318ff1ae3" @@ -1992,6 +2217,14 @@ "@docusaurus/types" "3.10.0" tslib "^2.6.0" +"@docusaurus/utils-common@3.10.1", "@docusaurus/utils-common@^2 || ^3": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/utils-common/-/utils-common-3.10.1.tgz#6350b4898691e765de750f90eade0e0fa7902d99" + integrity sha512-5mFSgEADtnFxFH7RLw02QA5MpU5JVUCj0MPeIvi/aF4Fi45tQRIuTwXoXDqJ+1VfQJuYJGz3SI63wmGz4HvXzA== + dependencies: + "@docusaurus/types" "3.10.1" + tslib "^2.6.0" + "@docusaurus/utils-validation@3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/utils-validation/-/utils-validation-3.10.0.tgz#a2418d7f31980d991fd3a1f39c8aad8820b36812" @@ -2006,6 +2239,20 @@ lodash "^4.17.21" tslib "^2.6.0" +"@docusaurus/utils-validation@3.10.1", "@docusaurus/utils-validation@^2 || ^3": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/utils-validation/-/utils-validation-3.10.1.tgz#ddbcce997a5506424cdd16abf6845cc51692acae" + integrity sha512-cRv1X69jwaWv47waglllgZVWzeBFLhl53XT/XED/83BerVBTC5FTP8WTcVl8Z6sZOegDSwitu/wpCSPCDOT6lg== + dependencies: + "@docusaurus/logger" "3.10.1" + "@docusaurus/utils" "3.10.1" + "@docusaurus/utils-common" "3.10.1" + fs-extra "^11.2.0" + joi "^17.9.2" + js-yaml "^4.1.0" + lodash "^4.17.21" + tslib "^2.6.0" + "@docusaurus/utils@3.10.0": version "3.10.0" resolved "https://registry.yarnpkg.com/@docusaurus/utils/-/utils-3.10.0.tgz#ea7d7b0d325b60f728decc00bb3908d00ef86faf" @@ -2033,6 +2280,86 @@ utility-types "^3.10.0" webpack "^5.88.1" +"@docusaurus/utils@3.10.1", "@docusaurus/utils@^2 || ^3": + version "3.10.1" + resolved "https://registry.yarnpkg.com/@docusaurus/utils/-/utils-3.10.1.tgz#535968caa2c9bff69f997a081b98b95b3c5d3785" + integrity sha512-3ojeJry9xBYdJO6qoyyzqeJFSJBVx2mXhyDzSdjwL2+URFQMf+h25gG38iswGImicK0ELjTd1EL2xzk8hf3QPw== + dependencies: + "@docusaurus/logger" "3.10.1" + "@docusaurus/types" "3.10.1" + "@docusaurus/utils-common" "3.10.1" + escape-string-regexp "^4.0.0" + execa "^5.1.1" + file-loader "^6.2.0" + fs-extra "^11.1.1" + github-slugger "^1.5.0" + globby "^11.1.0" + gray-matter "^4.0.3" + jiti "^1.20.0" + js-yaml "^4.1.0" + lodash "^4.17.21" + micromatch "^4.0.5" + p-queue "^6.6.2" + prompts "^2.4.2" + resolve-pathname "^3.0.0" + tslib "^2.6.0" + url-loader "^4.1.1" + utility-types "^3.10.0" + webpack "^5.88.1" + +"@easyops-cn/autocomplete.js@^0.38.1": + version "0.38.1" + resolved "https://registry.yarnpkg.com/@easyops-cn/autocomplete.js/-/autocomplete.js-0.38.1.tgz#46dff5795a9a032fa9b9250fdf63ca6c61c07629" + integrity sha512-drg76jS6syilOUmVNkyo1c7ZEBPcPuK+aJA7AksM5ZIIbV57DMHCywiCr+uHyv8BE5jUTU98j/H7gVrkHrWW3Q== + dependencies: + cssesc "^3.0.0" + immediate "^3.2.3" + +"@easyops-cn/docusaurus-search-local@^0.55.2": + version "0.55.2" + resolved "https://registry.yarnpkg.com/@easyops-cn/docusaurus-search-local/-/docusaurus-search-local-0.55.2.tgz#563ab1f8fd7bc18541d889f4d5001a3ef85c5a1e" + integrity sha512-dI/riu+MbDxkAjAHAdc0uahjXRaWKvbIPe9IAmA6AGcUfnVb9xd8s2I/6wEPTOXsAd6eFqn4Yis3WBWh3KUd3g== + dependencies: + "@docusaurus/plugin-content-docs" "^2 || ^3" + "@docusaurus/theme-translations" "^2 || ^3" + "@docusaurus/utils" "^2 || ^3" + "@docusaurus/utils-common" "^2 || ^3" + "@docusaurus/utils-validation" "^2 || ^3" + "@easyops-cn/autocomplete.js" "^0.38.1" + "@node-rs/jieba" "^1.6.0" + cheerio "^1.0.0" + clsx "^2.1.1" + comlink "^4.4.2" + debug "^4.2.0" + fs-extra "^10.0.0" + klaw-sync "^6.0.0" + lunr "^2.3.9" + lunr-languages "^1.4.0" + mark.js "^8.11.1" + tslib "^2.4.0" + +"@emnapi/core@^1.4.3": + version "1.10.0" + resolved "https://registry.yarnpkg.com/@emnapi/core/-/core-1.10.0.tgz#380ccc8f2412ea22d1d972df7f8ee23a3b9c7467" + integrity sha512-yq6OkJ4p82CAfPl0u9mQebQHKPJkY7WrIuk205cTYnYe+k2Z8YBh11FrbRG/H6ihirqcacOgl2BIO8oyMQLeXw== + dependencies: + "@emnapi/wasi-threads" "1.2.1" + tslib "^2.4.0" + +"@emnapi/runtime@^1.4.3": + version "1.10.0" + resolved "https://registry.yarnpkg.com/@emnapi/runtime/-/runtime-1.10.0.tgz#4b260c0d3534204e98c6110b8db1a987d26ec87c" + integrity sha512-ewvYlk86xUoGI0zQRNq/mC+16R1QeDlKQy21Ki3oSYXNgLb45GV1P6A0M+/s6nyCuNDqe5VpaY84BzXGwVbwFA== + dependencies: + tslib "^2.4.0" + +"@emnapi/wasi-threads@1.2.1": + version "1.2.1" + resolved "https://registry.yarnpkg.com/@emnapi/wasi-threads/-/wasi-threads-1.2.1.tgz#28fed21a1ba1ce797c44a070abc94d42f3ae8548" + integrity sha512-uTII7OYF+/Mes/MrcIOYp5yOtSMLBWSIoLPpcgwipoiKbli6k322tcoFsxoIIxPDqW01SQGAgko4EzZi2BNv2w== + dependencies: + tslib "^2.4.0" + "@hapi/hoek@^9.0.0", "@hapi/hoek@^9.3.0": version "9.3.0" resolved "https://registry.yarnpkg.com/@hapi/hoek/-/hoek-9.3.0.tgz#8368869dcb735be2e7f5cb7647de78e167a251fb" @@ -2330,11 +2657,112 @@ dependencies: langium "^4.0.0" +"@napi-rs/wasm-runtime@^0.2.3": + version "0.2.12" + resolved "https://registry.yarnpkg.com/@napi-rs/wasm-runtime/-/wasm-runtime-0.2.12.tgz#3e78a8b96e6c33a6c517e1894efbd5385a7cb6f2" + integrity sha512-ZVWUcfwY4E/yPitQJl481FjFo3K22D6qF0DuFH6Y/nbnE11GY5uguDxZMGXPQ8WQ0128MXQD7TnfHyK4oWoIJQ== + dependencies: + "@emnapi/core" "^1.4.3" + "@emnapi/runtime" "^1.4.3" + "@tybys/wasm-util" "^0.10.0" + "@noble/hashes@1.4.0": version "1.4.0" resolved "https://registry.yarnpkg.com/@noble/hashes/-/hashes-1.4.0.tgz#45814aa329f30e4fe0ba49426f49dfccdd066426" integrity sha512-V1JJ1WTRUqHHrOSh597hURcMqVKVGL/ea3kv0gSnEdsEZ0/+VyPghM1lMNGc00z7CIQorSvbKpuJkxvuHbvdbg== +"@node-rs/jieba-android-arm-eabi@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-android-arm-eabi/-/jieba-android-arm-eabi-1.10.4.tgz#c8c0be3895f01c86a0138cbb1b2228d0895c6854" + integrity sha512-MhyvW5N3Fwcp385d0rxbCWH42kqDBatQTyP8XbnYbju2+0BO/eTeCCLYj7Agws4pwxn2LtdldXRSKavT7WdzNA== + +"@node-rs/jieba-android-arm64@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-android-arm64/-/jieba-android-arm64-1.10.4.tgz#02bcf7a52d6036983398fa041d50ab73e53e8e03" + integrity sha512-XyDwq5+rQ+Tk55A+FGi6PtJbzf974oqnpyCcCPzwU3QVXJCa2Rr4Lci+fx8oOpU4plT3GuD+chXMYLsXipMgJA== + +"@node-rs/jieba-darwin-arm64@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-darwin-arm64/-/jieba-darwin-arm64-1.10.4.tgz#2f39e7f21d1f01afe06fb4c5deeb7ac098f7870c" + integrity sha512-G++RYEJ2jo0rxF9626KUy90wp06TRUjAsvY/BrIzEOX/ingQYV/HjwQzNPRR1P1o32a6/U8RGo7zEBhfdybL6w== + +"@node-rs/jieba-darwin-x64@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-darwin-x64/-/jieba-darwin-x64-1.10.4.tgz#c3d007962f5b247c3a8a0707dd393ee71f840ea6" + integrity sha512-MmDNeOb2TXIZCPyWCi2upQnZpPjAxw5ZGEj6R8kNsPXVFALHIKMa6ZZ15LCOkSTsKXVC17j2t4h+hSuyYb6qfQ== + +"@node-rs/jieba-freebsd-x64@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-freebsd-x64/-/jieba-freebsd-x64-1.10.4.tgz#5ab23591604f4a256f6bad1e4230faeac5220a0d" + integrity sha512-/x7aVQ8nqUWhpXU92RZqd333cq639i/olNpd9Z5hdlyyV5/B65LLy+Je2B2bfs62PVVm5QXRpeBcZqaHelp/bg== + +"@node-rs/jieba-linux-arm-gnueabihf@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-linux-arm-gnueabihf/-/jieba-linux-arm-gnueabihf-1.10.4.tgz#415237af704f9bbd10742995f02f779679a840b1" + integrity sha512-crd2M35oJBRLkoESs0O6QO3BBbhpv+tqXuKsqhIG94B1d02RVxtRIvSDwO33QurxqSdvN9IeSnVpHbDGkuXm3g== + +"@node-rs/jieba-linux-arm64-gnu@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-linux-arm64-gnu/-/jieba-linux-arm64-gnu-1.10.4.tgz#3e9debcc6c903852a28df9caa3d004cb08bc9299" + integrity sha512-omIzNX1psUzPcsdnUhGU6oHeOaTCuCjUgOA/v/DGkvWC1jLcnfXe4vdYbtXMh4XOCuIgS1UCcvZEc8vQLXFbXQ== + +"@node-rs/jieba-linux-arm64-musl@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-linux-arm64-musl/-/jieba-linux-arm64-musl-1.10.4.tgz#faf11579a7cc3f798780819403b1fb34a0360d9e" + integrity sha512-Y/tiJ1+HeS5nnmLbZOE+66LbsPOHZ/PUckAYVeLlQfpygLEpLYdlh0aPpS5uiaWMjAXYZYdFkpZHhxDmSLpwpw== + +"@node-rs/jieba-linux-x64-gnu@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-linux-x64-gnu/-/jieba-linux-x64-gnu-1.10.4.tgz#05187afe917370ef2607564897ec5979f8e67ca9" + integrity sha512-WZO8ykRJpWGE9MHuZpy1lu3nJluPoeB+fIJJn5CWZ9YTVhNDWoCF4i/7nxz1ntulINYGQ8VVuCU9LD86Mek97g== + +"@node-rs/jieba-linux-x64-musl@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-linux-x64-musl/-/jieba-linux-x64-musl-1.10.4.tgz#d38addcb65de3b6c5e8af4bcdfaf7495bb676534" + integrity sha512-uBBD4S1rGKcgCyAk6VCKatEVQb6EDD5I40v/DxODi5CuZVCANi9m5oee/MQbAoaX7RydA2f0OSCE9/tcwXEwUg== + +"@node-rs/jieba-wasm32-wasi@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-wasm32-wasi/-/jieba-wasm32-wasi-1.10.4.tgz#28662dba21da3fdf7a7904dac19ecffba9244457" + integrity sha512-Y2umiKHjuIJy0uulNDz9SDYHdfq5Hmy7jY5nORO99B4pySKkcrMjpeVrmWXJLIsEKLJwcCXHxz8tjwU5/uhz0A== + dependencies: + "@napi-rs/wasm-runtime" "^0.2.3" + +"@node-rs/jieba-win32-arm64-msvc@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-win32-arm64-msvc/-/jieba-win32-arm64-msvc-1.10.4.tgz#7d8dffe5e54fc9ca0f8fddef93fde72ecc2a4ae4" + integrity sha512-nwMtViFm4hjqhz1it/juQnxpXgqlGltCuWJ02bw70YUDMDlbyTy3grCJPpQQpueeETcALUnTxda8pZuVrLRcBA== + +"@node-rs/jieba-win32-ia32-msvc@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-win32-ia32-msvc/-/jieba-win32-ia32-msvc-1.10.4.tgz#5081fa5e4ca84ba8044f52e0d53d9c07b2ab370b" + integrity sha512-DCAvLx7Z+W4z5oKS+7vUowAJr0uw9JBw8x1Y23Xs/xMA4Em+OOSiaF5/tCJqZUCJ8uC4QeImmgDFiBqGNwxlyA== + +"@node-rs/jieba-win32-x64-msvc@1.10.4": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba-win32-x64-msvc/-/jieba-win32-x64-msvc-1.10.4.tgz#fc325ccea3f7b864965d8cfe2ddd6bf10857f9df" + integrity sha512-+sqemSfS1jjb+Tt7InNbNzrRh1Ua3vProVvC4BZRPg010/leCbGFFiQHpzcPRfpxAXZrzG5Y0YBTsPzN/I4yHQ== + +"@node-rs/jieba@^1.6.0": + version "1.10.4" + resolved "https://registry.yarnpkg.com/@node-rs/jieba/-/jieba-1.10.4.tgz#9bc8f7e65bbb968b329c7571086993b55a95ef56" + integrity sha512-GvDgi8MnBiyWd6tksojej8anIx18244NmIOc1ovEw8WKNUejcccLfyu8vj66LWSuoZuKILVtNsOy4jvg3aoxIw== + optionalDependencies: + "@node-rs/jieba-android-arm-eabi" "1.10.4" + "@node-rs/jieba-android-arm64" "1.10.4" + "@node-rs/jieba-darwin-arm64" "1.10.4" + "@node-rs/jieba-darwin-x64" "1.10.4" + "@node-rs/jieba-freebsd-x64" "1.10.4" + "@node-rs/jieba-linux-arm-gnueabihf" "1.10.4" + "@node-rs/jieba-linux-arm64-gnu" "1.10.4" + "@node-rs/jieba-linux-arm64-musl" "1.10.4" + "@node-rs/jieba-linux-x64-gnu" "1.10.4" + "@node-rs/jieba-linux-x64-musl" "1.10.4" + "@node-rs/jieba-wasm32-wasi" "1.10.4" + "@node-rs/jieba-win32-arm64-msvc" "1.10.4" + "@node-rs/jieba-win32-ia32-msvc" "1.10.4" + "@node-rs/jieba-win32-x64-msvc" "1.10.4" + "@nodelib/fs.scandir@2.1.5": version "2.1.5" resolved "https://registry.yarnpkg.com/@nodelib/fs.scandir/-/fs.scandir-2.1.5.tgz#7619c2eb21b25483f6d167548b4cfd5a7488c3d5" @@ -2659,6 +3087,13 @@ dependencies: defer-to-connect "^2.0.1" +"@tybys/wasm-util@^0.10.0": + version "0.10.2" + resolved "https://registry.yarnpkg.com/@tybys/wasm-util/-/wasm-util-0.10.2.tgz#12b3a1b33db1f9cad4ddff1f604ab7dd00bf464e" + integrity sha512-RoBvJ2X0wuKlWFIjrwffGw1IqZHKQqzIchKaadZZfnNpsAYp2mM0h36JtPCjNDAHGgYez/15uMBpfGwchhiMgg== + dependencies: + tslib "^2.4.0" + "@types/body-parser@*": version "1.19.6" resolved "https://registry.yarnpkg.com/@types/body-parser/-/body-parser-1.19.6.tgz#1859bebb8fd7dac9918a45d54c1971ab8b5af474" @@ -3923,6 +4358,23 @@ cheerio@1.0.0-rc.12: parse5 "^7.0.0" parse5-htmlparser2-tree-adapter "^7.0.0" +cheerio@^1.0.0: + version "1.2.0" + resolved "https://registry.yarnpkg.com/cheerio/-/cheerio-1.2.0.tgz#f23b777c49021ead7475dcf3390d3535a7f896d6" + integrity sha512-WDrybc/gKFpTYQutKIK6UvfcuxijIZfMfXaYm8NMsPQxSYvf+13fXUJ4rztGGbJcBQ/GF55gvrZ0Bc0bj/mqvg== + dependencies: + cheerio-select "^2.1.0" + dom-serializer "^2.0.0" + domhandler "^5.0.3" + domutils "^3.2.2" + encoding-sniffer "^0.2.1" + htmlparser2 "^10.1.0" + parse5 "^7.3.0" + parse5-htmlparser2-tree-adapter "^7.1.0" + parse5-parser-stream "^7.1.2" + undici "^7.19.0" + whatwg-mimetype "^4.0.0" + chevrotain-allstar@~0.4.1: version "0.4.1" resolved "https://registry.yarnpkg.com/chevrotain-allstar/-/chevrotain-allstar-0.4.1.tgz#04e1429faca94a14d4572e0107c4865beac36298" @@ -4038,6 +4490,11 @@ combine-promises@^1.1.0: resolved "https://registry.yarnpkg.com/combine-promises/-/combine-promises-1.2.0.tgz#5f2e68451862acf85761ded4d9e2af7769c2ca6a" integrity sha512-VcQB1ziGD0NXrhKxiwyNbCDmRzs/OShMs2GqW2DlU2A/Sd0nQxE1oWDAE5O0ygSx5mgQOn9eIFh7yKPgFRVkPQ== +comlink@^4.4.2: + version "4.4.2" + resolved "https://registry.yarnpkg.com/comlink/-/comlink-4.4.2.tgz#cbbcd82742fbebc06489c28a183eedc5c60a2bca" + integrity sha512-OxGdvBmJuNKSCMO4NTl1L47VRp6xn2wG4F/2hYzB6tiCb709otOxtEYCSvK80PtjODfXXZu8ds+Nw5kVCjqd2g== + comma-separated-tokens@^2.0.0: version "2.0.3" resolved "https://registry.yarnpkg.com/comma-separated-tokens/-/comma-separated-tokens-2.0.3.tgz#4e89c9458acb61bc8fef19f4529973b2392839ee" @@ -4732,7 +5189,7 @@ debug@2.6.9: dependencies: ms "2.0.0" -debug@4, debug@^4.0.0, debug@^4.1.0, debug@^4.3.1, debug@^4.4.3: +debug@4, debug@^4.0.0, debug@^4.1.0, debug@^4.2.0, debug@^4.3.1, debug@^4.4.3: version "4.4.3" resolved "https://registry.yarnpkg.com/debug/-/debug-4.4.3.tgz#c6ae432d9bd9662582fce08709b038c58e9e3d6a" integrity sha512-RGwwWnwQvkVfavKVt22FGLw+xYSdzARwm0ru6DhTVA3umU5hZc28V3kO4stgYryrTlLpuvgI9GiijltAjNbcqA== @@ -4930,7 +5387,7 @@ domutils@^2.5.2, domutils@^2.8.0: domelementtype "^2.2.0" domhandler "^4.2.0" -domutils@^3.0.1: +domutils@^3.0.1, domutils@^3.2.2: version "3.2.2" resolved "https://registry.yarnpkg.com/domutils/-/domutils-3.2.2.tgz#edbfe2b668b0c1d97c24baf0f1062b132221bc78" integrity sha512-6kZKyUajlDuqlHKVX1w7gyslj9MPIXzIFiz/rGu35uC1wMi+kMhQwGhl4lt9unC9Vb9INnY9Z3/ZA3+FhASLaw== @@ -5013,6 +5470,14 @@ encodeurl@~2.0.0: resolved "https://registry.yarnpkg.com/encodeurl/-/encodeurl-2.0.0.tgz#7b8ea898077d7e409d3ac45474ea38eaf0857a58" integrity sha512-Q0n9HRi4m6JuGIV1eFlmvJB7ZEVxu93IrMyiMsGC0lrMJMWzRgx6WGquyfQgZVb31vhGgXnfmPNNXmxnOkRBrg== +encoding-sniffer@^0.2.1: + version "0.2.1" + resolved "https://registry.yarnpkg.com/encoding-sniffer/-/encoding-sniffer-0.2.1.tgz#396ec97ac22ce5a037ba44af1992ac9d46a7b819" + integrity sha512-5gvq20T6vfpekVtqrYQsSCFZ1wEg5+wW0/QaZMWkFr6BqD3NfKs0rLCx4rrVlSWJeZb5NBJgVLswK/w2MWU+Gw== + dependencies: + iconv-lite "^0.6.3" + whatwg-encoding "^3.1.1" + enhanced-resolve@^5.20.0: version "5.20.1" resolved "https://registry.yarnpkg.com/enhanced-resolve/-/enhanced-resolve-5.20.1.tgz#eeeb3966bea62c348c40a0cc9e7912e2557d0be0" @@ -5036,6 +5501,11 @@ entities@^6.0.0: resolved "https://registry.yarnpkg.com/entities/-/entities-6.0.1.tgz#c28c34a43379ca7f61d074130b2f5f7020a30694" integrity sha512-aN97NXWF6AWBTahfVOIrB/NShkzi5H7F9r1s9mD3cDj4Ko5f2qhhVoYMibXF7GlLveb/D2ioWay8lxI97Ven3g== +entities@^7.0.1: + version "7.0.1" + resolved "https://registry.yarnpkg.com/entities/-/entities-7.0.1.tgz#26e8a88889db63417dcb9a1e79a3f1bc92b5976b" + integrity sha512-TWrgLOFUQTH994YUyl1yT4uyavY5nNB5muff+RtWaqNVCAK408b5ZnnbNAUEWLTCpum9w6arT70i1XdQ4UeOPA== + error-ex@^1.3.1: version "1.3.4" resolved "https://registry.yarnpkg.com/error-ex/-/error-ex-1.3.4.tgz#b3a8d8bb6f92eecc1629e3e27d3c8607a8a32414" @@ -5431,6 +5901,15 @@ fresh@~0.5.2: resolved "https://registry.yarnpkg.com/fresh/-/fresh-0.5.2.tgz#3d8cadd90d976569fa835ab1f8e4b23a105605a7" integrity sha512-zJ2mQYM18rEFOudeV4GShTGIQ7RbzA7ozbU9I/XBpm7kqgMywgmylMwXHxZJmkVoYkna9d2pVXVXPdYTP9ej8Q== +fs-extra@^10.0.0: + version "10.1.0" + resolved "https://registry.yarnpkg.com/fs-extra/-/fs-extra-10.1.0.tgz#02873cfbc4084dde127eaa5f9905eef2325d1abf" + integrity sha512-oRXApq54ETRj4eMiFzGnHWGy+zo5raudjuxN0b8H7s/RU2oW0Wvsx9O0ACRN/kRq9E8Vu/ReskGB5o3ji+FzHQ== + dependencies: + graceful-fs "^4.2.0" + jsonfile "^6.0.1" + universalify "^2.0.0" + fs-extra@^11.1.1, fs-extra@^11.2.0: version "11.3.4" resolved "https://registry.yarnpkg.com/fs-extra/-/fs-extra-11.3.4.tgz#ab6934eca8bcf6f7f6b82742e33591f86301d6fc" @@ -5575,7 +6054,7 @@ graceful-fs@4.2.10: resolved "https://registry.yarnpkg.com/graceful-fs/-/graceful-fs-4.2.10.tgz#147d3a006da4ca3ce14728c7aefc287c367d7a6c" integrity sha512-9ByhssR2fPVsNZj478qUUbKfmL0+t5BDVyjShtyZZLiK7ZDAArFFfopyOTj0M05wE2tJPisA4iTnnXl2YoPvOA== -graceful-fs@^4.1.2, graceful-fs@^4.1.6, graceful-fs@^4.2.0, graceful-fs@^4.2.11, graceful-fs@^4.2.4, graceful-fs@^4.2.6, graceful-fs@^4.2.9: +graceful-fs@^4.1.11, graceful-fs@^4.1.2, graceful-fs@^4.1.6, graceful-fs@^4.2.0, graceful-fs@^4.2.11, graceful-fs@^4.2.4, graceful-fs@^4.2.6, graceful-fs@^4.2.9: version "4.2.11" resolved "https://registry.yarnpkg.com/graceful-fs/-/graceful-fs-4.2.11.tgz#4183e4e8bf08bb6e05bbb2f7d2e0c8f712ca40e3" integrity sha512-RbJ5/jmFcNNCcDV5o9eTnBLJ/HszWV0P73bc+Ff4nS/rJj+YaS6IGyiOL0VoBYX+l1Wrl3k63h/KrH+nhJ0XvQ== @@ -5884,6 +6363,16 @@ html-webpack-plugin@^5.6.0: pretty-error "^4.0.0" tapable "^2.0.0" +htmlparser2@^10.1.0: + version "10.1.0" + resolved "https://registry.yarnpkg.com/htmlparser2/-/htmlparser2-10.1.0.tgz#fe3f2e12c73b6e462d4e10395db9c1119e4d6ae4" + integrity sha512-VTZkM9GWRAtEpveh7MSF6SjjrpNVNNVJfFup7xTY3UpFtm67foy9HDVXneLtFVt4pMz5kZtgNcvCniNFb1hlEQ== + dependencies: + domelementtype "^2.3.0" + domhandler "^5.0.3" + domutils "^3.2.2" + entities "^7.0.1" + htmlparser2@^6.1.0: version "6.1.0" resolved "https://registry.yarnpkg.com/htmlparser2/-/htmlparser2-6.1.0.tgz#c4d762b6c3371a05dbe65e94ae43a9f845fb8fb7" @@ -5979,7 +6468,7 @@ hyperdyperid@^1.2.0: resolved "https://registry.yarnpkg.com/hyperdyperid/-/hyperdyperid-1.2.0.tgz#59668d323ada92228d2a869d3e474d5a33b69e6b" integrity sha512-Y93lCzHYgGWdrJ66yIktxiaGULYc6oGiABxhcO5AufBeOyoIdZF7bIfLaOrbM0iGIOXQQgxxRrFEnb+Y6w1n4A== -iconv-lite@0.6: +iconv-lite@0.6, iconv-lite@0.6.3, iconv-lite@^0.6.3: version "0.6.3" resolved "https://registry.yarnpkg.com/iconv-lite/-/iconv-lite-0.6.3.tgz#a52f80bf38da1952eb5c681790719871a1a72501" integrity sha512-4fCk79wshMdzMp2rH06qWrJE4iolqLhCUH+OiuIgU++RB0+94NlDL81atO7GX55uUKueo0txHNtvEyI6D7WdMw== @@ -6008,6 +6497,11 @@ image-size@^2.0.2: resolved "https://registry.yarnpkg.com/image-size/-/image-size-2.0.2.tgz#84a7b43704db5736f364bf0d1b029821299b4bdc" integrity sha512-IRqXKlaXwgSMAMtpNzZa1ZAe8m+Sa1770Dhk8VkSsP9LS+iHD62Zd8FQKs8fbPiagBE7BzoFX23cxFnwshpV6w== +immediate@^3.2.3: + version "3.3.0" + resolved "https://registry.yarnpkg.com/immediate/-/immediate-3.3.0.tgz#1aef225517836bcdf7f2a2de2600c79ff0269266" + integrity sha512-HR7EVodfFUdQCTIeySw+WDRFJlPcLOJbXfwwZ7Oom6tjsvZ3bOkCDJHehQC3nxJrv7+f9XecwazynjU8e4Vw3Q== + import-fresh@^3.3.0: version "3.3.1" resolved "https://registry.yarnpkg.com/import-fresh/-/import-fresh-3.3.1.tgz#9cecb56503c0ada1f2741dbbd6546e4b13b57ccf" @@ -6410,6 +6904,13 @@ kind-of@^6.0.0, kind-of@^6.0.2: resolved "https://registry.yarnpkg.com/kind-of/-/kind-of-6.0.3.tgz#07c05034a6c349fa06e24fa35aa76db4580ce4dd" integrity sha512-dcS1ul+9tmeD95T+x28/ehLgd9mENa3LsvDTtzm3vyBEO7RPptvAD+t44WVXaUjTBRcrpFeFlC8WCruUR456hw== +klaw-sync@^6.0.0: + version "6.0.0" + resolved "https://registry.yarnpkg.com/klaw-sync/-/klaw-sync-6.0.0.tgz#1fd2cfd56ebb6250181114f0a581167099c2b28c" + integrity sha512-nIeuVSzdCCs6TDPTqI8w1Yre34sSq7AkZ4B3sfOBbI2CgVSB4Du4aLQijFU2+lhAFCwt9+42Hel6lQNIv6AntQ== + dependencies: + graceful-fs "^4.1.11" + kleur@^3.0.3: version "3.0.3" resolved "https://registry.yarnpkg.com/kleur/-/kleur-3.0.3.tgz#a79c9ecc86ee1ce3fa6206d1216c501f147fc07e" @@ -6544,6 +7045,21 @@ lru-cache@^5.1.1: dependencies: yallist "^3.0.2" +lunr-languages@^1.4.0: + version "1.20.0" + resolved "https://registry.yarnpkg.com/lunr-languages/-/lunr-languages-1.20.0.tgz#d145555fdeb546300b1394860d768487b8e0e182" + integrity sha512-3LVgE7ekWXt04NBci/hjm+NXJxXZeRXuyClL0kA0HONyBOjxhP3ZQkuWIM4Ok3pbeptUW/rj3XcJcJuJVPwPYA== + +lunr@^2.3.9: + version "2.3.9" + resolved "https://registry.yarnpkg.com/lunr/-/lunr-2.3.9.tgz#18b123142832337dd6e964df1a5a7707b25d35e1" + integrity sha512-zTU3DaZaF3Rt9rhN3uBMGQD3dD2/vFQqnvZCDv4dl5iOzq2IZQqTxu90r4E5J+nP70J3ilqVCrbho2eWaeW8Ow== + +mark.js@^8.11.1: + version "8.11.1" + resolved "https://registry.yarnpkg.com/mark.js/-/mark.js-8.11.1.tgz#180f1f9ebef8b0e638e4166ad52db879beb2ffc5" + integrity sha512-1I+1qpDt4idfgLQG+BNWmrqku+7/2bi5nLf4YwF8y8zXvmfiTBY3PV3ZibfrjBueCByROpuBjLLFCajqkgYoLQ== + markdown-extensions@^2.0.0: version "2.0.0" resolved "https://registry.yarnpkg.com/markdown-extensions/-/markdown-extensions-2.0.0.tgz#34bebc83e9938cae16e0e017e4a9814a8330d3c4" @@ -7703,7 +8219,7 @@ parse-numeric-range@^1.3.0: resolved "https://registry.yarnpkg.com/parse-numeric-range/-/parse-numeric-range-1.3.0.tgz#7c63b61190d61e4d53a1197f0c83c47bb670ffa3" integrity sha512-twN+njEipszzlMJd4ONUYgSfZPDxgHhT9Ahed5uTigpQn90FggW4SA/AIPq/6a149fTbE9qBEcSwE3FAEp6wQQ== -parse5-htmlparser2-tree-adapter@^7.0.0: +parse5-htmlparser2-tree-adapter@^7.0.0, parse5-htmlparser2-tree-adapter@^7.1.0: version "7.1.0" resolved "https://registry.yarnpkg.com/parse5-htmlparser2-tree-adapter/-/parse5-htmlparser2-tree-adapter-7.1.0.tgz#b5a806548ed893a43e24ccb42fbb78069311e81b" integrity sha512-ruw5xyKs6lrpo9x9rCZqZZnIUntICjQAd0Wsmp396Ul9lN/h+ifgVV1x1gZHi8euej6wTfpqX8j+BFQxF0NS/g== @@ -7711,7 +8227,14 @@ parse5-htmlparser2-tree-adapter@^7.0.0: domhandler "^5.0.3" parse5 "^7.0.0" -parse5@^7.0.0: +parse5-parser-stream@^7.1.2: + version "7.1.2" + resolved "https://registry.yarnpkg.com/parse5-parser-stream/-/parse5-parser-stream-7.1.2.tgz#d7c20eadc37968d272e2c02660fff92dd27e60e1" + integrity sha512-JyeQc9iwFLn5TbvvqACIF/VXG6abODeB3Fwmv/TGdLk2LfbWkaySGY72at4+Ty7EkPZj854u4CrICqNk2qIbow== + dependencies: + parse5 "^7.0.0" + +parse5@^7.0.0, parse5@^7.3.0: version "7.3.0" resolved "https://registry.yarnpkg.com/parse5/-/parse5-7.3.0.tgz#d7e224fa72399c7a175099f45fc2ad024b05ec05" integrity sha512-IInvU7fabl34qmi9gY8XOVxhYyMyuH2xUNpb2q8/Y+7552KlejkRvqvD19nMoUW/uQGGbqNpA6Tufu5FL5BZgw== @@ -9625,7 +10148,7 @@ tslib@^1.9.3: resolved "https://registry.yarnpkg.com/tslib/-/tslib-1.14.1.tgz#cf2d38bdc34a134bcaf1091c41f6619e2f672d00" integrity sha512-Xni35NKzjgMrwevysHTCArtLDpPvye8zV/0E4EyYn43P7/7qvQwPh9BGkHewbMulVntbigmcT7rdX3BNo9wRJg== -tslib@^2.0.0, tslib@^2.0.3, tslib@^2.6.0, tslib@^2.8.1: +tslib@^2.0.0, tslib@^2.0.3, tslib@^2.4.0, tslib@^2.6.0, tslib@^2.8.1: version "2.8.1" resolved "https://registry.yarnpkg.com/tslib/-/tslib-2.8.1.tgz#612efe4ed235d567e8aba5f2a5fab70280ade83f" integrity sha512-oJFu94HQb+KVduSUQL7wnpmqnfmLsOA/nAh6b6EH0wCEoK0/mPeXU6c3wKDV83MkOuHPRHtSXKKU99IBazS/2w== @@ -9672,6 +10195,11 @@ undici-types@~7.19.0: resolved "https://registry.yarnpkg.com/undici-types/-/undici-types-7.19.2.tgz#1b67fc26d0f157a0cba3a58a5b5c1e2276b8ba2a" integrity sha512-qYVnV5OEm2AW8cJMCpdV20CDyaN3g0AjDlOGf1OW4iaDEx8MwdtChUp4zu4H0VP3nDRF/8RKWH+IPp9uW0YGZg== +undici@^7.19.0: + version "7.27.0" + resolved "https://registry.yarnpkg.com/undici/-/undici-7.27.0.tgz#8f1d99dfc28273fe8a5736aa93a507850fda78c9" + integrity sha512-+t2Z/GwkZQDtu00813aP66ygViGtPHKhhoFZpQKpKrE+9jIgES+Zw+mFNaDWOVRKiuJjuqKHzD3B1sfGg8+ZOQ== + unicode-canonical-property-names-ecmascript@^2.0.0: version "2.0.1" resolved "https://registry.yarnpkg.com/unicode-canonical-property-names-ecmascript/-/unicode-canonical-property-names-ecmascript-2.0.1.tgz#cb3173fe47ca743e228216e4a3ddc4c84d628cc2" @@ -10096,6 +10624,18 @@ websocket-extensions@>=0.1.1: resolved "https://registry.yarnpkg.com/websocket-extensions/-/websocket-extensions-0.1.4.tgz#7f8473bc839dfd87608adb95d7eb075211578a42" integrity sha512-OqedPIGOfsDlo31UNwYbCFMSaO9m9G/0faIHj5/dZFDMFqPTcx6UwqyOy3COEaEOg/9VsGIpdqn62W5KhoKSpg== +whatwg-encoding@^3.1.1: + version "3.1.1" + resolved "https://registry.yarnpkg.com/whatwg-encoding/-/whatwg-encoding-3.1.1.tgz#d0f4ef769905d426e1688f3e34381a99b60b76e5" + integrity sha512-6qN4hJdMwfYBtE3YBTTHhoeuUrDBPZmbQaxWAqSALV/MeEnR5z1xd8UKud2RAkFoPkmB+hli1TZSnyi84xz1vQ== + dependencies: + iconv-lite "0.6.3" + +whatwg-mimetype@^4.0.0: + version "4.0.0" + resolved "https://registry.yarnpkg.com/whatwg-mimetype/-/whatwg-mimetype-4.0.0.tgz#bc1bf94a985dc50388d54a9258ac405c3ca2fc0a" + integrity sha512-QaKxh0eNIi2mE9p2vEdzfagOKHCcj1pJ56EEHGQOVxp8r9/iszLUUV7v89x9O1p/T+NlTM5W7jW6+cz4Fq1YVg== + which@^2.0.1: version "2.0.2" resolved "https://registry.yarnpkg.com/which/-/which-2.0.2.tgz#7c6a8dd0a636a0327e10b59c9286eee93f3f51b1" From e2ec498c4835fe89297a4d9abb6756c85fcc744c Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 2 Jun 2026 11:48:34 +0200 Subject: [PATCH 07/62] Use GHC 9.12 for hydra cross compilation jobs GHC 9.6.7 can't compile Plutus. --- nix/ci.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/nix/ci.nix b/nix/ci.nix index 5cafb2fc2e..3093742d85 100644 --- a/nix/ci.nix +++ b/nix/ci.nix @@ -50,7 +50,7 @@ let }; } // lib.optionalAttrs (buildSystem == "x86_64-linux") { windows = { - haskell96 = mkHaskellJobsFor pkgs.hsPkgs.projectCross.ucrt64; + haskell912 = mkHaskellJobsFor pkgs.hsPkgs.projectVariants.ghc912.projectCross.ucrt64; }; }); From df770478c05a74aba55b187f57c24bbb63b883e0 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 2 Jun 2026 11:50:41 +0200 Subject: [PATCH 08/62] Remove artificial constraints on plutus. --- cabal.project | 3 --- 1 file changed, 3 deletions(-) diff --git a/cabal.project b/cabal.project index 2bb87ac71c..3d76c4cc97 100644 --- a/cabal.project +++ b/cabal.project @@ -46,9 +46,6 @@ if os (windows) constraints: tasty <1.5.4, - plutus-core ^>=1.61, - plutus-ledger-api ^>=1.61, - plutus-tx ^>=1.61 -- ouroboros-network dependency after introducing `bracketKeepAlive` (PR#5371) source-repository-package From 862c3c691ebd6088e10a62270b8df1b3c0ddca7b Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 7 May 2026 10:20:08 +0200 Subject: [PATCH 09/62] Introduce Bytes32RealPoint This commit introduces a specialization of RealPoint for blocks where the header hash is always 32 bytes long. --- ...7_102103_agustin.mista_bytes32realpoint.md | 23 +++++++ .../Ouroboros/Consensus/Block/RealPoint.hs | 63 +++++++++++++++++++ 2 files changed, 86 insertions(+) create mode 100644 changelog.d/20260507_102103_agustin.mista_bytes32realpoint.md diff --git a/changelog.d/20260507_102103_agustin.mista_bytes32realpoint.md b/changelog.d/20260507_102103_agustin.mista_bytes32realpoint.md new file mode 100644 index 0000000000..2434d73981 --- /dev/null +++ b/changelog.d/20260507_102103_agustin.mista_bytes32realpoint.md @@ -0,0 +1,23 @@ + + + +### Non-Breaking + +- Introduce `Bytes32RealPoint` for real points with 32byte header hashes. + + diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs index 94e2b9515d..966cec0f81 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -22,12 +23,24 @@ module Ouroboros.Consensus.Block.RealPoint , realPointSlot , realPointToPoint , withOriginRealPointToPoint + + -- * Bytes32RealPoint + , Bytes32RealPoint + , bytes32RealPointHash + , bytes32RealPointSlot + , decodeBytes32RealPoint + , encodeBytes32RealPoint + , fromBytes32RealPoint + , toBytes32RealPoint ) where import Cardano.Binary (enforceSize) import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding, encodeListLen) import Codec.Serialise (decode, encode) +import Control.Exception (assert) +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as ByteString import Data.Coerce import Data.Proxy import Data.Typeable (Typeable, typeRep) @@ -120,3 +133,53 @@ castRealPoint :: RealPoint blk -> RealPoint blk' castRealPoint (RealPoint s h) = RealPoint s (coerce h) + +{------------------------------------------------------------------------------- + Bytes32RealPoint +-------------------------------------------------------------------------------} + +-- | A 'RealPoint' where the hash is always 32 bytes. +-- +-- The length of the hash is enforced during decoding. +data Bytes32RealPoint = Bytes32RealPoint !SlotNo !ShortByteString + deriving (Show, Eq, Generic, NoThunks) + +bytes32RealPointSlot :: Bytes32RealPoint -> SlotNo +bytes32RealPointSlot (Bytes32RealPoint s _) = s + +bytes32RealPointHash :: Bytes32RealPoint -> ShortByteString +bytes32RealPointHash (Bytes32RealPoint _ h) = h + +encodeBytes32RealPoint :: Bytes32RealPoint -> Encoding +encodeBytes32RealPoint (Bytes32RealPoint s h) = + mconcat + [ encodeListLen 2 + , encode s + , encode h + ] + +decodeBytes32RealPoint :: forall s. Decoder s Bytes32RealPoint +decodeBytes32RealPoint = do + enforceSize "Bytes32RealPoint" 2 + s <- decode + h <- decode + case ByteString.length h of + 32 -> pure (Bytes32RealPoint s h) + len -> fail $ "decodeBytes32RealPoint: expected 32 bytes, got " <> show len + +fromBytes32RealPoint :: + forall blk. + Coercible (HeaderHash blk) ShortByteString => + Bytes32RealPoint -> + RealPoint blk +fromBytes32RealPoint (Bytes32RealPoint s h) = + RealPoint s (coerce h) + +toBytes32RealPoint :: + forall blk. + Coercible (HeaderHash blk) ShortByteString => + RealPoint blk -> + Bytes32RealPoint +toBytes32RealPoint (RealPoint s h) = + assert (ByteString.length (coerce h) == 32) $ + Bytes32RealPoint s (coerce h) From bad56131bbf01b7374a781144455b809875c496f Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Fri, 27 Mar 2026 10:25:41 +0100 Subject: [PATCH 10/62] Introduce O.C.Util.Bitmap This commit implements a compact bitmaps via ByteStrings, adapted from the Leios voting committee demo package (leios-wfa-ls-demo): https://github.com/cardano-scaling/leios-wfa-ls-demo/blob/main/leios-wfa-ls-demo/lib/Cardano/Leios/BitMapPV.hs Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- ouroboros-consensus.cabal | 1 + .../Ouroboros/Consensus/Util/Bitmap.hs | 144 ++++++++++++++++++ 2 files changed, 145 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Bitmap.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 8aa0a29356..3bfbca6758 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -320,6 +320,7 @@ library Ouroboros.Consensus.Util.AnchoredSeq Ouroboros.Consensus.Util.Args Ouroboros.Consensus.Util.Assert + Ouroboros.Consensus.Util.Bitmap Ouroboros.Consensus.Util.CallStack Ouroboros.Consensus.Util.CBOR Ouroboros.Consensus.Util.Condense diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Bitmap.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Bitmap.hs new file mode 100644 index 0000000000..ae6a8c656e --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Bitmap.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A compact bitmap representation using serialisation-ready ByteStrings. +-- +-- Adapted from @Cardano.Leios.BitMapPV@ in the @leios-wfa-ls-demo@ package. +-- +-- NOTE: this module is meant to be imported qualified. +module Ouroboros.Consensus.Util.Bitmap + ( Bitmap + , fromIndices + , toIndices + , logicalUpperBound + , rawSerialise + , rawDeserialise + ) where + +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) +import qualified Codec.CBOR.Decoding as CBOR +import qualified Codec.CBOR.Encoding as CBOR +import Control.Monad (forM_, when) +import Data.Bits + ( countTrailingZeros + , popCount + , unsafeShiftL + , (.&.) + , (.|.) + ) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Internal as ByteString +import Data.Word (Word8) +import Foreign.Marshal.Utils (fillBytes) +import Foreign.Storable (peekByteOff, pokeByteOff) + +-- | A compact bitmap representation over an index type. +-- +-- NOTE: the logical upper bound is stored explicitly so serialisation +-- round-trips exactly. +data Bitmap a + = Bitmap + -- | Logical upper bound + !a + -- | Payload + !ByteString + deriving Eq + +instance Show a => Show (Bitmap a) where + show (Bitmap maxIx bs) = + "Bitmap{maxIx=" + <> show maxIx + <> ",bytes=" + <> show (ByteString.length bs) + <> ",set=" + <> show (countSetBits bs) + <> "}" + where + countSetBits arr = + sum + [ popCount (ByteString.index arr i) + | i <- [0 .. ByteString.length arr - 1] + ] + +-- | Construct a 'Bitmap' from a list of indexes that should be set (flipped to +-- 1) and a maximum index (inclusive logical upper bound). +fromIndices :: Integral a => a -> [a] -> Bitmap a +fromIndices maxIx flipped = + Bitmap maxIx $ + ByteString.unsafeCreate nBytes $ \ptr -> do + fillBytes ptr 0 nBytes + forM_ flipped $ \ix -> do + let !i = fromIntegral ix :: Int + when (i >= 0 && i <= maxI) $ do + let !byteIx = i `quot` 8 + let !bitIx = i `rem` 8 + let !mask = bitMask bitIx + w <- peekByteOff ptr byteIx :: IO Word8 + pokeByteOff ptr byteIx (w .|. mask) + where + !maxI = fromIntegral maxIx :: Int + !nBytes = (maxI `quot` 8) + 1 + + bitMask k = fromIntegral ((1 :: Int) `unsafeShiftL` k) + +-- | Retrieve all indexes that are set (flipped to 1) in the bitmap, in +-- ascending order. +toIndices :: Integral a => Bitmap a -> [a] +toIndices (Bitmap maxIx bitmap) = + goBytes 0 + where + !maxI = fromIntegral maxIx :: Int + !nBytes = ByteString.length bitmap + + goBytes !byteIx + | byteIx >= nBytes = [] + | otherwise = + let !w = ByteString.index bitmap byteIx + in goBits (byteIx * 8) w <> goBytes (byteIx + 1) + + goBits !_ 0 = [] + goBits !base !w = + let !bitIx = countTrailingZeros w + !i = base + bitIx + !w' = w .&. (w - 1) + in if i <= maxI + then fromIntegral i : goBits base w' + else [] + +-- | Get the logical upper bound of a bitmap +logicalUpperBound :: Bitmap a -> a +logicalUpperBound (Bitmap a _) = a + +-- | Raw serialisation of the bitmap (just the underlying bytes, without the +-- logical upper bound). +rawSerialise :: Bitmap a -> ByteString +rawSerialise (Bitmap _ bs) = bs + +-- | Raw deserialisation of a bitmap from a logical upper bound and a ByteString +-- +-- Returns 'Nothing' if the byte string length does not match the expected size +-- for the given upper bound. +rawDeserialise :: Integral a => a -> ByteString -> Maybe (Bitmap a) +rawDeserialise maxIx bs + | ByteString.length bs /= expectedBytes = Nothing + | otherwise = Just (Bitmap maxIx bs) + where + expectedBytes = (fromIntegral maxIx `quot` 8) + 1 + +instance ToCBOR a => ToCBOR (Bitmap a) where + toCBOR (Bitmap maxIx bs) = + CBOR.encodeListLen 2 + <> toCBOR maxIx + <> CBOR.encodeBytes bs + +instance (Integral a, FromCBOR a) => FromCBOR (Bitmap a) where + fromCBOR = do + CBOR.decodeListLenOf 2 + maxIx <- fromCBOR + bs <- CBOR.decodeBytes + case rawDeserialise maxIx bs of + Nothing -> + fail "Bitmap: invalid bitmap data or size mismatch" + Just bitmap -> + pure bitmap From c6f3cad7894f7911ecde0f7317899320f810325d Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Fri, 27 Mar 2026 13:06:56 +0100 Subject: [PATCH 11/62] Define concrete Peras certs and votes using BLS signatures This commit defines concrete data structures for Peras votes and certificates using BLS signatures to represent vote/cert signatures as well as non-persistent eligibility proofs. In addition it defines serialization routines for both types, using a compact bitmap representation in the case of certificates. Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- ouroboros-consensus.cabal | 4 +- .../Consensus/Block/SupportsPeras.hs | 34 ++- .../Ouroboros/Consensus/Peras/Cert.hs | 3 - .../Ouroboros/Consensus/Peras/Cert/V1.hs | 218 ++++++++++++++++++ .../Ouroboros/Consensus/Peras/Vote.hs | 3 - .../Ouroboros/Consensus/Peras/Vote/V1.hs | 106 +++++++++ 6 files changed, 359 insertions(+), 9 deletions(-) delete mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs delete mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 3bfbca6758..6d6aeb7e91 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -236,12 +236,12 @@ library Ouroboros.Consensus.Node.Run Ouroboros.Consensus.Node.Serialisation Ouroboros.Consensus.NodeId - Ouroboros.Consensus.Peras.Cert Ouroboros.Consensus.Peras.Cert.Inclusion + Ouroboros.Consensus.Peras.Cert.V1 Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView - Ouroboros.Consensus.Peras.Vote Ouroboros.Consensus.Peras.Vote.Aggregation + Ouroboros.Consensus.Peras.Vote.V1 Ouroboros.Consensus.Peras.Voting.Rules Ouroboros.Consensus.Peras.Voting.View Ouroboros.Consensus.Peras.Weight diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index adb80c5118..dc1db1bb87 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -14,6 +14,8 @@ module Ouroboros.Consensus.Block.SupportsPeras ( PerasRoundNo (..) , onPerasRoundNo + , PerasBoostedBlock (..) + , PerasSeatIndex (..) , PerasVoteId (..) , PerasVoteTarget (..) , PerasVoterId (..) @@ -59,10 +61,15 @@ import qualified Data.Map as Map import Data.Map.Strict (Map) import Data.Monoid (Sum (..)) import Data.Proxy (Proxy (..)) -import Data.Word (Word64) +import Data.Word (Word16, Word64) import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.Block.RealPoint + ( Bytes32RealPoint + , decodeBytes32RealPoint + , encodeBytes32RealPoint + ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Peras.Params import Ouroboros.Consensus.Util @@ -92,6 +99,31 @@ onPerasRoundNo :: (PerasRoundNo -> PerasRoundNo -> PerasRoundNo) onPerasRoundNo = coerce +-- ** Boosted blocks + +-- | The slot number and 32-byte hash of the block being voted for +newtype PerasBoostedBlock + = PerasBoostedBlock + { unPerasBoostedBlock :: Bytes32RealPoint + } + deriving stock (Eq, Show) + +instance FromCBOR PerasBoostedBlock where + fromCBOR = PerasBoostedBlock <$> decodeBytes32RealPoint + +instance ToCBOR PerasBoostedBlock where + toCBOR = encodeBytes32RealPoint . unPerasBoostedBlock + +-- ** Seat indices + +-- | Seat index in the voting committee used for Peras +newtype PerasSeatIndex + = PerasSeatIndex + { unPerasSeatIndex :: Word16 + } + deriving stock (Eq, Ord, Show) + deriving newtype (FromCBOR, ToCBOR, Enum, Bounded) + -- ** Stake pool distributions newtype PerasVoterId = PerasVoterId diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert.hs deleted file mode 100644 index 005f1323a6..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Ouroboros.Consensus.Peras.Cert (module X) where - -import Ouroboros.Consensus.Peras.Cert.Inclusion as X diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs new file mode 100644 index 0000000000..889fe06cc2 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Concrete Peras certificate types using BLS signatures. +-- +-- NOTE: this module is meant to be imported qualified. +-- +-- NOTE: the validation performed during serialization is minimal, and does not +-- cover any of additional semantic and cryptographic checks that must be +-- performed on the certificate later on. +module Ouroboros.Consensus.Peras.Cert.V1 + ( PerasCert (..) + , PerasCertVoters (..) + ) where + +import Cardano.Binary + ( FromCBOR (..) + , ToCBOR (..) + , decodeListLenOf + , encodeListLen + ) +import Control.Monad (when) +import Control.Monad.Error.Class (MonadError (..)) +import Data.Containers.NonEmpty (HasNonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.NonEmpty as NEMap +import Data.Map.Strict (Map) +import Data.Maybe (catMaybes) +import Data.Word (Word16) +import Ouroboros.Consensus.Block.SupportsPeras + ( PerasBoostedBlock + , PerasRoundNo + , PerasSeatIndex (..) + ) +import Ouroboros.Consensus.Committee.Crypto + ( CryptoSupportsAggregateVoteSigning (..) + ) +import Ouroboros.Consensus.Peras.Crypto.BLS + ( PerasBLSCrypto + , VRFOutput + ) +import Ouroboros.Consensus.Peras.Vote.V1 (PerasVoteEligibilityProof (..)) +import Ouroboros.Consensus.Util.Bitmap (Bitmap) +import qualified Ouroboros.Consensus.Util.Bitmap as Bitmap + +-- | Concrete Peras certificates using BLS signatures +data PerasCert + = PerasCert + { pcRoundNo :: !PerasRoundNo + -- ^ Election identifier + , pcBoostedBlock :: !PerasBoostedBlock + -- ^ Certificate message, i.e., the hash of the block being boosted + , pcVoters :: !PerasCertVoters + -- ^ Voters who contributed to this certificate + , pcSignature :: !(AggregateVoteSignature PerasBLSCrypto) + -- ^ Aggregate BLS signature on the hash of the election identifier and + -- the certificate message + } + deriving (Show, Eq) + +instance FromCBOR PerasCert where + fromCBOR = do + decodeListLenOf 4 + pcRoundNo <- fromCBOR + pcBoostedBlock <- fromCBOR + pcVoters <- fromCBOR + pcSignature <- fromCBOR + pure + PerasCert + { pcRoundNo + , pcBoostedBlock + , pcVoters + , pcSignature + } + +instance ToCBOR PerasCert where + toCBOR cert = + encodeListLen 4 + <> toCBOR (pcRoundNo cert) + <> toCBOR (pcBoostedBlock cert) + <> toCBOR (pcVoters cert) + <> toCBOR (pcSignature cert) + +-- | Voters contained in a certificate with their appropriate eligibility proof +newtype PerasCertVoters + = PerasCertVoters + { unPerasCertVoters :: + NE (Map PerasSeatIndex PerasVoteEligibilityProof) + } + deriving (Eq, Show) + +instance FromCBOR PerasCertVoters where + fromCBOR = do + decodeListLenOf 2 + votersBitmap <- fromCBOR + nonPersistentSigs <- fromCBOR + + either fail pure + . fromCompactRepr + $ CompactPerasCertVoters + { votersBitmap + , nonPersistentSigs + } + +instance ToCBOR PerasCertVoters where + toCBOR voters = + encodeListLen 2 + <> toCBOR votersBitmap + <> toCBOR nonPersistentSigs + where + CompactPerasCertVoters + { votersBitmap + , nonPersistentSigs + } = + toCompactRepr voters + +-- | Compact representation of the voters in a Peras certificate. +-- +-- This compact representation consists of a bitmap of voter seat indices and a +-- list of non-persistent eligibility proofs (VRF outputs). In this setup, the +-- last @np@ indices in the bitmap that are flipped to 1 correspond to +-- non-persistent voters, where @np@ is the length of the list of non-persistent +-- eligibility proofs. The remaining flipped indices in the bitmap correspond +-- to persistent voters. +-- +-- @ +-- fromCompactRepr +-- CompactPerasCertVoters { +-- votersBitmap = <01101011>, +-- nonPersistentSigs = [np1, np2, np3] +-- } +-- == +-- PerasCertVoters { +-- 1 => persistent +-- 2 => persistent +-- 4 => non-persistent(np1) +-- 6 => non-persistent(np2) +-- 7 => non-persistent(np3) +-- } +-- @ +data CompactPerasCertVoters + = CompactPerasCertVoters + { votersBitmap :: !(Bitmap Word16) + , nonPersistentSigs :: ![VRFOutput PerasBLSCrypto] + } + deriving (Eq, Show) + +-- | Decode 'PerasCertVoters' from their compact representation. +-- +-- See 'CompactPerasCertVoters' for the encoding scheme used here. +fromCompactRepr :: + CompactPerasCertVoters -> + Either String PerasCertVoters +fromCompactRepr + CompactPerasCertVoters + { votersBitmap + , nonPersistentSigs + } = do + let voterSeatIndices = + PerasSeatIndex <$> Bitmap.toIndices votersBitmap + + when (null voterSeatIndices) $ + throwError "Invalid Peras certificate: empty voters bitmap" + + when (length nonPersistentSigs > length voterSeatIndices) $ + throwError $ + unlines + [ "Invalid Peras certificate:" + <> " more non-persistent voter eligibility proofs were provided" + <> " than the number of voters in the certificate" + , " * number of voters: " + <> show (length voterSeatIndices) + , " * number of proofs: " + <> show (length nonPersistentSigs) + ] + + let numPersistentVoters = + length voterSeatIndices - length nonPersistentSigs + let persistentProofs = + take numPersistentVoters (repeat PersistentPerasVoteEligibilityProof) + let nonPersistentProofs = + fmap NonPersistentPerasVoteEligibilityProof nonPersistentSigs + let voters = + NEMap.fromAscList + . NonEmpty.fromList + . zip voterSeatIndices + $ persistentProofs <> nonPersistentProofs + + pure (PerasCertVoters voters) + +-- | Encode 'PerasCertVoters' into their compact representation. +-- +-- See 'CompactPerasCertVoters' for the encoding scheme used here. +toCompactRepr :: + PerasCertVoters -> + CompactPerasCertVoters +toCompactRepr (PerasCertVoters voters) = + CompactPerasCertVoters + { votersBitmap + , nonPersistentSigs + } + where + logicalUpperBound = + unPerasSeatIndex (fst (NEMap.findMax voters)) + votersByAscSeatIndex = + NonEmpty.toList (NEMap.toAscList voters) + votersSeatIndices = + fmap (unPerasSeatIndex . fst) votersByAscSeatIndex + votersBitmap = + Bitmap.fromIndices logicalUpperBound votersSeatIndices + nonPersistentSigs = + catMaybes (fmap getNonPersistentSig votersByAscSeatIndex) + getNonPersistentSig = \case + (_, PersistentPerasVoteEligibilityProof) -> Nothing + (_, NonPersistentPerasVoteEligibilityProof p) -> Just p diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote.hs deleted file mode 100644 index 281de61cb5..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Ouroboros.Consensus.Peras.Vote (module X) where - -import Ouroboros.Consensus.Peras.Vote.Aggregation as X diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs new file mode 100644 index 0000000000..4f32a31ca0 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Concrete Peras vote types using BLS signatures. +-- +-- NOTE: this module is meant to be imported qualified. +module Ouroboros.Consensus.Peras.Vote.V1 + ( PerasVote (..) + , PerasVoteEligibilityProof (..) + ) where + +import Cardano.Binary + ( FromCBOR (..) + , ToCBOR (..) + , decodeListLen + , decodeListLenOf + , encodeListLen + ) +import Data.Word (Word8) +import Ouroboros.Consensus.Block.SupportsPeras + ( PerasBoostedBlock + , PerasRoundNo + , PerasSeatIndex + ) +import Ouroboros.Consensus.Committee.Crypto (CryptoSupportsVoteSigning (..)) +import Ouroboros.Consensus.Peras.Crypto.BLS + ( PerasBLSCrypto + , VRFOutput + ) + +-- | Concrete Peras votes using BLS signatures +data PerasVote + = PerasVote + { pvRoundNo :: !PerasRoundNo + -- ^ Election identifier + , pvBoostedBlock :: !PerasBoostedBlock + -- ^ Vote message, i.e., the hash of the block being voted for + , pvSeatIndex :: !PerasSeatIndex + -- ^ Seat index assigned to the committee member (identifies the voter) + , pvEligibilityProof :: !PerasVoteEligibilityProof + -- ^ Proof of eligibility for voting, depending on the type of membership to + -- the committee (persistent vs non-persistent) + , pvSignature :: !(VoteSignature PerasBLSCrypto) + -- ^ BLS signature on the hash of the election identifier and vote message + } + deriving (Show, Eq) + +instance FromCBOR PerasVote where + fromCBOR = do + decodeListLenOf 5 + pvRoundNo <- fromCBOR + pvBoostedBlock <- fromCBOR + pvSeatIndex <- fromCBOR + pvEligibilityProof <- fromCBOR + pvSignature <- fromCBOR + pure + PerasVote + { pvRoundNo + , pvBoostedBlock + , pvSeatIndex + , pvEligibilityProof + , pvSignature + } + +instance ToCBOR PerasVote where + toCBOR vote = + encodeListLen 5 + <> toCBOR (pvRoundNo vote) + <> toCBOR (pvBoostedBlock vote) + <> toCBOR (pvSeatIndex vote) + <> toCBOR (pvEligibilityProof vote) + <> toCBOR (pvSignature vote) + +-- | Proof of eligibility for voting for committee members +data PerasVoteEligibilityProof + = -- | Persistent committee members require no additional proof of eligibility + PersistentPerasVoteEligibilityProof + | -- | Non-persistent committee members provide a VRF proof of eligibility + NonPersistentPerasVoteEligibilityProof !(VRFOutput PerasBLSCrypto) + deriving stock (Eq, Show) + +instance FromCBOR PerasVoteEligibilityProof where + fromCBOR = do + len <- decodeListLen + tag <- fromCBOR @Word8 + case (len, tag) of + (1, 0) -> pure PersistentPerasVoteEligibilityProof + (2, 1) -> NonPersistentPerasVoteEligibilityProof <$> fromCBOR + _ -> + fail $ + "Invalid PerasVoteEligibilityProof length/tag: " + <> show (len, tag) + +instance ToCBOR PerasVoteEligibilityProof where + toCBOR = \case + PersistentPerasVoteEligibilityProof -> + encodeListLen 1 + <> toCBOR (0 :: Word8) + NonPersistentPerasVoteEligibilityProof vrfOutput -> + encodeListLen 2 + <> toCBOR (1 :: Word8) + <> toCBOR vrfOutput From f5548b220cabf0b0284b34671435e02b60ce0288 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Fri, 10 Apr 2026 14:13:38 +0200 Subject: [PATCH 12/62] Define PerasCrypto and wire up voting committee instance using BLS This commit defines a concrete PerasCrypto scheme using BLS signatures to instantiate all the voting committee superclasses needed by the WFALS and EveryoneVotes voting committee implementations. Note that these instances are heavily inspired by the ones defined for TestCrypto in the generic voting committee test-suite, albeit with slightly different types and more documentation. Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- ouroboros-consensus.cabal | 1 + .../Ouroboros/Consensus/Peras/Crypto/BLS.hs | 283 ++++++++++++++++++ 2 files changed, 284 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 6d6aeb7e91..ea5f78404c 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -238,6 +238,7 @@ library Ouroboros.Consensus.NodeId Ouroboros.Consensus.Peras.Cert.Inclusion Ouroboros.Consensus.Peras.Cert.V1 + Ouroboros.Consensus.Peras.Crypto.BLS Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.Vote.Aggregation diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs new file mode 100644 index 0000000000..aa23a44e10 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | BLS-based crypto scheme used in Peras voting committees +module Ouroboros.Consensus.Peras.Crypto.BLS + ( PerasBLSCrypto + , ElectionId + , VoteCandidate + , PerasPrivateKey (..) + , PerasPublicKey (..) + , VoteSignature (..) + , VRFElectionInput (..) + , VRFOutput (..) + , AggregateVoteVerificationKey + , AggregateVoteSignature + + -- * For testing purposes + , PerasBLSCryptoAggregateVoteVerificationKey (..) + , PerasBLSCryptoAggregateVoteSignature (..) + ) where + +import Cardano.Binary (FromCBOR, ToCBOR (..)) +import Cardano.Crypto.DSIGN (BLS12381MinSigDSIGN, DSIGNAlgorithm (..)) +import Cardano.Crypto.Hash (Hash) +import qualified Cardano.Crypto.Hash as Hash +import Cardano.Ledger.BaseTypes (Nonce (..), SlotNo (..)) +import Cardano.Ledger.Binary (runByteBuilder) +import Cardano.Ledger.Hashes (HASH) +import qualified Data.ByteString.Builder as BS +import qualified Data.ByteString.Builder.Extra as BS +import qualified Data.ByteString.Short as BS +import Ouroboros.Consensus.Block.RealPoint + ( bytes32RealPointHash + , bytes32RealPointSlot + ) +import Ouroboros.Consensus.Block.SupportsPeras + ( PerasBoostedBlock (..) + , PerasRoundNo (..) + ) +import Ouroboros.Consensus.Committee.Crypto + ( CryptoSupportsAggregateVoteSigning (..) + , CryptoSupportsBatchVRFVerification (..) + , CryptoSupportsVRF (..) + , CryptoSupportsVoteSigning (..) + , ElectionId + , PrivateKey + , PublicKey + , VRFPoolContext (..) + , VoteCandidate + ) +import Ouroboros.Consensus.Committee.Crypto.BLS (KeyRole (..)) +import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS + +-- | BLS-based crypto scheme used in Peras voting committees +data PerasBLSCrypto + +type instance ElectionId PerasBLSCrypto = PerasRoundNo +type instance VoteCandidate PerasBLSCrypto = PerasBoostedBlock + +-- | Private key of a Peras committee member +data PerasPrivateKey + = PerasPrivateKey + { perasVoteSignKey :: BLS.PrivateKey SIGN + , perasVRFSignKey :: BLS.PrivateKey VRF + } + +type instance PrivateKey PerasBLSCrypto = PerasPrivateKey + +-- | Public key of a Peras committee member +data PerasPublicKey + = PerasPublicKey + { perasVoteVerKey :: BLS.PublicKey SIGN + , perasVRFVerKey :: BLS.PublicKey VRF + } + +type instance PublicKey PerasBLSCrypto = PerasPublicKey + +-- | Hash the message of a Peras vote +-- +-- NOTE: this is inspired by the implementation used by the Praos VRF check in +-- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. +hashVoteSignature :: + ElectionId PerasBLSCrypto -> + VoteCandidate PerasBLSCrypto -> + Hash HASH (SigDSIGN BLS12381MinSigDSIGN) +hashVoteSignature roundNo boostedBlock = + Hash.castHash + . Hash.hashWith id + . runByteBuilder (8 + 8 + 32) + $ roundNoBytes + <> boostedBlockSlotBytes + <> boostedBlockHashBytes + where + roundNoBytes = + BS.word64BE + . unPerasRoundNo + $ roundNo + boostedBlockSlotBytes = + BS.word64BE + . unSlotNo + . bytes32RealPointSlot + . unPerasBoostedBlock + $ boostedBlock + boostedBlockHashBytes = + BS.byteStringCopy + . BS.fromShort + . bytes32RealPointHash + . unPerasBoostedBlock + $ boostedBlock + +-- | Hash the input for the VRF used in Peras elections +-- +-- NOTE: this is inspired by the implementation used by the Praos VRF check in +-- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. +hashVRFInput :: + ElectionId PerasBLSCrypto -> + Nonce -> + Hash HASH (SigDSIGN BLS12381MinSigDSIGN) +hashVRFInput roundNo epochNonce = + Hash.castHash + . Hash.hashWith id + . runByteBuilder (8 + 32) + $ roundNoBytes <> epochNonceBytes + where + roundNoBytes = + BS.word64BE (unPerasRoundNo roundNo) + epochNonceBytes = + case epochNonce of + NeutralNonce -> mempty + Nonce h -> BS.byteStringCopy (Hash.hashToBytes h) + +-- * Crypto instances + +instance CryptoSupportsVoteSigning PerasBLSCrypto where + type VoteSigningKey PerasBLSCrypto = BLS.PrivateKey SIGN + type VoteVerificationKey PerasBLSCrypto = BLS.PublicKey SIGN + + newtype VoteSignature PerasBLSCrypto + = PerasBLSCryptoVoteSignature + { unPerasBLSCryptoVoteSignature :: + BLS.Signature BLS.SIGN + } + deriving stock (Eq, Show) + deriving newtype (FromCBOR, ToCBOR) + + getVoteSigningKey _ = + perasVoteSignKey + getVoteVerificationKey _ = + perasVoteVerKey + + signVote sk roundNo boostedBlock = + PerasBLSCryptoVoteSignature + . BLS.signWithRole @SIGN sk + $ hashVoteSignature roundNo boostedBlock + + verifyVoteSignature + pk + roundNo + boostedBlock + (PerasBLSCryptoVoteSignature sig) = + BLS.verifyWithRole @SIGN + pk + (hashVoteSignature roundNo boostedBlock) + sig + +instance CryptoSupportsVRF PerasBLSCrypto where + type VRFSigningKey PerasBLSCrypto = BLS.PrivateKey VRF + type VRFVerificationKey PerasBLSCrypto = BLS.PublicKey VRF + + newtype VRFElectionInput PerasBLSCrypto + = PerasBLSCryptoVRFElectionInput + { unPerasBLSCryptoVRFElectionInput :: + Hash HASH (SigDSIGN BLS12381MinSigDSIGN) + } + deriving stock (Eq, Show) + + newtype VRFOutput PerasBLSCrypto + = PerasBLSCryptoVRFOutput + { unPerasBLSCryptoVRFOutput :: + BLS.Signature VRF + } + deriving stock (Eq, Show) + deriving newtype (FromCBOR, ToCBOR) + + getVRFSigningKey _ = + perasVRFSignKey + + getVRFVerificationKey _ = + perasVRFVerKey + + mkVRFElectionInput epochNonce roundNo = + PerasBLSCryptoVRFElectionInput $ + hashVRFInput roundNo epochNonce + + evalVRF context (PerasBLSCryptoVRFElectionInput input) = + case context of + VRFSignContext sk -> do + let sig = BLS.signWithRole @VRF (BLS.coercePrivateKey @VRF sk) input + pure $ PerasBLSCryptoVRFOutput sig + VRFVerifyContext pk (PerasBLSCryptoVRFOutput sig) -> do + BLS.verifyWithRole @VRF (BLS.coercePublicKey @VRF pk) input sig + pure $ PerasBLSCryptoVRFOutput sig + + normalizeVRFOutput (PerasBLSCryptoVRFOutput sig) = + BLS.toNormalizedVRFOutput sig + +-- * Support for aggregate signatures and VRF outputs + +-- | Wrapper around the aggregate vote signatures. +newtype PerasBLSCryptoAggregateVoteVerificationKey + = PerasBLSCryptoAggregateVoteVerificationKey + { unPerasBLSCryptoAggregateVoteVerificationKey :: + BLS.PublicKey SIGN + } + deriving stock (Eq, Show) + +-- | Wrapper around the aggregate vote verification keys. +newtype PerasBLSCryptoAggregateVoteSignature + = PerasBLSCryptoAggregateVoteSignature + { unPerasBLSCryptoAggregateVoteSignature :: + BLS.Signature SIGN + } + deriving stock (Eq, Show) + deriving newtype (FromCBOR, ToCBOR) + +instance CryptoSupportsAggregateVoteSigning PerasBLSCrypto where + type + AggregateVoteVerificationKey PerasBLSCrypto = + PerasBLSCryptoAggregateVoteVerificationKey + type + AggregateVoteSignature PerasBLSCrypto = + PerasBLSCryptoAggregateVoteSignature + + aggregateVoteVerificationKeys _ pks = do + aggPk <- BLS.aggregatePublicKeys @SIGN pks + pure (PerasBLSCryptoAggregateVoteVerificationKey aggPk) + + aggregateVoteSignatures _ sigs = do + aggSig <- + BLS.aggregateSignatures @SIGN + . fmap unPerasBLSCryptoVoteSignature + $ sigs + pure (PerasBLSCryptoAggregateVoteSignature aggSig) + + verifyAggregateVoteSignature + _ + aggPk + roundNo + boostedBlock + aggSig = do + BLS.verifyWithRole @SIGN + (unPerasBLSCryptoAggregateVoteVerificationKey aggPk) + (hashVoteSignature roundNo boostedBlock) + (unPerasBLSCryptoAggregateVoteSignature aggSig) + +instance CryptoSupportsBatchVRFVerification PerasBLSCrypto where + -- NOTE: in contrast to vote signatures, we cannot aggregate multiple VRF + -- outputs into a single one when forging a certificate (because we need to + -- derive non-persistent seat numbers from each individual one). This means + -- that, at verification time, @sigs@ will always contain one VRF output per + -- non-persistent voter in the certificate, even when verifying a certificate + -- forged by someone else that we received over the network. + -- + -- However, we still want to verify all the VRF outputs in a single batch for + -- efficiency reasons, and we can do that by first aggregating all the VRF + -- outputs in the list locally (using linearization to avoid swap-attacks), + -- and then verifying the resulting aggregate VRF output against the aggregate + -- VRF verification key. + batchVerifyVRFOutputs + pks + (PerasBLSCryptoVRFElectionInput input) + sigs = do + BLS.linearizeAndVerifyVRFs + pks + input + . fmap unPerasBLSCryptoVRFOutput + $ sigs From aed3e55017fdf35fc4ae55140f324b052bda7055 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 21 Apr 2026 13:39:11 +0200 Subject: [PATCH 13/62] Add conversions between Peras votes/certs and voting committee types This commit implements conversion routines between the brand-new (concrete) Peras votes and certificates and their corresponding (abstract) voting committee counterparts. This is done by introducing a `VotingCommitteeSupportsPeras` type class to allow us to easily change the underlying voting committee implementation via a proxy type. Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- ouroboros-consensus.cabal | 1 + .../Consensus/Peras/Voting/Committee.hs | 302 ++++++++++++++++++ 2 files changed, 303 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index ea5f78404c..d439b72656 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -243,6 +243,7 @@ library Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.Vote.Aggregation Ouroboros.Consensus.Peras.Vote.V1 + Ouroboros.Consensus.Peras.Voting.Committee Ouroboros.Consensus.Peras.Voting.Rules Ouroboros.Consensus.Peras.Voting.View Ouroboros.Consensus.Peras.Weight diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs new file mode 100644 index 0000000000..d581ac0865 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Support for using concrete votes and certificates with multiple voting +-- committee implementations. +module Ouroboros.Consensus.Peras.Voting.Committee + ( -- * Peras support for multiple voting committee implementations + PerasConversionError (..) + , PerasVoteCompatibleWithVotingCommittee (..) + , PerasCertCompatibleWithVotingCommittee (..) + ) where + +import Data.Containers.NonEmpty (HasNonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.NonEmpty as NEMap +import Data.Maybe (isJust) +import Data.Word (Word16, Word64) +import Ouroboros.Consensus.Block.SupportsPeras (PerasSeatIndex (..)) +import qualified Ouroboros.Consensus.Committee.Class as Committee +import Ouroboros.Consensus.Committee.Crypto (CryptoSupportsVRF (..)) +import Ouroboros.Consensus.Committee.EveryoneVotes + ( Cert (..) + , EveryoneVotes + , Vote (..) + ) +import Ouroboros.Consensus.Committee.WFA (SeatIndex (..)) +import Ouroboros.Consensus.Committee.WFALS (Cert (..), Vote (..), WFALS) +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import Ouroboros.Consensus.Peras.Crypto.BLS (PerasBLSCrypto) +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 + +-- * Peras support for multiple voting committee implementations + +-- | Errors that can occur when converting between Peras and committee types +data PerasConversionError + = EveryoneVotesButFoundNonPersistentVoterInVote SeatIndex + | EveryoneVotesButFoundNonPersistentVotersInCert (NE [SeatIndex]) + | SeatIndexOverflowError Word64 + | CryptoError String + deriving stock (Eq, Show) + +-- | Conversion between (concrete) Peras votes and (abstract) committee votes. +-- +-- NOTE: the functional dependency @vote -> crypto@ explicitly ties each +-- concrete Peras vote type to a specific crypto scheme. +class + PerasVoteCompatibleWithVotingCommittee vote crypto committee + | vote -> crypto + where + toPerasVote :: + Committee.Vote crypto committee -> + Either PerasConversionError vote + fromPerasVote :: + vote -> + Either PerasConversionError (Committee.Vote crypto committee) + +-- | Conversion between (concrete) Peras certificates and (abstract) committee +-- certificates. +-- +-- NOTE: the functional dependency @cert -> crypto@ explicitly ties each +-- concrete Peras certificate type to a specific crypto scheme. +class + PerasCertCompatibleWithVotingCommittee cert crypto committee + | cert -> crypto + where + toPerasCert :: + Committee.Cert crypto committee -> + Either PerasConversionError cert + fromPerasCert :: + cert -> + Either PerasConversionError (Committee.Cert crypto committee) + +-- 'V1.PerasVote's are compatible with 'WFALS' as long as we make sure to avoid +-- overflowing their `Word16` seat index. +instance + PerasVoteCompatibleWithVotingCommittee + V1.PerasVote + PerasBLSCrypto + WFALS + where + toPerasVote = \case + WFALSPersistentVote seatIndex electionId candidate sig -> do + perasSeatIndex <- toPerasSeatIndex seatIndex + pure $ + V1.PerasVote + { V1.pvRoundNo = electionId + , V1.pvBoostedBlock = candidate + , V1.pvSeatIndex = perasSeatIndex + , V1.pvEligibilityProof = V1.PersistentPerasVoteEligibilityProof + , V1.pvSignature = sig + } + WFALSNonPersistentVote seatIndex electionId candidate vrfOutput sig -> do + perasSeatIndex <- toPerasSeatIndex seatIndex + let proof = V1.NonPersistentPerasVoteEligibilityProof vrfOutput + pure $ + V1.PerasVote + { V1.pvRoundNo = electionId + , V1.pvBoostedBlock = candidate + , V1.pvSeatIndex = perasSeatIndex + , V1.pvEligibilityProof = proof + , V1.pvSignature = sig + } + + fromPerasVote = \case + V1.PerasVote electionId candidate seatIndex proof sig -> do + let seatIndex' = fromPerasSeatIndex seatIndex + case proof of + V1.PersistentPerasVoteEligibilityProof -> + pure $ + WFALSPersistentVote + seatIndex' + electionId + candidate + sig + V1.NonPersistentPerasVoteEligibilityProof vrfOutput -> + pure $ + WFALSNonPersistentVote + seatIndex' + electionId + candidate + vrfOutput + sig + +-- 'V1.PerasCert's are compatible with 'WFALS' as long as we make sure to avoid +-- overflowing the `Word16` seat index of each voter. +instance + PerasCertCompatibleWithVotingCommittee + V1.PerasCert + PerasBLSCrypto + WFALS + where + toPerasCert = \case + WFALSCert electionId candidate voters sig -> do + voters' <- toPerasCertVoters voters + pure $ + V1.PerasCert + { V1.pcRoundNo = electionId + , V1.pcBoostedBlock = candidate + , V1.pcVoters = voters' + , V1.pcSignature = sig + } + + fromPerasCert = \case + V1.PerasCert electionId candidate voters sig -> do + let voters' = fromPerasCertVoters voters + pure $ + WFALSCert + electionId + candidate + voters' + sig + +-- 'V1.PerasVote's are compatible with 'EveryoneVotes' as long as we make sure +-- to only accept votes with persistent eligibility proofs (in addition to +-- avoiding overflowing their `Word16` seat index). +instance + PerasVoteCompatibleWithVotingCommittee + V1.PerasVote + PerasBLSCrypto + EveryoneVotes + where + toPerasVote = \case + EveryoneVotesVote seatIndex electionId candidate sig -> do + perasSeatIndex <- toPerasSeatIndex seatIndex + pure $ + V1.PerasVote + { V1.pvRoundNo = electionId + , V1.pvBoostedBlock = candidate + , V1.pvSeatIndex = perasSeatIndex + , V1.pvEligibilityProof = V1.PersistentPerasVoteEligibilityProof + , V1.pvSignature = sig + } + + fromPerasVote = \case + V1.PerasVote electionId candidate seatIndex proof sig -> do + let seatIndex' = fromPerasSeatIndex seatIndex + case proof of + V1.PersistentPerasVoteEligibilityProof -> + pure $ + EveryoneVotesVote + seatIndex' + electionId + candidate + sig + V1.NonPersistentPerasVoteEligibilityProof _ -> + Left $ + EveryoneVotesButFoundNonPersistentVoterInVote seatIndex' + +-- 'V1.PerasCert's are compatible with 'EveryoneVotes' as long as we make sure +-- to only accept certificates containing only persistent eligibility proofs +-- (in addition to avoiding overflowing the `Word16` seat index of each voter). +instance + PerasCertCompatibleWithVotingCommittee + V1.PerasCert + PerasBLSCrypto + EveryoneVotes + where + toPerasCert = \case + EveryoneVotesCert electionId candidate voters sig -> do + voters' <- + toPerasCertVoters + . NEMap.fromSet (const Nothing) + $ voters + pure $ + V1.PerasCert + { V1.pcRoundNo = electionId + , V1.pcBoostedBlock = candidate + , V1.pcVoters = voters' + , V1.pcSignature = sig + } + + fromPerasCert = \case + V1.PerasCert electionId candidate voters sig -> do + let voters' = fromPerasCertVoters voters + case nonPersistentVoters voters' of + Nothing -> + pure $ + EveryoneVotesCert + electionId + candidate + (NEMap.keysSet voters') + sig + Just nonPersistentSeatIndices -> + Left $ + EveryoneVotesButFoundNonPersistentVotersInCert + nonPersistentSeatIndices + where + nonPersistentVoters voters' = + case Map.keys (NEMap.filter isJust voters') of + [] -> + Nothing + nonPersistentSeats -> + Just (NonEmpty.fromList nonPersistentSeats) + +-- * Helpers + +-- | Convert a Peras seat index to a committee seat index. +fromPerasSeatIndex :: + PerasSeatIndex -> + SeatIndex +fromPerasSeatIndex (PerasSeatIndex seatIndex) = + SeatIndex (fromIntegral @Word16 @Word64 seatIndex) + +-- | Convert a committee seat index to a Peras seat index +-- +-- NOTE: this can fail if the seat index in the committee vote or certificate +-- overflows the smaller 'Word16' type used by Peras votes and certificates. +-- In practice, this should never happen unless there is a bug in the voting +-- committee logic. +toPerasSeatIndex :: + SeatIndex -> + Either PerasConversionError PerasSeatIndex +toPerasSeatIndex (SeatIndex seatIndex) + | seatIndex <= fromIntegral @Word16 @Word64 maxBound = + Right (PerasSeatIndex (fromIntegral @Word64 @Word16 seatIndex)) + | otherwise = + Left (SeatIndexOverflowError seatIndex) + +-- | Convert concrete Peras certificate voters to abstract committee voters +fromPerasCertVoters :: + V1.PerasCertVoters -> + NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) +fromPerasCertVoters voters = + NEMap.fromAscList + . NonEmpty.map + ( \(seatIndex, proof) -> + ( fromPerasSeatIndex seatIndex + , fromPerasVoteEligibilityProof proof + ) + ) + . NEMap.toAscList + . V1.unPerasCertVoters + $ voters + where + fromPerasVoteEligibilityProof = \case + V1.PersistentPerasVoteEligibilityProof -> Nothing + V1.NonPersistentPerasVoteEligibilityProof vrfOutput -> Just vrfOutput + +-- | Convert abstract committee voters to concrete Peras certificate voters +toPerasCertVoters :: + NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) -> + Either PerasConversionError V1.PerasCertVoters +toPerasCertVoters voters = + fmap V1.PerasCertVoters + . fmap NEMap.fromAscList + . traverse + ( \(seatIndex, proof) -> do + seatIndex' <- toPerasSeatIndex seatIndex + let proof' = toPerasVoteEligibilityProof proof + pure (seatIndex', proof') + ) + . NEMap.toAscList + $ voters + where + toPerasVoteEligibilityProof = \case + Nothing -> V1.PersistentPerasVoteEligibilityProof + Just vrfOutput -> V1.NonPersistentPerasVoteEligibilityProof vrfOutput From e9162068a4742a9bc0f8bc749a3b643a9c9d3e1e Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 21 Apr 2026 14:02:19 +0200 Subject: [PATCH 14/62] Add test helpers for PerasCrypto This commit adds test helpers to aid with the definition of the upcoming roundtrip properties for concrete Peras votes and certificates. Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- ouroboros-consensus.cabal | 1 + .../Test/Consensus/Peras/Util.hs | 266 ++++++++++++++++++ 2 files changed, 267 insertions(+) create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index d439b72656..7c37157226 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -676,6 +676,7 @@ test-suite consensus-test Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke Test.Consensus.Peras.Cert.Inclusion + Test.Consensus.Peras.Util Test.Consensus.Peras.Voting.Rules Test.Consensus.Peras.WeightSnapshot Test.Consensus.Util.MonadSTM.NormalForm diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs new file mode 100644 index 0000000000..e7f4608673 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Common utilities for writing tests for Peras types. +module Test.Consensus.Peras.Util + ( -- * Predicates + perasVoteIsPersistent + , perasCertContainsOnlyPersistentVotes + + -- * Generators + , genPerasVote + , genPerasCert + + -- * Tabulators + , mkBucket + , tabulatePerasCert + , tabulatePerasVote + ) where + +import Cardano.Crypto.Hash (ByteString) +import Cardano.Ledger.BaseTypes (SlotNo (..)) +import Control.Monad (forM) +import qualified Data.ByteString as ByteString +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as ShortByteString +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.NonEmpty as NEMap +import Data.Maybe (catMaybes, fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.String (IsString (..)) +import Data.Traversable (mapAccumM) +import Data.Word (Word8) +import GHC.Word (Word16) +import Ouroboros.Consensus.Block (HeaderHash) +import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), toBytes32RealPoint) +import Ouroboros.Consensus.Block.SupportsPeras + ( PerasBoostedBlock (..) + , PerasRoundNo (..) + , PerasSeatIndex (..) + ) +import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import Ouroboros.Consensus.Peras.Crypto.BLS + ( PerasBLSCryptoAggregateVoteSignature (..) + , VRFOutput (..) + , VoteSignature (..) + ) +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import Test.QuickCheck + ( Arbitrary (..) + , Gen + , Property + , choose + , frequency + , sized + , tabulate + , vectorOf + ) + +-- * Predicates + +-- | Whether a Peras vote is a persistent one +perasVoteIsPersistent :: V1.PerasVote -> Bool +perasVoteIsPersistent vote + | V1.PersistentPerasVoteEligibilityProof{} <- V1.pvEligibilityProof vote = True + | otherwise = False + +-- | Whether a Peras certifcate only contains persistent votes +perasCertContainsOnlyPersistentVotes :: V1.PerasCert -> Bool +perasCertContainsOnlyPersistentVotes cert = + all + ( \case + V1.PersistentPerasVoteEligibilityProof -> True + V1.NonPersistentPerasVoteEligibilityProof{} -> False + ) + ( NEMap.elems + . V1.unPerasCertVoters + . V1.pcVoters + $ cert + ) + +-- * Generators + +genRoundNo :: Gen PerasRoundNo +genRoundNo = PerasRoundNo <$> arbitrary + +data BlockWith32BytesHeaderHash +type instance HeaderHash BlockWith32BytesHeaderHash = ShortByteString + +genBoostedBlock :: Gen PerasBoostedBlock +genBoostedBlock = do + slotNo <- SlotNo <$> arbitrary + hash <- ShortByteString.pack <$> vectorOf 32 arbitrary + let bytes32realPoint = + toBytes32RealPoint @BlockWith32BytesHeaderHash $ + RealPoint slotNo hash + pure (PerasBoostedBlock bytes32realPoint) + +genSeatIndex :: Gen PerasSeatIndex +genSeatIndex = PerasSeatIndex <$> arbitrary + +genPrivateKey :: Proxy r -> Gen (BLS.PrivateKey r) +genPrivateKey _ = + fromMaybe (error "genPrivateKey: invalid key bytes") + . BLS.rawDeserialisePrivateKey "ROUNDTRIP" + . ByteString.pack + <$> vectorOf 32 (arbitrary @Word8) + +genSignature :: + forall r. + BLS.HasBLSContext r => + Proxy r -> + Gen (BLS.Signature r) +genSignature _ = do + key <- genPrivateKey (Proxy @r) + msg <- fromString @ByteString <$> arbitrary + pure $ BLS.signWithRole key msg + +genVoteEligibilityProof :: Bool -> Gen V1.PerasVoteEligibilityProof +genVoteEligibilityProof shouldGenNonPersistent = do + frequency + [ + ( 4 + , pure V1.PersistentPerasVoteEligibilityProof + ) + , + ( if shouldGenNonPersistent then 1 else 0 + , V1.NonPersistentPerasVoteEligibilityProof + . PerasBLSCryptoVRFOutput + <$> genSignature (Proxy @BLS.VRF) + ) + ] + +genVoters :: Bool -> Gen V1.PerasCertVoters +genVoters shouldGenNonPersistent = do + numVoters <- + sized $ \size -> + fmap (+ 1) $ + choose @Word16 (0, fromIntegral size * 10) + numPersistentVoters <- + case shouldGenNonPersistent of + True -> choose (0, numVoters) + False -> pure numVoters + persistentVoters <- + if numPersistentVoters == 0 + then pure [] + else forM [0 .. numPersistentVoters - 1] $ \i -> do + let proof = V1.PersistentPerasVoteEligibilityProof + pure (PerasSeatIndex i, proof) + nonPersistentVoters <- + if numPersistentVoters == numVoters + then pure [] + else forM [numPersistentVoters .. numVoters - 1] $ \i -> do + proof <- + V1.NonPersistentPerasVoteEligibilityProof + . PerasBLSCryptoVRFOutput + <$> genSignature (Proxy @BLS.VRF) + pure (PerasSeatIndex i, proof) + voters <- + fmap (snd . fmap catMaybes) + . mapAccumM + ( \canDrop (i, proof) -> do + voter <- + frequency + [ (75, pure (Just (i, proof))) + , (if canDrop then 25 else 0, pure Nothing) + ] + pure + ( canDrop || voter == Nothing + , voter + ) + ) + False + $ persistentVoters <> nonPersistentVoters + pure $ + V1.PerasCertVoters (NEMap.fromList (NonEmpty.fromList voters)) + +genPerasVote :: Bool -> Gen V1.PerasVote +genPerasVote shouldGenNonPersistent = do + pvRoundNo <- genRoundNo + pvBoostedBlock <- genBoostedBlock + pvSeatIndex <- genSeatIndex + pvEligibilityProof <- genVoteEligibilityProof shouldGenNonPersistent + pvSignature <- + PerasBLSCryptoVoteSignature + <$> genSignature (Proxy @BLS.SIGN) + pure + V1.PerasVote + { V1.pvRoundNo + , V1.pvBoostedBlock + , V1.pvSeatIndex + , V1.pvEligibilityProof + , V1.pvSignature + } + +genPerasCert :: Bool -> Gen V1.PerasCert +genPerasCert shouldGenNonPersistent = do + pcRoundNo <- genRoundNo + pcBoostedBlock <- genBoostedBlock + pcVoters <- genVoters shouldGenNonPersistent + pcSignature <- + PerasBLSCryptoAggregateVoteSignature + <$> genSignature (Proxy @BLS.SIGN) + pure + V1.PerasCert + { V1.pcRoundNo + , V1.pcBoostedBlock + , V1.pcVoters + , V1.pcSignature + } + +-- * Tabulators + +mkBucket :: Int -> Int -> String -> String +mkBucket bucketSize x suffix + | lower == upper = show lower <> suffix + | otherwise = show lower <> "-" <> show upper <> suffix + where + lower = (x `div` bucketSize) * bucketSize + upper = lower + bucketSize + +tabulatePerasCert :: V1.PerasCert -> Property -> Property +tabulatePerasCert cert = + foldr (flip (.)) id $ + [ tabulate + "Number of voters" + [mkBucket 100 numVoters " voters"] + , tabulate + "Proportion of persistent voters" + [mkBucket 10 persistentVotersRatio "%"] + ] + where + numVoters = + length + . V1.unPerasCertVoters + . V1.pcVoters + $ cert + numPersistentVoters = + length + . filter (== V1.PersistentPerasVoteEligibilityProof) + . NonEmpty.toList + . NEMap.elems + . V1.unPerasCertVoters + . V1.pcVoters + $ cert + + persistentVotersRatio + | numVoters == 0 = 0 + | otherwise = numPersistentVoters * 100 `div` numVoters + +tabulatePerasVote :: V1.PerasVote -> Property -> Property +tabulatePerasVote vote = + foldr (flip (.)) id $ + [ tabulate + "Voter type" + [voterType] + ] + where + voterType = + case V1.pvEligibilityProof vote of + V1.PersistentPerasVoteEligibilityProof -> "persistent" + V1.NonPersistentPerasVoteEligibilityProof _ -> "non-persistent" From 384acee93cbd08d03dc214e74a729f78d492e481 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 21 Apr 2026 17:25:41 +0200 Subject: [PATCH 15/62] Add property tests for Bitmap library This commit adds property tests for the newly added bitmap library asserting that both conversion from and/to indices as well as serialization roundtrip correctly. Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- ouroboros-consensus.cabal | 1 + .../test/consensus-test/Main.hs | 2 + .../Test/Consensus/Util/Bitmap.hs | 73 +++++++++++++++++++ 3 files changed, 76 insertions(+) create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Util/Bitmap.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 7c37157226..41738aff86 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -679,6 +679,7 @@ test-suite consensus-test Test.Consensus.Peras.Util Test.Consensus.Peras.Voting.Rules Test.Consensus.Peras.WeightSnapshot + Test.Consensus.Util.Bitmap Test.Consensus.Util.MonadSTM.NormalForm Test.Consensus.Util.Pred Test.Consensus.Util.Versioned diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index f0b10c40f6..0aa9896073 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -25,6 +25,7 @@ import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke (tests) import qualified Test.Consensus.Peras.Cert.Inclusion (tests) import qualified Test.Consensus.Peras.Voting.Rules (tests) import qualified Test.Consensus.Peras.WeightSnapshot (tests) +import qualified Test.Consensus.Util.Bitmap (tests) import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests) import qualified Test.Consensus.Util.Pred (tests) import qualified Test.Consensus.Util.Versioned (tests) @@ -69,6 +70,7 @@ tests = , Test.Consensus.Peras.Voting.Rules.tests , Test.Consensus.Peras.WeightSnapshot.tests ] + , Test.Consensus.Util.Bitmap.tests , Test.Consensus.Util.MonadSTM.NormalForm.tests , Test.Consensus.Util.Versioned.tests , Test.Consensus.Util.Pred.tests diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/Bitmap.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/Bitmap.hs new file mode 100644 index 0000000000..b059d497e6 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/Bitmap.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Property-based tests for 'Bitmap' +module Test.Consensus.Util.Bitmap (tests) where + +import Cardano.Binary (decodeFull, serialize) +import qualified Data.Set as Set +import qualified Ouroboros.Consensus.Util.Bitmap as Bitmap +import Test.QuickCheck (Testable (..), counterexample, vectorOf) +import Test.Tasty +import Test.Tasty.QuickCheck + ( Gen + , Property + , choose + , forAll + , testProperty + , (===) + ) +import Test.Util.TestEnv (adjustQuickCheckTests) + +tests :: TestTree +tests = + adjustQuickCheckTests (* 100) $ + testGroup + "Bitmap" + [ testProperty + "prop_roundtrip_toIndices" + prop_roundtrip_toIndices + , testProperty + "prop_roundtrip_serialisation" + prop_roundtrip_serialisation + ] + +-- * Properties + +-- | Converting from indices to bitmap and back preserves the indices. +prop_roundtrip_toIndices :: Property +prop_roundtrip_toIndices = + forAll genMaxIndex $ \maxIndex -> + forAll genNumIndices $ \numIndices -> do + forAll (genIndices numIndices maxIndex) $ \indices -> do + let bitmap = Bitmap.fromIndices maxIndex indices + let indices' = Bitmap.toIndices bitmap + Set.fromList indices === Set.fromList indices' + +-- | Serialisation roundtrip preserves the bitmap. +prop_roundtrip_serialisation :: Property +prop_roundtrip_serialisation = + forAll genMaxIndex $ \maxIndex -> + forAll genNumIndices $ \numIndices -> do + forAll (genIndices numIndices maxIndex) $ \indices -> do + let bitmap = Bitmap.fromIndices maxIndex indices + let encoded = serialize bitmap + case decodeFull encoded of + Left err -> + counterexample ("Deserialization failed: " <> show err) $ + property False + Right bitmap' -> + bitmap === bitmap' + +-- * Generators + +genMaxIndex :: Gen Int +genMaxIndex = + choose (0, 10000) + +genNumIndices :: Gen Int +genNumIndices = + choose (0, 100) + +genIndices :: Int -> Int -> Gen [Int] +genIndices numIndices maxIndex = + vectorOf numIndices (choose (0, maxIndex)) From ab1b772bc1f8bffad59ac811d11c1a53e8bb87cf Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Fri, 27 Mar 2026 13:07:38 +0100 Subject: [PATCH 16/62] Add serialization roundtrip tests for PerasCert and PerasVote This commit adds serialization roundtrip tests for the concrete Peras votes and certificate types. Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- ouroboros-consensus.cabal | 1 + .../test/consensus-test/Main.hs | 2 + .../Test/Consensus/Peras/Serialisation.hs | 82 +++++++++++++++++++ 3 files changed, 85 insertions(+) create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 41738aff86..3d408ffe60 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -676,6 +676,7 @@ test-suite consensus-test Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke Test.Consensus.Peras.Cert.Inclusion + Test.Consensus.Peras.Serialisation Test.Consensus.Peras.Util Test.Consensus.Peras.Voting.Rules Test.Consensus.Peras.WeightSnapshot diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 0aa9896073..f994d5e63b 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -23,6 +23,7 @@ import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke (te import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke (tests) import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke (tests) import qualified Test.Consensus.Peras.Cert.Inclusion (tests) +import qualified Test.Consensus.Peras.Serialisation (tests) import qualified Test.Consensus.Peras.Voting.Rules (tests) import qualified Test.Consensus.Peras.WeightSnapshot (tests) import qualified Test.Consensus.Util.Bitmap (tests) @@ -69,6 +70,7 @@ tests = [ Test.Consensus.Peras.Cert.Inclusion.tests , Test.Consensus.Peras.Voting.Rules.tests , Test.Consensus.Peras.WeightSnapshot.tests + , Test.Consensus.Peras.Serialisation.tests ] , Test.Consensus.Util.Bitmap.tests , Test.Consensus.Util.MonadSTM.NormalForm.tests diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs new file mode 100644 index 0000000000..c67e6ff9a1 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Serialisation roundtrip tests for Peras types +module Test.Consensus.Peras.Serialisation + ( tests + ) where + +import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeFull, serialize) +import qualified Data.ByteString.Lazy as LazyByteString +import Test.Consensus.Peras.Util + ( genPerasCert + , genPerasVote + , mkBucket + , tabulatePerasCert + , tabulatePerasVote + ) +import Test.QuickCheck + ( Gen + , Property + , counterexample + , forAll + , tabulate + , (===) + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.TestEnv (adjustQuickCheckTests) + +tests :: TestTree +tests = + testGroup + "Serialization roundtrip for Peras types" + [ adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasVote" $ + prop_roundtrip + -- Generate both persistent and non-persistent votes + (genPerasVote True) + tabulatePerasVote + , adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasCert" $ + prop_roundtrip + -- Generate certs with both persistent and non-persistent votes + (genPerasCert True) + tabulatePerasCert + ] + +-- * Properties + +prop_roundtrip :: + forall a. + ( Eq a + , Show a + , ToCBOR a + , FromCBOR a + ) => + Gen a -> + (a -> Property -> Property) -> + Property +prop_roundtrip gen tabulateValue = + forAll gen $ \a -> do + let encoded = serialize a + let decoded = decodeFull encoded + tabulateValue a + . tabulateEncodedSize encoded + . counterexample + ( unlines + [ "Original value:" + , show a + , "Decoded value:" + , show decoded + ] + ) + $ Right a === decoded + +-- * Tabulators + +tabulateEncodedSize :: LazyByteString.ByteString -> Property -> Property +tabulateEncodedSize bytes = + tabulate + "Encoded size" + [mkBucket 1000 (fromIntegral (LazyByteString.length bytes)) " bytes"] From 13205ee635315bd0b5ecf91d2b06533e25383812 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 21 Apr 2026 14:03:38 +0200 Subject: [PATCH 17/62] Add conversion roundtrip tests between Peras votes/certs and voting committee types This commit adds conversion rountrip tests between concrete Peras votes and certificates and their corresponding (abstract) counterparts in the WFALS and EveryoneVotes voting committee implementations. Notably, the roundtrip properties allow testing both total (WFALS) and partial (EveryoneVotes) conversions, generating both good and bad cases and contrasting them against their expected rountrip outcome. Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- ouroboros-consensus.cabal | 1 + .../test/consensus-test/Main.hs | 2 + .../Test/Consensus/Peras/Voting/Committee.hs | 207 ++++++++++++++++++ 3 files changed, 210 insertions(+) create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 3d408ffe60..988c8ed976 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -678,6 +678,7 @@ test-suite consensus-test Test.Consensus.Peras.Cert.Inclusion Test.Consensus.Peras.Serialisation Test.Consensus.Peras.Util + Test.Consensus.Peras.Voting.Committee Test.Consensus.Peras.Voting.Rules Test.Consensus.Peras.WeightSnapshot Test.Consensus.Util.Bitmap diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index f994d5e63b..c66e29766d 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -24,6 +24,7 @@ import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke (te import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke (tests) import qualified Test.Consensus.Peras.Cert.Inclusion (tests) import qualified Test.Consensus.Peras.Serialisation (tests) +import qualified Test.Consensus.Peras.Voting.Committee (tests) import qualified Test.Consensus.Peras.Voting.Rules (tests) import qualified Test.Consensus.Peras.WeightSnapshot (tests) import qualified Test.Consensus.Util.Bitmap (tests) @@ -68,6 +69,7 @@ tests = , testGroup "Peras" [ Test.Consensus.Peras.Cert.Inclusion.tests + , Test.Consensus.Peras.Voting.Committee.tests , Test.Consensus.Peras.Voting.Rules.tests , Test.Consensus.Peras.WeightSnapshot.tests , Test.Consensus.Peras.Serialisation.tests diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs new file mode 100644 index 0000000000..ab9d800919 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Test properties relating Peras and voting committee types. +module Test.Consensus.Peras.Voting.Committee + ( tests + ) where + +import Data.Proxy (Proxy (..)) +import qualified Ouroboros.Consensus.Committee.Class as Committee +import Ouroboros.Consensus.Committee.EveryoneVotes (EveryoneVotes) +import Ouroboros.Consensus.Committee.WFALS (WFALS) +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import Ouroboros.Consensus.Peras.Voting.Committee + ( PerasCertCompatibleWithVotingCommittee (..) + , PerasVoteCompatibleWithVotingCommittee (..) + ) +import Test.Consensus.Peras.Util + ( genPerasCert + , genPerasVote + , perasCertContainsOnlyPersistentVotes + , perasVoteIsPersistent + , tabulatePerasCert + , tabulatePerasVote + ) +import Test.QuickCheck + ( Gen + , Property + , Testable (..) + , counterexample + , forAll + , frequency + , tabulate + , (===) + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.TestEnv (adjustQuickCheckTests) + +tests :: TestTree +tests = + testGroup + "Roundtrip for Peras types via abstract committee types" + [ adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasVote via WFALS" $ + prop_roundtrip_vote + (Proxy @V1.PerasVote) + (Proxy @WFALS) + -- WFALS supports both persistent and non-persistent of votes + (const True) + -- Generate both persistent and non-persistent votes + (genPerasVote True) + tabulatePerasVote + , adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasVote via EveryoneVotes" $ + prop_roundtrip_vote + (Proxy @V1.PerasVote) + (Proxy @EveryoneVotes) + -- EveryoneVotes only supports non-persistent votes + perasVoteIsPersistent + -- Generate both persistent and non-persistent votes to trigger + -- conversion errors in a reasonable amount of tests + (genPerasVote =<< frequency [(2, pure True), (1, pure False)]) + tabulatePerasVote + , adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasCert via WFALS" $ + prop_roundtrip_cert + (Proxy @V1.PerasCert) + (Proxy @WFALS) + -- WFALS supports certs with both persistent and non-persistent votes + (const True) + -- Generate certs with both persistent and non-persistent votes + (genPerasCert True) + tabulatePerasCert + , adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasCert via EveryoneVotes" $ + prop_roundtrip_cert + (Proxy @V1.PerasCert) + (Proxy @EveryoneVotes) + -- EveryoneVotes only supports certs with persistent votes + perasCertContainsOnlyPersistentVotes + -- Only sometimes generate certs with non-persistent votes to + -- trigger conversion errors in a reasonable amount of tests + (genPerasCert =<< frequency [(2, pure False), (1, pure True)]) + tabulatePerasCert + ] + +-- * Properties + +-- | Test that converting a concrete Peras vote to an committee vote and back +-- again results in the original Peras vote. +-- +-- NOTE: this takes a predicate to determine whether triggering an exception is +-- a test failure or an expected outcome for the given voting committee scheme. +prop_roundtrip_vote :: + forall vote crypto committee. + ( Show vote + , Eq vote + , PerasVoteCompatibleWithVotingCommittee vote crypto committee + ) => + Proxy vote -> + Proxy committee -> + (vote -> Bool) -> + Gen vote -> + (vote -> Property -> Property) -> + Property +prop_roundtrip_vote _ _ shouldPass gen tabulateValue = + forAll gen $ \vote -> do + tabulateValue vote $ + case fromPerasVote vote of + Left err + | shouldPass vote -> + counterexample + ( unlines + [ "fromPerasVote failed with:" + , show err + , "Original vote:" + , show vote + ] + ) + False + | otherwise -> + tabulateOutcome "Fails as expected" $ + property True + Right (committeeVote :: Committee.Vote crypto committee) -> + case toPerasVote committeeVote of + Left err -> + counterexample + ( unlines + [ "toPerasVote failed with:" + , show err + ] + ) + $ property False + Right vote' -> + tabulateOutcome "Roundtrips successfully" + . counterexample + ( unlines + [ "Original vote:" + , show vote + , "Roundtripped vote:" + , show vote' + ] + ) + $ vote === vote' + +-- | Test that converting a concrete Peras cert to an committee cert and back +-- again results in the original Peras cert. +-- +-- NOTE: this takes a predicate to determine whether triggering an exception is +-- a test failure or an expected outcome for the given voting committee scheme. +prop_roundtrip_cert :: + forall cert crypto committee. + ( Show cert + , Eq cert + , PerasCertCompatibleWithVotingCommittee cert crypto committee + ) => + Proxy cert -> + Proxy committee -> + (cert -> Bool) -> + Gen cert -> + (cert -> Property -> Property) -> + Property +prop_roundtrip_cert _ _ shouldPass gen tabulateValue = + forAll gen $ \cert -> do + tabulateValue cert $ + case fromPerasCert cert of + Left err + | shouldPass cert -> + counterexample + ( unlines + [ "fromPerasCert failed with:" + , show err + , "Original cert:" + , show cert + ] + ) + $ property False + | otherwise -> + tabulateOutcome "Fails as expected" $ + property True + Right (committeeCert :: Committee.Cert crypto committee) -> + case toPerasCert committeeCert of + Left err -> + counterexample + ( unlines + [ "toPerasCert failed with:" + , show err + ] + ) + False + Right cert' -> + tabulateOutcome "Roundtrips successfully" + . counterexample + ( unlines + [ "Original cert:" + , show cert + , "Roundtripped cert:" + , show cert' + ] + ) + $ cert === cert' + +tabulateOutcome :: String -> Property -> Property +tabulateOutcome outcome = tabulate "Outcome" [outcome] From 2a12c982cd63a31d6c19befe4ff0876f2e3f13c3 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 21 Apr 2026 17:03:38 +0200 Subject: [PATCH 18/62] Add changelog Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- ..._agustin.mista_concrete_certs_and_votes.md | 28 +++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 changelog.d/20260421_170000_agustin.mista_concrete_certs_and_votes.md diff --git a/changelog.d/20260421_170000_agustin.mista_concrete_certs_and_votes.md b/changelog.d/20260421_170000_agustin.mista_concrete_certs_and_votes.md new file mode 100644 index 0000000000..0bce9065c2 --- /dev/null +++ b/changelog.d/20260421_170000_agustin.mista_concrete_certs_and_votes.md @@ -0,0 +1,28 @@ + + + + +### Non-Breaking + +- Introduce `Ouroboros.Consensus.Util.Bitmap` providing `ByteString`-based compact bitmaps. +- Define `PerasBLSCrypto` scheme with support for all the voting committee superclasses. +- Define concrete `PerasVote` and `PerasCert` types using BLS signatures. +- Define `PerasVoteCompatibleWithVotingCommittee` and `PerasCertCompatibleWithVotingCommittee` type classes with conversions between concrete Peras types and their abstract voting committee counterparts. +- Instantiate `VotingCommitteeSupportsPeras` for both `WFALS` and `EveryoneVotes`. + + From af2f9ec2aed7e287e298fd30c56d125ecbe00d79 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 5 May 2026 13:49:27 +0200 Subject: [PATCH 19/62] Split base Peras types into separate module Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- ouroboros-consensus.cabal | 1 + .../Consensus/Block/SupportsPeras.hs | 198 ++--------------- .../Consensus/Peras/Cert/Inclusion.hs | 7 +- .../Ouroboros/Consensus/Peras/Types.hs | 202 ++++++++++++++++++ .../Consensus/Peras/Vote/Aggregation.hs | 7 + .../Consensus/Peras/Voting/Committee.hs | 2 +- .../Ouroboros/Consensus/Peras/Voting/Rules.hs | 2 - .../Ouroboros/Consensus/Peras/Voting/View.hs | 2 +- .../Consensus/Storage/PerasVoteDB/Impl.hs | 1 + .../Test/Ouroboros/Storage/TestBlock.hs | 2 + .../Test/Util/Orphans/ToExpr.hs | 2 + .../ObjectDiffusion/PerasCert/Smoke.hs | 2 + .../ObjectDiffusion/PerasVote/Smoke.hs | 8 + .../Test/Consensus/Peras/Cert/Inclusion.hs | 6 - .../Test/Consensus/Peras/Util.hs | 10 +- .../Test/Consensus/Peras/Voting/Rules.hs | 2 - .../Test/Ouroboros/Storage/ChainDB/Model.hs | 1 + .../Ouroboros/Storage/ChainDB/StateMachine.hs | 2 + .../Storage/PerasCertDB/StateMachine.hs | 2 + .../Ouroboros/Storage/PerasVoteDB/Model.hs | 21 +- .../Storage/PerasVoteDB/StateMachine.hs | 14 +- 21 files changed, 278 insertions(+), 216 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 988c8ed976..3c03ddadee 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -241,6 +241,7 @@ library Ouroboros.Consensus.Peras.Crypto.BLS Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView + Ouroboros.Consensus.Peras.Types Ouroboros.Consensus.Peras.Vote.Aggregation Ouroboros.Consensus.Peras.Vote.V1 Ouroboros.Consensus.Peras.Voting.Committee diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index dc1db1bb87..cd6bee6eed 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -12,18 +11,7 @@ {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Block.SupportsPeras - ( PerasRoundNo (..) - , onPerasRoundNo - , PerasBoostedBlock (..) - , PerasSeatIndex (..) - , PerasVoteId (..) - , PerasVoteTarget (..) - , PerasVoterId (..) - , PerasVoteStake (..) - , stakeAboveThreshold - , PerasVoteStakeDistr (..) - , lookupPerasVoteStake - , BlockSupportsPeras (..) + ( BlockSupportsPeras (..) , PerasCert (..) , PerasVote (..) , ValidatedPerasCert (..) @@ -43,166 +31,32 @@ module Ouroboros.Consensus.Block.SupportsPeras , HasPerasVoteStake (..) , HasPerasVoteTarget (..) , HasPerasVoteId (..) - - -- * Convenience re-exports - , module Ouroboros.Consensus.Peras.Params ) where -import Cardano.Binary (FromCBOR, ToCBOR) -import qualified Cardano.Binary as KeyHash -import Cardano.Ledger.Hashes (KeyHash, KeyRole (..)) +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Codec.Serialise (Serialise (..)) import Codec.Serialise.Decoding (decodeListLenOf) import Codec.Serialise.Encoding (encodeListLen) -import Control.DeepSeq (NFData) -import Data.Coerce (coerce) import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map as Map -import Data.Map.Strict (Map) -import Data.Monoid (Sum (..)) import Data.Proxy (Proxy (..)) -import Data.Word (Word16, Word64) import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block.Abstract -import Ouroboros.Consensus.Block.RealPoint - ( Bytes32RealPoint - , decodeBytes32RealPoint - , encodeBytes32RealPoint - ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Peras.Params -import Ouroboros.Consensus.Util -import Ouroboros.Consensus.Util.Condense -import Quiet (Quiet (..)) - -{------------------------------------------------------------------------------- --- * Peras types --------------------------------------------------------------------------------} - --- ** Round numbers - -newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} - deriving Show via Quiet PerasRoundNo - deriving stock Generic - deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise, NFData, ToCBOR, FromCBOR) - -instance Condense PerasRoundNo where - condense = show . unPerasRoundNo - -instance ShowProxy PerasRoundNo where - showProxy _ = "PerasRoundNo" - --- | Lift a binary operation on 'Word64' to 'PerasRoundNo' -onPerasRoundNo :: - (Word64 -> Word64 -> Word64) -> - (PerasRoundNo -> PerasRoundNo -> PerasRoundNo) -onPerasRoundNo = coerce - --- ** Boosted blocks - --- | The slot number and 32-byte hash of the block being voted for -newtype PerasBoostedBlock - = PerasBoostedBlock - { unPerasBoostedBlock :: Bytes32RealPoint - } - deriving stock (Eq, Show) - -instance FromCBOR PerasBoostedBlock where - fromCBOR = PerasBoostedBlock <$> decodeBytes32RealPoint - -instance ToCBOR PerasBoostedBlock where - toCBOR = encodeBytes32RealPoint . unPerasBoostedBlock - --- ** Seat indices - --- | Seat index in the voting committee used for Peras -newtype PerasSeatIndex - = PerasSeatIndex - { unPerasSeatIndex :: Word16 - } - deriving stock (Eq, Ord, Show) - deriving newtype (FromCBOR, ToCBOR, Enum, Bounded) - --- ** Stake pool distributions - -newtype PerasVoterId = PerasVoterId - { unPerasVoterId :: KeyHash StakePool - } - deriving newtype NoThunks - deriving stock (Eq, Ord, Generic) - deriving Show via Quiet PerasVoterId - --- NOTE: At the moment there is no consensus from researchers/engineers on how --- we go from the absolute stake of a voter in the ledger to the relative stake --- of their vote in the voting commitee (given that the quorum is expressed as --- a relative value of the voting commitee total stake). --- --- So, for now you can consider this 'Rational' as the best approximation we --- have at the moment of the concrete type for a relative vote stake that can be --- compared to the quorum threshold value (also currently a 'Rational'). -newtype PerasVoteStake = PerasVoteStake - { unPerasVoteStake :: Rational - } - deriving newtype (Eq, Ord, Num, Fractional, NoThunks, Serialise) - deriving stock Generic - deriving Show via Quiet PerasVoteStake - deriving Semigroup via Sum Rational - deriving Monoid via Sum Rational - --- | Check whether a given vote stake is above the quorum threshold. --- --- TODO: this function assumes that the 'PerasVoteStake' and the quorum --- threshold used in 'PerasParams' are expressed in the same units. That is, --- both are either absolute or relative (normalized) values. Under the current --- current implementation of 'PerasParams', this function only makes sense when --- both values are relative (normalized) values, so we should either normalize --- the 'PerasVoteStake' before calling this function, or change this function to --- accept a stake distribution and perform the normalization internally. -stakeAboveThreshold :: PerasParams -> PerasVoteStake -> Bool -stakeAboveThreshold params voteStake = - stake >= quorumThreshold + safetyMargin - where - stake = - unPerasVoteStake voteStake - quorumThreshold = - unPerasQuorumStakeThreshold - (perasQuorumStakeThreshold params) - safetyMargin = - unPerasQuorumStakeThresholdSafetyMargin - (perasQuorumStakeThresholdSafetyMargin params) - -newtype PerasVoteStakeDistr = PerasVoteStakeDistr - { unPerasVoteStakeDistr :: Map PerasVoterId PerasVoteStake - } - deriving newtype NoThunks - deriving stock (Show, Eq, Generic) - -data PerasVoteTarget blk = PerasVoteTarget - { pvtRoundNo :: !PerasRoundNo - , pvtBlock :: !(Point blk) - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass NoThunks - -data PerasVoteId blk = PerasVoteId - { pviRoundNo :: !PerasRoundNo - , pviVoterId :: !PerasVoterId - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass NoThunks - --- | Lookup the stake of a vote cast by a member of a given stake distribution. -lookupPerasVoteStake :: - PerasVote blk -> - PerasVoteStakeDistr -> - Maybe PerasVoteStake -lookupPerasVoteStake vote distr = - Map.lookup - (pvVoteVoterId vote) - (unPerasVoteStakeDistr distr) +import Ouroboros.Consensus.Peras.Types + ( PerasRoundNo + , PerasVoteId (..) + , PerasVoteStake + , PerasVoteStakeDistr (..) + , PerasVoteTarget (..) + , PerasVoterId (..) + , lookupPerasVoteStake + , stakeAboveThreshold + ) +import Ouroboros.Consensus.Util (ShowProxy (..)) --- ** Validated types +-- * Validated types data ValidatedPerasCert blk = ValidatedPerasCert { vpcCert :: !(PerasCert blk) @@ -218,8 +72,6 @@ data ValidatedPerasVote blk = ValidatedPerasVote deriving stock (Show, Eq, Ord, Generic) deriving anyclass NoThunks --- ** Votes with enough stake to reach quorum for a given target - -- | A collection of validated Peras votes that: -- 1. are all for the same target, and -- 2. have total stake above the quorum threshold for a given 'PerasCfg'. @@ -271,9 +123,7 @@ votesReachQuorum cfg votes = allVotesMatchTarget target = all ((== (getPerasVoteTarget target)) . getPerasVoteTarget) -{------------------------------------------------------------------------------- -- * BlockSupportsPeras class --------------------------------------------------------------------------------} class ( Show (PerasCfg blk) @@ -361,7 +211,7 @@ instance StandardHash blk => BlockSupportsPeras blk where -- possible 'PerasValidationErr' variants -- see https://github.com/tweag/cardano-peras/issues/120 validatePerasVote _params stakeDistr vote - | Just stake <- lookupPerasVoteStake vote stakeDistr = + | Just stake <- lookupPerasVoteStake (getPerasVoteVoterId vote) stakeDistr = Right ValidatedPerasVote { vpvVote = vote @@ -394,9 +244,6 @@ instance ShowProxy blk => ShowProxy (PerasCert blk) where instance ShowProxy blk => ShowProxy (PerasVote blk) where showProxy _ = "PerasVote " <> showProxy (Proxy @blk) -instance ShowProxy blk => ShowProxy (PerasVoteId blk) where - showProxy _ = "PerasVoteId " <> showProxy (Proxy @blk) - instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where encode PerasCert{pcCertRound, pcCertBoostedBlock} = encodeListLen 2 @@ -413,25 +260,14 @@ instance Serialise (HeaderHash blk) => Serialise (PerasVote blk) where encodeListLen 3 <> encode pvVoteRound <> encode pvVoteBlock - <> KeyHash.toCBOR (unPerasVoterId pvVoteVoterId) + <> toCBOR (unPerasVoterId pvVoteVoterId) decode = do decodeListLenOf 3 pvVoteRound <- decode pvVoteBlock <- decode - pvVoteVoterId <- PerasVoterId <$> KeyHash.fromCBOR + pvVoteVoterId <- PerasVoterId <$> fromCBOR pure $ PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} -instance Serialise (PerasVoteId blk) where - encode PerasVoteId{pviRoundNo, pviVoterId} = - encodeListLen 2 - <> encode pviRoundNo - <> KeyHash.toCBOR (unPerasVoterId pviVoterId) - decode = do - decodeListLenOf 2 - pviRoundNo <- decode - pviVoterId <- PerasVoterId <$> KeyHash.fromCBOR - pure $ PerasVoteId{pviRoundNo, pviVoterId} - -- | Extract the certificate round from a Peras certificate container class HasPerasCertRound cert where getPerasCertRound :: cert -> PerasRoundNo diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs index a0de635ec9..64504ef821 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs @@ -26,12 +26,9 @@ module Ouroboros.Consensus.Peras.Cert.Inclusion import Data.Set (Set) import qualified Data.Set as Set import Ouroboros.Consensus.Block (WithOrigin (..), withOriginToMaybe) -import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasCertRound (..) - , PerasParams - , PerasRoundNo (..) - ) +import Ouroboros.Consensus.Block.SupportsPeras (HasPerasCertRound (..)) import Ouroboros.Consensus.Peras.Params (PerasCertMaxRounds (..), PerasParams (..)) +import Ouroboros.Consensus.Peras.Types (PerasRoundNo (..)) import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.Pred ( Evidence (..) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs new file mode 100644 index 0000000000..8258bb2a3d --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Base Peras types used throughout the implementation. +module Ouroboros.Consensus.Peras.Types + ( PerasRoundNo (..) + , onPerasRoundNo + , PerasBoostedBlock (..) + , PerasSeatIndex (..) + , PerasVoteStake (..) + , stakeAboveThreshold + , PerasVoteTarget (..) + , PerasVoteId (..) + , PerasVoterId (..) + , PerasVoteStakeDistr (..) + , lookupPerasVoteStake + ) +where + +import Cardano.Binary + ( FromCBOR (..) + , ToCBOR (..) + , decodeListLenOf + , encodeListLen + ) +import Cardano.Ledger.Hashes (KeyHash, KeyRole (..)) +import Codec.Serialise.Class (Serialise (..)) +import Control.DeepSeq (NFData) +import Data.Coerce (coerce) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import Data.Semigroup (Sum (..)) +import Data.Word (Word16, Word64) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract (Point) +import Ouroboros.Consensus.Block.RealPoint + ( Bytes32RealPoint + , decodeBytes32RealPoint + , encodeBytes32RealPoint + ) +import Ouroboros.Consensus.Peras.Params + ( PerasParams (..) + , PerasQuorumStakeThreshold (..) + , PerasQuorumStakeThresholdSafetyMargin (..) + ) +import Ouroboros.Consensus.Util (ShowProxy (..)) +import Ouroboros.Consensus.Util.Condense (Condense (..)) +import Quiet (Quiet (..)) + +-- * Peras types + +-- ** Round numbers + +newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} + deriving Show via Quiet PerasRoundNo + deriving stock Generic + deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise, NFData, ToCBOR, FromCBOR) + +instance Condense PerasRoundNo where + condense = show . unPerasRoundNo + +instance ShowProxy PerasRoundNo where + showProxy _ = "PerasRoundNo" + +-- | Lift a binary operation on 'Word64' to 'PerasRoundNo' +onPerasRoundNo :: + (Word64 -> Word64 -> Word64) -> + (PerasRoundNo -> PerasRoundNo -> PerasRoundNo) +onPerasRoundNo = coerce + +-- ** Boosted blocks + +-- | The slot number and 32-byte hash of the block being voted for. +-- +-- NOTE: this type is mostly used in production votes and certificates, while +-- mocked votes and certificates generally use the more abstract 'Point blk'. +newtype PerasBoostedBlock + = PerasBoostedBlock + { unPerasBoostedBlock :: Bytes32RealPoint + } + deriving stock (Eq, Show) + +instance FromCBOR PerasBoostedBlock where + fromCBOR = PerasBoostedBlock <$> decodeBytes32RealPoint + +instance ToCBOR PerasBoostedBlock where + toCBOR = encodeBytes32RealPoint . unPerasBoostedBlock + +-- ** Seat indices + +-- | Seat index in the voting committee used for Peras +newtype PerasSeatIndex + = PerasSeatIndex + { unPerasSeatIndex :: Word16 + } + deriving stock (Eq, Ord, Show) + deriving newtype (FromCBOR, ToCBOR, Enum, Bounded) + +-- ** Vote parameters + +-- | The target of a vote in a Peras election +data PerasVoteTarget blk = PerasVoteTarget + { pvtRoundNo :: !PerasRoundNo + , pvtBlock :: !(Point blk) + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks + +-- | The identifier of a vote in a Peras election +data PerasVoteId blk = PerasVoteId + { pviRoundNo :: !PerasRoundNo + , pviVoterId :: !PerasVoterId + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks + +instance ShowProxy blk => ShowProxy (PerasVoteId blk) where + showProxy _ = "PerasVoteId " <> showProxy (Proxy @blk) + +instance Serialise (PerasVoteId blk) where + encode PerasVoteId{pviRoundNo, pviVoterId} = + encodeListLen 2 + <> encode pviRoundNo + <> toCBOR (unPerasVoterId pviVoterId) + decode = do + decodeListLenOf 2 + pviRoundNo <- decode + pviVoterId <- PerasVoterId <$> fromCBOR + pure $ PerasVoteId{pviRoundNo, pviVoterId} + +-- NOTE: At the moment there is no consensus from researchers/engineers on how +-- we go from the absolute stake of a voter in the ledger to the relative stake +-- of their vote in the voting commitee (given that the quorum is expressed as +-- a relative value of the voting commitee total stake). +-- +-- So, for now you can consider this 'Rational' as the best approximation we +-- have at the moment of the concrete type for a relative vote stake that can be +-- compared to the quorum threshold value (also currently a 'Rational'). +newtype PerasVoteStake = PerasVoteStake + { unPerasVoteStake :: Rational + } + deriving newtype (Eq, Ord, Num, Fractional, NoThunks, NFData, Serialise) + deriving stock Generic + deriving Show via Quiet PerasVoteStake + deriving Semigroup via Sum Rational + deriving Monoid via Sum Rational + +-- | Check whether a given vote stake is above the quorum threshold. +-- +-- TODO: this function assumes that the 'PerasVoteStake' and the quorum +-- threshold used in 'PerasParams' are expressed in the same units. That is, +-- both are either absolute or relative (normalized) values. Under the current +-- current implementation of 'PerasParams', this function only makes sense when +-- both values are relative (normalized) values, so we should either normalize +-- the 'PerasVoteStake' before calling this function, or change this function to +-- accept a stake distribution and perform the normalization internally. +stakeAboveThreshold :: PerasParams -> PerasVoteStake -> Bool +stakeAboveThreshold params voteStake = + stake >= quorumThreshold + safetyMargin + where + stake = + unPerasVoteStake voteStake + quorumThreshold = + unPerasQuorumStakeThreshold + (perasQuorumStakeThreshold params) + safetyMargin = + unPerasQuorumStakeThresholdSafetyMargin + (perasQuorumStakeThresholdSafetyMargin params) + +-- ** Voting stake distributions + +-- | The identifier of a voter in a Peras election +newtype PerasVoterId = PerasVoterId + { unPerasVoterId :: KeyHash StakePool + } + deriving newtype NoThunks + deriving stock (Eq, Ord, Generic) + deriving Show via Quiet PerasVoterId + +-- | Voting stake distribution for a Peras election +newtype PerasVoteStakeDistr = PerasVoteStakeDistr + { unPerasVoteStakeDistr :: Map PerasVoterId PerasVoteStake + } + deriving newtype NoThunks + deriving stock (Show, Eq, Generic) + +-- | Lookup the stake of a vote cast by a member of a given stake distribution. +lookupPerasVoteStake :: + PerasVoterId -> + PerasVoteStakeDistr -> + Maybe PerasVoteStake +lookupPerasVoteStake voterId distr = + Map.lookup + voterId + (unPerasVoteStakeDistr distr) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs index 45bd8fbca0..5d2fd20482 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs @@ -98,6 +98,13 @@ import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (WithArrivalTime, forgetArrivalTime) +import Ouroboros.Consensus.Peras.Types + ( PerasRoundNo + , PerasVoteId + , PerasVoteStake (..) + , PerasVoteTarget (..) + , stakeAboveThreshold + ) {------------------------------------------------------------------------------- Voting state for a given Peras round diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs index d581ac0865..745196a356 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs @@ -20,7 +20,6 @@ import qualified Data.Map as Map import qualified Data.Map.NonEmpty as NEMap import Data.Maybe (isJust) import Data.Word (Word16, Word64) -import Ouroboros.Consensus.Block.SupportsPeras (PerasSeatIndex (..)) import qualified Ouroboros.Consensus.Committee.Class as Committee import Ouroboros.Consensus.Committee.Crypto (CryptoSupportsVRF (..)) import Ouroboros.Consensus.Committee.EveryoneVotes @@ -32,6 +31,7 @@ import Ouroboros.Consensus.Committee.WFA (SeatIndex (..)) import Ouroboros.Consensus.Committee.WFALS (Cert (..), Vote (..), WFALS) import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import Ouroboros.Consensus.Peras.Crypto.BLS (PerasBLSCrypto) +import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 -- * Peras support for multiple voting committee implementations diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs index 58d727ba1b..d74113a3f5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs @@ -34,9 +34,7 @@ import Ouroboros.Consensus.Block.Abstract ) import Ouroboros.Consensus.Block.SupportsPeras ( HasPerasCertRound (..) - , PerasRoundNo (..) , getPerasCertRound - , onPerasRoundNo ) import Ouroboros.Consensus.Peras.Params ( PerasCertArrivalThreshold (..) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs index b9019690a1..0d12bef2a3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs @@ -43,7 +43,6 @@ import Ouroboros.Consensus.Block.Abstract ) import Ouroboros.Consensus.Block.SupportsPeras ( HasPerasCertRound (..) - , PerasRoundNo (..) , ValidatedPerasCert , getPerasCertBoostedBlock , getPerasCertRound @@ -61,6 +60,7 @@ import Ouroboros.Consensus.Peras.Params ( PerasBlockMinSlots (..) , PerasParams (..) ) +import Ouroboros.Consensus.Peras.Types (PerasRoundNo) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index 7f5fce1611..835e002afd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -33,6 +33,7 @@ import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (WithArrivalTime (..)) +import Ouroboros.Consensus.Peras.Types (PerasRoundNo, PerasVoteId (..)) import Ouroboros.Consensus.Peras.Vote.Aggregation import Ouroboros.Consensus.Storage.PerasVoteDB.API import Ouroboros.Consensus.Util.Args diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index 792acb5580..d221f7131a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -114,6 +114,8 @@ import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Params (mkPerasParams, perasRoundLength) +import Ouroboros.Consensus.Peras.Types (PerasRoundNo (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT import Ouroboros.Consensus.Protocol.ModChainSel diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index 385382e69a..10dec54605 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -22,6 +22,8 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mempool.API import Ouroboros.Consensus.Mempool.TxSeq +import Ouroboros.Consensus.Peras.Params (PerasWeight) +import Ouroboros.Consensus.Peras.Types (PerasRoundNo) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..)) import Ouroboros.Consensus.Storage.ImmutableDB diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index 3bd7376cc3..576e6f8078 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -23,6 +23,8 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert +import Ouroboros.Consensus.Peras.Params (mkPerasParams, perasWeight) +import Ouroboros.Consensus.Peras.Types (PerasRoundNo (..)) import Ouroboros.Consensus.Storage.PerasCertDB.API ( AddPerasCertResult (..) , PerasCertDB diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs index 9f50967421..a5b8ded77c 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs @@ -28,6 +28,14 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote +import Ouroboros.Consensus.Peras.Params (mkPerasParams) +import Ouroboros.Consensus.Peras.Types + ( PerasRoundNo (..) + , PerasVoteId (..) + , PerasVoteStake (..) + , PerasVoteStakeDistr (..) + , PerasVoterId (..) + ) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs index 7c7a4f8525..413a059fd2 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs @@ -20,7 +20,6 @@ import GHC.Generics (Generic) import Ouroboros.Consensus.Block (WithOrigin (..)) import Ouroboros.Consensus.Block.SupportsPeras ( HasPerasCertRound (..) - , PerasRoundNo (..) , getPerasCertRound ) import Ouroboros.Consensus.Peras.Cert.Inclusion @@ -30,11 +29,6 @@ import Ouroboros.Consensus.Peras.Cert.Inclusion , PerasCertInclusionView (..) , needCert ) -import Ouroboros.Consensus.Peras.Params - ( PerasCertMaxRounds (..) - , PerasParams (..) - , mkPerasParams - ) import Ouroboros.Consensus.Util.Pred (Evidence (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs index e7f4608673..b1c4007be2 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs @@ -37,11 +37,6 @@ import Data.Word (Word8) import GHC.Word (Word16) import Ouroboros.Consensus.Block (HeaderHash) import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), toBytes32RealPoint) -import Ouroboros.Consensus.Block.SupportsPeras - ( PerasBoostedBlock (..) - , PerasRoundNo (..) - , PerasSeatIndex (..) - ) import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import Ouroboros.Consensus.Peras.Crypto.BLS @@ -49,6 +44,11 @@ import Ouroboros.Consensus.Peras.Crypto.BLS , VRFOutput (..) , VoteSignature (..) ) +import Ouroboros.Consensus.Peras.Types + ( PerasBoostedBlock (..) + , PerasRoundNo (..) + , PerasSeatIndex (..) + ) import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 import Test.QuickCheck ( Arbitrary (..) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs index d47497cfde..26b7a31986 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs @@ -19,9 +19,7 @@ import Ouroboros.Consensus.Block.Abstract ) import Ouroboros.Consensus.Block.SupportsPeras ( HasPerasCertRound (..) - , PerasRoundNo (..) , getPerasCertRound - , onPerasRoundNo ) import Ouroboros.Consensus.BlockchainTime ( RelativeTime (..) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 155df7f6d8..41357239e3 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -113,6 +113,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Params (PerasWeight (..), mkPerasParams) import Ouroboros.Consensus.Peras.SelectView import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract 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 cbfa12a690..c8bed04b34 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 @@ -125,6 +125,8 @@ import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Peras.Params (PerasWeight (..)) +import Ouroboros.Consensus.Peras.Types (PerasRoundNo (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB hiding ( TraceFollowerEvent (..) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index 25277db826..d307154848 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -28,6 +28,8 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , WithArrivalTime (..) ) +import Ouroboros.Consensus.Peras.Params (mkPerasParams, perasWeight) +import Ouroboros.Consensus.Peras.Types (PerasRoundNo (..)) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import Ouroboros.Consensus.Storage.PerasCertDB.API (AddPerasCertResult (..), PerasCertDB) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs index 04a9e56193..ed20b6c874 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs @@ -27,22 +27,29 @@ import Ouroboros.Consensus.Block.SupportsPeras , HasPerasVoteRound (..) , PerasCert (..) , PerasCfg - , PerasParams (..) - , PerasRoundNo - , PerasVoteId (..) - , PerasVoteStake (..) - , PerasVoteTarget (..) - , PerasVoterId , ValidatedPerasCert (..) , ValidatedPerasVote , getPerasCertBoostedBlock , getPerasVoteStake , getPerasVoteVoterId - , stakeAboveThreshold ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( WithArrivalTime (..) ) +import Ouroboros.Consensus.Peras.Params (PerasParams, perasWeight) +import Ouroboros.Consensus.Peras.Types + ( PerasRoundNo + , PerasVoteId (..) + , PerasVoteStake (..) + , PerasVoteTarget (..) + , PerasVoterId + , ValidatedPerasCert (..) + , ValidatedPerasVote (..) + , perasWeight + , stakeAboveThreshold + ) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Storage.PerasVoteDB.API ( AddPerasVoteResult (..) , PerasVoteTicketNo diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index fe5905eb95..e14344c554 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -44,20 +44,22 @@ import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) , HasPerasVoteBlock (..) , HasPerasVoteRound (..) - , PerasRoundNo (..) , PerasVote (..) - , PerasVoteId - , PerasVoteStake (..) - , PerasVoteTarget (..) - , PerasVoterId (..) , ValidatedPerasCert , ValidatedPerasVote (..) - , mkPerasParams ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , WithArrivalTime (..) ) +import Ouroboros.Consensus.Peras.Params (mkPerasParams) +import Ouroboros.Consensus.Peras.Types + ( PerasRoundNo (..) + , PerasVoteId + , PerasVoteStake (..) + , PerasVoteTarget (..) + , PerasVoterId (..) + ) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB From 1c1833c15083e78cd22d8071e964b26a328a1ac3 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 5 May 2026 15:30:39 +0200 Subject: [PATCH 20/62] Remove PerasCfg type family Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- .../Consensus/Block/SupportsPeras.hs | 33 ++++++----------- .../Consensus/Peras/Vote/Aggregation.hs | 37 ++++++++----------- .../Consensus/Storage/ChainDB/Impl/Args.hs | 2 +- .../Consensus/Storage/PerasVoteDB/Impl.hs | 15 ++++---- .../Test/Util/ChainDB.hs | 2 +- .../Storage/PerasCertDB/StateMachine.hs | 8 ++-- .../Ouroboros/Storage/PerasVoteDB/Model.hs | 3 +- .../Storage/PerasVoteDB/StateMachine.hs | 13 +++---- 8 files changed, 47 insertions(+), 66 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index cd6bee6eed..6d541081f1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -19,7 +19,7 @@ module Ouroboros.Consensus.Block.SupportsPeras , ValidatedPerasVotesWithQuorum ( vpvqTarget , vpvqVotes - , vpvqPerasCfg + , vpvqPerasParams ) , votesReachQuorum , HasPerasCertRound (..) @@ -80,8 +80,8 @@ data ValidatedPerasVotesWithQuorum blk = ValidatedPerasVotesWithQuorum -- ^ The target that all the votes are for , vpvqVotes :: !(NonEmpty (ValidatedPerasVote blk)) -- ^ The votes that reached quorum for the given target - , vpvqPerasCfg :: !(PerasCfg blk) - -- ^ The Peras configuration used to validate that the votes reach quorum + , vpvqPerasParams :: !PerasParams + -- ^ The Peras parameters used to validate that the votes reach quorum } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks @@ -93,10 +93,10 @@ data ValidatedPerasVotesWithQuorum blk = ValidatedPerasVotesWithQuorum -- It returns 'Nothing' if either of these conditions is not met. votesReachQuorum :: StandardHash blk => - PerasCfg blk -> + PerasParams -> [ValidatedPerasVote blk] -> Maybe (ValidatedPerasVotesWithQuorum blk) -votesReachQuorum cfg votes = +votesReachQuorum params votes = case votes of -- We need at least one vote to determine who these votes are for, so we -- can't vacuously reach a quorum, even if the quorum threshold is 0. @@ -113,26 +113,19 @@ votesReachQuorum cfg votes = ValidatedPerasVotesWithQuorum { vpvqTarget = getPerasVoteTarget v0 , vpvqVotes = v0 :| vs - , vpvqPerasCfg = cfg + , vpvqPerasParams = params } where totalVoteStake = mconcat (vpvVoteStake <$> votes) votesHaveEnoughStake = - stakeAboveThreshold cfg totalVoteStake + stakeAboveThreshold params totalVoteStake allVotesMatchTarget target = all ((== (getPerasVoteTarget target)) . getPerasVoteTarget) -- * BlockSupportsPeras class -class - ( Show (PerasCfg blk) - , NoThunks (PerasCert blk) - ) => - BlockSupportsPeras blk - where - type PerasCfg blk - +class BlockSupportsPeras blk where data PerasCert blk data PerasVote blk @@ -142,18 +135,18 @@ class data PerasForgeErr blk validatePerasCert :: - PerasCfg blk -> + PerasParams -> PerasCert blk -> Either (PerasValidationErr blk) (ValidatedPerasCert blk) validatePerasVote :: - PerasCfg blk -> + PerasParams -> PerasVoteStakeDistr -> PerasVote blk -> Either (PerasValidationErr blk) (ValidatedPerasVote blk) forgePerasCert :: - PerasCfg blk -> + PerasParams -> ValidatedPerasVotesWithQuorum blk -> Either (PerasForgeErr blk) (ValidatedPerasCert blk) @@ -167,9 +160,7 @@ class -- TODO: degenerate instance for all blks to get things to compile -- see https://github.com/tweag/cardano-peras/issues/73 -instance StandardHash blk => BlockSupportsPeras blk where - type PerasCfg blk = PerasParams - +instance BlockSupportsPeras blk where data PerasCert blk = PerasCert { pcCertRound :: PerasRoundNo , pcCertBoostedBlock :: Point blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs index 5d2fd20482..be95bcb7ff 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs @@ -46,7 +46,7 @@ -- -- = Quorum Threshold and Multiple Winners -- --- The quorum threshold is parameterized via 'PerasCfg'. Depending on this +-- The quorum threshold is parameterized via 'PerasParams'. Depending on this -- configuration and the stake distribution, it may be theoretically possible -- for multiple targets to exceed the threshold within the same round. -- @@ -98,13 +98,6 @@ import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (WithArrivalTime, forgetArrivalTime) -import Ouroboros.Consensus.Peras.Types - ( PerasRoundNo - , PerasVoteId - , PerasVoteStake (..) - , PerasVoteTarget (..) - , stakeAboveThreshold - ) {------------------------------------------------------------------------------- Voting state for a given Peras round @@ -207,10 +200,10 @@ updatePerasRoundVoteState :: forall blk. StandardHash blk => WithArrivalTime (ValidatedPerasVote blk) -> - PerasCfg blk -> + PerasParams -> PerasRoundVoteState blk -> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk) -updatePerasRoundVoteState vote cfg roundState = +updatePerasRoundVoteState vote params roundState = assert (getPerasVoteRound vote == getPerasVoteRound roundState) $ do case roundState of -- Quorum not yet reached @@ -227,7 +220,7 @@ updatePerasRoundVoteState vote cfg roundState = (getPerasVoteBlock vote) candidateStates candidateOrWinnerState <- - updateCandidateVoteState cfg vote oldCandidateState + updateCandidateVoteState params vote oldCandidateState `onErr` \err -> RoundVoteStateForgingCertError err case candidateOrWinnerState of @@ -301,7 +294,7 @@ updatePerasRoundVoteState vote cfg roundState = fromMaybe (freshLoserVoteState (getPerasVoteTarget vote)) updateMaybeLoserVoteState mState = fmap Just $ - updateLoserVoteState cfg vote (existingOrFreshLoserVoteState mState) + updateLoserVoteState params vote (existingOrFreshLoserVoteState mState) `onErr` \err -> RoundVoteStateLoserAboveQuorum winnerState err loserStates' <- Map.alterF updateMaybeLoserVoteState votePoint loserStates @@ -327,12 +320,12 @@ updatePerasRoundVoteStates :: forall blk. StandardHash blk => WithArrivalTime (ValidatedPerasVote blk) -> - PerasCfg blk -> + PerasParams -> Map PerasRoundNo (PerasRoundVoteState blk) -> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk, Map PerasRoundNo (PerasRoundVoteState blk)) -updatePerasRoundVoteStates vote cfg = +updatePerasRoundVoteStates vote params = alterMapAndReturnUpdatedValue updateMaybePerasRoundVoteState (getPerasVoteRound vote) @@ -365,7 +358,7 @@ updatePerasRoundVoteStates vote cfg = (PerasRoundVoteState blk, PerasRoundVoteState blk) updateMaybePerasRoundVoteState mRoundState = do let roundState = existingOrFreshRoundVoteState mRoundState - newRoundState <- updatePerasRoundVoteState vote cfg roundState + newRoundState <- updatePerasRoundVoteState vote params roundState pure (newRoundState, newRoundState) {------------------------------------------------------------------------------- @@ -575,20 +568,20 @@ data PerasVoteStateCandidateOrWinner blk -- May fail if the candidate is elected winner but forging the certificate fails. updateCandidateVoteState :: StandardHash blk => - PerasCfg blk -> + PerasParams -> WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Candidate -> Either (PerasForgeErr blk) (PerasVoteStateCandidateOrWinner blk) -updateCandidateVoteState cfg vote oldState = +updateCandidateVoteState params vote oldState = let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState) voteList = forgetArrivalTime <$> Map.elems (ptvtVotes newVoteTally) in - case votesReachQuorum cfg voteList of + case votesReachQuorum params voteList of Just votesWithQuorum -> do - cert <- forgePerasCert cfg votesWithQuorum + cert <- forgePerasCert params votesWithQuorum pure $ BecameWinner (PerasTargetVoteWinner newVoteTally cert) Nothing -> do pure $ RemainedCandidate (PerasTargetVoteCandidate newVoteTally) @@ -600,14 +593,14 @@ updateCandidateVoteState cfg vote oldState = -- May fail if the loser goes above quorum by adding the vote. updateLoserVoteState :: StandardHash blk => - PerasCfg blk -> + PerasParams -> WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Loser -> Either (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser) -updateLoserVoteState cfg vote oldState = +updateLoserVoteState params vote oldState = assert (getPerasVoteTarget vote == ptvtTarget (ptvsVoteTally oldState)) $ do let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState) - aboveQuorum = stakeAboveThreshold cfg (ptvtTotalStake newVoteTally) + aboveQuorum = stakeAboveThreshold params (ptvtTotalStake newVoteTally) in if aboveQuorum then Left $ PerasTargetVoteLoser newVoteTally else Right $ PerasTargetVoteLoser newVoteTally diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index 3828af1bf8..a595a690f3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -229,7 +229,7 @@ completeChainDbArgs , cdbPerasVoteDbArgs = PerasVoteDB.PerasVoteDbArgs { PerasVoteDB.pvdbaTracer = PerasVoteDB.pvdbaTracer (cdbPerasVoteDbArgs defArgs) - , PerasVoteDB.pvdbaPerasCfg = mkPerasParams + , PerasVoteDB.pvdbaPerasParams = mkPerasParams } , cdbsArgs = (cdbsArgs defArgs) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index 835e002afd..0b11267ad1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -33,7 +33,6 @@ import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (WithArrivalTime (..)) -import Ouroboros.Consensus.Peras.Types (PerasRoundNo, PerasVoteId (..)) import Ouroboros.Consensus.Peras.Vote.Aggregation import Ouroboros.Consensus.Storage.PerasVoteDB.API import Ouroboros.Consensus.Util.Args @@ -125,14 +124,14 @@ data TraceEvent blk type PerasVoteDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type data PerasVoteDbArgs f m blk = PerasVoteDbArgs { pvdbaTracer :: Tracer m (TraceEvent blk) - , pvdbaPerasCfg :: HKD f (PerasCfg blk) + , pvdbaPerasParams :: HKD f PerasParams } defaultArgs :: Applicative m => Incomplete PerasVoteDbArgs m blk defaultArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer - , pvdbaPerasCfg = noDefault + , pvdbaPerasParams = noDefault } createDB :: @@ -143,7 +142,7 @@ createDB :: ) => Complete PerasVoteDbArgs m blk -> m (PerasVoteDB m blk) -createDB args@PerasVoteDbArgs{pvdbaPerasCfg} = do +createDB args@PerasVoteDbArgs{pvdbaPerasParams} = do pvdeState <- newTVarWithInvariantIO (either Just (const Nothing) . invariantForPerasVoteDbState) @@ -155,7 +154,7 @@ createDB args@PerasVoteDbArgs{pvdbaPerasCfg} = do } pure PerasVoteDB - { addVote = implAddVote pvdbaPerasCfg env + { addVote = implAddVote pvdbaPerasParams env , getVoteIds = implGetVoteIds env , getVotesAfter = implGetVotesAfter env , getForgedCertForRound = implGetForgedCertForRound env @@ -177,11 +176,11 @@ implAddVote :: , StandardHash blk , Typeable blk ) => - PerasCfg blk -> + PerasParams -> PerasVoteDbEnv m blk -> WithArrivalTime (ValidatedPerasVote blk) -> STM m (m (AddPerasVoteResult blk)) -implAddVote perasCfg PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do +implAddVote params PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do let voteId = getPerasVoteId vote addPerasVoteRes <- do WithFingerprint pvds fp <- readTVar pvdeState @@ -206,7 +205,7 @@ implAddVote perasCfg PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do pvsVotesByTicket' = Map.insert pvsLastTicketNo' vote (pvdsVotesByTicket pvds) (addPerasVoteRes, pvsRoundVoteStates') <- - case updatePerasRoundVoteStates vote perasCfg (pvdsRoundVoteStates pvds) of + case updatePerasRoundVoteStates vote params (pvdsRoundVoteStates pvds) of -- Added vote and reached a quorum, forging a new certificate Right (VoteGeneratedNewCert cert, pvsRoundVoteStates') -> pure (AddedPerasVoteAndGeneratedNewCert cert, pvsRoundVoteStates') diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs index da655ce9c8..e64d3de4fb 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -141,7 +141,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs{..} = , cdbPerasVoteDbArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer - , pvdbaPerasCfg = mkPerasParams + , pvdbaPerasParams = mkPerasParams } , cdbsArgs = ChainDbSpecificArgs diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index d307154848..a1930915b2 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -28,7 +28,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , WithArrivalTime (..) ) -import Ouroboros.Consensus.Peras.Params (mkPerasParams, perasWeight) +import Ouroboros.Consensus.Peras.Params (PerasParams, mkPerasParams, perasWeight) import Ouroboros.Consensus.Peras.Types (PerasRoundNo (..)) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB @@ -53,8 +53,8 @@ tests = [ adjustQuickCheckTests (* 100) $ testProperty "q-d" $ prop_qd ] -perasTestCfg :: PerasCfg TestBlock -perasTestCfg = mkPerasParams +perasTestParams :: PerasParams +perasTestParams = mkPerasParams prop_qd :: Actions Model -> Property prop_qd actions = QC.monadic f $ property () <$ runActions actions @@ -97,7 +97,7 @@ instance StateModel Model where { pcCertRound = roundNo , pcCertBoostedBlock = boostedBlock } - , vpcCertBoost = perasWeight perasTestCfg + , vpcCertBoost = perasWeight perasTestParams } pure (AddCert certWithTime) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs index ed20b6c874..1d842c400a 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs @@ -26,7 +26,6 @@ import Ouroboros.Consensus.Block.SupportsPeras ( HasPerasVoteBlock (..) , HasPerasVoteRound (..) , PerasCert (..) - , PerasCfg , ValidatedPerasCert (..) , ValidatedPerasVote , getPerasCertBoostedBlock @@ -86,7 +85,7 @@ data Model blk = Model instance StandardHash blk => ToExpr (Model blk) where toExpr = defaultExprViaShow -initModel :: PerasCfg blk -> Model blk +initModel :: PerasParams -> Model blk initModel cfg = Model { open = False diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index e14344c554..7949370bbd 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -41,8 +41,7 @@ import Data.Word (Word64) import GHC.Generics (Generic) import Ouroboros.Consensus.Block.Abstract (Point (..), SlotNo (..)) import Ouroboros.Consensus.Block.SupportsPeras - ( BlockSupportsPeras (..) - , HasPerasVoteBlock (..) + ( HasPerasVoteBlock (..) , HasPerasVoteRound (..) , PerasVote (..) , ValidatedPerasCert @@ -52,7 +51,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , WithArrivalTime (..) ) -import Ouroboros.Consensus.Peras.Params (mkPerasParams) +import Ouroboros.Consensus.Peras.Params (PerasParams, mkPerasParams) import Ouroboros.Consensus.Peras.Types ( PerasRoundNo (..) , PerasVoteId @@ -106,8 +105,8 @@ tests = prop_qd ] -perasTestCfg :: PerasCfg TestBlock -perasTestCfg = mkPerasParams +perasTestParams :: PerasParams +perasTestParams = mkPerasParams prop_qd :: Actions Model -> Property prop_qd actions = monadic runActualImplemMonad resultAsPropertyM @@ -236,7 +235,7 @@ instance StateModel Model where pure (RelativeTime time) initialState = - Model (Model.initModel perasTestCfg) + Model (Model.initModel perasTestParams) nextState (Model m) action _ = case action of @@ -266,7 +265,7 @@ instance RunModel Model (StateT (PerasVoteDB IO TestBlock) IO) where perform _ action _ = case action of CreateDB -> do - let args = PerasVoteDB.PerasVoteDbArgs nullTracer perasTestCfg + let args = PerasVoteDB.PerasVoteDbArgs nullTracer perasTestParams voteDB <- lift $ PerasVoteDB.createDB args put voteDB AddVote vote -> do From 9b44840f90b7938ee36bf099c2845e135910d3c2 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Fri, 8 May 2026 12:40:02 +0200 Subject: [PATCH 21/62] Consolidate Peras vote and certificate projection type classes Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- .../Consensus/Block/SupportsPeras.hs | 329 +++++++----------- .../ObjectDiffusion/ObjectPool/PerasCert.hs | 4 +- .../ObjectDiffusion/ObjectPool/PerasVote.hs | 4 +- .../Ouroboros/Consensus/Node/Serialisation.hs | 6 +- .../Consensus/Peras/Cert/Inclusion.hs | 17 +- .../Ouroboros/Consensus/Peras/Types.hs | 20 +- .../Consensus/Peras/Vote/Aggregation.hs | 33 +- .../Ouroboros/Consensus/Peras/Voting/Rules.hs | 21 +- .../Ouroboros/Consensus/Peras/Voting/View.hs | 7 +- .../Storage/ChainDB/Impl/Background.hs | 2 +- .../Storage/ChainDB/Impl/ChainSel.hs | 2 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 5 +- .../Consensus/Storage/PerasCertDB/API.hs | 2 +- .../Consensus/Storage/PerasCertDB/Impl.hs | 4 +- .../Consensus/Storage/PerasVoteDB/API.hs | 2 + .../Consensus/Storage/PerasVoteDB/Impl.hs | 13 +- .../ObjectDiffusion/PerasCert/Smoke.hs | 4 +- .../Test/Consensus/Peras/Cert/Inclusion.hs | 27 +- .../Test/Consensus/Peras/Voting/Rules.hs | 20 +- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 4 +- .../Ouroboros/Storage/PerasCertDB/Model.hs | 6 +- .../Storage/PerasCertDB/StateMachine.hs | 8 +- .../Ouroboros/Storage/PerasVoteDB/Model.hs | 17 +- .../Storage/PerasVoteDB/StateMachine.hs | 3 +- 24 files changed, 241 insertions(+), 319 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 6d541081f1..e1157c2b93 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -14,6 +14,10 @@ module Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) , PerasCert (..) , PerasVote (..) + , IsPerasVote (..) + , getPerasVoteId + , getPerasVoteTarget + , IsPerasCert (..) , ValidatedPerasCert (..) , ValidatedPerasVote (..) , ValidatedPerasVotesWithQuorum @@ -22,15 +26,6 @@ module Ouroboros.Consensus.Block.SupportsPeras , vpvqPerasParams ) , votesReachQuorum - , HasPerasCertRound (..) - , HasPerasCertBoostedBlock (..) - , HasPerasCertBoost (..) - , HasPerasVoteRound (..) - , HasPerasVoteBlock (..) - , HasPerasVoteVoterId (..) - , HasPerasVoteStake (..) - , HasPerasVoteTarget (..) - , HasPerasVoteId (..) ) where import Cardano.Binary (FromCBOR (..), ToCBOR (..)) @@ -56,76 +51,14 @@ import Ouroboros.Consensus.Peras.Types ) import Ouroboros.Consensus.Util (ShowProxy (..)) --- * Validated types - -data ValidatedPerasCert blk = ValidatedPerasCert - { vpcCert :: !(PerasCert blk) - , vpcCertBoost :: !PerasWeight - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass NoThunks - -data ValidatedPerasVote blk = ValidatedPerasVote - { vpvVote :: !(PerasVote blk) - , vpvVoteStake :: !PerasVoteStake - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass NoThunks - --- | A collection of validated Peras votes that: --- 1. are all for the same target, and --- 2. have total stake above the quorum threshold for a given 'PerasCfg'. -data ValidatedPerasVotesWithQuorum blk = ValidatedPerasVotesWithQuorum - { vpvqTarget :: !(PerasVoteTarget blk) - -- ^ The target that all the votes are for - , vpvqVotes :: !(NonEmpty (ValidatedPerasVote blk)) - -- ^ The votes that reached quorum for the given target - , vpvqPerasParams :: !PerasParams - -- ^ The Peras parameters used to validate that the votes reach quorum - } - deriving stock (Show, Eq, Generic) - deriving anyclass NoThunks - --- | Smart constructor for 'ValidatedPerasVotesReachingQuorum'. --- --- This function checks that all votes are for the same target, and that their --- total stake is above the quorum threshold defined in the given 'PerasCfg'. --- It returns 'Nothing' if either of these conditions is not met. -votesReachQuorum :: - StandardHash blk => - PerasParams -> - [ValidatedPerasVote blk] -> - Maybe (ValidatedPerasVotesWithQuorum blk) -votesReachQuorum params votes = - case votes of - -- We need at least one vote to determine who these votes are for, so we - -- can't vacuously reach a quorum, even if the quorum threshold is 0. - [] -> Nothing - -- If we have at least one vote, we must check that all votes are for the - -- same target, and that their total stake of is above the quorum threshold. - (v0 : vs) - | not (allVotesMatchTarget v0 vs) -> - Nothing - | not votesHaveEnoughStake -> - Nothing - | otherwise -> - Just - ValidatedPerasVotesWithQuorum - { vpvqTarget = getPerasVoteTarget v0 - , vpvqVotes = v0 :| vs - , vpvqPerasParams = params - } - where - totalVoteStake = - mconcat (vpvVoteStake <$> votes) - votesHaveEnoughStake = - stakeAboveThreshold params totalVoteStake - allVotesMatchTarget target = - all ((== (getPerasVoteTarget target)) . getPerasVoteTarget) - -- * BlockSupportsPeras class -class BlockSupportsPeras blk where +class + ( IsPerasVote (PerasVote blk) blk + , IsPerasCert (PerasCert blk) blk + ) => + BlockSupportsPeras blk + where data PerasCert blk data PerasVote blk @@ -163,7 +96,7 @@ class BlockSupportsPeras blk where instance BlockSupportsPeras blk where data PerasCert blk = PerasCert { pcCertRound :: PerasRoundNo - , pcCertBoostedBlock :: Point blk + , pcCertBlock :: Point blk } deriving stock (Generic, Eq, Ord, Show) deriving anyclass NoThunks @@ -220,7 +153,7 @@ instance BlockSupportsPeras blk where { vpcCert = PerasCert { pcCertRound = pvtRoundNo (vpvqTarget votes) - , pcCertBoostedBlock = pvtBlock (vpvqTarget votes) + , pcCertBlock = pvtBlock (vpvqTarget votes) } , vpcCertBoost = perasWeight params } @@ -236,15 +169,15 @@ instance ShowProxy blk => ShowProxy (PerasVote blk) where showProxy _ = "PerasVote " <> showProxy (Proxy @blk) instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where - encode PerasCert{pcCertRound, pcCertBoostedBlock} = + encode PerasCert{pcCertRound, pcCertBlock} = encodeListLen 2 <> encode pcCertRound - <> encode pcCertBoostedBlock + <> encode pcCertBlock decode = do decodeListLenOf 2 pcCertRound <- decode - pcCertBoostedBlock <- decode - pure $ PerasCert{pcCertRound, pcCertBoostedBlock} + pcCertBlock <- decode + pure $ PerasCert{pcCertRound, pcCertBlock} instance Serialise (HeaderHash blk) => Serialise (PerasVote blk) where encode PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} = @@ -259,148 +192,128 @@ instance Serialise (HeaderHash blk) => Serialise (PerasVote blk) where pvVoteVoterId <- PerasVoterId <$> fromCBOR pure $ PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} --- | Extract the certificate round from a Peras certificate container -class HasPerasCertRound cert where - getPerasCertRound :: cert -> PerasRoundNo - -instance HasPerasCertRound (PerasCert blk) where - getPerasCertRound = pcCertRound - -instance HasPerasCertRound (ValidatedPerasCert blk) where - getPerasCertRound = getPerasCertRound . vpcCert - -instance - HasPerasCertRound cert => - HasPerasCertRound (WithArrivalTime cert) - where - getPerasCertRound = getPerasCertRound . forgetArrivalTime - --- | Extract the boosted block point from a Peras certificate container -class HasPerasCertBoostedBlock cert blk | cert -> blk where - getPerasCertBoostedBlock :: cert -> Point blk - -instance HasPerasCertBoostedBlock (PerasCert blk) blk where - getPerasCertBoostedBlock = pcCertBoostedBlock +-- * Validated types -instance HasPerasCertBoostedBlock (ValidatedPerasCert blk) blk where - getPerasCertBoostedBlock = getPerasCertBoostedBlock . vpcCert +data ValidatedPerasVote blk + = ValidatedPerasVote + { vpvVote :: !(PerasVote blk) + , vpvVoteStake :: !PerasVoteStake + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks -instance - HasPerasCertBoostedBlock cert blk => - HasPerasCertBoostedBlock (WithArrivalTime cert) blk - where - getPerasCertBoostedBlock = getPerasCertBoostedBlock . forgetArrivalTime +data ValidatedPerasCert blk + = ValidatedPerasCert + { vpcCert :: !(PerasCert blk) + , vpcCertBoost :: !PerasWeight + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks --- | Extract the certificate boost from a Peras certificate container -class HasPerasCertBoost cert where - getPerasCertBoost :: cert -> PerasWeight +-- | A collection of validated Peras votes that: +-- 1. are all for the same target, and +-- 2. have total stake above the quorum threshold for a given 'PerasCfg'. +data ValidatedPerasVotesWithQuorum blk + = ValidatedPerasVotesWithQuorum + { vpvqTarget :: !(PerasVoteTarget blk) + -- ^ The target that all the votes are for + , vpvqVotes :: !(NonEmpty (ValidatedPerasVote blk)) + -- ^ The votes that reached quorum for the given target + , vpvqPerasParams :: !PerasParams + -- ^ The Peras parameters used to validate that the votes reach quorum + } + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks -instance HasPerasCertBoost (ValidatedPerasCert blk) where - getPerasCertBoost = vpcCertBoost +-- | Smart constructor for 'ValidatedPerasVotesReachingQuorum'. +-- +-- This function checks that all votes are for the same target, and that their +-- total stake is above the quorum threshold defined in the given 'PerasCfg'. +-- It returns 'Nothing' if either of these conditions is not met. +votesReachQuorum :: + StandardHash blk => + PerasParams -> + [ValidatedPerasVote blk] -> + Maybe (ValidatedPerasVotesWithQuorum blk) +votesReachQuorum params votes = + case votes of + -- We need at least one vote to determine who these votes are for, so we + -- can't vacuously reach a quorum, even if the quorum threshold is 0. + [] -> Nothing + -- If we have at least one vote, we must check that all votes are for the + -- same target, and that their total stake of is above the quorum threshold. + (v0 : vs) + | not (allVotesMatchTarget v0 vs) -> + Nothing + | not votesHaveEnoughStake -> + Nothing + | otherwise -> + Just + ValidatedPerasVotesWithQuorum + { vpvqTarget = getPerasVoteTarget v0 + , vpvqVotes = v0 :| vs + , vpvqPerasParams = params + } + where + totalVoteStake = + mconcat (vpvVoteStake <$> votes) + votesHaveEnoughStake = + stakeAboveThreshold params totalVoteStake + allVotesMatchTarget target = + all ((== (getPerasVoteTarget target)) . getPerasVoteTarget) -instance - HasPerasCertBoost cert => - HasPerasCertBoost (WithArrivalTime cert) - where - getPerasCertBoost = getPerasCertBoost . forgetArrivalTime +-- * Convenience projection classes --- | Extract the vote round from a Peras vote container -class HasPerasVoteRound vote where +-- | Types that support being treated as Peras votes +class IsPerasVote vote blk | vote -> blk where getPerasVoteRound :: vote -> PerasRoundNo - -instance HasPerasVoteRound (PerasVote blk) where - getPerasVoteRound = pvVoteRound - -instance HasPerasVoteRound (ValidatedPerasVote blk) where - getPerasVoteRound = getPerasVoteRound . vpvVote - -instance - HasPerasVoteRound vote => - HasPerasVoteRound (WithArrivalTime vote) - where - getPerasVoteRound = getPerasVoteRound . forgetArrivalTime - --- | Extract the vote block point from a Peras vote container -class HasPerasVoteBlock vote blk | vote -> blk where getPerasVoteBlock :: vote -> Point blk + getPerasVoteVoterId :: vote -> PerasVoterId -instance HasPerasVoteBlock (PerasVote blk) blk where - getPerasVoteBlock = pvVoteBlock - -instance HasPerasVoteBlock (ValidatedPerasVote blk) blk where - getPerasVoteBlock = getPerasVoteBlock . vpvVote - -instance - HasPerasVoteBlock vote blk => - HasPerasVoteBlock (WithArrivalTime vote) blk - where - getPerasVoteBlock = getPerasVoteBlock . forgetArrivalTime +-- | Extract the vote ID from a Peras vote container +getPerasVoteId :: IsPerasVote vote blk => vote -> PerasVoteId blk +getPerasVoteId vote = + PerasVoteId + { pviRoundNo = getPerasVoteRound vote + , pviVoterId = getPerasVoteVoterId vote + } --- | Extract the stake pool ID from a Peras vote container -class HasPerasVoteVoterId vote where - getPerasVoteVoterId :: vote -> PerasVoterId +-- | Extract the vote target from a Peras vote container +getPerasVoteTarget :: IsPerasVote vote blk => vote -> PerasVoteTarget blk +getPerasVoteTarget vote = + PerasVoteTarget + { pvtRoundNo = getPerasVoteRound vote + , pvtBlock = getPerasVoteBlock vote + } -instance HasPerasVoteVoterId (PerasVote blk) where +instance IsPerasVote (PerasVote blk) blk where + getPerasVoteRound = pvVoteRound + getPerasVoteBlock = pvVoteBlock getPerasVoteVoterId = pvVoteVoterId -instance HasPerasVoteVoterId (ValidatedPerasVote blk) where +instance IsPerasVote (ValidatedPerasVote blk) blk where + getPerasVoteRound = getPerasVoteRound . vpvVote + getPerasVoteBlock = getPerasVoteBlock . vpvVote getPerasVoteVoterId = getPerasVoteVoterId . vpvVote -instance - HasPerasVoteVoterId vote => - HasPerasVoteVoterId (WithArrivalTime vote) - where +instance IsPerasVote vote blk => IsPerasVote (WithArrivalTime vote) blk where + getPerasVoteRound = getPerasVoteRound . forgetArrivalTime + getPerasVoteBlock = getPerasVoteBlock . forgetArrivalTime getPerasVoteVoterId = getPerasVoteVoterId . forgetArrivalTime --- | Extract the vote stake from a validated Peras vote container -class HasPerasVoteStake vote where - getPerasVoteStake :: vote -> PerasVoteStake - -instance HasPerasVoteStake (ValidatedPerasVote blk) where - getPerasVoteStake = vpvVoteStake +-- | Types that support being treated as Peras certificates +class IsPerasCert cert blk | cert -> blk where + getPerasCertRound :: cert -> PerasRoundNo + getPerasCertBlock :: cert -> Point blk -instance - HasPerasVoteStake vote => - HasPerasVoteStake (WithArrivalTime vote) - where - getPerasVoteStake = getPerasVoteStake . forgetArrivalTime +instance IsPerasCert (PerasCert blk) blk where + getPerasCertRound = pcCertRound + getPerasCertBlock = pcCertBlock --- | Extract the vote target from a Peras vote container -class HasPerasVoteTarget vote blk | vote -> blk where - getPerasVoteTarget :: vote -> PerasVoteTarget blk - -instance HasPerasVoteTarget (PerasVote blk) blk where - getPerasVoteTarget vote = - PerasVoteTarget - { pvtRoundNo = pvVoteRound vote - , pvtBlock = pvVoteBlock vote - } - -instance HasPerasVoteTarget (ValidatedPerasVote blk) blk where - getPerasVoteTarget = getPerasVoteTarget . vpvVote - -instance - HasPerasVoteTarget vote blk => - HasPerasVoteTarget (WithArrivalTime vote) blk - where - getPerasVoteTarget = getPerasVoteTarget . forgetArrivalTime +instance IsPerasCert (ValidatedPerasCert blk) blk where + getPerasCertRound = getPerasCertRound . vpcCert + getPerasCertBlock = getPerasCertBlock . vpcCert --- | Extract the vote ID from a Peras vote container -class HasPerasVoteId vote blk | vote -> blk where - getPerasVoteId :: vote -> PerasVoteId blk - -instance HasPerasVoteId (PerasVote blk) blk where - getPerasVoteId vote = - PerasVoteId - { pviRoundNo = pvVoteRound vote - , pviVoterId = pvVoteVoterId vote - } - -instance HasPerasVoteId (ValidatedPerasVote blk) blk where - getPerasVoteId = getPerasVoteId . vpvVote - -instance - HasPerasVoteId vote blk => - HasPerasVoteId (WithArrivalTime vote) blk - where - getPerasVoteId = getPerasVoteId . forgetArrivalTime +instance IsPerasCert cert blk => IsPerasCert (WithArrivalTime cert) blk where + getPerasCertRound = getPerasCertRound . forgetArrivalTime + getPerasCertBlock = getPerasCertBlock . forgetArrivalTime diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index 5051818331..88a6517124 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -89,7 +89,7 @@ makePerasCertPoolReaderFromChainDB chainDB = -- see 'makePerasCertPoolWriterFromChainDB' which creates a pool writer from the -- 'ChainDB' with proper handling of chain selection side-effects. makePerasCertPoolWriterFromCertDB :: - (StandardHash blk, IOLike m) => + IOLike m => SystemTime m -> PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m @@ -111,7 +111,7 @@ makePerasCertPoolWriterFromCertDB systemTime perasCertDB = -- | Create a pool writer from the 'ChainDB'. This properly handles any needed -- chain selection side-effects. makePerasCertPoolWriterFromChainDB :: - (StandardHash blk, IOLike m) => + IOLike m => SystemTime m -> ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs index b565cc3239..5ae493e3a0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs @@ -90,7 +90,7 @@ makePerasVotePoolReaderFromChainDB chainDB = -- see 'makePerasVotePoolWriterFromChainDB' which creates a pool writer from the -- 'ChainDB' and thus properly handles the produced certs. makePerasVotePoolWriterFromVoteDB :: - (StandardHash blk, IOLike m) => + IOLike m => SystemTime m -> -- | This is needed for validating votes (since it is during the validation of -- votes that we give them a verified weight. In the future, we won't read it @@ -120,7 +120,7 @@ makePerasVotePoolWriterFromVoteDB systemTime getStakeDistrSTM perasVoteDB = -- This properly handles the produced certs by letting the ChainDB take care -- of them (see 'ChainDB.addPerasVoteWithAsyncCertHandling'). makePerasVotePoolWriterFromChainDB :: - (StandardHash blk, IOLike m) => + IOLike m => SystemTime m -> -- | This is needed for validating votes (since its during the validation of -- votes that we give them a verified weight. In the future, we won't read it diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs index a218642e50..2b36fc2f10 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs @@ -202,12 +202,12 @@ instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where encodeNodeToNode ccfg version PerasCert{..} = encodeListLen 2 <> encodeNodeToNode ccfg version pcCertRound - <> encodeNodeToNode ccfg version pcCertBoostedBlock + <> encodeNodeToNode ccfg version pcCertBlock decodeNodeToNode ccfg version = do decodeListLenOf 2 pcCertRound <- decodeNodeToNode ccfg version - pcCertBoostedBlock <- decodeNodeToNode ccfg version - pure $ PerasCert pcCertRound pcCertBoostedBlock + pcCertBlock <- decodeNodeToNode ccfg version + pure $ PerasCert pcCertRound pcCertBlock instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasVote blk) where -- Consistent with the 'Serialise' instance for 'PerasVote' defined in Ouroboros.Consensus.Block.SupportsPeras diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs index 64504ef821..55cb5266fa 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} -- | This module defines the logic needed to evaluate when a Peras certificate -- must be included in a block. @@ -25,10 +26,14 @@ module Ouroboros.Consensus.Peras.Cert.Inclusion import Data.Set (Set) import qualified Data.Set as Set -import Ouroboros.Consensus.Block (WithOrigin (..), withOriginToMaybe) -import Ouroboros.Consensus.Block.SupportsPeras (HasPerasCertRound (..)) -import Ouroboros.Consensus.Peras.Params (PerasCertMaxRounds (..), PerasParams (..)) -import Ouroboros.Consensus.Peras.Types (PerasRoundNo (..)) +import Ouroboros.Consensus.Block + ( IsPerasCert (..) + , PerasCertMaxRounds (..) + , PerasParams (..) + , PerasRoundNo (..) + , WithOrigin (..) + , withOriginToMaybe + ) import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.Pred ( Evidence (..) @@ -85,7 +90,7 @@ data PerasCertInclusionView cert blk = PerasCertInclusionView -- within the same STM transaction, or the results may be inconsistent. mkPerasCertInclusionView :: forall cert blk. - HasPerasCertRound cert => + IsPerasCert cert blk => -- | Peras protocol parameters PerasParams -> -- | Current Peras round number @@ -144,7 +149,7 @@ data PerasCertInclusionRulesDecision cert deriving Show instance - HasPerasCertRound cert => + IsPerasCert cert blk => Explainable (PerasCertInclusionRulesDecision cert) where explain mode = \case diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs index 8258bb2a3d..dd38e82ce3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -58,7 +58,10 @@ import Quiet (Quiet (..)) -- ** Round numbers -newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} +newtype PerasRoundNo + = PerasRoundNo + { unPerasRoundNo :: Word64 + } deriving Show via Quiet PerasRoundNo deriving stock Generic deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise, NFData, ToCBOR, FromCBOR) @@ -106,7 +109,8 @@ newtype PerasSeatIndex -- ** Vote parameters -- | The target of a vote in a Peras election -data PerasVoteTarget blk = PerasVoteTarget +data PerasVoteTarget blk + = PerasVoteTarget { pvtRoundNo :: !PerasRoundNo , pvtBlock :: !(Point blk) } @@ -114,7 +118,8 @@ data PerasVoteTarget blk = PerasVoteTarget deriving anyclass NoThunks -- | The identifier of a vote in a Peras election -data PerasVoteId blk = PerasVoteId +data PerasVoteId blk + = PerasVoteId { pviRoundNo :: !PerasRoundNo , pviVoterId :: !PerasVoterId } @@ -143,7 +148,8 @@ instance Serialise (PerasVoteId blk) where -- So, for now you can consider this 'Rational' as the best approximation we -- have at the moment of the concrete type for a relative vote stake that can be -- compared to the quorum threshold value (also currently a 'Rational'). -newtype PerasVoteStake = PerasVoteStake +newtype PerasVoteStake + = PerasVoteStake { unPerasVoteStake :: Rational } deriving newtype (Eq, Ord, Num, Fractional, NoThunks, NFData, Serialise) @@ -177,7 +183,8 @@ stakeAboveThreshold params voteStake = -- ** Voting stake distributions -- | The identifier of a voter in a Peras election -newtype PerasVoterId = PerasVoterId +newtype PerasVoterId + = PerasVoterId { unPerasVoterId :: KeyHash StakePool } deriving newtype NoThunks @@ -185,7 +192,8 @@ newtype PerasVoterId = PerasVoterId deriving Show via Quiet PerasVoterId -- | Voting stake distribution for a Peras election -newtype PerasVoteStakeDistr = PerasVoteStakeDistr +newtype PerasVoteStakeDistr + = PerasVoteStakeDistr { unPerasVoteStakeDistr :: Map PerasVoterId PerasVoteStake } deriving newtype NoThunks diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs index be95bcb7ff..8b4d66cfa3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs @@ -79,13 +79,16 @@ -- freshly forged (as opposed to voting on an already-won target). module Ouroboros.Consensus.Peras.Vote.Aggregation ( PerasRoundVoteState - , ptvsTotalStake + , getPerasRoundVoteStateRound + , getPerasRoundVoteStateCertMaybe + , getPerasRoundVoteStateMaxTargetedSlot , pattern VoteGeneratedNewCert , pattern VoteDidntGenerateNewCert , updatePerasRoundVoteStates - , getPerasRoundVoteStateCertMaybe - , getPerasRoundVoteStateMaxTargetedSlot , UpdateRoundVoteStateError (..) + , PerasTargetVoteState + , getPerasTargetVoteStateTotalStake + , getPerasTargetVoteStateBlock ) where import Cardano.Prelude (fromMaybe) @@ -111,9 +114,6 @@ data PerasRoundVoteState blk = PerasRoundVoteState deriving stock (Generic, Eq, Show) deriving anyclass NoThunks -instance HasPerasVoteRound (PerasRoundVoteState blk) where - getPerasVoteRound = prvsRoundNo - -- | Current vote state when a quorum has not yet been reached data NoQuorum blk = NoQuorum { candidateStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Candidate)) @@ -130,6 +130,10 @@ data Quorum blk = Quorum deriving stock (Generic, Eq, Show) deriving anyclass NoThunks +-- | Get the round number of a round vote state +getPerasRoundVoteStateRound :: PerasRoundVoteState blk -> PerasRoundNo +getPerasRoundVoteStateRound = prvsRoundNo + -- | Get the certificate if quorum was reached for the given round getPerasRoundVoteStateCertMaybe :: PerasRoundVoteState blk -> @@ -161,7 +165,7 @@ getPerasRoundVoteStateMaxTargetedSlot PerasRoundVoteState{prvsState} = maximumOrOrigin $ map pointSlot $ Map.keys candidateStates Right Quorum{winnerState, loserStates} -> maximumOrOrigin $ - pointSlot (getPerasVoteBlock winnerState) + pointSlot (getPerasTargetVoteStateBlock winnerState) : (pointSlot <$> Map.keys loserStates) where maximumOrOrigin [] = Origin @@ -204,7 +208,7 @@ updatePerasRoundVoteState :: PerasRoundVoteState blk -> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk) updatePerasRoundVoteState vote params roundState = - assert (getPerasVoteRound vote == getPerasVoteRound roundState) $ do + assert (getPerasVoteRound vote == getPerasRoundVoteStateRound roundState) $ do case roundState of -- Quorum not yet reached state@PerasRoundVoteState @@ -522,11 +526,13 @@ instance noThunks ctx (PerasTargetVoteWinner tally cert) = noThunks ctx (tally, cert) -instance HasPerasVoteRound (PerasTargetVoteState blk status) where - getPerasVoteRound = pvtRoundNo . ptvtTarget . ptvsVoteTally +-- | Extract the total stake from a target vote state +getPerasTargetVoteStateTotalStake :: PerasTargetVoteState blk status -> PerasVoteStake +getPerasTargetVoteStateTotalStake = ptvtTotalStake . ptvsVoteTally -instance HasPerasVoteBlock (PerasTargetVoteState blk status) blk where - getPerasVoteBlock = pvtBlock . ptvtTarget . ptvsVoteTally +-- | Extract the block point from a target vote state +getPerasTargetVoteStateBlock :: PerasTargetVoteState blk status -> Point blk +getPerasTargetVoteStateBlock = pvtBlock . ptvtTarget . ptvsVoteTally -- | Extract the underlying vote tally from a target vote state ptvsVoteTally :: PerasTargetVoteState blk status -> PerasTargetVoteTally blk @@ -535,9 +541,6 @@ ptvsVoteTally = \case PerasTargetVoteLoser tally -> tally PerasTargetVoteWinner tally _ -> tally --- | Extract the total stake from a target vote state -ptvsTotalStake :: PerasTargetVoteState blk status -> PerasVoteStake -ptvsTotalStake = ptvtTotalStake . ptvsVoteTally freshCandidateVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Candidate freshCandidateVoteState target = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs index d74113a3f5..59168bbcd0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs @@ -33,11 +33,8 @@ import Ouroboros.Consensus.Block.Abstract ( SlotNo (..) ) import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasCertRound (..) - , getPerasCertRound - ) -import Ouroboros.Consensus.Peras.Params - ( PerasCertArrivalThreshold (..) + ( IsPerasCert (..) + , PerasCertArrivalThreshold (..) , PerasCooldownRounds (..) , PerasIgnoranceRounds (..) , PerasParams (..) @@ -74,7 +71,7 @@ instance Explainable PerasVotingRulesDecision where -- | Evaluate whether voting is allowed or not according to the voting rules isPerasVotingAllowed :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> PerasVotingRulesDecision isPerasVotingAllowed pvv = @@ -125,7 +122,7 @@ instance Explainable PerasVotingRule where -- | VR-1A: the voter has seen the certificate for the previous round, and the -- certificate was received in the first X slots after the start of the round. perasVR1A :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVR1A @@ -188,7 +185,7 @@ perasVR1B -- This enforces the chain-healing period that must occur before leaving a -- cooldown period. perasVR2A :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVR2A @@ -221,7 +218,7 @@ perasVR2A -- This enforces chain quality and common prefix before leaving a cooldown -- period. perasVR2B :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVR2B @@ -265,7 +262,7 @@ perasVR2B -- | Both VR-1A and VR-1B hold, which is the situation typically occurring when -- the voting has regularly occurred in preceding rounds. perasVR1 :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVR1 pvv = @@ -274,7 +271,7 @@ perasVR1 pvv = -- | Both VR-2A and VR-2B hold, which is the situation typically occurring when -- the chain is about to exit a cooldown period. perasVR2 :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVR2 pvv = @@ -282,7 +279,7 @@ perasVR2 pvv = -- | Voting is allowed if either VR-1A and VR-1B hold, or VR-2A and VR-2B hold. perasVotingRules :: - HasPerasCertRound cert => + IsPerasCert cert blk => PerasVotingView cert -> Pred PerasVotingRule perasVotingRules pvv = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs index 0d12bef2a3..d762574af7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs @@ -42,10 +42,7 @@ import Ouroboros.Consensus.Block.Abstract , castPoint ) import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasCertRound (..) - , ValidatedPerasCert - , getPerasCertBoostedBlock - , getPerasCertRound + ( ValidatedPerasCert, IsPerasCert (..) ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( WithArrivalTime (..) @@ -291,5 +288,5 @@ mkPerasVotingView -- Check whether the boosted block is within the volatile fragment leading -- to the candidate block. AF.withinFragmentBounds - (castPoint (getPerasCertBoostedBlock cert)) + (castPoint (getPerasCertBlock cert)) chainAtCandidateBlock 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 2118a9a06d..817c8137e2 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 @@ -615,7 +615,7 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do ChainSelAddPerasCert cert _varProcessed -> traceWith cdbTracer $ TraceAddPerasCertEvent $ - PoppedPerasCertFromQueue (getPerasCertRound cert) (getPerasCertBoostedBlock cert) + PoppedPerasCertFromQueue (getPerasCertRound cert) (getPerasCertBlock cert) chainSelSync cdb message lift $ atomically $ processedChainSelMessage cdbChainSelQueue message ) 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 0369cd7fec..9dfa1ca4c2 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 @@ -535,7 +535,7 @@ chainSelSync cdb@CDB{..} (ChainSelAddPerasCert cert varProcessed) = do certRound = getPerasCertRound cert boostedBlock :: Point blk - boostedBlock = getPerasCertBoostedBlock cert + boostedBlock = getPerasCertBlock cert -- | Return 'True' when the given header should be ignored when adding it -- because it is too old, i.e., we wouldn't be able to switch to a chain diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 2f15c44679..def5127dea 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -654,7 +654,10 @@ addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do { waitPerasCertProcessed = atomically $ readTMVar varProcessed } where - addedToQueue = AddedPerasCertToQueue (getPerasCertRound cert) (getPerasCertBoostedBlock cert) + addedToQueue = + AddedPerasCertToQueue + (getPerasCertRound cert) + (getPerasCertBlock cert) -- | Try to add blocks again that were postponed due to the LoE. addReprocessLoEBlocks :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs index 339190fda3..963890c5bf 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -169,7 +169,7 @@ prop_garbageCollectRemovesOldCerts db slotNo = do _ <- garbageCollect db slotNo getCertsAfter db zeroPerasCertTicketNo allCertValues <- sequence (Map.elems allCertActions) - let targetSlots = pointSlot . getPerasCertBoostedBlock . forgetArrivalTime <$> allCertValues + let targetSlots = pointSlot . getPerasCertBlock . forgetArrivalTime <$> allCertValues pure $ all (>= NotOrigin slotNo) targetSlots diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index 2a859ffd57..c828a58034 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -208,7 +208,7 @@ implGetWeightSnapshot PerasCertDbEnv{pcdbState} = do WithFingerprint pcds fp <- readTVar pcdbState let weights = mkPerasWeightSnapshot - [ (getPerasCertBoostedBlock cert, getPerasCertBoost cert) + [ (getPerasCertBlock cert, vpcCertBoost (forgetArrivalTime cert)) | cert <- Map.elems (pcdsCertsByTicket pcds) ] pure (WithFingerprint weights fp) @@ -263,7 +263,7 @@ implGarbageCollect PerasCertDbEnv{pcdbTracer, pcdbState} slotNo = do } = let pcdsCertsByTicket' = Map.filter - (\cert -> pointSlot (getPerasCertBoostedBlock cert) >= NotOrigin slotNo) + (\cert -> pointSlot (getPerasCertBlock cert) >= NotOrigin slotNo) pcdsCertsByTicket pcdsCertIds' = Set.fromList (getPerasCertRound <$> Map.elems pcdsCertsByTicket') diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs index 319c01a6a8..f1a4b95765 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs @@ -2,6 +2,8 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index 0b11267ad1..4c1ffd425a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -80,7 +80,10 @@ invariantForPerasVoteDbState :: WithFingerprint (PerasVoteDbState blk) -> Either String () invariantForPerasVoteDbState pvs = do for_ (Map.toList pvdsRoundVoteStates) $ \(roundNo, prvs) -> - checkEqual "pvcRoundVoteStates rounds" roundNo (getPerasVoteRound prvs) + checkEqual + "pvcRoundVoteStates rounds" + roundNo + (getPerasRoundVoteStateRound prvs) checkEqual "pvcsVotesByTicket" (Set.fromList (getPerasVoteRound <$> Map.elems pvdsVotesByTicket)) @@ -221,13 +224,13 @@ implAddVote params PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do MultipleWinnersInRound (getPerasVoteRound vote) ( ExistingPerasRoundWinner - ( getPerasVoteBlock winnerState - , ptvsTotalStake winnerState + ( getPerasTargetVoteStateBlock winnerState + , getPerasTargetVoteStateTotalStake winnerState ) ) ( BlockedPerasRoundWinner - ( getPerasVoteBlock loserState - , ptvsTotalStake loserState + ( getPerasTargetVoteStateBlock loserState + , getPerasTargetVoteStateTotalStake loserState ) ) -- Reached quorum but failed to forge a certificate diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index 576e6f8078..65fbddf3ae 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -65,8 +65,8 @@ tests = genPerasCert :: Gen (PerasCert TestBlock) genPerasCert = do pcCertRound <- PerasRoundNo <$> arbitrary - pcCertBoostedBlock <- genPointTestBlock - pure $ PerasCert{pcCertRound, pcCertBoostedBlock} + pcCertBlock <- genPointTestBlock + pure $ PerasCert{pcCertRound, pcCertBlock} instance WithId (PerasCert blk) PerasRoundNo where getId = pcCertRound diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs index 413a059fd2..32296cff34 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -17,10 +18,13 @@ module Test.Consensus.Peras.Cert.Inclusion (tests) where import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) -import Ouroboros.Consensus.Block (WithOrigin (..)) +import Ouroboros.Consensus.Block (Point (..), WithOrigin (..)) import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasCertRound (..) - , getPerasCertRound + ( IsPerasCert (..) + , PerasCertMaxRounds (..) + , PerasParams (..) + , PerasRoundNo (..) + , mkPerasParams ) import Ouroboros.Consensus.Peras.Cert.Inclusion ( LatestCertOnChainView (..) @@ -44,6 +48,7 @@ import Test.Tasty.QuickCheck , testProperty ) import Test.Util.QuickCheck (geometric) +import Test.Util.TestBlock (TestBlock) import Test.Util.TestEnv (adjustQuickCheckTests) {------------------------------------------------------------------------------- @@ -77,7 +82,7 @@ data PerasCertInclusionRulesDecisionModel -- -- NOTE: this predicate could be lifted directly from the agda specification. needCertModel :: - PerasCertInclusionView TestCert TestBlk -> + PerasCertInclusionView TestCert TestBlock -> PerasCertInclusionRulesDecisionModel needCertModel PerasCertInclusionView @@ -229,9 +234,12 @@ data TestCert } deriving (Show, Eq, Generic) -instance HasPerasCertRound TestCert where +instance IsPerasCert TestCert TestBlock where getPerasCertRound = tcRoundNo + -- We don't really care about the block being boosted for the inclusion rules + getPerasCertBlock = const GenesisPoint + -- | Generate a test certificate -- -- NOTE: to improve the probabilities of covering all the paths in the code, @@ -250,13 +258,6 @@ genTestCert roundNo = do { tcRoundNo = roundNo' } --- * Mocked block type - --- | A mocked block type for testing -data TestBlk - = TestBlk - deriving (Show, Eq, Generic) - -- * Certificate and inclusion views genLatestCertSeen :: PerasRoundNo -> Gen (LatestCertSeenView TestCert) @@ -286,7 +287,7 @@ genPerasCertIds currRoundNo = do then Set.singleton (currRoundNo - 2) else Set.empty -genPerasCertInclusionView :: Gen (PerasCertInclusionView TestCert TestBlk) +genPerasCertInclusionView :: Gen (PerasCertInclusionView TestCert TestBlock) genPerasCertInclusionView = do perasParams <- genPerasParams currRoundNo <- genPerasRoundNo diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs index 26b7a31986..3c60654103 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -13,19 +14,14 @@ module Test.Consensus.Peras.Voting.Rules (tests) where import GHC.Generics (Generic) +import Ouroboros.Consensus.Block (Point (..)) import Ouroboros.Consensus.Block.Abstract ( SlotNo (..) , WithOrigin (..) ) import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasCertRound (..) - , getPerasCertRound - ) -import Ouroboros.Consensus.BlockchainTime - ( RelativeTime (..) - ) -import Ouroboros.Consensus.Peras.Params - ( PerasBlockMinSlots (..) + ( IsPerasCert (..) + , PerasBlockMinSlots (..) , PerasCertArrivalThreshold (..) , PerasCooldownRounds (..) , PerasIgnoranceRounds (..) @@ -57,6 +53,7 @@ import Test.Tasty.QuickCheck ) import Test.Util.Orphans.Arbitrary (genNominalDiffTime50Years) import Test.Util.QuickCheck (geometric) +import Test.Util.TestBlock (TestBlock) import Test.Util.TestEnv (adjustQuickCheckTests) {------------------------------------------------------------------------------- @@ -253,9 +250,12 @@ data TestCert } deriving (Show, Eq, Generic) -instance HasPerasCertRound TestCert where +instance IsPerasCert TestCert TestBlock where getPerasCertRound = tcRoundNo + -- We don't really care about the block being boosted for the voting rules + getPerasCertBlock = const GenesisPoint + -- | Generate a test certificate -- -- NOTE: to improve the probabilities of covering all the paths in the code, 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 c8bed04b34..12e83f3fb6 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 @@ -1283,7 +1283,7 @@ generator loe genBlock genPerasBlock m@Model{..} = { vpcCert = PerasCert { pcCertRound = roundNo - , pcCertBoostedBlock = blockPoint blk + , pcCertBlock = blockPoint blk } , vpcCertBoost = boost } @@ -1757,7 +1757,7 @@ addPerasCertOutcomes = concatMap classifyEvent classifyEvent :: Event Blk m Symbolic -> [String] classifyEvent ev = case unAt (eventCmd ev) of AddPerasCert certWithTime _ -> - let targetPt = pcCertBoostedBlock (vpcCert (forgetArrivalTime certWithTime)) + let targetPt = pcCertBlock (vpcCert (forgetArrivalTime certWithTime)) in case (isBlockConnected targetPt (dbModel (eventBefore ev))) of False -> assert (chainSelOutcome ev == "no chain selection change") $ diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs index 3b44055bd6..b01244114f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -18,7 +18,7 @@ import qualified Data.Set as Set import Data.TreeDiff (ToExpr (..), defaultExprViaShow) import GHC.Generics (Generic) import Ouroboros.Consensus.Block -import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot , mkPerasWeightSnapshot @@ -68,7 +68,7 @@ getWeightSnapshot :: Model blk -> PerasWeightSnapshot blk getWeightSnapshot Model{certs} = mkPerasWeightSnapshot - [ (getPerasCertBoostedBlock cert, getPerasCertBoost cert) + [ (getPerasCertBlock cert, vpcCertBoost (forgetArrivalTime cert)) | cert <- Set.toList certs ] @@ -81,4 +81,4 @@ garbageCollect :: SlotNo -> Model blk -> Model blk garbageCollect slotNo model@Model{certs} = model{certs = Set.filter keepCert certs} where - keepCert cert = pointSlot (getPerasCertBoostedBlock cert) >= NotOrigin slotNo + keepCert cert = pointSlot (getPerasCertBlock cert) >= NotOrigin slotNo diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index a1930915b2..33e4621335 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -95,7 +95,7 @@ instance StateModel Model where { vpcCert = PerasCert { pcCertRound = roundNo - , pcCertBoostedBlock = boostedBlock + , pcCertBlock = boostedBlock } , vpcCertBoost = perasWeight perasTestParams } @@ -139,7 +139,7 @@ instance StateModel Model where -- So we should enforce: round = round' => boostedBlock = boostedBlock' p cert' = getPerasCertRound cert /= getPerasCertRound cert' - || getPerasCertBoostedBlock cert == getPerasCertBoostedBlock cert' + || getPerasCertBlock cert == getPerasCertBlock cert' GetWeightSnapshot -> True GetLatestCertSeen -> True GarbageCollect _slotNo -> True @@ -196,7 +196,7 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where "Certificate block collision" [ show $ Set.member - (getPerasCertBoostedBlock cert) - (Set.map getPerasCertBoostedBlock model.certs) + (getPerasCertBlock cert) + (Set.map getPerasCertBlock model.certs) ] monitoring _ _ _ _ prop = prop diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs index 1d842c400a..a5089b50cf 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs @@ -22,16 +22,7 @@ import Data.TreeDiff (ToExpr (..), defaultExprViaShow) import GHC.Generics (Generic) import Ouroboros.Consensus.Block (SlotNo, WithOrigin (..), pointSlot) import Ouroboros.Consensus.Block.Abstract (StandardHash) -import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasVoteBlock (..) - , HasPerasVoteRound (..) - , PerasCert (..) - , ValidatedPerasCert (..) - , ValidatedPerasVote - , getPerasCertBoostedBlock - , getPerasVoteStake - , getPerasVoteVoterId - ) +import Ouroboros.Consensus.Block.SupportsPeras (IsPerasCert (..), IsPerasVote (..), PerasCert (..), ValidatedPerasCert (..), ValidatedPerasVote (..)) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( WithArrivalTime (..) ) @@ -164,7 +155,7 @@ addVote vote model -- block in this round => integrity violation (shouldn't happen in practice) | reachedQuorum , Just existingCert <- certAtRound - , getPerasCertBoostedBlock freshCert /= getPerasCertBoostedBlock existingCert = + , getPerasCertBlock freshCert /= getPerasCertBlock existingCert = ( Left $ MultipleWinnersInRound roundNo , model @@ -233,7 +224,7 @@ addVote vote model . sum . fmap ( unPerasVoteStake - . getPerasVoteStake + . vpvVoteStake . forgetArrivalTime . veVote ) @@ -259,7 +250,7 @@ addVote vote model { vpcCert = PerasCert { pcCertRound = getPerasVoteRound vote - , pcCertBoostedBlock = getPerasVoteBlock vote + , pcCertBlock = getPerasVoteBlock vote } , vpcCertBoost = perasWeight (params model) } diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index 7949370bbd..ea2147f8bd 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -41,8 +41,7 @@ import Data.Word (Word64) import GHC.Generics (Generic) import Ouroboros.Consensus.Block.Abstract (Point (..), SlotNo (..)) import Ouroboros.Consensus.Block.SupportsPeras - ( HasPerasVoteBlock (..) - , HasPerasVoteRound (..) + ( IsPerasVote (..) , PerasVote (..) , ValidatedPerasCert , ValidatedPerasVote (..) From 8021e0737e7c8163e0ed289d38cea81ead10285a Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 13 May 2026 11:36:59 +0200 Subject: [PATCH 22/62] Introduce O.C.Peras.(Vote|Cert).Mock Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- .../Ouroboros/Consensus/Peras/Cert/Mock.hs | 145 +++++++++++++++++ .../Ouroboros/Consensus/Peras/Vote/Mock.hs | 153 ++++++++++++++++++ 2 files changed, 298 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs new file mode 100644 index 0000000000..6401f06437 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Mocked Peras certificates without crypto. +module Ouroboros.Consensus.Peras.Cert.Mock + ( MockPerasCert (..) + , validateMockPerasCert + , forgeMockPerasCert + ) where + +import Cardano.Binary (decodeListLenOf, encodeListLen) +import Codec.Serialise (Serialise (..)) +import Control.DeepSeq (NFData) +import Data.Data (Proxy (..)) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract + ( ConvertRawHash + , HeaderHash + , Point + , StandardHash + ) +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , IsPerasCert (..) + , PerasParams (..) + , PerasRoundNo + , PerasVoteTarget (..) + , ValidatedPerasCert (..) + , ValidatedPerasVotesWithQuorum (..) + ) +import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..)) +import Ouroboros.Consensus.Util (ShowProxy) +import Ouroboros.Network.Util (ShowProxy (..)) + +-- | Mocked Peras certificates without crypto. +-- +-- NOTE: this is parameterized around the concrete block type being certified. +data MockPerasCert blk + = MockPerasCert + { mockCertRound :: PerasRoundNo + , mockCertBlock :: Point blk + } + +deriving instance StandardHash blk => Show (MockPerasCert blk) +deriving instance StandardHash blk => Eq (MockPerasCert blk) +deriving instance StandardHash blk => Ord (MockPerasCert blk) +deriving instance StandardHash blk => NoThunks (MockPerasCert blk) +deriving instance StandardHash blk => NFData (MockPerasCert blk) +deriving instance Generic (MockPerasCert blk) + +instance IsPerasCert (MockPerasCert blk) blk where + getPerasCertRound = mockCertRound + getPerasCertBlock = mockCertBlock + +instance ShowProxy blk => ShowProxy (MockPerasCert blk) where + showProxy _ = "MockPerasCert(" <> showProxy (Proxy @blk) <> ")" + +instance + Serialise (HeaderHash blk) => + Serialise (MockPerasCert blk) + where + encode + MockPerasCert + { mockCertRound + , mockCertBlock + } = + encodeListLen 2 + <> encode mockCertRound + <> encode mockCertBlock + decode = do + decodeListLenOf 2 + mockCertRound <- decode + mockCertBlock <- decode + pure $ + MockPerasCert + { mockCertRound + , mockCertBlock + } + +instance + ConvertRawHash blk => + SerialiseNodeToNode blk (MockPerasCert blk) + where + encodeNodeToNode + ccfg + version + MockPerasCert + { mockCertRound + , mockCertBlock + } = + encodeListLen 2 + <> encodeNodeToNode ccfg version mockCertRound + <> encodeNodeToNode ccfg version mockCertBlock + decodeNodeToNode ccfg version = do + decodeListLenOf 2 + mockCertRound <- decodeNodeToNode ccfg version + mockCertBlock <- decodeNodeToNode ccfg version + pure + MockPerasCert + { mockCertRound + , mockCertBlock + } + +-- | Helper to write 'BlockSupportsPeras.validatePerasCert'. +-- +-- WARNING: we do not perform any validation whatsoever for mocked certificates. +validateMockPerasCert :: + forall blk. + PerasParams -> + PerasCert blk -> + Either (PerasError blk) (ValidatedPerasCert blk) +validateMockPerasCert params cert = + Right + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasWeight params + } + +-- | Helper to write 'BlockSupportsPeras.forgePerasCert'. +forgeMockPerasCert :: + forall blk. + PerasCert blk ~ MockPerasCert blk => + PerasParams -> + ValidatedPerasVotesWithQuorum blk -> + Either (PerasError blk) (ValidatedPerasCert blk) +forgeMockPerasCert params votes = + return $ + ValidatedPerasCert + { vpcCert = + MockPerasCert + { mockCertRound = pvtRoundNo (vpvqTarget votes) + , mockCertBlock = pvtBlock (vpvqTarget votes) + } + , vpcCertBoost = perasWeight params + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs new file mode 100644 index 0000000000..7df3e19d73 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Mocked Peras votes without crypto. +module Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + , validateMockPerasVote + ) where + +import Cardano.Binary (decodeListLenOf, encodeListLen) +import Codec.Serialise (Serialise (..)) +import Control.DeepSeq (NFData) +import Data.Data (Proxy (..)) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract + ( ConvertRawHash + , HeaderHash + , Point + , StandardHash + ) +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , IsPerasVote (..) + , PerasRoundNo + , PerasVoteStake + , PerasVoteStakeDistr + , PerasVoterId (..) + , ValidatedPerasVote (..) + ) +import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..)) +import Ouroboros.Consensus.Peras.Params (PerasParams) +import Ouroboros.Consensus.Util (ShowProxy) +import Ouroboros.Network.Util (ShowProxy (..)) + +-- | Mocked Peras votes without crypto. +-- +-- NOTE: this is parameterized around the concrete block type being voted for. +data MockPerasVote blk + = MockPerasVote + { mockVoteRound :: PerasRoundNo + , mockVoteBlock :: Point blk + , mockVoteVoterId :: PerasVoterId + , mockVoteStake :: PerasVoteStake + -- ^ This field is unique to the mocked vote, and allows us to bypass the + -- need for a 'PerasVoteStakeDistr' when creating validated votes in tests. + } + +deriving instance StandardHash blk => Show (MockPerasVote blk) +deriving instance StandardHash blk => Eq (MockPerasVote blk) +deriving instance StandardHash blk => Ord (MockPerasVote blk) +deriving instance StandardHash blk => NoThunks (MockPerasVote blk) +deriving instance StandardHash blk => NFData (MockPerasVote blk) +deriving instance Generic (MockPerasVote blk) + +instance IsPerasVote (MockPerasVote blk) blk where + getPerasVoteRound = mockVoteRound + getPerasVoteBlock = mockVoteBlock + getPerasVoteVoterId = mockVoteVoterId + +instance ShowProxy blk => ShowProxy (MockPerasVote blk) where + showProxy _ = "MockPerasVote(" <> showProxy (Proxy @blk) <> ")" + +instance + Serialise (HeaderHash blk) => + Serialise (MockPerasVote blk) + where + encode + MockPerasVote + { mockVoteRound + , mockVoteBlock + , mockVoteVoterId + } = + encodeListLen 3 + <> encode mockVoteRound + <> encode mockVoteBlock + <> encode mockVoteVoterId + decode = do + decodeListLenOf 3 + mockVoteRound <- decode + mockVoteBlock <- decode + mockVoteVoterId <- decode + pure $ + MockPerasVote + { mockVoteRound + , mockVoteBlock + , mockVoteVoterId + , mockVoteStake = 0 + -- NOTE: stakes are never sent over the wire, but computed locally from + -- the stake distribution. We might need to change this in the future if + -- we ever need roundtrip tests using mocked votes, but for now this is + -- sufficient for our needs. + } + +instance + ConvertRawHash blk => + SerialiseNodeToNode blk (MockPerasVote blk) + where + encodeNodeToNode + ccfg + version + MockPerasVote + { mockVoteRound + , mockVoteBlock + , mockVoteVoterId + } = + encodeListLen 3 + <> encodeNodeToNode ccfg version mockVoteRound + <> encodeNodeToNode ccfg version mockVoteBlock + <> encodeNodeToNode ccfg version mockVoteVoterId + decodeNodeToNode ccfg version = do + decodeListLenOf 3 + mockVoteRound <- decodeNodeToNode ccfg version + mockVoteBlock <- decodeNodeToNode ccfg version + mockVoteVoterId <- decodeNodeToNode ccfg version + pure + MockPerasVote + { mockVoteRound + , mockVoteBlock + , mockVoteVoterId + , mockVoteStake = 0 + -- NOTE: stakes are never sent over the wire, but computed locally from + -- the stake distribution. We might need to change this in the future if + -- we ever need roundtrip tests using mocked votes, but for now this is + -- sufficient for our needs. + } + +-- | Helper to write 'BlockSupportsPeras.validatePerasVote'. +-- +-- WARNING: we do not perform any validation whatsoever for mocked votes. +validateMockPerasVote :: + forall blk. + PerasVote blk ~ MockPerasVote blk => + PerasParams -> + PerasVoteStakeDistr -> + PerasVote blk -> + Either (PerasError blk) (ValidatedPerasVote blk) +validateMockPerasVote _params _stakeDistr vote = + Right + ValidatedPerasVote + { vpvVote = vote + , vpvVoteStake = mockVoteStake vote + } From 1288ad55ba1beff4730e2bf9279832c414dd1e7f Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Fri, 8 May 2026 15:14:09 +0200 Subject: [PATCH 23/62] Split degenerate BlockSupportsPeras instance Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- .../Consensus/Byron/Ledger/Ledger.hs | 8 + .../byron/Ouroboros/Consensus/Byron/Node.hs | 4 +- .../Ouroboros/Consensus/Byron/Node/Peras.hs | 19 ++ .../Consensus/Byron/Node/Serialisation.hs | 1 + .../Consensus/Shelley/Ledger/Block.hs | 2 + .../Ouroboros/Consensus/Shelley/Node/Peras.hs | 55 ++++ .../Consensus/Shelley/Node/Serialisation.hs | 1 + .../Ouroboros/Consensus/ByronDual/Node.hs | 1 + .../Consensus/ByronDual/Node/Peras.hs | 19 ++ .../Consensus/ByronDual/Node/Serialisation.hs | 1 + .../Ouroboros/Consensus/Network/NodeToNode.hs | 7 +- .../Ouroboros/Consensus/Node/Tracers.hs | 2 + .../Test/ThreadNet/Network.hs | 2 + .../Test/Consensus/Genesis/Setup.hs | 3 + .../Test/Consensus/Genesis/TestSuite.hs | 2 + .../Test/Consensus/HardFork/Combinator/A.hs | 4 + .../Test/Consensus/HardFork/Combinator/B.hs | 4 + .../Consensus/PeerSimulator/NodeLifecycle.hs | 3 + .../Test/Consensus/PeerSimulator/Run.hs | 2 + ouroboros-consensus.cabal | 6 + .../Consensus/Block/SupportsPeras.hs | 308 +++++++++--------- .../Consensus/HardFork/Combinator/Basics.hs | 40 +++ .../Combinator/Serialisation/Common.hs | 4 + .../ObjectDiffusion/ObjectPool/PerasCert.hs | 32 +- .../ObjectDiffusion/ObjectPool/PerasVote.hs | 32 +- .../Ouroboros/Consensus/Node/Run.hs | 5 + .../Ouroboros/Consensus/Node/Serialisation.hs | 35 +- .../Ouroboros/Consensus/Peras/Types.hs | 6 +- .../Consensus/Peras/Vote/Aggregation.hs | 116 ++++++- .../Ouroboros/Consensus/Peras/Voting/Rules.hs | 2 + .../Ouroboros/Consensus/Peras/Voting/View.hs | 6 +- .../Ouroboros/Consensus/Peras/Weight.hs | 3 + .../Consensus/Storage/ChainDB/Impl.hs | 3 + .../Storage/ChainDB/Impl/Background.hs | 2 + .../Storage/ChainDB/Impl/ChainSel.hs | 9 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 8 +- .../Consensus/Storage/PerasCertDB/API.hs | 21 +- .../Consensus/Storage/PerasCertDB/Impl.hs | 40 ++- .../Consensus/Storage/PerasVoteDB/API.hs | 69 +++- .../Consensus/Storage/PerasVoteDB/Impl.hs | 60 +++- .../Ouroboros/Consensus/Util/Orphans.hs | 7 + .../Test/Ouroboros/Storage/TestBlock.hs | 55 +++- .../Test/Util/Orphans/ToExpr.hs | 13 +- .../Test/Util/TestBlock.hs | 34 ++ .../Ouroboros/Consensus/Mock/Node/Peras.hs | 25 ++ .../Consensus/Mock/Node/Serialisation.hs | 1 + .../ObjectDiffusion/PerasCert/Smoke.hs | 32 +- .../ObjectDiffusion/PerasVote/Smoke.hs | 58 ++-- .../Test/Consensus/Peras/Cert/Inclusion.hs | 1 + .../Test/Consensus/Peras/Voting/Rules.hs | 6 + .../Test/Ouroboros/Storage/ChainDB/Model.hs | 110 +++++-- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 42 ++- .../Ouroboros/Storage/PerasCertDB/Model.hs | 19 +- .../Storage/PerasCertDB/StateMachine.hs | 9 +- .../Ouroboros/Storage/PerasVoteDB/Model.hs | 55 +++- .../Storage/PerasVoteDB/StateMachine.hs | 31 +- 56 files changed, 1048 insertions(+), 397 deletions(-) create mode 100644 ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs create mode 100644 ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs create mode 100644 ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Peras.hs create mode 100644 ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index a4398e4b1a..7cca08c3f5 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -88,6 +88,7 @@ import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsPeerSelection +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Util (ShowProxy (..)) @@ -573,3 +574,10 @@ decodeByronResult query = case query of instance CanUpgradeLedgerTables LedgerState ByronBlock where upgradeTables _ _ = id + +{------------------------------------------------------------------------------- + LedgerSupportsPeras +-------------------------------------------------------------------------------} + +-- | Default instance with no Peras support +instance LedgerSupportsPeras ByronBlock diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs index a4f8fcbdb7..782bd8fd4d 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -42,6 +42,7 @@ import Ouroboros.Consensus.Byron.Crypto.DSIGN import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Ledger.Conversions import Ouroboros.Consensus.Byron.Ledger.Inspect () +import Ouroboros.Consensus.Byron.Node.Peras () import Ouroboros.Consensus.Byron.Node.Serialisation () import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.Config @@ -49,7 +50,6 @@ import Ouroboros.Consensus.Config.SupportsNode import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run @@ -302,8 +302,6 @@ instance NodeInitStorage ByronBlock where RunNode instance -------------------------------------------------------------------------------} -instance LedgerSupportsPeras ByronBlock - instance BlockSupportsMetrics ByronBlock where isSelfIssued = isSelfIssuedConstUnknown diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs new file mode 100644 index 0000000000..7509b4f185 --- /dev/null +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Empty Peras support for Byron. +-- +-- NOTE: this module exists solely because the orphan module +-- 'Ouroboros.Consensus.Byron.Node.Serialisation' needs this instance, but +-- defining it there would be too confusing. +module Ouroboros.Consensus.Byron.Node.Peras () where + +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras) +import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: Byron does not support Peras, so we can use the empty instance here. +instance BlockSupportsPeras ByronBlock diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Serialisation.hs index f9a9d48380..0141b04722 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Serialisation.hs @@ -24,6 +24,7 @@ import Data.Word import Ouroboros.Consensus.Block import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Ledger.Conversions +import Ouroboros.Consensus.Byron.Node.Peras () import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Query diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs index def77f1549..13c73e14c8 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -123,6 +123,8 @@ class HasPartialConsensusConfig proto , DecCBOR (SL.PState era) , Crypto (ProtoCrypto proto) + , -- Peras constraints + BlockSupportsPeras (ShelleyBlock proto era) , -- Backwards compatibility Plain.FromCBOR (LegacyPParams era) , Plain.ToCBOR (LegacyPParams era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs new file mode 100644 index 0000000000..b9ececeffe --- /dev/null +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Mocked Peras support for Shelley. +-- +-- NOTE: this module exists solely because the orphan module +-- 'Ouroboros.Consensus.Shelley.Node.Serialisation' needs this instance, but +-- defining it there would be too confusing. +module Ouroboros.Consensus.Shelley.Node.Peras () where + +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , VoidPerasError + ) +import Ouroboros.Consensus.Peras.Cert.Mock + ( MockPerasCert (..) + , forgeMockPerasCert + , validateMockPerasCert + ) +import Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + , validateMockPerasVote + ) +import Ouroboros.Consensus.Shelley.Ledger.Block + ( ShelleyBlock + , ShelleyCompatible + ) + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: this is a mocked up implementation without crypto! + +-- TODO: replace this with a concrete implementation using 'Peras.Vote.V1' and +-- 'Peras.Cert.V1', either forall eras or for @forall era. era >= DijkstraEra@. + +instance + ShelleyCompatible proto era => + BlockSupportsPeras (ShelleyBlock proto era) + where + type PerasVote (ShelleyBlock proto era) = MockPerasVote (ShelleyBlock proto era) + type PerasCert (ShelleyBlock proto era) = MockPerasCert (ShelleyBlock proto era) + type PerasError (ShelleyBlock proto era) = VoidPerasError (ShelleyBlock proto era) + + validatePerasVote = validateMockPerasVote + validatePerasCert = validateMockPerasCert + forgePerasCert = forgeMockPerasCert + + -- TODO: extract actual Peras certificates from blocks + getPerasCertInBlock _ = Nothing diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs index e0aa6b1277..4d541def62 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs @@ -45,6 +45,7 @@ import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion () +import Ouroboros.Consensus.Shelley.Node.Peras () import Ouroboros.Consensus.Shelley.Protocol.Abstract ( pHeaderBlockSize , pHeaderSize diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs index 4a9bfd2366..183dce4f95 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs @@ -27,6 +27,7 @@ import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Node import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.ByronDual.Ledger +import Ouroboros.Consensus.ByronDual.Node.Peras () import Ouroboros.Consensus.ByronDual.Node.Serialisation () import Ouroboros.Consensus.ByronSpec.Ledger import qualified Ouroboros.Consensus.ByronSpec.Ledger.Genesis as Genesis diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Peras.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Peras.hs new file mode 100644 index 0000000000..5cf7407010 --- /dev/null +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Peras.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Empty Peras support for DualByron. +-- +-- NOTE: this module exists solely because the orphan module +-- 'Ouroboros.Consensus.ByronDual.Node.Serialisation' needs this instance, but +-- defining it there would be too confusing. +module Ouroboros.Consensus.ByronDual.Node.Peras () where + +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras) +import Ouroboros.Consensus.ByronDual.Ledger (DualByronBlock) + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: DualByron does not support Peras, so we can use the empty instance here. +instance BlockSupportsPeras DualByronBlock diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs index 946ec235bb..787cf7e4ab 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs @@ -16,6 +16,7 @@ import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Node.Serialisation () import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.ByronDual.Ledger +import Ouroboros.Consensus.ByronDual.Node.Peras () import Ouroboros.Consensus.ByronSpec.Ledger import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Dual diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 53d85783fb..fb0782ab35 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -276,8 +276,9 @@ mkHandlers :: ( IOLike m , MonadTime m , MonadTimer m - , LedgerSupportsMempool blk , HasTxId (GenTx blk) + , BlockSupportsPeras blk + , LedgerSupportsMempool blk , LedgerSupportsProtocol blk , Ord addrNTN , Hashable addrNTN @@ -621,6 +622,8 @@ showTracers :: , Show (Header blk) , Show (GenTx blk) , Show (GenTxId blk) + , Show (PerasVote blk) + , Show (PerasCert blk) , HasHeader blk , HasNestedContent Header blk ) => @@ -778,6 +781,8 @@ mkApps :: , ShowProxy (Header blk) , ShowProxy (TxId (GenTx blk)) , ShowProxy (GenTx blk) + , ShowProxy (PerasVote blk) + , ShowProxy (PerasCert blk) , Show addrNTN , LedgerSupportsMempool blk , HasTxId (GenTx blk) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index dc48b9d317..cffac87302 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs @@ -191,6 +191,8 @@ showTracers :: , Show (ForgeStateUpdateError blk) , Show (CannotForge blk) , Show (TxMeasure blk) + , Show (PerasVote blk) + , Show (PerasCert blk) , Show remotePeer , LedgerSupportsProtocol blk ) => diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index ee17e0a1fb..068684c9d4 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -1777,6 +1777,8 @@ type TracingConstraints blk = , Show (CannotForge blk) , Show (TxMeasure blk) , Show (ReasonForSwitch (TiebreakerView (BlockProtocol blk))) + , Show (PerasVote blk) + , Show (PerasCert blk) , HasNestedContent Header blk ) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs index c4f7c6ba9d..7c0771d947 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs @@ -31,6 +31,7 @@ import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Block.SupportsDiffusionPipelining ( BlockSupportsDiffusionPipelining ) +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras) import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode) import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.Ledger.Basics (LedgerState) @@ -162,6 +163,7 @@ runGenesisTest :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -224,6 +226,7 @@ runConformanceTest :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs index 768bdd1032..17fafb54ae 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs @@ -35,6 +35,7 @@ import Data.Monoid (Endo (..)) import GHC.Generics (Generic, Generically (..)) import Ouroboros.Consensus.Block ( BlockSupportsDiffusionPipelining + , BlockSupportsPeras , ConvertRawHash , Header ) @@ -186,6 +187,7 @@ toTestTree :: , LedgerSupportsPeras blk , SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 2f6d1f4dea..8a8a37abcf 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -309,6 +310,9 @@ instance LedgerSupportsProtocol BlockA where instance LedgerSupportsPeras BlockA +-- NOTE: this block does not support Peras, so we can use the empty instance here. +instance BlockSupportsPeras BlockA + instance HasPartialConsensusConfig ProtocolA instance HasPartialLedgerConfig BlockA where diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index 6e7401deca..b01cea1f33 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -265,6 +266,9 @@ instance LedgerSupportsProtocol BlockB where instance LedgerSupportsPeras BlockB +-- NOTE: this block does not support Peras, so we can use the empty instance here. +instance BlockSupportsPeras BlockB + instance HasPartialConsensusConfig ProtocolB instance HasPartialLedgerConfig BlockB diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs index 20b4147bb7..8d91c0fe3e 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs @@ -137,6 +137,7 @@ mkChainDb :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -190,6 +191,7 @@ restoreNode :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -220,6 +222,7 @@ lifecycleStart :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index 78e43cbe4f..439e5993d8 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -561,6 +561,7 @@ nodeLifecycle :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -620,6 +621,7 @@ runPointSchedule :: , LedgerSupportsPeras blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 3c03ddadee..31d7af5e83 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -237,12 +237,14 @@ library Ouroboros.Consensus.Node.Serialisation Ouroboros.Consensus.NodeId Ouroboros.Consensus.Peras.Cert.Inclusion + Ouroboros.Consensus.Peras.Cert.Mock Ouroboros.Consensus.Peras.Cert.V1 Ouroboros.Consensus.Peras.Crypto.BLS Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.Types Ouroboros.Consensus.Peras.Vote.Aggregation + Ouroboros.Consensus.Peras.Vote.Mock Ouroboros.Consensus.Peras.Vote.V1 Ouroboros.Consensus.Peras.Voting.Committee Ouroboros.Consensus.Peras.Voting.Rules @@ -580,6 +582,7 @@ library unstable-mock-block Ouroboros.Consensus.Mock.Node.Abstract Ouroboros.Consensus.Mock.Node.BFT Ouroboros.Consensus.Mock.Node.PBFT + Ouroboros.Consensus.Mock.Node.Peras Ouroboros.Consensus.Mock.Node.Praos Ouroboros.Consensus.Mock.Node.PraosRule Ouroboros.Consensus.Mock.Node.Serialisation @@ -1315,6 +1318,7 @@ library cardano Ouroboros.Consensus.Byron.Ledger.PBFT Ouroboros.Consensus.Byron.Ledger.Serialisation Ouroboros.Consensus.Byron.Node + Ouroboros.Consensus.Byron.Node.Peras Ouroboros.Consensus.Byron.Node.Serialisation Ouroboros.Consensus.Byron.Protocol Ouroboros.Consensus.Cardano @@ -1346,6 +1350,7 @@ library cardano Ouroboros.Consensus.Shelley.Node Ouroboros.Consensus.Shelley.Node.Common Ouroboros.Consensus.Shelley.Node.DiffusionPipelining + Ouroboros.Consensus.Shelley.Node.Peras Ouroboros.Consensus.Shelley.Node.Praos Ouroboros.Consensus.Shelley.Node.Serialisation Ouroboros.Consensus.Shelley.Node.TPraos @@ -1443,6 +1448,7 @@ library unstable-byron-testlib exposed-modules: Ouroboros.Consensus.ByronDual.Ledger Ouroboros.Consensus.ByronDual.Node + Ouroboros.Consensus.ByronDual.Node.Peras Ouroboros.Consensus.ByronDual.Node.Serialisation Test.Consensus.Byron.Examples Test.Consensus.Byron.Generators diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index e1157c2b93..66c6a91b57 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -1,23 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) - , PerasCert (..) - , PerasVote (..) - , IsPerasVote (..) - , getPerasVoteId - , getPerasVoteTarget - , IsPerasCert (..) + , VoidPerasVote (..) + , VoidPerasCert (..) + , VoidPerasError (..) , ValidatedPerasCert (..) , ValidatedPerasVote (..) , ValidatedPerasVotesWithQuorum @@ -26,62 +26,97 @@ module Ouroboros.Consensus.Block.SupportsPeras , vpvqPerasParams ) , votesReachQuorum + , IsPerasVote (..) + , getPerasVoteId + , getPerasVoteTarget + , IsPerasCert (..) + + -- * Convenience re-exports + , module Ouroboros.Consensus.Peras.Params + , module Ouroboros.Consensus.Peras.Types ) where -import Cardano.Binary (FromCBOR (..), ToCBOR (..)) -import Codec.Serialise (Serialise (..)) -import Codec.Serialise.Decoding (decodeListLenOf) -import Codec.Serialise.Encoding (encodeListLen) +import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Proxy (Proxy (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Typeable (Typeable) +import Data.Void (Void, absurd) import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Peras.Params import Ouroboros.Consensus.Peras.Types - ( PerasRoundNo - , PerasVoteId (..) - , PerasVoteStake - , PerasVoteStakeDistr (..) - , PerasVoteTarget (..) - , PerasVoterId (..) - , lookupPerasVoteStake - , stakeAboveThreshold - ) -import Ouroboros.Consensus.Util (ShowProxy (..)) +import Ouroboros.Consensus.Util (ShowProxy) -- * BlockSupportsPeras class class - ( IsPerasVote (PerasVote blk) blk + ( StandardHash blk + , Typeable blk + , Typeable (PerasVote blk) + , Typeable (PerasCert blk) + , Typeable (PerasError blk) + , Show (PerasVote blk) + , Show (PerasCert blk) + , Show (PerasError blk) + , Eq (PerasVote blk) + , Eq (PerasCert blk) + , Eq (PerasError blk) + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + , NoThunks (PerasError blk) + , IsPerasVote (PerasVote blk) blk , IsPerasCert (PerasCert blk) blk ) => BlockSupportsPeras blk where - data PerasCert blk + type PerasVote blk = (vote :: Type) | vote -> blk + type PerasVote blk = VoidPerasVote blk - data PerasVote blk + type PerasCert blk = (cert :: Type) | cert -> blk + type PerasCert blk = VoidPerasCert blk - data PerasValidationErr blk + type PerasError blk = (err :: Type) | err -> blk + type PerasError blk = VoidPerasError blk - data PerasForgeErr blk + validatePerasVote :: + PerasParams -> + PerasVoteStakeDistr -> + PerasVote blk -> + Either (PerasError blk) (ValidatedPerasVote blk) + default validatePerasVote :: + PerasVote blk ~ VoidPerasVote blk => + PerasParams -> + PerasVoteStakeDistr -> + PerasVote blk -> + Either (PerasError blk) (ValidatedPerasVote blk) + validatePerasVote _ _ vote = + absurd (unVoidPerasVote vote) validatePerasCert :: PerasParams -> PerasCert blk -> - Either (PerasValidationErr blk) (ValidatedPerasCert blk) - - validatePerasVote :: + Either (PerasError blk) (ValidatedPerasCert blk) + default validatePerasCert :: + PerasCert blk ~ VoidPerasCert blk => PerasParams -> - PerasVoteStakeDistr -> - PerasVote blk -> - Either (PerasValidationErr blk) (ValidatedPerasVote blk) + PerasCert blk -> + Either (PerasError blk) (ValidatedPerasCert blk) + validatePerasCert _ cert = + absurd (unVoidPerasCert cert) forgePerasCert :: PerasParams -> ValidatedPerasVotesWithQuorum blk -> - Either (PerasForgeErr blk) (ValidatedPerasCert blk) + Either (PerasError blk) (ValidatedPerasCert blk) + default forgePerasCert :: + PerasVote blk ~ VoidPerasVote blk => + PerasParams -> + ValidatedPerasVotesWithQuorum blk -> + Either (PerasError blk) (ValidatedPerasCert blk) + forgePerasCert _ votes = + absurd (unVoidPerasVote (vpvVote (NonEmpty.head (vpvqVotes votes)))) -- | Extract a Peras certificate optionally stored in a block. -- @@ -90,107 +125,46 @@ class getPerasCertInBlock :: blk -> Maybe (PerasCert blk) + getPerasCertInBlock _ = + Nothing --- TODO: degenerate instance for all blks to get things to compile --- see https://github.com/tweag/cardano-peras/issues/73 -instance BlockSupportsPeras blk where - data PerasCert blk = PerasCert - { pcCertRound :: PerasRoundNo - , pcCertBlock :: Point blk - } - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass NoThunks +-- * Helpers to derive @BlockSupportsPeras@ for block types without Peras support - data PerasVote blk = PerasVote - { pvVoteRound :: PerasRoundNo - , pvVoteBlock :: Point blk - , pvVoteVoterId :: PerasVoterId - } - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass NoThunks - - -- TODO: enrich with actual error types - -- see https://github.com/tweag/cardano-peras/issues/120 - data PerasValidationErr blk - = PerasValidationErr - deriving stock (Show, Eq) - - -- TODO: enrich with actual error types - -- see https://github.com/tweag/cardano-peras/issues/120 - data PerasForgeErr blk - = PerasForgeErr - deriving stock (Show, Eq) - - -- TODO: perform actual validation against all - -- possible 'PerasValidationErr' variants - -- see https://github.com/tweag/cardano-peras/issues/120 - validatePerasCert params cert = - Right - ValidatedPerasCert - { vpcCert = cert - , vpcCertBoost = perasWeight params - } - - -- TODO: perform actual validation against all - -- possible 'PerasValidationErr' variants - -- see https://github.com/tweag/cardano-peras/issues/120 - validatePerasVote _params stakeDistr vote - | Just stake <- lookupPerasVoteStake (getPerasVoteVoterId vote) stakeDistr = - Right - ValidatedPerasVote - { vpvVote = vote - , vpvVoteStake = stake - } - | otherwise = - Left PerasValidationErr - - -- TODO: perform actual validation against all - -- possible 'PerasForgeErr' variants - -- see https://github.com/tweag/cardano-peras/issues/120 - forgePerasCert params votes = - return $ - ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = pvtRoundNo (vpvqTarget votes) - , pcCertBlock = pvtBlock (vpvqTarget votes) - } - , vpcCertBoost = perasWeight params - } - - -- TODO: extract actual Peras certificates from blocks when the HFC plumbing - -- is in place. - getPerasCertInBlock _ = Nothing - -instance ShowProxy blk => ShowProxy (PerasCert blk) where - showProxy _ = "PerasCert " <> showProxy (Proxy @blk) - -instance ShowProxy blk => ShowProxy (PerasVote blk) where - showProxy _ = "PerasVote " <> showProxy (Proxy @blk) - -instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where - encode PerasCert{pcCertRound, pcCertBlock} = - encodeListLen 2 - <> encode pcCertRound - <> encode pcCertBlock - decode = do - decodeListLenOf 2 - pcCertRound <- decode - pcCertBlock <- decode - pure $ PerasCert{pcCertRound, pcCertBlock} - -instance Serialise (HeaderHash blk) => Serialise (PerasVote blk) where - encode PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} = - encodeListLen 3 - <> encode pvVoteRound - <> encode pvVoteBlock - <> toCBOR (unPerasVoterId pvVoteVoterId) - decode = do - decodeListLenOf 3 - pvVoteRound <- decode - pvVoteBlock <- decode - pvVoteVoterId <- PerasVoterId <$> fromCBOR - pure $ PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} +-- | Imposible Peras vote for @blk@. +-- +-- NOTE: the phantom @blk@ is used to keep the 'PerasVote' type family injective. +newtype VoidPerasVote blk + = VoidPerasVote + { unVoidPerasVote :: Void + } + deriving newtype (Show, Eq, NoThunks, ShowProxy) + +-- | Imposible Peras certificate for @blk@. +-- +-- NOTE: the phantom @blk@ is used to keep the 'PerasCert' type family injective. +newtype VoidPerasCert blk + = VoidPerasCert + { unVoidPerasCert :: Void + } + deriving newtype (Show, Eq, NoThunks, ShowProxy) + +instance IsPerasVote (VoidPerasVote blk) blk where + getPerasVoteRound = absurd . unVoidPerasVote + getPerasVoteBlock = absurd . unVoidPerasVote + getPerasVoteVoterId = absurd . unVoidPerasVote + +instance IsPerasCert (VoidPerasCert blk) blk where + getPerasCertRound = absurd . unVoidPerasCert + getPerasCertBlock = absurd . unVoidPerasCert + +-- | Imposible Peras error for @blk@. +-- +-- NOTE: the phantom @blk@ is used to keep the 'PerasError' type family injective. +newtype VoidPerasError blk + = VoidPerasError + { unVoidPerasError :: Void + } + deriving newtype (Show, Eq, NoThunks, ShowProxy) -- * Validated types @@ -199,16 +173,24 @@ data ValidatedPerasVote blk { vpvVote :: !(PerasVote blk) , vpvVoteStake :: !PerasVoteStake } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass NoThunks + +deriving instance Show (PerasVote blk) => Show (ValidatedPerasVote blk) +deriving instance Eq (PerasVote blk) => Eq (ValidatedPerasVote blk) +deriving instance Ord (PerasVote blk) => Ord (ValidatedPerasVote blk) +deriving instance NoThunks (PerasVote blk) => NoThunks (ValidatedPerasVote blk) +deriving instance Generic (ValidatedPerasVote blk) data ValidatedPerasCert blk = ValidatedPerasCert { vpcCert :: !(PerasCert blk) , vpcCertBoost :: !PerasWeight } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass NoThunks + +deriving instance Show (PerasCert blk) => Show (ValidatedPerasCert blk) +deriving instance Eq (PerasCert blk) => Eq (ValidatedPerasCert blk) +deriving instance Ord (PerasCert blk) => Ord (ValidatedPerasCert blk) +deriving instance NoThunks (PerasCert blk) => NoThunks (ValidatedPerasCert blk) +deriving instance Generic (ValidatedPerasCert blk) -- | A collection of validated Peras votes that: -- 1. are all for the same target, and @@ -222,8 +204,24 @@ data ValidatedPerasVotesWithQuorum blk , vpvqPerasParams :: !PerasParams -- ^ The Peras parameters used to validate that the votes reach quorum } - deriving stock (Show, Eq, Generic) - deriving anyclass NoThunks + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + ) => + Show (ValidatedPerasVotesWithQuorum blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + ) => + Eq (ValidatedPerasVotesWithQuorum blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + ) => + NoThunks (ValidatedPerasVotesWithQuorum blk) +deriving instance + Generic (ValidatedPerasVotesWithQuorum blk) -- | Smart constructor for 'ValidatedPerasVotesReachingQuorum'. -- @@ -231,7 +229,9 @@ data ValidatedPerasVotesWithQuorum blk -- total stake is above the quorum threshold defined in the given 'PerasCfg'. -- It returns 'Nothing' if either of these conditions is not met. votesReachQuorum :: - StandardHash blk => + ( StandardHash blk + , IsPerasVote (PerasVote blk) blk + ) => PerasParams -> [ValidatedPerasVote blk] -> Maybe (ValidatedPerasVotesWithQuorum blk) @@ -286,17 +286,18 @@ getPerasVoteTarget vote = , pvtBlock = getPerasVoteBlock vote } -instance IsPerasVote (PerasVote blk) blk where - getPerasVoteRound = pvVoteRound - getPerasVoteBlock = pvVoteBlock - getPerasVoteVoterId = pvVoteVoterId - -instance IsPerasVote (ValidatedPerasVote blk) blk where +instance + IsPerasVote (PerasVote blk) blk => + IsPerasVote (ValidatedPerasVote blk) blk + where getPerasVoteRound = getPerasVoteRound . vpvVote getPerasVoteBlock = getPerasVoteBlock . vpvVote getPerasVoteVoterId = getPerasVoteVoterId . vpvVote -instance IsPerasVote vote blk => IsPerasVote (WithArrivalTime vote) blk where +instance + IsPerasVote vote blk => + IsPerasVote (WithArrivalTime vote) blk + where getPerasVoteRound = getPerasVoteRound . forgetArrivalTime getPerasVoteBlock = getPerasVoteBlock . forgetArrivalTime getPerasVoteVoterId = getPerasVoteVoterId . forgetArrivalTime @@ -306,11 +307,10 @@ class IsPerasCert cert blk | cert -> blk where getPerasCertRound :: cert -> PerasRoundNo getPerasCertBlock :: cert -> Point blk -instance IsPerasCert (PerasCert blk) blk where - getPerasCertRound = pcCertRound - getPerasCertBlock = pcCertBlock - -instance IsPerasCert (ValidatedPerasCert blk) blk where +instance + IsPerasCert (PerasCert blk) blk => + IsPerasCert (ValidatedPerasCert blk) blk + where getPerasCertRound = getPerasCertRound . vpcCert getPerasCertBlock = getPerasCertBlock . vpcCert diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index d2a0a69457..9024aba930 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -47,6 +47,7 @@ import Data.Typeable import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras (..), VoidPerasError) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.AcrossEras @@ -57,6 +58,15 @@ import Ouroboros.Consensus.HardFork.Combinator.State.Types import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) +import Ouroboros.Consensus.Peras.Cert.Mock + ( MockPerasCert (..) + , forgeMockPerasCert + , validateMockPerasCert + ) +import Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + , validateMockPerasVote + ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (ShowProxy) @@ -258,3 +268,33 @@ instance CanHardFork xs => LedgerSupportsPeras (HardForkBlock xs) where . hcmap proxySingle (K . getLatestPerasCertRound . unFlip) . State.tip . hardForkLedgerStatePerEra + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: this is a mocked up implementation without crypto! + +-- TODO: when replacing this with a real votes and certificates, we need to make +-- sure that their binary representation would be compatible with the one the +-- HFC would produce if it were in charge of dispatching them. Concretely, this +-- means adding an envelope around the actual votes and certificates indicating +-- which era they belong to. This is to allow for the possibility of having the +-- HFC dispatch different types of votes and certificates in the future. + +instance + ( StandardHash (HardForkBlock xs) + , CanHardFork xs + ) => + BlockSupportsPeras (HardForkBlock xs) + where + type PerasVote (HardForkBlock xs) = MockPerasVote (HardForkBlock xs) + type PerasCert (HardForkBlock xs) = MockPerasCert (HardForkBlock xs) + type PerasError (HardForkBlock xs) = VoidPerasError (HardForkBlock xs) + + validatePerasVote = validateMockPerasVote + validatePerasCert = validateMockPerasCert + forgePerasCert = forgeMockPerasCert + + -- TODO: extract actual Peras certificates from blocks + getPerasCertInBlock _ = Nothing diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs index 23839c8c9f..d2758d2c80 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Serialisation/Common.hs @@ -104,6 +104,7 @@ import Ouroboros.Consensus.HardFork.Combinator.State.Instances import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run +import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode) import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Network.Block (Serialised) @@ -205,6 +206,9 @@ class , LedgerDbSerialiseConstraints (HardForkBlock xs) , VolatileDbSerialiseConstraints (HardForkBlock xs) , EncodeDiskDep (NestedCtxt Header) (HardForkBlock xs) + , -- Required for Peras + SerialiseNodeToNode (HardForkBlock xs) (PerasVote (HardForkBlock xs)) + , SerialiseNodeToNode (HardForkBlock xs) (PerasVote (HardForkBlock xs)) ) => SerialiseHFC xs where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index 88a6517124..fe5e48340a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} @@ -44,7 +45,9 @@ takeAscMap n = Map.fromDistinctAscList . take n . Map.toAscList -- | Internal helper: create a pool reader from a @getCertsAfter@ function. makePerasCertPoolReader :: - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => ( PerasCertTicketNo -> STM m (Map PerasCertTicketNo (m (WithArrivalTime (ValidatedPerasCert blk)))) ) -> @@ -65,7 +68,9 @@ makePerasCertPoolReader getCertsAfterSTM = } makePerasCertPoolReaderFromCertDB :: - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromCertDB perasCertDB = @@ -73,7 +78,9 @@ makePerasCertPoolReaderFromCertDB perasCertDB = (PerasCertDB.getCertsAfter perasCertDB) makePerasCertPoolReaderFromChainDB :: - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromChainDB chainDB = @@ -89,7 +96,9 @@ makePerasCertPoolReaderFromChainDB chainDB = -- see 'makePerasCertPoolWriterFromChainDB' which creates a pool writer from the -- 'ChainDB' with proper handling of chain selection side-effects. makePerasCertPoolWriterFromCertDB :: - IOLike m => + ( IOLike m + , BlockSupportsPeras blk + ) => SystemTime m -> PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m @@ -111,7 +120,9 @@ makePerasCertPoolWriterFromCertDB systemTime perasCertDB = -- | Create a pool writer from the 'ChainDB'. This properly handles any needed -- chain selection side-effects. makePerasCertPoolWriterFromChainDB :: - IOLike m => + ( IOLike m + , BlockSupportsPeras blk + ) => SystemTime m -> ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m @@ -137,7 +148,9 @@ makePerasCertPoolWriterFromChainDB systemTime chainDB = } data PerasCertInboundException - = forall blk. PerasCertValidationError [PerasValidationErr blk] + = forall blk. + Show (PerasError blk) => + PerasCertValidationError [PerasError blk] deriving instance Show PerasCertInboundException @@ -154,10 +167,13 @@ instance Exception PerasCertInboundException -- each valid certificate is timestamped with the current wall-clock time and -- added to the database via @addCert@. processCerts :: - MonadSTM m => + ( MonadSTM m + , Show (PerasError blk) + , IsPerasCert (PerasCert blk) blk + ) => SystemTime m -> STM m (Set PerasRoundNo) -> - (PerasCert blk -> Either (PerasValidationErr blk) (ValidatedPerasCert blk)) -> + (PerasCert blk -> Either (PerasError blk) (ValidatedPerasCert blk)) -> (WithArrivalTime (ValidatedPerasCert blk) -> m ()) -> [PerasCert blk] -> m () diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs index 5ae493e3a0..3dcbf4dbb5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} @@ -45,7 +46,9 @@ takeAscMap n = Map.fromDistinctAscList . take n . Map.toAscList -- | Internal helper: create a pool reader from a @getVotesAfter@ function. makePerasVotePoolReader :: - IOLike m => + ( IOLike m + , IsPerasVote (PerasVote blk) blk + ) => ( PerasVoteTicketNo -> STM m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))) ) -> @@ -64,7 +67,9 @@ makePerasVotePoolReader getVotesAfterSTM = } makePerasVotePoolReaderFromVoteDB :: - IOLike m => + ( IOLike m + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDB m blk -> ObjectPoolReader (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m makePerasVotePoolReaderFromVoteDB perasVoteDB = @@ -72,7 +77,9 @@ makePerasVotePoolReaderFromVoteDB perasVoteDB = (PerasVoteDB.getVotesAfter perasVoteDB) makePerasVotePoolReaderFromChainDB :: - IOLike m => + ( IOLike m + , IsPerasVote (PerasVote blk) blk + ) => ChainDB m blk -> ObjectPoolReader (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m makePerasVotePoolReaderFromChainDB chainDB = @@ -90,7 +97,9 @@ makePerasVotePoolReaderFromChainDB chainDB = -- see 'makePerasVotePoolWriterFromChainDB' which creates a pool writer from the -- 'ChainDB' and thus properly handles the produced certs. makePerasVotePoolWriterFromVoteDB :: - IOLike m => + ( IOLike m + , BlockSupportsPeras blk + ) => SystemTime m -> -- | This is needed for validating votes (since it is during the validation of -- votes that we give them a verified weight. In the future, we won't read it @@ -120,7 +129,9 @@ makePerasVotePoolWriterFromVoteDB systemTime getStakeDistrSTM perasVoteDB = -- This properly handles the produced certs by letting the ChainDB take care -- of them (see 'ChainDB.addPerasVoteWithAsyncCertHandling'). makePerasVotePoolWriterFromChainDB :: - IOLike m => + ( IOLike m + , BlockSupportsPeras blk + ) => SystemTime m -> -- | This is needed for validating votes (since its during the validation of -- votes that we give them a verified weight. In the future, we won't read it @@ -152,7 +163,9 @@ makePerasVotePoolWriterFromChainDB systemTime getStakeDistrSTM chainDB = } data PerasVoteInboundException - = forall blk. PerasVoteValidationError [PerasValidationErr blk] + = forall blk. + Show (PerasError blk) => + PerasVoteValidationError [PerasError blk] deriving instance Show PerasVoteInboundException @@ -168,10 +181,13 @@ instance Exception PerasVoteInboundException -- `ouroboros-network`). Otherwise, each valid vote is timestamped with the -- current wall-clock time and added to the database via @addVote@. processVotes :: - MonadSTM m => + ( MonadSTM m + , Show (PerasError blk) + , IsPerasVote (PerasVote blk) blk + ) => SystemTime m -> STM m (Set (PerasVoteId blk)) -> - (PerasVote blk -> STM m (Either (PerasValidationErr blk) (ValidatedPerasVote blk))) -> + (PerasVote blk -> STM m (Either (PerasError blk) (ValidatedPerasVote blk))) -> (WithArrivalTime (ValidatedPerasVote blk) -> m ()) -> [PerasVote blk] -> m () diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs index bbe02cd7ad..d7b7c2f9bb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs @@ -59,6 +59,8 @@ class , SerialiseNodeToNode blk (SerialisedHeader blk) , SerialiseNodeToNode blk (GenTx blk) , SerialiseNodeToNode blk (GenTxId blk) + , SerialiseNodeToNode blk (PerasVote blk) + , SerialiseNodeToNode blk (PerasCert blk) ) => SerialiseNodeToNodeConstraints blk where @@ -109,6 +111,7 @@ class , NodeInitStorage blk , BlockSupportsMetrics blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , BlockSupportsSanityCheck blk , Show (CannotForge blk) , Show (ForgeStateInfo blk) @@ -119,6 +122,8 @@ class , ShowProxy (Header blk) , ShowProxy (BlockQuery blk) , ShowProxy (TxId (GenTx blk)) + , ShowProxy (PerasVote blk) + , ShowProxy (PerasCert blk) , (forall fp. ShowQuery (BlockQuery blk fp)) , CanUpgradeLedgerTables LedgerState blk ) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs index 2b36fc2f10..a266cadb53 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs @@ -42,6 +42,7 @@ import Codec.CBOR.Encoding (Encoding, encodeListLen) import Codec.Serialise (Serialise (decode, encode)) import Data.Kind import Data.SOP.BasicFunctors +import Data.Void (absurd) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool @@ -197,32 +198,6 @@ instance SerialiseNodeToNode blk PerasRoundNo where encodeNodeToNode _ccfg _version = encode decodeNodeToNode _ccfg _version = decode -instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where - -- Consistent with the 'Serialise' instance for 'PerasCert' defined in Ouroboros.Consensus.Block.SupportsPeras - encodeNodeToNode ccfg version PerasCert{..} = - encodeListLen 2 - <> encodeNodeToNode ccfg version pcCertRound - <> encodeNodeToNode ccfg version pcCertBlock - decodeNodeToNode ccfg version = do - decodeListLenOf 2 - pcCertRound <- decodeNodeToNode ccfg version - pcCertBlock <- decodeNodeToNode ccfg version - pure $ PerasCert pcCertRound pcCertBlock - -instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasVote blk) where - -- Consistent with the 'Serialise' instance for 'PerasVote' defined in Ouroboros.Consensus.Block.SupportsPeras - encodeNodeToNode ccfg version PerasVote{..} = - encodeListLen 3 - <> encodeNodeToNode ccfg version pvVoteRound - <> encodeNodeToNode ccfg version pvVoteBlock - <> encodeNodeToNode ccfg version pvVoteVoterId - decodeNodeToNode ccfg version = do - decodeListLenOf 3 - pvVoteRound <- decodeNodeToNode ccfg version - pvVoteBlock <- decodeNodeToNode ccfg version - pvVoteVoterId <- decodeNodeToNode ccfg version - pure $ PerasVote pvVoteRound pvVoteBlock pvVoteVoterId - instance SerialiseNodeToNode blk PerasVoterId where encodeNodeToNode _ccfg _version = KeyHash.toCBOR . unPerasVoterId decodeNodeToNode _ccfg _version = PerasVoterId <$> KeyHash.fromCBOR @@ -239,6 +214,14 @@ instance SerialiseNodeToNode blk (PerasVoteId blk) where pviVoterId <- decodeNodeToNode ccfg version pure $ PerasVoteId pviRoundNo pviVoterId +instance SerialiseNodeToNode blk (VoidPerasVote blk) where + encodeNodeToNode _ _ = absurd . unVoidPerasVote + decodeNodeToNode _ _ = fail "VoidPerasVote cannot be decoded" + +instance SerialiseNodeToNode blk (VoidPerasCert blk) where + encodeNodeToNode _ _ = absurd . unVoidPerasCert + decodeNodeToNode _ _ = fail "VoidPerasCert cannot be decoded" + deriving newtype instance SerialiseNodeToClient blk (GenTxId blk) => SerialiseNodeToClient blk (WrapGenTxId blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs index dd38e82ce3..86a2f7adf6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -187,10 +187,14 @@ newtype PerasVoterId = PerasVoterId { unPerasVoterId :: KeyHash StakePool } - deriving newtype NoThunks + deriving newtype (NoThunks, NFData, FromCBOR, ToCBOR) deriving stock (Eq, Ord, Generic) deriving Show via Quiet PerasVoterId +instance Serialise PerasVoterId where + encode = toCBOR . unPerasVoterId + decode = PerasVoterId <$> fromCBOR + -- | Voting stake distribution for a Peras election newtype PerasVoteStakeDistr = PerasVoteStakeDistr diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs index 8b4d66cfa3..d9f82e7a71 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs @@ -12,6 +12,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -- | Peras vote aggregation and certificate forging @@ -111,15 +112,53 @@ data PerasRoundVoteState blk = PerasRoundVoteState { prvsRoundNo :: !PerasRoundNo , prvsState :: !(Either (NoQuorum blk) (Quorum blk)) } - deriving stock (Generic, Eq, Show) - deriving anyclass NoThunks + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (PerasRoundVoteState blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + , Eq (PerasCert blk) + ) => + Eq (PerasRoundVoteState blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + ) => + NoThunks (PerasRoundVoteState blk) +deriving instance + Generic (PerasRoundVoteState blk) -- | Current vote state when a quorum has not yet been reached data NoQuorum blk = NoQuorum { candidateStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Candidate)) } - deriving stock (Generic, Eq, Show) - deriving anyclass NoThunks + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (NoQuorum blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + , Eq (PerasCert blk) + ) => + Eq (NoQuorum blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + ) => + NoThunks (NoQuorum blk) +deriving instance + Generic (NoQuorum blk) -- | Current vote state when a quorum has been reached data Quorum blk = Quorum @@ -127,8 +166,27 @@ data Quorum blk = Quorum , loserStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Loser)) , winnerState :: !(PerasTargetVoteState blk 'Winner) } - deriving stock (Generic, Eq, Show) - deriving anyclass NoThunks + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (Quorum blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + , Eq (PerasCert blk) + ) => + Eq (Quorum blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + ) => + NoThunks (Quorum blk) +deriving instance + Generic (Quorum blk) -- | Get the round number of a round vote state getPerasRoundVoteStateRound :: PerasRoundVoteState blk -> PerasRoundNo @@ -192,7 +250,7 @@ data UpdateRoundVoteStateError blk (PerasTargetVoteState blk 'Winner) (PerasTargetVoteState blk 'Loser) | RoundVoteStateForgingCertError - (PerasForgeErr blk) + (PerasError blk) -- | Add a vote to an existing round vote aggregate. -- @@ -202,7 +260,7 @@ data UpdateRoundVoteStateError blk -- quorum) or if forging the certificate fails. updatePerasRoundVoteState :: forall blk. - StandardHash blk => + BlockSupportsPeras blk => WithArrivalTime (ValidatedPerasVote blk) -> PerasParams -> PerasRoundVoteState blk -> @@ -322,7 +380,7 @@ updatePerasRoundVoteState vote params roundState = -- quorum) or if forging the certificate fails. updatePerasRoundVoteStates :: forall blk. - StandardHash blk => + BlockSupportsPeras blk => WithArrivalTime (ValidatedPerasVote blk) -> PerasParams -> Map PerasRoundNo (PerasRoundVoteState blk) -> @@ -416,8 +474,27 @@ data PerasTargetVoteTally blk = PerasTargetVoteTally , ptvtTotalStake :: !PerasVoteStake -- ^ Total stake of the votes received for this target } - deriving stock (Generic, Eq, Show) - deriving anyclass NoThunks + +deriving instance + ( StandardHash blk + , Show (PerasVoteTarget blk) + , Show (ValidatedPerasVote blk) + ) => + Show (PerasTargetVoteTally blk) +deriving instance + ( StandardHash blk + , Eq (PerasVoteTarget blk) + , Eq (ValidatedPerasVote blk) + ) => + Eq (PerasTargetVoteTally blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVoteTarget blk) + , NoThunks (ValidatedPerasVote blk) + ) => + NoThunks (PerasTargetVoteTally blk) +deriving instance + Generic (PerasTargetVoteTally blk) freshTargetVoteTally :: PerasVoteTarget blk -> PerasTargetVoteTally blk freshTargetVoteTally target = @@ -432,7 +509,9 @@ freshTargetVoteTally target = -- -- PRECONDITION: the vote's target must match the tally's target. updateTargetVoteTally :: - StandardHash blk => + ( StandardHash blk + , IsPerasVote (PerasVote blk) blk + ) => WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteTally blk -> PerasTargetVoteTally blk @@ -541,7 +620,6 @@ ptvsVoteTally = \case PerasTargetVoteLoser tally -> tally PerasTargetVoteWinner tally _ -> tally - freshCandidateVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Candidate freshCandidateVoteState target = PerasTargetVoteCandidate (freshTargetVoteTally target) @@ -570,12 +648,12 @@ data PerasVoteStateCandidateOrWinner blk -- -- May fail if the candidate is elected winner but forging the certificate fails. updateCandidateVoteState :: - StandardHash blk => + BlockSupportsPeras blk => PerasParams -> WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Candidate -> Either - (PerasForgeErr blk) + (PerasError blk) (PerasVoteStateCandidateOrWinner blk) updateCandidateVoteState params vote oldState = let @@ -595,7 +673,9 @@ updateCandidateVoteState params vote oldState = -- -- May fail if the loser goes above quorum by adding the vote. updateLoserVoteState :: - StandardHash blk => + ( StandardHash blk + , IsPerasVote (PerasVote blk) blk + ) => PerasParams -> WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Loser -> @@ -612,7 +692,9 @@ updateLoserVoteState params vote oldState = -- -- PRECONDITION: the vote's target must match the underlying tally's target. updateWinnerVoteState :: - StandardHash blk => + ( StandardHash blk + , IsPerasVote (PerasVote blk) blk + ) => WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Winner -> PerasTargetVoteState blk 'Winner diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs index 59168bbcd0..d088bae441 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs @@ -38,6 +38,8 @@ import Ouroboros.Consensus.Block.SupportsPeras , PerasCooldownRounds (..) , PerasIgnoranceRounds (..) , PerasParams (..) + , PerasRoundNo (..) + , onPerasRoundNo ) import Ouroboros.Consensus.Peras.Voting.View ( LatestCertOnChainView (..) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs index d762574af7..9454cb46d8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -42,7 +43,9 @@ import Ouroboros.Consensus.Block.Abstract , castPoint ) import Ouroboros.Consensus.Block.SupportsPeras - ( ValidatedPerasCert, IsPerasCert (..) + ( BlockSupportsPeras (..) + , IsPerasCert (..) + , ValidatedPerasCert ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( WithArrivalTime (..) @@ -220,6 +223,7 @@ forgetBoostedBlockStatus = \case mkPerasVotingView :: ( cert ~ WithArrivalTime (ValidatedPerasCert blk) , GetHeader blk + , IsPerasCert (PerasCert blk) blk ) => -- | Peras protocol parameters PerasParams -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs index de345e8de0..751860e3e6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -28,6 +28,9 @@ module Ouroboros.Consensus.Peras.Weight , weightBoostOfFragment , totalWeightOfFragment , takeVolatileSuffix + + -- * Re-exports + , PerasWeight (..) ) where import Data.Foldable as Foldable (foldl') 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 1e86e9df06..0b04e7a088 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 @@ -103,6 +103,7 @@ withDB :: , LedgerSupportsProtocol blk , LedgerSupportsPeras blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -119,6 +120,7 @@ openDB :: , LedgerSupportsProtocol blk , LedgerSupportsPeras blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash blk @@ -134,6 +136,7 @@ openDBInternal :: , LedgerSupportsProtocol blk , LedgerSupportsPeras blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , InspectLedger blk , HasHardForkHistory blk , ConvertRawHash 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 817c8137e2..a25c1d8639 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 @@ -91,6 +91,7 @@ import System.Random launchBgTasks :: forall m blk. ( IOLike m + , IsPerasCert (PerasCert blk) blk , LedgerSupportsProtocol blk , BlockSupportsDiffusionPipelining blk , InspectLedger blk @@ -571,6 +572,7 @@ dumpGcSchedule (GcSchedule varQueue) = toList <$> readTVar varQueue -- ChainDB. addBlockRunner :: ( IOLike m + , IsPerasCert (PerasCert blk) blk , LedgerSupportsProtocol blk , BlockSupportsDiffusionPipelining blk , InspectLedger blk 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 9dfa1ca4c2..a97509e061 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 @@ -301,7 +301,9 @@ addBlockAsync CDB{cdbTracer, cdbChainSelQueue} = addPerasCertAsync :: forall m blk. - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => ChainDbEnv m blk -> WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) @@ -313,7 +315,9 @@ addPerasCertAsync CDB{cdbTracer, cdbChainSelQueue} = -- the ChainDB as well. addPerasVoteWithAsyncCertHandling :: forall m blk. - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => ChainDbEnv m blk -> WithArrivalTime (ValidatedPerasVote blk) -> m (Maybe (AddPerasCertPromise m)) @@ -345,6 +349,7 @@ triggerChainSelectionAsync CDB{cdbTracer, cdbChainSelQueue} = chainSelSync :: forall m blk. ( IOLike m + , IsPerasCert (PerasCert blk) blk , LedgerSupportsProtocol blk , BlockSupportsDiffusionPipelining blk , InspectLedger blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index def5127dea..ade24f0213 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -637,7 +637,9 @@ addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish -- | Add a Peras certificate to the background queue. addPerasCertToQueue :: - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => Tracer m (TraceAddPerasCertEvent blk) -> ChainSelQueue m blk -> WithArrivalTime (ValidatedPerasCert blk) -> @@ -792,9 +794,11 @@ data TraceEvent blk deriving instance ( Show (Header blk) + , Show (TraceAddBlockEvent blk) + , Show (PerasVote blk) + , Show (PerasCert blk) , LedgerSupportsProtocol blk , InspectLedger blk - , Show (TraceAddBlockEvent blk) ) => Show (TraceEvent blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs index 963890c5bf..045a692fa6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Ouroboros.Consensus.Storage.PerasCertDB.API @@ -110,7 +111,9 @@ data AddPerasCertResult -- | After adding a cert, its round number should be present in 'getCertIds'. prop_addCertThenGetCertIds :: - MonadSTM m => + ( MonadSTM m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDB m blk -> WithArrivalTime (ValidatedPerasCert blk) -> m Bool @@ -125,7 +128,9 @@ prop_addCertThenGetCertIds db cert = -- | 'getCertsAfter' with ticket 0 should return all certs in the database. -- NOTE: this property is not purely STM. prop_getCertsAfterZero :: - MonadSTM m => + ( MonadSTM m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDB m blk -> m Bool prop_getCertsAfterZero db = do @@ -160,7 +165,9 @@ prop_getCertsAfterMonotonic db ticketNo = -- | After garbage collection for slot S, no certs with target slot < S should remain. -- NOTE: this property is not purely STM. prop_garbageCollectRemovesOldCerts :: - MonadSTM m => + ( MonadSTM m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDB m blk -> SlotNo -> m Bool @@ -176,7 +183,9 @@ prop_garbageCollectRemovesOldCerts db slotNo = do -- | After adding a cert, the round number reported by 'getLatestCertSeen' -- should be greater than or equal to its previous value. prop_addCertLatestCertSeenMonotonic :: - MonadSTM m => + ( MonadSTM m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDB m blk -> WithArrivalTime (ValidatedPerasCert blk) -> m Bool @@ -193,7 +202,9 @@ prop_addCertLatestCertSeenMonotonic db cert = -- | 'getLatestCertSeen' is not affected by garbage collection. prop_garbageCollectPreservesLatestCertSeen :: - (MonadSTM m, StandardHash blk) => + ( MonadSTM m + , Eq (PerasCert blk) + ) => PerasCertDB m blk -> SlotNo -> m Bool diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index c828a58034..aca2517b2f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -2,9 +2,12 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.PerasCertDB.Impl ( -- * Opening @@ -61,8 +64,15 @@ data PerasCertDbState blk = PerasCertDbState -- ^ The certificate with the highest round number that has been added to the -- db since it has been opened. } - deriving stock (Show, Generic) - deriving anyclass NoThunks + +deriving instance + Show (PerasCert blk) => + Show (PerasCertDbState blk) +deriving instance + NoThunks (PerasCert blk) => + NoThunks (PerasCertDbState blk) +deriving instance + Generic (PerasCertDbState blk) initialPerasCertDbState :: WithFingerprint (PerasCertDbState blk) initialPerasCertDbState = @@ -77,6 +87,7 @@ initialPerasCertDbState = -- | Check that the fields of 'PerasCertDbState' are in sync. invariantForPerasCertDbState :: + IsPerasCert (PerasCert blk) blk => WithFingerprint (PerasCertDbState blk) -> Either String () invariantForPerasCertDbState pcds = do checkEqual @@ -112,7 +123,15 @@ data TraceEvent blk AddPerasCertResult | GarbageCollected SlotNo - deriving stock (Show, Eq, Generic) + +deriving instance + Show (PerasCert blk) => + Show (TraceEvent blk) +deriving instance + Eq (PerasCert blk) => + Eq (TraceEvent blk) +deriving instance + Generic (TraceEvent blk) {------------------------------------------------------------------------------ Creating the database @@ -132,7 +151,7 @@ defaultArgs = createDB :: forall m blk. ( IOLike m - , StandardHash blk + , BlockSupportsPeras blk ) => Complete PerasCertDbArgs m blk -> m (PerasCertDB m blk) @@ -167,7 +186,9 @@ createDB args = do -- TODO: we will need to update this method with non-trivial validation logic -- see https://github.com/tweag/cardano-peras/issues/120 implAddCert :: - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDbEnv m blk -> WithArrivalTime (ValidatedPerasCert blk) -> STM m (m AddPerasCertResult) @@ -201,7 +222,10 @@ implAddCert PerasCertDbEnv{pcdbTracer, pcdbState} cert = do pure addPerasCertRes implGetWeightSnapshot :: - (IOLike m, StandardHash blk) => + ( IOLike m + , StandardHash blk + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk)) implGetWeightSnapshot PerasCertDbEnv{pcdbState} = do @@ -244,7 +268,9 @@ implGetLatestCertSeen PerasCertDbEnv{pcdbState} = do implGarbageCollect :: forall m blk. - IOLike m => + ( IOLike m + , IsPerasCert (PerasCert blk) blk + ) => PerasCertDbEnv m blk -> SlotNo -> STM m (m ()) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs index f1a4b95765..39cc4333cd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs @@ -6,6 +6,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.PerasVoteDB.API ( PerasVoteDB (..) @@ -33,6 +35,7 @@ import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set +import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class @@ -84,8 +87,21 @@ data AddPerasVoteResult blk = PerasVoteAlreadyInDB | AddedPerasVoteButDidntGenerateNewCert | AddedPerasVoteAndGeneratedNewCert (ValidatedPerasCert blk) - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass NoThunks + +deriving instance + Show (PerasCert blk) => + Show (AddPerasVoteResult blk) +deriving instance + Eq (PerasCert blk) => + Eq (AddPerasVoteResult blk) +deriving instance + Ord (PerasCert blk) => + Ord (AddPerasVoteResult blk) +deriving instance + NoThunks (PerasCert blk) => + NoThunks (AddPerasVoteResult blk) +deriving instance + Generic (AddPerasVoteResult blk) {------------------------------------------------------------------------------- Exceptions @@ -99,17 +115,27 @@ newtype BlockedPerasRoundWinner blk = BlockedPerasRoundWinner (Point blk, PerasVoteStake) deriving stock (Show, Eq) -data PerasVoteDbError blk - = -- | Attempted to add a vote that would lead to multiple winners for the - -- same round - MultipleWinnersInRound - PerasRoundNo - (ExistingPerasRoundWinner blk) - (BlockedPerasRoundWinner blk) - | -- | An error occurred while forging a certificate - ForgingCertError (PerasForgeErr blk) - deriving stock Show - deriving anyclass Exception +data PerasVoteDbError blk where + -- | Attempted to add a vote that would lead to multiple winners for the same round + MultipleWinnersInRound :: + PerasRoundNo -> + (ExistingPerasRoundWinner blk) -> + (BlockedPerasRoundWinner blk) -> + PerasVoteDbError blk + -- | An error occurred while forging a certificate + ForgingCertError :: + Show (PerasError blk) => + PerasError blk -> + PerasVoteDbError blk + +deriving instance + StandardHash blk => + Show (PerasVoteDbError blk) +deriving instance + ( StandardHash blk + , Typeable blk + ) => + Exception (PerasVoteDbError blk) -- * Invariants @@ -117,7 +143,9 @@ data PerasVoteDbError blk -- | After adding a vote, its ID should be present in 'getVoteIds'. prop_addVoteThenGetVoteIds :: - MonadSTM m => + ( MonadSTM m + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDB m blk -> WithArrivalTime (ValidatedPerasVote blk) -> m Bool @@ -131,7 +159,9 @@ prop_addVoteThenGetVoteIds db vote = -- | 'getVotesAfter' with ticket 0 should return all votes in the database. prop_getVotesAfterZero :: - MonadSTM m => + ( MonadSTM m + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDB m blk -> m Bool prop_getVotesAfterZero db = @@ -162,7 +192,9 @@ prop_getVotesAfterMonotonic db ticketNo = -- | After garbage collection for slot S, no votes with target slot < S should remain. prop_garbageCollectRemovesOldVotes :: - MonadSTM m => + ( MonadSTM m + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDB m blk -> SlotNo -> m Bool @@ -177,7 +209,10 @@ prop_garbageCollectRemovesOldVotes db slotNo = -- | When adding a vote results in a certificate just being forged for a round, -- this certificate should also be retrievable via 'getForgedCertForRound'. prop_addVoteThenGetForgedCertForRound :: - (MonadSTM m, StandardHash blk) => + ( MonadSTM m + , Eq (PerasCert blk) + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDB m blk -> WithArrivalTime (ValidatedPerasVote blk) -> m Bool diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index 4c1ffd425a..8ef8170af1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -6,7 +6,10 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.PerasVoteDB.Impl ( -- * Opening @@ -21,7 +24,6 @@ module Ouroboros.Consensus.Storage.PerasVoteDB.Impl import Control.Monad (when) import Control.Monad.Except (throwError) import Control.Tracer (Tracer, nullTracer, traceWith) -import Data.Data (Typeable) import Data.Foldable (for_) import Data.Foldable qualified as Foldable import Data.Kind (Type) @@ -61,8 +63,27 @@ data PerasVoteDbState blk = PerasVoteDbState , pvdsLastTicketNo :: !PerasVoteTicketNo -- ^ The most recent 'PerasVoteTicketNo' (or 'zeroPerasVoteTicketNo' otherwise). } - deriving stock (Show, Generic) - deriving anyclass NoThunks + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (PerasVoteDbState blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + , Eq (PerasCert blk) + ) => + Eq (PerasVoteDbState blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + ) => + NoThunks (PerasVoteDbState blk) +deriving instance + Generic (PerasVoteDbState blk) initialPerasVoteDbState :: WithFingerprint (PerasVoteDbState blk) initialPerasVoteDbState = @@ -77,6 +98,7 @@ initialPerasVoteDbState = -- | Check that the fields of 'PerasVoteState' are in sync. invariantForPerasVoteDbState :: + IsPerasVote (PerasVote blk) blk => WithFingerprint (PerasVoteDbState blk) -> Either String () invariantForPerasVoteDbState pvs = do for_ (Map.toList pvdsRoundVoteStates) $ \(roundNo, prvs) -> @@ -118,7 +140,27 @@ data TraceEvent blk (AddPerasVoteResult blk) | GarbageCollected SlotNo - deriving stock (Show, Eq, Generic) + +deriving instance + ( Show (PerasVoteId blk) + , Show (ValidatedPerasVote blk) + , Show (AddPerasVoteResult blk) + ) => + Show (TraceEvent blk) +deriving instance + ( Eq (PerasVoteId blk) + , Eq (ValidatedPerasVote blk) + , Eq (AddPerasVoteResult blk) + ) => + Eq (TraceEvent blk) +deriving instance + ( NoThunks (PerasVoteId blk) + , NoThunks (ValidatedPerasVote blk) + , NoThunks (AddPerasVoteResult blk) + ) => + NoThunks (TraceEvent blk) +deriving instance + Generic (TraceEvent blk) {------------------------------------------------------------------------------ Creating the database @@ -140,8 +182,7 @@ defaultArgs = createDB :: forall m blk. ( IOLike m - , StandardHash blk - , Typeable blk + , BlockSupportsPeras blk ) => Complete PerasVoteDbArgs m blk -> m (PerasVoteDB m blk) @@ -176,8 +217,7 @@ createDB args@PerasVoteDbArgs{pvdbaPerasParams} = do -- see https://github.com/tweag/cardano-peras/issues/120 implAddVote :: ( IOLike m - , StandardHash blk - , Typeable blk + , BlockSupportsPeras blk ) => PerasParams -> PerasVoteDbEnv m blk -> @@ -281,7 +321,9 @@ implGetForgedCertForRound PerasVoteDbEnv{pvdeState} roundNo = do implGarbageCollect :: forall m blk. - IOLike m => + ( IOLike m + , IsPerasVote (PerasVote blk) blk + ) => PerasVoteDbEnv m blk -> SlotNo -> STM m (m ()) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index 6dcef59082..ec3e8a6259 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -23,6 +23,7 @@ import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MultiSet import Data.SOP.BasicFunctors import Data.Typeable (Typeable) +import Data.Void (Void) import NoThunks.Class ( InspectHeap (..) , InspectHeapNamed (..) @@ -107,3 +108,9 @@ deriving via OnlyCheckWhnfNamed "SomeHasFS" (SomeHasFS m) instance NoThunks (SomeHasFS m) + +{------------------------------------------------------------------------------- + ShowProxy +-------------------------------------------------------------------------------} + +instance ShowProxy Void diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index d221f7131a..a7dff10c5f 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -114,8 +114,15 @@ import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.NodeId -import Ouroboros.Consensus.Peras.Params (mkPerasParams, perasRoundLength) -import Ouroboros.Consensus.Peras.Types (PerasRoundNo (..)) +import Ouroboros.Consensus.Peras.Cert.Mock + ( MockPerasCert (..) + , forgeMockPerasCert + , validateMockPerasCert + ) +import Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + , validateMockPerasVote + ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT import Ouroboros.Consensus.Protocol.ModChainSel @@ -623,22 +630,18 @@ instance ApplyBlock LedgerState TestBlock where TestLedger (Chain.blockPoint tb) (BlockHash (blockHash tb)) - ( let - -- NOTE: this bypasses the degenerate global implementation of - -- 'BlockSupportsPeras.getPerasCertInBlock' for 'TestBlock', - -- which currently always returns 'Nothing'. - -- - -- TODO: refactor this to use 'getPerasCertInBlock' after the - -- HFC plumbing for 'BlockSupportsPeras' is in place. - certRoundInBlock = tbPerasCertRound testBody - in - -- the highest Peras certificate round number we've seen so far - case (certRoundInBlock, latestPerasCertRound) of - (Nothing, Nothing) -> Nothing - (Just rb, Nothing) -> Just rb - (Nothing, Just rl) -> Just rl - (Just rb, Just rl) -> Just (rb `max` rl) - ) + latestPerasCertRound' + where + -- The round number of the Peras certificate stored in this block, if any + perasCertRoundInBlock = + getPerasCertRound <$> getPerasCertInBlock tb + -- The highest Peras certificate round number we've seen so far + latestPerasCertRound' = + case (perasCertRoundInBlock, latestPerasCertRound) of + (Nothing, Nothing) -> Nothing + (Just rb, Nothing) -> Just rb + (Nothing, Just rl) -> Just rl + (Just rb, Just rl) -> Just (rb `max` rl) applyBlockLedgerResult = defaultApplyBlockLedgerResult reapplyBlockLedgerResult = @@ -726,6 +729,22 @@ instance LedgerSupportsProtocol TestBlock where instance LedgerSupportsPeras TestBlock where getLatestPerasCertRound = latestPerasCertRound +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: this is a mocked up implementation without crypto! + +instance BlockSupportsPeras TestBlock where + type PerasVote TestBlock = MockPerasVote TestBlock + type PerasCert TestBlock = MockPerasCert TestBlock + type PerasError TestBlock = VoidPerasError TestBlock + + validatePerasVote = validateMockPerasVote + validatePerasCert = validateMockPerasCert + forgePerasCert = forgeMockPerasCert + getPerasCertInBlock = tbPerasCert . testBody + instance HasHardForkHistory TestBlock where type HardForkIndices TestBlock = '[TestBlock] hardForkSummary = neverForksHardForkSummary id diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index 10dec54605..34a7aee03d 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -22,8 +22,8 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mempool.API import Ouroboros.Consensus.Mempool.TxSeq -import Ouroboros.Consensus.Peras.Params (PerasWeight) -import Ouroboros.Consensus.Peras.Types (PerasRoundNo) +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..)) import Ouroboros.Consensus.Storage.ImmutableDB @@ -126,12 +126,17 @@ deriving anyclass instance ToExpr PerasRoundNo deriving anyclass instance ToExpr PerasWeight -deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (PerasCert blk) +deriving anyclass instance ToExpr PerasVoteStake -deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (ValidatedPerasCert blk) +deriving anyclass instance ToExpr (PerasVoteId blk) deriving anyclass instance ToExpr a => ToExpr (WithArrivalTime a) +instance ToExpr PerasVoterId where toExpr = defaultExprViaShow + +instance ToExpr (HeaderHash blk) => ToExpr (MockPerasVote blk) +instance ToExpr (HeaderHash blk) => ToExpr (MockPerasCert blk) + {------------------------------------------------------------------------------- si-timers --------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index ab7c7d4682..63e0f721e7 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -142,7 +142,16 @@ import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Cert.Mock + ( MockPerasCert (..) + , forgeMockPerasCert + , validateMockPerasCert + ) import Ouroboros.Consensus.Peras.SelectView (weightedSelectView) +import Ouroboros.Consensus.Peras.Vote.Mock + ( MockPerasVote (..) + , validateMockPerasVote + ) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT @@ -694,6 +703,31 @@ instance PayloadSemantics ptype => LedgerSupportsProtocol (TestBlockWith ptype) instance LedgerSupportsPeras (TestBlockWith ptype) +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: this is a mocked up implementation without crypto! + +instance + Typeable ptype => + BlockSupportsPeras (TestBlockWith ptype) + where + type PerasVote (TestBlockWith ptype) = MockPerasVote (TestBlockWith ptype) + type PerasCert (TestBlockWith ptype) = MockPerasCert (TestBlockWith ptype) + type PerasError (TestBlockWith ptype) = VoidPerasError (TestBlockWith ptype) + + validatePerasVote = validateMockPerasVote + validatePerasCert = validateMockPerasCert + forgePerasCert = forgeMockPerasCert + + -- TODO: extract actual Peras certificates from blocks + getPerasCertInBlock _ = Nothing + +{------------------------------------------------------------------------------- + Test infrastructure: config +-------------------------------------------------------------------------------} + singleNodeTestConfigWith :: CodecConfig (TestBlockWith ptype) -> StorageConfig (TestBlockWith ptype) -> diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs new file mode 100644 index 0000000000..1452104da8 --- /dev/null +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Empty Peras support for the mock block. +-- +-- NOTE: this module exists solely because the orphan module +-- 'Ouroboros.Consensus.Mock.Node.Serialisation' needs this instance, but +-- defining it there would be too confusing. +module Ouroboros.Consensus.Mock.Node.Peras () where + +import Data.Typeable (Typeable) +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras (..)) +import Ouroboros.Consensus.Mock.Ledger.Block (SimpleBlock, SimpleCrypto) + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: The mock block does not support Peras, so we can use the empty instance here. +instance + (SimpleCrypto c, Typeable ext) => + BlockSupportsPeras (SimpleBlock c ext) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Serialisation.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Serialisation.hs index f5a00a8964..6642141ec4 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Serialisation.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Serialisation.hs @@ -27,6 +27,7 @@ import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Mock.Node.Abstract +import Ouroboros.Consensus.Mock.Node.Peras () import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index 65fbddf3ae..15cc9a5d92 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke @@ -23,8 +25,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert -import Ouroboros.Consensus.Peras.Params (mkPerasParams, perasWeight) -import Ouroboros.Consensus.Peras.Types (PerasRoundNo (..)) +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Storage.PerasCertDB.API ( AddPerasCertResult (..) , PerasCertDB @@ -33,7 +34,6 @@ import Ouroboros.Consensus.Storage.PerasCertDB.API import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Network.Block (StandardHash) import Ouroboros.Network.Protocol.ObjectDiffusion.Codec import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound ( objectDiffusionInboundPeerPipelined @@ -64,15 +64,22 @@ tests = genPerasCert :: Gen (PerasCert TestBlock) genPerasCert = do - pcCertRound <- PerasRoundNo <$> arbitrary - pcCertBlock <- genPointTestBlock - pure $ PerasCert{pcCertRound, pcCertBlock} + mockCertRound <- PerasRoundNo <$> arbitrary + mockCertBlock <- genPointTestBlock + pure $ + MockPerasCert + { mockCertRound + , mockCertBlock + } -instance WithId (PerasCert blk) PerasRoundNo where - getId = pcCertRound +instance WithId (MockPerasCert blk) PerasRoundNo where + getId = getPerasCertRound -instance WithId (WithArrivalTime (ValidatedPerasCert blk)) PerasRoundNo where - getId = pcCertRound . vpcCert . forgetArrivalTime +instance + IsPerasCert (PerasCert blk) blk => + WithId (WithArrivalTime (ValidatedPerasCert blk)) PerasRoundNo + where + getId = getPerasCertRound . vpcCert . forgetArrivalTime genValidatedPerasCert :: Gen (ValidatedPerasCert TestBlock) genValidatedPerasCert = @@ -81,7 +88,10 @@ genValidatedPerasCert = <*> pure (perasWeight mkPerasParams) newCertDB :: - (IOLike m, StandardHash blk) => [WithArrivalTime (ValidatedPerasCert blk)] -> m (PerasCertDB m blk) + ( IOLike m + , BlockSupportsPeras blk + ) => + [WithArrivalTime (ValidatedPerasCert blk)] -> m (PerasCertDB m blk) newCertDB certs = do db <- PerasCertDB.createDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) mapM_ diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs index a5b8ded77c..058fa9fca9 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke @@ -16,7 +18,6 @@ import qualified Cardano.Crypto.Seed as SL import qualified Cardano.Ledger.Keys as SL import Control.Monad (join) import Control.Tracer (contramap, nullTracer) -import Data.Data (Typeable) import qualified Data.Map as Map import Data.Ratio ((%)) import Data.String (IsString (..)) @@ -28,14 +29,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote -import Ouroboros.Consensus.Peras.Params (mkPerasParams) -import Ouroboros.Consensus.Peras.Types - ( PerasRoundNo (..) - , PerasVoteId (..) - , PerasVoteStake (..) - , PerasVoteStakeDistr (..) - , PerasVoterId (..) - ) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB @@ -44,7 +38,6 @@ import Ouroboros.Consensus.Storage.PerasVoteDB ) import qualified Ouroboros.Consensus.Storage.PerasVoteDB as PerasVoteDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Network.Block (StandardHash) import Ouroboros.Network.Protocol.ObjectDiffusion.Codec import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound ( objectDiffusionInboundPeerPipelined @@ -88,25 +81,40 @@ genPerasVoteStake = do genPerasVote :: Gen (PerasVote TestBlock) genPerasVote = do - pvVoteRound <- PerasRoundNo <$> arbitrary - pvVoteBlock <- genPointTestBlock - pvVoteVoterId <- genPerasVoterId - pure $ PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} + mockVoteRound <- PerasRoundNo <$> arbitrary + mockVoteBlock <- genPointTestBlock + mockVoteVoterId <- genPerasVoterId + mockVoteStake <- genPerasVoteStake + pure $ + MockPerasVote + { mockVoteRound + , mockVoteBlock + , mockVoteVoterId + , mockVoteStake + } -instance WithId (PerasVote blk) (PerasVoteId blk) where +instance WithId (MockPerasVote blk) (PerasVoteId blk) where getId = getPerasVoteId -instance WithId (WithArrivalTime (ValidatedPerasVote blk)) (PerasVoteId blk) where +instance + IsPerasVote (PerasVote blk) blk => + WithId (WithArrivalTime (ValidatedPerasVote blk)) (PerasVoteId blk) + where getId = getPerasVoteId . vpvVote . forgetArrivalTime genValidatedPerasVote :: Gen (ValidatedPerasVote TestBlock) -genValidatedPerasVote = - ValidatedPerasVote - <$> genPerasVote - <*> genPerasVoteStake +genValidatedPerasVote = do + mockVote <- genPerasVote + pure + ValidatedPerasVote + { vpvVote = mockVote + , vpvVoteStake = mockVoteStake mockVote + } newVoteDB :: - (IOLike m, StandardHash blk, Typeable blk) => + ( IOLike m + , BlockSupportsPeras blk + ) => [WithArrivalTime (ValidatedPerasVote blk)] -> m (PerasVoteDB m blk) newVoteDB votes = do db <- PerasVoteDB.createDB (PerasVoteDB.PerasVoteDbArgs nullTracer mkPerasParams) @@ -139,16 +147,10 @@ prop_smoke = inboundPool <- newVoteDB [] let outboundPoolReader = makePerasVotePoolReaderFromVoteDB outboundPool - stakeDistr = - PerasVoteStakeDistr $ - Map.fromList - [ (pvVoteVoterId (vpvVote v), vpvVoteStake v) - | WithArrivalTime _ v <- watValidatedVotes - ] inboundPoolWriter = makePerasVotePoolWriterFromVoteDB mockSystemTime - (pure stakeDistr) + (pure (PerasVoteStakeDistr mempty)) -- mocked votes are self-validating inboundPool getAllInboundPoolContent = do votesMap <- diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs index 32296cff34..27c088ac1f 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs index 3c60654103..aeb7c50086 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} @@ -26,7 +27,12 @@ import Ouroboros.Consensus.Block.SupportsPeras , PerasCooldownRounds (..) , PerasIgnoranceRounds (..) , PerasParams (..) + , PerasRoundNo (..) , mkPerasParams + , onPerasRoundNo + ) +import Ouroboros.Consensus.BlockchainTime + ( RelativeTime (..) ) import Ouroboros.Consensus.Peras.Voting.Rules ( PerasVotingRulesDecision (..) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 41357239e3..678aa5155f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -9,6 +9,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Model implementation of the chain DB @@ -113,7 +114,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Ledger.SupportsProtocol -import Ouroboros.Consensus.Peras.Params (PerasWeight (..), mkPerasParams) +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert) import Ouroboros.Consensus.Peras.SelectView import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract @@ -183,12 +184,20 @@ deriving instance , ToExpr (Chain blk) , ToExpr (ChainProducerState blk) , ToExpr (ExtLedgerState blk EmptyMK) + , Show (PerasCert blk) + , Show (PerasVote blk) , StandardHash blk , Show blk ) => ToExpr (Model blk) -deriving instance (LedgerSupportsProtocol blk, Show blk) => Show (Model blk) +deriving instance + ( LedgerSupportsProtocol blk + , Show (PerasVote blk) + , Show (PerasCert blk) + , Show blk + ) => + Show (Model blk) {------------------------------------------------------------------------------- Queries @@ -260,7 +269,11 @@ getMaxSlotNo = foldMap (MaxSlotNo . blockSlot) . blocks -- * After VolatileDB corruption, the whole chain might have more than weight -- @k@, but the tip of the ImmutableDB might be buried under significantly -- less than weight @k@ worth of blocks. -maxActualRollback :: HasHeader blk => SecurityParam -> Model blk -> PerasWeight +maxActualRollback :: + ( HasHeader blk + , IsPerasCert (PerasCert blk) blk + ) => + SecurityParam -> Model blk -> PerasWeight maxActualRollback k m = foldMap' (weightBoostOfPoint weights) . takeWhile (/= immutableTipPoint) @@ -288,7 +301,9 @@ maxActualRollback k m = -- ImmutableDB to know the most recent \"immutable\" block. immutableChain :: forall blk. - HasHeader blk => + ( HasHeader blk + , IsPerasCert (PerasCert blk) blk + ) => SecurityParam -> Model blk -> Chain blk @@ -328,7 +343,10 @@ immutableChain k m = -- 2. The suffix of the current chain not part of the 'immutableDbChain', i.e., -- the \"ImmutableDB\". volatileChain :: - (HasHeader a, HasHeader blk) => + ( HasHeader a + , HasHeader blk + , IsPerasCert (PerasCert blk) blk + ) => SecurityParam -> -- | Provided since 'AnchoredFragment' is not a functor (blk -> a) -> @@ -353,7 +371,9 @@ volatileChain k f m = -- because the background thread copying blocks to the ImmutableDB might not -- have caught up. immutableBlockNo :: - HasHeader blk => + ( HasHeader blk + , IsPerasCert (PerasCert blk) blk + ) => SecurityParam -> Model blk -> WithOrigin BlockNo immutableBlockNo k = Chain.headBlockNo . immutableChain k @@ -363,7 +383,9 @@ immutableBlockNo k = Chain.headBlockNo . immutableChain k -- This is used for garbage collection of the VolatileDB, which is done in -- terms of slot numbers, not in terms of block numbers. immutableSlotNo :: - HasHeader blk => + ( HasHeader blk + , IsPerasCert (PerasCert blk) blk + ) => SecurityParam -> Model blk -> WithOrigin SlotNo @@ -396,11 +418,20 @@ isValid = flip getIsValid getLoEFragment :: Model blk -> LoE (AnchoredFragment blk) getLoEFragment = loeFragment -perasWeights :: StandardHash blk => Model blk -> PerasWeightSnapshot blk -perasWeights = PerasCertDBModel.getWeightSnapshot . perasCertModel +perasWeights :: + ( StandardHash blk + , IsPerasCert (PerasCert blk) blk + ) => + Model blk -> PerasWeightSnapshot blk +perasWeights = + PerasCertDBModel.getWeightSnapshot . perasCertModel -roundNoOfLatestCertSeen :: Model blk -> Maybe PerasRoundNo -roundNoOfLatestCertSeen m = getPerasCertRound <$> PerasCertDBModel.getLatestCertSeen (perasCertModel m) +roundNoOfLatestCertSeen :: + IsPerasCert (PerasCert blk) blk => + Model blk -> Maybe PerasRoundNo +roundNoOfLatestCertSeen m = + getPerasCertRound + <$> PerasCertDBModel.getLatestCertSeen (perasCertModel m) {------------------------------------------------------------------------------- Construction @@ -429,7 +460,10 @@ empty loe initLedger = addBlock :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> blk -> Model blk -> @@ -458,7 +492,11 @@ addBlock cfg blk m addPerasCert :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , Ord (PerasCert blk) + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> WithArrivalTime (ValidatedPerasCert blk) -> Model blk -> @@ -468,7 +506,14 @@ addPerasCert cfg cert m = addPerasVote :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , Ord (PerasVote blk) + , Ord (PerasCert blk) + , PerasCert blk ~ MockPerasCert blk + , IsPerasVote (PerasVote blk) blk + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> WithArrivalTime (ValidatedPerasVote blk) -> Model blk -> @@ -486,6 +531,7 @@ chainSelection :: forall blk. ( LedgerTablesAreTrivial ExtLedgerState blk , LedgerSupportsProtocol blk + , IsPerasCert (PerasCert blk) blk ) => TopLevelConfig blk -> Model blk -> @@ -613,7 +659,10 @@ chainSelection cfg m = consideredCandidates addBlocks :: - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> [blk] -> Model blk -> @@ -623,7 +672,11 @@ addBlocks cfg = repeatedly (addBlock cfg) -- | Wrapper around 'addBlock' that returns an 'AddBlockPromise'. addBlockPromise :: forall m blk. - (LedgerSupportsProtocol blk, MonadSTM m, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , MonadSTM m + , LedgerTablesAreTrivial ExtLedgerState blk + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> blk -> Model blk -> @@ -646,6 +699,7 @@ updateLoE :: forall blk. ( LedgerTablesAreTrivial ExtLedgerState blk , LedgerSupportsProtocol blk + , IsPerasCert (PerasCert blk) blk ) => TopLevelConfig blk -> AnchoredFragment blk -> @@ -660,7 +714,7 @@ updateLoE cfg f m = (tipPoint m', m') -------------------------------------------------------------------------------} stream :: - GetPrevHash blk => + (GetPrevHash blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> StreamFrom blk -> StreamTo blk -> @@ -906,7 +960,10 @@ chains bs = go Chain.Genesis validChains :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> Model blk -> Map (HeaderHash blk) blk -> @@ -962,7 +1019,7 @@ successors = Map.unionsWith Map.union . map single between :: forall blk. - GetPrevHash blk => + (GetPrevHash blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> StreamFrom blk -> StreamTo blk -> @@ -1064,7 +1121,7 @@ between k from to m = do -- tip). garbageCollectable :: forall blk. - HasHeader blk => + (HasHeader blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> Model blk -> blk -> Bool garbageCollectable secParam m b = -- Note: we don't use the block number but the slot number, as the @@ -1080,7 +1137,7 @@ garbageCollectable secParam m b = -- case from a block that was never added to the model in the first place. garbageCollectablePoint :: forall blk. - HasHeader blk => + (HasHeader blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> Model blk -> RealPoint blk -> Bool garbageCollectablePoint secParam m pt | Just blk <- getBlock (realPointHash pt) m = @@ -1093,7 +1150,7 @@ garbageCollectablePoint secParam m pt -- garbage collected it. garbageCollectableIteratorNext :: forall blk. - ModelSupportsBlock blk => + (ModelSupportsBlock blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> Model blk -> IteratorId -> Bool garbageCollectableIteratorNext secParam m itId = case fst (iteratorNext itId GetBlock m) of @@ -1111,7 +1168,7 @@ garbageCollectableIteratorNext secParam m itId = -- used in isolation and is not exported. garbageCollect :: forall blk. - HasHeader blk => + (HasHeader blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> Model blk -> Model blk garbageCollect secParam m@Model{..} = m @@ -1137,7 +1194,7 @@ data ShouldGarbageCollect = GarbageCollect | DoNotGarbageCollect -- Idempotent. copyToImmutableDB :: forall blk. - HasHeader blk => + (HasHeader blk, IsPerasCert (PerasCert blk) blk) => SecurityParam -> ShouldGarbageCollect -> Model blk -> Model blk copyToImmutableDB secParam shouldCollectGarbage m = garbageCollectIf shouldCollectGarbage $ @@ -1161,7 +1218,10 @@ reopen m = m{isOpen = True} -- see https://github.com/tweag/cardano-peras/issues/122 wipeVolatileDB :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , IsPerasCert (PerasCert blk) blk + ) => TopLevelConfig blk -> Model blk -> (Point blk, Model blk) 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 12e83f3fb6..a66cd5d1db 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 @@ -15,6 +15,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -125,8 +127,8 @@ import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils -import Ouroboros.Consensus.Peras.Params (PerasWeight (..)) -import Ouroboros.Consensus.Peras.Types (PerasRoundNo (..)) +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB hiding ( TraceFollowerEvent (..) @@ -255,7 +257,17 @@ data Cmd blk it flr UpdateLedgerSnapshots | -- Corruption WipeVolatileDB - deriving (Generic, Show, Functor, Foldable, Traversable) + deriving (Generic, Functor, Foldable, Traversable) + +deriving instance + ( StandardHash blk + , Show blk + , Show it + , Show flr + , Show (PerasCert blk) + , Show (PerasVote blk) + ) => + Show (Cmd blk it flr) -- = Invalid blocks -- @@ -375,6 +387,9 @@ type TestConstraints blk = , LedgerTablesAreTrivial LedgerState blk , CanUpgradeLedgerTables LedgerState blk , ImmutableEraParams blk + , BlockSupportsPeras blk + , PerasVote blk ~ MockPerasVote blk + , PerasCert blk ~ MockPerasCert blk ) deriving instance @@ -1281,9 +1296,9 @@ generator loe genBlock genPerasBlock m@Model{..} = WithArrivalTime now $ ValidatedPerasCert { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBlock = blockPoint blk + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = blockPoint blk } , vpcCertBoost = boost } @@ -1315,10 +1330,11 @@ generator loe genBlock genPerasBlock m@Model{..} = WithArrivalTime now $ ValidatedPerasVote { vpvVote = - PerasVote - { pvVoteRound = roundNo - , pvVoteBlock = blockPoint blk - , pvVoteVoterId = voterId + MockPerasVote + { mockVoteRound = roundNo + , mockVoteBlock = blockPoint blk + , mockVoteVoterId = voterId + , mockVoteStake = stake } , vpvVoteStake = stake } @@ -1608,6 +1624,8 @@ deriving instance , ToExpr (ExtValidationError blk) , StandardHash blk , Show blk + , Show (PerasVote blk) + , Show (PerasCert blk) ) => ToExpr (Model blk IO Concrete) @@ -1757,7 +1775,7 @@ addPerasCertOutcomes = concatMap classifyEvent classifyEvent :: Event Blk m Symbolic -> [String] classifyEvent ev = case unAt (eventCmd ev) of AddPerasCert certWithTime _ -> - let targetPt = pcCertBlock (vpcCert (forgetArrivalTime certWithTime)) + let targetPt = getPerasCertBlock (vpcCert (forgetArrivalTime certWithTime)) in case (isBlockConnected targetPt (dbModel (eventBefore ev))) of False -> assert (chainSelOutcome ev == "no chain selection change") $ @@ -1775,7 +1793,7 @@ addPerasVoteOutcomes = concatMap classifyEvent classifyEvent :: Event Blk m Symbolic -> [String] classifyEvent ev = case unAt (eventCmd ev) of AddPerasVote voteWithTime _ -> - let targetPt = pvVoteBlock (vpvVote (forgetArrivalTime voteWithTime)) + let targetPt = getPerasVoteBlock (vpvVote (forgetArrivalTime voteWithTime)) certsBefore = numCerts (eventBefore ev) certsAfter = numCerts (eventAfter ev) certProduced = certsAfter > certsBefore diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs index b01244114f..7487edf5ef 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Test.Ouroboros.Storage.PerasCertDB.Model ( Model (..) @@ -31,9 +33,9 @@ data Model blk = Model } deriving Generic -deriving instance StandardHash blk => Show (Model blk) +deriving instance Show (PerasCert blk) => Show (Model blk) -instance StandardHash blk => ToExpr (Model blk) where +instance Show (PerasCert blk) => ToExpr (Model blk) where toExpr = defaultExprViaShow initModel :: Model blk @@ -43,7 +45,9 @@ openDB :: Model blk -> Model blk openDB model = model{open = True} addCert :: - StandardHash blk => + ( Ord (PerasCert blk) + , IsPerasCert (PerasCert blk) blk + ) => Model blk -> WithArrivalTime (ValidatedPerasCert blk) -> Model blk addCert model@Model{certs, latestCertSeen} cert | certs `hasRoundNo` cert = model @@ -57,6 +61,7 @@ addCert model@Model{certs, latestCertSeen} cert | otherwise -> Just prev hasRoundNo :: + IsPerasCert (PerasCert blk) blk => Set (WithArrivalTime (ValidatedPerasCert blk)) -> WithArrivalTime (ValidatedPerasCert blk) -> Bool @@ -64,7 +69,9 @@ hasRoundNo certs cert = (getPerasCertRound cert) `Set.member` (Set.map getPerasCertRound certs) getWeightSnapshot :: - StandardHash blk => + ( IsPerasCert (PerasCert blk) blk + , StandardHash blk + ) => Model blk -> PerasWeightSnapshot blk getWeightSnapshot Model{certs} = mkPerasWeightSnapshot @@ -77,7 +84,9 @@ getLatestCertSeen :: getLatestCertSeen Model{latestCertSeen} = latestCertSeen -garbageCollect :: SlotNo -> Model blk -> Model blk +garbageCollect :: + IsPerasCert (PerasCert blk) blk => + SlotNo -> Model blk -> Model blk garbageCollect slotNo model@Model{certs} = model{certs = Set.filter keepCert certs} where diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index 33e4621335..5833d57ad0 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -28,8 +28,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , WithArrivalTime (..) ) -import Ouroboros.Consensus.Peras.Params (PerasParams, mkPerasParams, perasWeight) -import Ouroboros.Consensus.Peras.Types (PerasRoundNo (..)) +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import Ouroboros.Consensus.Storage.PerasCertDB.API (AddPerasCertResult (..), PerasCertDB) @@ -93,9 +92,9 @@ instance StateModel Model where WithArrivalTime now $ ValidatedPerasCert { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBlock = boostedBlock + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = boostedBlock } , vpcCertBoost = perasWeight perasTestParams } diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs index a5089b50cf..5f03f35a03 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs @@ -1,4 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Test.Ouroboros.Storage.PerasVoteDB.Model ( PerasVoteDbModelError (..) @@ -22,13 +26,12 @@ import Data.TreeDiff (ToExpr (..), defaultExprViaShow) import GHC.Generics (Generic) import Ouroboros.Consensus.Block (SlotNo, WithOrigin (..), pointSlot) import Ouroboros.Consensus.Block.Abstract (StandardHash) -import Ouroboros.Consensus.Block.SupportsPeras (IsPerasCert (..), IsPerasVote (..), PerasCert (..), ValidatedPerasCert (..), ValidatedPerasVote (..)) -import Ouroboros.Consensus.BlockchainTime.WallClock.Types - ( WithArrivalTime (..) - ) -import Ouroboros.Consensus.Peras.Params (PerasParams, perasWeight) -import Ouroboros.Consensus.Peras.Types - ( PerasRoundNo +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , IsPerasCert (..) + , IsPerasVote (..) + , PerasParams + , PerasRoundNo , PerasVoteId (..) , PerasVoteStake (..) , PerasVoteTarget (..) @@ -54,7 +57,11 @@ data VoteEntry blk = VoteEntry , veVote :: WithArrivalTime (ValidatedPerasVote blk) -- ^ The vote itself } - deriving (Show, Eq, Ord, Generic) + +deriving instance Show (PerasVote blk) => Show (VoteEntry blk) +deriving instance Eq (PerasVote blk) => Eq (VoteEntry blk) +deriving instance Ord (PerasVote blk) => Ord (VoteEntry blk) +deriving instance Generic (VoteEntry blk) data PerasVoteDbModelError = MultipleWinnersInRound PerasRoundNo deriving (Show, Generic) @@ -71,9 +78,24 @@ data Model blk = Model , certs :: Map PerasRoundNo (ValidatedPerasCert blk) -- ^ Forged certificates indexed by round number } - deriving (Show, Generic) -instance StandardHash blk => ToExpr (Model blk) where +-- deriving (Show, Generic) + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (Model blk) +deriving instance Generic (Model blk) + +instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + ToExpr (Model blk) + where toExpr = defaultExprViaShow initModel :: PerasParams -> Model blk @@ -132,7 +154,12 @@ closeDB model = } addVote :: - StandardHash blk => + ( StandardHash blk + , Ord (PerasVote blk) + , PerasCert blk ~ MockPerasCert blk + , IsPerasVote (PerasVote blk) blk + , IsPerasCert (PerasCert blk) blk + ) => WithArrivalTime (ValidatedPerasVote blk) -> Model blk -> ( Either PerasVoteDbModelError (AddPerasVoteResult blk) @@ -248,9 +275,9 @@ addVote vote model freshCert = ValidatedPerasCert { vpcCert = - PerasCert - { pcCertRound = getPerasVoteRound vote - , pcCertBlock = getPerasVoteBlock vote + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = votedBlock } , vpcCertBoost = perasWeight (params model) } diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index ea2147f8bd..2dae37aa84 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -42,22 +42,21 @@ import GHC.Generics (Generic) import Ouroboros.Consensus.Block.Abstract (Point (..), SlotNo (..)) import Ouroboros.Consensus.Block.SupportsPeras ( IsPerasVote (..) - , PerasVote (..) + , PerasParams + , PerasRoundNo (..) + , PerasVoteId + , PerasVoteStake (..) + , PerasVoteTarget (..) + , PerasVoterId (..) , ValidatedPerasCert , ValidatedPerasVote (..) + , mkPerasParams ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , WithArrivalTime (..) ) -import Ouroboros.Consensus.Peras.Params (PerasParams, mkPerasParams) -import Ouroboros.Consensus.Peras.Types - ( PerasRoundNo (..) - , PerasVoteId - , PerasVoteStake (..) - , PerasVoteTarget (..) - , PerasVoterId (..) - ) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB @@ -91,7 +90,10 @@ import Test.QuickCheck.StateModel ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Test.Util.TestBlock (TestBlock, TestHash (..)) +import Test.Util.TestBlock + ( TestBlock + , TestHash (..) + ) import Test.Util.TestEnv (adjustQuickCheckMaxSize, adjustQuickCheckTests) tests :: TestTree @@ -186,10 +188,11 @@ instance StateModel Model where WithArrivalTime now $ ValidatedPerasVote { vpvVote = - PerasVote - { pvVoteRound = roundNo - , pvVoteBlock = point - , pvVoteVoterId = voterId + MockPerasVote + { mockVoteRound = roundNo + , mockVoteBlock = point + , mockVoteVoterId = voterId + , mockVoteStake = stake } , vpvVoteStake = stake } From 672c407c7a110c9ae673a8d2b6c146e56daca560 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 18 May 2026 14:24:41 +0200 Subject: [PATCH 24/62] Tweak TestBlock to use getPerasCertInBlock in tests Co-authored-by: Agustin Mista Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY --- .../bench/PerasCertDB-bench/Main.hs | 2 +- .../Test/Ouroboros/Storage/TestBlock.hs | 27 ++++++++----- .../Ouroboros/Storage/ChainDB/Iterator.hs | 38 +++++++++---------- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 29 ++++++++++---- .../Storage/VolatileDB/StateMachine.hs | 13 ++++++- 5 files changed, 70 insertions(+), 39 deletions(-) diff --git a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs index 64c7a22f02..3fbafe551f 100644 --- a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs +++ b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs @@ -115,7 +115,7 @@ fragments = iterate' addSuccessorBlock genesisFragment in (xs AF.:> x) AF.:> TestBlock.mkNextBlock x nextBlockSlot dummyBody dummyBody :: TestBody - dummyBody = TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} + dummyBody = TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} -- | Given a chain fragment, construct a weight snapshot where there's a boosted block every 90 slots uniformWeightSnapshot :: AF.AnchoredFragment TestBlock -> PerasWeightSnapshot TestBlock diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index a7dff10c5f..39c97c33a4 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -135,6 +135,7 @@ import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IndexedMemPack import Ouroboros.Consensus.Util.Orphans () import qualified Ouroboros.Network.Mock.Chain as Chain +import Ouroboros.Network.Point (Block) import System.FS.API.Lazy import Test.Cardano.Slotting.Numeric () import Test.Cardano.Slotting.TreeDiff () @@ -207,13 +208,13 @@ data TestBody = TestBody -- Note that this is a /local/ number, it is specific to this block, -- other blocks need not be aware of it. , tbIsValid :: !Bool - , tbPerasCertRound :: !(Maybe PerasRoundNo) + , tbPerasCert :: !(Maybe (PerasCert TestBlock)) -- ^ Some real blocks will ocasionally carry a Peras certificate inside their - -- body to coordinate the end of a cooldown period. For the purposes of the - -- ChainDB, we don't really care about the details of the certificate other - -- than its round number, which needs to be stored (and carefully updated - -- whenever a newer one pops up) so it can be used to evaluate the Peras - -- voting rules and decide if a node should resume voting. + -- body to coordinate the end of a cooldown period. + -- NOTE: for the purposes of the ChainDB, we don't care about the details of + -- the certificate other than its round number, which needs to be stored (and + -- carefully updated whenever a newer one pops up) so it can be used to + -- evaluate the Peras voting rules and decide if a node should resume voting. } deriving stock (Eq, Show, Generic) deriving anyclass (NFData, NoThunks, Serialise, Hashable) @@ -953,16 +954,22 @@ corruptionFiles = map snd . NE.toList Orphans -------------------------------------------------------------------------------} +-- ** Hashable + deriving newtype instance Hashable SlotNo deriving newtype instance Hashable BlockNo deriving newtype instance Hashable PerasRoundNo -instance Hashable IsEBB - --- use generic instance +instance Hashable IsEBB +instance Hashable TestHeader +instance Hashable TestBlock +instance Hashable (Block SlotNo TestHeaderHash) +instance Hashable (Point TestBlock) +instance Hashable (MockPerasCert TestBlock) +instance (Hashable a, Hashable (WithOrigin a)) => Hashable (WithOrigin a) instance (StandardHash b, Hashable (HeaderHash b)) => Hashable (ChainHash b) --- use generic instance +-- ** ToExpr instance ToExpr EBB instance ToExpr IsEBB diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs index 2bcb9af556..ae49ed149f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Iterator.hs @@ -115,11 +115,11 @@ tests = -- All blocks on the same chain a, b, c, d, e :: TestBlock -a = firstBlock 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} -b = mkNextBlock a 1 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} -c = mkNextBlock b 2 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} -d = mkNextBlock c 3 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} -e = mkNextBlock d 4 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} +a = firstBlock 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} +b = mkNextBlock a 1 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} +c = mkNextBlock b 2 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} +d = mkNextBlock c 3 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} +e = mkNextBlock d 4 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = A -> C -- @@ -176,9 +176,9 @@ prop_1435_case1 = (Left (ForkTooOld (StreamFromInclusive (blockRealPoint b')))) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = EBB' -> EBB' where EBB, B, and EBB' are all blocks in -- the same slot, and EBB' is not part of the current chain nor ChainDB. @@ -197,9 +197,9 @@ prop_1435_case2 = (Left (ForkTooOld (StreamFromInclusive (blockRealPoint ebb')))) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = EBB -> EBB where EBB and B are all blocks in the same -- slot. @@ -218,8 +218,8 @@ prop_1435_case3 = (Right (map Right [ebb])) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = EBB -> EBB where EBB and B are all blocks in the same -- slot. @@ -238,8 +238,8 @@ prop_1435_case4 = (Right (map Right [ebb])) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b = mkNextBlock ebb 0 TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = EBB -> EBB where EBB and B' are all blocks in the same -- slot, and B' is not part of the current chain nor ChainDB. @@ -258,8 +258,8 @@ prop_1435_case5 = (Left (ForkTooOld (StreamFromInclusive (blockRealPoint b')))) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + b' = mkNextBlock ebb 0 TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing} -- | Requested stream = EBB' -> EBB' where EBB and EBB' are all blocks in the -- same slot, and EBB' is not part of the current chain nor ChainDB. @@ -278,8 +278,8 @@ prop_1435_case6 = (Left (ForkTooOld (StreamFromInclusive (blockRealPoint ebb')))) where canContainEBB = const True - ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCertRound = Nothing} - ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCertRound = Nothing} + ebb = firstEBB canContainEBB TestBody{tbForkNo = 0, tbIsValid = True, tbPerasCert = Nothing} + ebb' = firstEBB canContainEBB TestBody{tbForkNo = 1, tbIsValid = True, tbPerasCert = Nothing} -- | The general property test prop_general_test :: 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 a66cd5d1db..599c1580a2 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 @@ -2119,24 +2119,37 @@ genBlkPair chunkInfo loe Model{..} = [ (4, return True) , (1, return False) ] - perasCertRound <- do - let maxRoundNo = - case Model.roundNoOfLatestCertSeen dbModel of - Nothing -> 0 - Just (PerasRoundNo r) -> r + 1 + perasCert <- do frequency - [ (9, return Nothing) + [ (4, return Nothing) , let freq = case loe of LoEDisabled -> 1 -- The LoE does not yet support Peras. LoEEnabled () -> 0 - in (freq, Just . PerasRoundNo <$> choose (0, maxRoundNo)) + in (freq, Just <$> genPerasCert) ] return TestBody { tbForkNo = forkNo , tbIsValid = isValid - , tbPerasCertRound = perasCertRound + , tbPerasCert = perasCert + } + + genPerasCert :: Gen (PerasCert TestBlock) + genPerasCert = do + let maxRoundNo = + case Model.roundNoOfLatestCertSeen dbModel of + Nothing -> 0 + Just (PerasRoundNo r) -> r + 1 + roundNo <- + PerasRoundNo <$> choose (0, maxRoundNo) + boostedBlock <- + -- NOTE: we don't care about this boosted block, it could be @Genesis@ + blockPoint <$> genSuccOfCurrentChainTip + pure + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = boostedBlock } -- | Generate a random security parameter (k) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs index cf8f1ee921..5884ee08a1 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs @@ -49,6 +49,7 @@ import GHC.Generics import GHC.Stack import qualified Generics.SOP as SOP import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.VolatileDB import Ouroboros.Consensus.Storage.VolatileDB.Impl.Types (FileId) @@ -392,7 +393,7 @@ generatorCmdImpl Model{..} = TestBody <$> arbitrary <*> arbitrary - <*> liftArbitrary (PerasRoundNo <$> arbitrary) + <*> liftArbitrary genPerasCert prevHash <- frequency [ (1, return GenesisHash) @@ -407,6 +408,16 @@ generatorCmdImpl Model{..} = let clen = ChainLength (fromIntegral (unBlockNo no)) return $ mkBlock canContainEBB body prevHash slot no clen ebb + genPerasCert :: Gen (PerasCert Block) + genPerasCert = do + mockCertRound <- PerasRoundNo <$> arbitrary + mockCertBlock <- blockPoint <$> genRandomBlock + pure $ + MockPerasCert + { mockCertRound + , mockCertBlock + } + genHash :: Gen (HeaderHash Block) genHash = frequency From f4e8e079766871e5ae6c8336a7d1623573e33f39 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 18 May 2026 17:14:28 +0200 Subject: [PATCH 25/62] Re-change Peras target to use `Point blk` instead of `PerasBoostedBlock` --- .../Ouroboros/Consensus/Peras/Cert/V1.hs | 54 +++++++---- .../Ouroboros/Consensus/Peras/Crypto/BLS.hs | 96 ++++++++++--------- .../Ouroboros/Consensus/Peras/Vote/V1.hs | 42 +++++--- .../Consensus/Peras/Voting/Committee.hs | 24 ++--- .../Test/Consensus/Peras/Serialisation.hs | 20 +++- .../Test/Consensus/Peras/Util.hs | 47 ++++----- .../Test/Consensus/Peras/Voting/Committee.hs | 32 +++++-- 7 files changed, 183 insertions(+), 132 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs index 889fe06cc2..960ae32dbe 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -- | Concrete Peras certificate types using BLS signatures. @@ -29,10 +30,17 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.NonEmpty as NEMap import Data.Map.Strict (Map) import Data.Maybe (catMaybes) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) import Data.Word (Word16) +import Ouroboros.Consensus.Block + ( ConvertRawHash (..) + , Point + , decodeRawHash + , encodeRawHash + ) import Ouroboros.Consensus.Block.SupportsPeras - ( PerasBoostedBlock - , PerasRoundNo + ( PerasRoundNo , PerasSeatIndex (..) ) import Ouroboros.Consensus.Committee.Crypto @@ -45,27 +53,33 @@ import Ouroboros.Consensus.Peras.Crypto.BLS import Ouroboros.Consensus.Peras.Vote.V1 (PerasVoteEligibilityProof (..)) import Ouroboros.Consensus.Util.Bitmap (Bitmap) import qualified Ouroboros.Consensus.Util.Bitmap as Bitmap +import Ouroboros.Network.Block (decodePoint, encodePoint) -- | Concrete Peras certificates using BLS signatures -data PerasCert +-- 'blk' is mainly used here to ensure type family injectivity. +-- For convenience/preventing annoying conversions, we also use it to indicate +-- in 'Point blk' for the boosted block. +data PerasCert blk = PerasCert { pcRoundNo :: !PerasRoundNo -- ^ Election identifier - , pcBoostedBlock :: !PerasBoostedBlock + , pcBoostedBlock :: !(Point blk) -- ^ Certificate message, i.e., the hash of the block being boosted - , pcVoters :: !PerasCertVoters + -- TODO: 'blk' here may not refer to the actual era of the boosted block, + -- see https://github.com/tweag/cardano-peras/issues/251 + , pcVoters :: !(PerasCertVoters blk) -- ^ Voters who contributed to this certificate - , pcSignature :: !(AggregateVoteSignature PerasBLSCrypto) + , pcSignature :: !(AggregateVoteSignature (PerasBLSCrypto blk)) -- ^ Aggregate BLS signature on the hash of the election identifier and -- the certificate message } deriving (Show, Eq) -instance FromCBOR PerasCert where +instance (Typeable blk, ConvertRawHash blk) => FromCBOR (PerasCert blk) where fromCBOR = do decodeListLenOf 4 pcRoundNo <- fromCBOR - pcBoostedBlock <- fromCBOR + pcBoostedBlock <- decodePoint (decodeRawHash (Proxy @blk)) pcVoters <- fromCBOR pcSignature <- fromCBOR pure @@ -76,23 +90,23 @@ instance FromCBOR PerasCert where , pcSignature } -instance ToCBOR PerasCert where +instance (Typeable blk, ConvertRawHash blk) => ToCBOR (PerasCert blk) where toCBOR cert = encodeListLen 4 <> toCBOR (pcRoundNo cert) - <> toCBOR (pcBoostedBlock cert) + <> encodePoint (encodeRawHash (Proxy @blk)) (pcBoostedBlock cert) <> toCBOR (pcVoters cert) <> toCBOR (pcSignature cert) -- | Voters contained in a certificate with their appropriate eligibility proof -newtype PerasCertVoters +newtype PerasCertVoters blk = PerasCertVoters { unPerasCertVoters :: - NE (Map PerasSeatIndex PerasVoteEligibilityProof) + NE (Map PerasSeatIndex (PerasVoteEligibilityProof blk)) } deriving (Eq, Show) -instance FromCBOR PerasCertVoters where +instance Typeable blk => FromCBOR (PerasCertVoters blk) where fromCBOR = do decodeListLenOf 2 votersBitmap <- fromCBOR @@ -105,7 +119,7 @@ instance FromCBOR PerasCertVoters where , nonPersistentSigs } -instance ToCBOR PerasCertVoters where +instance Typeable blk => ToCBOR (PerasCertVoters blk) where toCBOR voters = encodeListLen 2 <> toCBOR votersBitmap @@ -141,10 +155,10 @@ instance ToCBOR PerasCertVoters where -- 7 => non-persistent(np3) -- } -- @ -data CompactPerasCertVoters +data CompactPerasCertVoters blk = CompactPerasCertVoters { votersBitmap :: !(Bitmap Word16) - , nonPersistentSigs :: ![VRFOutput PerasBLSCrypto] + , nonPersistentSigs :: ![VRFOutput (PerasBLSCrypto blk)] } deriving (Eq, Show) @@ -152,8 +166,8 @@ data CompactPerasCertVoters -- -- See 'CompactPerasCertVoters' for the encoding scheme used here. fromCompactRepr :: - CompactPerasCertVoters -> - Either String PerasCertVoters + CompactPerasCertVoters blk -> + Either String (PerasCertVoters blk) fromCompactRepr CompactPerasCertVoters { votersBitmap @@ -195,8 +209,8 @@ fromCompactRepr -- -- See 'CompactPerasCertVoters' for the encoding scheme used here. toCompactRepr :: - PerasCertVoters -> - CompactPerasCertVoters + PerasCertVoters blk -> + CompactPerasCertVoters blk toCompactRepr (PerasCertVoters voters) = CompactPerasCertVoters { votersBitmap diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs index aa23a44e10..4ac2072a32 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -35,13 +39,15 @@ import Cardano.Ledger.Hashes (HASH) import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Builder.Extra as BS import qualified Data.ByteString.Short as BS -import Ouroboros.Consensus.Block.RealPoint - ( bytes32RealPointHash - , bytes32RealPointSlot +import Data.Proxy (Proxy (..)) +import Ouroboros.Consensus.Block + ( ConvertRawHash (..) + , Point + , pattern BlockPoint + , pattern GenesisPoint ) import Ouroboros.Consensus.Block.SupportsPeras - ( PerasBoostedBlock (..) - , PerasRoundNo (..) + ( PerasRoundNo (..) ) import Ouroboros.Consensus.Committee.Crypto ( CryptoSupportsAggregateVoteSigning (..) @@ -58,10 +64,10 @@ import Ouroboros.Consensus.Committee.Crypto.BLS (KeyRole (..)) import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS -- | BLS-based crypto scheme used in Peras voting committees -data PerasBLSCrypto +data PerasBLSCrypto blk -type instance ElectionId PerasBLSCrypto = PerasRoundNo -type instance VoteCandidate PerasBLSCrypto = PerasBoostedBlock +type instance ElectionId (PerasBLSCrypto blk) = PerasRoundNo +type instance VoteCandidate (PerasBLSCrypto blk) = Point blk -- | Private key of a Peras committee member data PerasPrivateKey @@ -70,7 +76,7 @@ data PerasPrivateKey , perasVRFSignKey :: BLS.PrivateKey VRF } -type instance PrivateKey PerasBLSCrypto = PerasPrivateKey +type instance PrivateKey (PerasBLSCrypto blk) = PerasPrivateKey -- | Public key of a Peras committee member data PerasPublicKey @@ -79,47 +85,49 @@ data PerasPublicKey , perasVRFVerKey :: BLS.PublicKey VRF } -type instance PublicKey PerasBLSCrypto = PerasPublicKey +type instance PublicKey (PerasBLSCrypto blk) = PerasPublicKey -- | Hash the message of a Peras vote -- -- NOTE: this is inspired by the implementation used by the Praos VRF check in -- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. hashVoteSignature :: - ElectionId PerasBLSCrypto -> - VoteCandidate PerasBLSCrypto -> + forall blk. + ConvertRawHash blk => + ElectionId (PerasBLSCrypto blk) -> + VoteCandidate (PerasBLSCrypto blk) -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN) -hashVoteSignature roundNo boostedBlock = +hashVoteSignature roundNo point = Hash.castHash . Hash.hashWith id . runByteBuilder (8 + 8 + 32) $ roundNoBytes - <> boostedBlockSlotBytes - <> boostedBlockHashBytes + <> pointSlotBytes + <> pointHashBytes where roundNoBytes = BS.word64BE . unPerasRoundNo $ roundNo - boostedBlockSlotBytes = - BS.word64BE - . unSlotNo - . bytes32RealPointSlot - . unPerasBoostedBlock - $ boostedBlock - boostedBlockHashBytes = - BS.byteStringCopy - . BS.fromShort - . bytes32RealPointHash - . unPerasBoostedBlock - $ boostedBlock + (pointSlotBytes, pointHashBytes) = case point of + GenesisPoint -> + ( BS.word64BE 0 + , mempty + ) + BlockPoint slotNo headerHash -> + ( BS.word64BE (unSlotNo slotNo) + , BS.byteStringCopy + . BS.fromShort + . toShortRawHash (Proxy @blk) + $ headerHash + ) -- | Hash the input for the VRF used in Peras elections -- -- NOTE: this is inspired by the implementation used by the Praos VRF check in -- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. hashVRFInput :: - ElectionId PerasBLSCrypto -> + ElectionId (PerasBLSCrypto blk) -> Nonce -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN) hashVRFInput roundNo epochNonce = @@ -137,11 +145,11 @@ hashVRFInput roundNo epochNonce = -- * Crypto instances -instance CryptoSupportsVoteSigning PerasBLSCrypto where - type VoteSigningKey PerasBLSCrypto = BLS.PrivateKey SIGN - type VoteVerificationKey PerasBLSCrypto = BLS.PublicKey SIGN +instance ConvertRawHash blk => CryptoSupportsVoteSigning (PerasBLSCrypto blk) where + type VoteSigningKey (PerasBLSCrypto blk) = BLS.PrivateKey SIGN + type VoteVerificationKey (PerasBLSCrypto blk) = BLS.PublicKey SIGN - newtype VoteSignature PerasBLSCrypto + newtype VoteSignature (PerasBLSCrypto blk) = PerasBLSCryptoVoteSignature { unPerasBLSCryptoVoteSignature :: BLS.Signature BLS.SIGN @@ -157,7 +165,7 @@ instance CryptoSupportsVoteSigning PerasBLSCrypto where signVote sk roundNo boostedBlock = PerasBLSCryptoVoteSignature . BLS.signWithRole @SIGN sk - $ hashVoteSignature roundNo boostedBlock + $ hashVoteSignature @blk roundNo boostedBlock verifyVoteSignature pk @@ -166,21 +174,21 @@ instance CryptoSupportsVoteSigning PerasBLSCrypto where (PerasBLSCryptoVoteSignature sig) = BLS.verifyWithRole @SIGN pk - (hashVoteSignature roundNo boostedBlock) + (hashVoteSignature @blk roundNo boostedBlock) sig -instance CryptoSupportsVRF PerasBLSCrypto where - type VRFSigningKey PerasBLSCrypto = BLS.PrivateKey VRF - type VRFVerificationKey PerasBLSCrypto = BLS.PublicKey VRF +instance CryptoSupportsVRF (PerasBLSCrypto blk) where + type VRFSigningKey (PerasBLSCrypto blk) = BLS.PrivateKey VRF + type VRFVerificationKey (PerasBLSCrypto blk) = BLS.PublicKey VRF - newtype VRFElectionInput PerasBLSCrypto + newtype VRFElectionInput (PerasBLSCrypto blk) = PerasBLSCryptoVRFElectionInput { unPerasBLSCryptoVRFElectionInput :: Hash HASH (SigDSIGN BLS12381MinSigDSIGN) } deriving stock (Eq, Show) - newtype VRFOutput PerasBLSCrypto + newtype VRFOutput (PerasBLSCrypto blk) = PerasBLSCryptoVRFOutput { unPerasBLSCryptoVRFOutput :: BLS.Signature VRF @@ -229,12 +237,12 @@ newtype PerasBLSCryptoAggregateVoteSignature deriving stock (Eq, Show) deriving newtype (FromCBOR, ToCBOR) -instance CryptoSupportsAggregateVoteSigning PerasBLSCrypto where +instance ConvertRawHash blk => CryptoSupportsAggregateVoteSigning (PerasBLSCrypto blk) where type - AggregateVoteVerificationKey PerasBLSCrypto = + AggregateVoteVerificationKey (PerasBLSCrypto blk) = PerasBLSCryptoAggregateVoteVerificationKey type - AggregateVoteSignature PerasBLSCrypto = + AggregateVoteSignature (PerasBLSCrypto blk) = PerasBLSCryptoAggregateVoteSignature aggregateVoteVerificationKeys _ pks = do @@ -256,10 +264,10 @@ instance CryptoSupportsAggregateVoteSigning PerasBLSCrypto where aggSig = do BLS.verifyWithRole @SIGN (unPerasBLSCryptoAggregateVoteVerificationKey aggPk) - (hashVoteSignature roundNo boostedBlock) + (hashVoteSignature @blk roundNo boostedBlock) (unPerasBLSCryptoAggregateVoteSignature aggSig) -instance CryptoSupportsBatchVRFVerification PerasBLSCrypto where +instance CryptoSupportsBatchVRFVerification (PerasBLSCrypto blk) where -- NOTE: in contrast to vote signatures, we cannot aggregate multiple VRF -- outputs into a single one when forging a certificate (because we need to -- derive non-persistent seat numbers from each individual one). This means diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs index 4f32a31ca0..d0f737aba1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} @@ -20,10 +21,17 @@ import Cardano.Binary , decodeListLenOf , encodeListLen ) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) import Data.Word (Word8) +import Ouroboros.Consensus.Block + ( ConvertRawHash (..) + , Point + , decodeRawHash + , encodeRawHash + ) import Ouroboros.Consensus.Block.SupportsPeras - ( PerasBoostedBlock - , PerasRoundNo + ( PerasRoundNo , PerasSeatIndex ) import Ouroboros.Consensus.Committee.Crypto (CryptoSupportsVoteSigning (..)) @@ -31,29 +39,35 @@ import Ouroboros.Consensus.Peras.Crypto.BLS ( PerasBLSCrypto , VRFOutput ) +import Ouroboros.Network.Block (decodePoint, encodePoint) -- | Concrete Peras votes using BLS signatures -data PerasVote +-- 'blk' is mainly used here to ensure type family injectivity. +-- For convenience/preventing annoying conversions, we also use it to indicate +-- in 'Point blk' for the boosted block. +data PerasVote blk = PerasVote { pvRoundNo :: !PerasRoundNo -- ^ Election identifier - , pvBoostedBlock :: !PerasBoostedBlock + , pvBoostedBlock :: !(Point blk) -- ^ Vote message, i.e., the hash of the block being voted for + -- TODO: 'blk' here may not refer to the actual era of the boosted block, + -- see https://github.com/tweag/cardano-peras/issues/251 , pvSeatIndex :: !PerasSeatIndex -- ^ Seat index assigned to the committee member (identifies the voter) - , pvEligibilityProof :: !PerasVoteEligibilityProof + , pvEligibilityProof :: !(PerasVoteEligibilityProof blk) -- ^ Proof of eligibility for voting, depending on the type of membership to -- the committee (persistent vs non-persistent) - , pvSignature :: !(VoteSignature PerasBLSCrypto) + , pvSignature :: !(VoteSignature (PerasBLSCrypto blk)) -- ^ BLS signature on the hash of the election identifier and vote message } deriving (Show, Eq) -instance FromCBOR PerasVote where +instance (Typeable blk, ConvertRawHash blk) => FromCBOR (PerasVote blk) where fromCBOR = do decodeListLenOf 5 pvRoundNo <- fromCBOR - pvBoostedBlock <- fromCBOR + pvBoostedBlock <- decodePoint (decodeRawHash (Proxy @blk)) pvSeatIndex <- fromCBOR pvEligibilityProof <- fromCBOR pvSignature <- fromCBOR @@ -66,24 +80,24 @@ instance FromCBOR PerasVote where , pvSignature } -instance ToCBOR PerasVote where +instance (Typeable blk, ConvertRawHash blk) => ToCBOR (PerasVote blk) where toCBOR vote = encodeListLen 5 <> toCBOR (pvRoundNo vote) - <> toCBOR (pvBoostedBlock vote) + <> encodePoint (encodeRawHash (Proxy @blk)) (pvBoostedBlock vote) <> toCBOR (pvSeatIndex vote) <> toCBOR (pvEligibilityProof vote) <> toCBOR (pvSignature vote) -- | Proof of eligibility for voting for committee members -data PerasVoteEligibilityProof +data PerasVoteEligibilityProof blk = -- | Persistent committee members require no additional proof of eligibility PersistentPerasVoteEligibilityProof | -- | Non-persistent committee members provide a VRF proof of eligibility - NonPersistentPerasVoteEligibilityProof !(VRFOutput PerasBLSCrypto) + NonPersistentPerasVoteEligibilityProof !(VRFOutput (PerasBLSCrypto blk)) deriving stock (Eq, Show) -instance FromCBOR PerasVoteEligibilityProof where +instance Typeable blk => FromCBOR (PerasVoteEligibilityProof blk) where fromCBOR = do len <- decodeListLen tag <- fromCBOR @Word8 @@ -95,7 +109,7 @@ instance FromCBOR PerasVoteEligibilityProof where "Invalid PerasVoteEligibilityProof length/tag: " <> show (len, tag) -instance ToCBOR PerasVoteEligibilityProof where +instance Typeable blk => ToCBOR (PerasVoteEligibilityProof blk) where toCBOR = \case PersistentPerasVoteEligibilityProof -> encodeListLen 1 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs index 745196a356..2fb2ace2d1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs @@ -79,8 +79,8 @@ class -- overflowing their `Word16` seat index. instance PerasVoteCompatibleWithVotingCommittee - V1.PerasVote - PerasBLSCrypto + (V1.PerasVote blk) + (PerasBLSCrypto blk) WFALS where toPerasVote = \case @@ -130,8 +130,8 @@ instance -- overflowing the `Word16` seat index of each voter. instance PerasCertCompatibleWithVotingCommittee - V1.PerasCert - PerasBLSCrypto + (V1.PerasCert blk) + (PerasBLSCrypto blk) WFALS where toPerasCert = \case @@ -160,8 +160,8 @@ instance -- avoiding overflowing their `Word16` seat index). instance PerasVoteCompatibleWithVotingCommittee - V1.PerasVote - PerasBLSCrypto + (V1.PerasVote blk) + (PerasBLSCrypto blk) EveryoneVotes where toPerasVote = \case @@ -196,8 +196,8 @@ instance -- (in addition to avoiding overflowing the `Word16` seat index of each voter). instance PerasCertCompatibleWithVotingCommittee - V1.PerasCert - PerasBLSCrypto + (V1.PerasCert blk) + (PerasBLSCrypto blk) EveryoneVotes where toPerasCert = \case @@ -263,8 +263,8 @@ toPerasSeatIndex (SeatIndex seatIndex) -- | Convert concrete Peras certificate voters to abstract committee voters fromPerasCertVoters :: - V1.PerasCertVoters -> - NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) + V1.PerasCertVoters blk -> + NE (Map SeatIndex (Maybe (VRFOutput (PerasBLSCrypto blk)))) fromPerasCertVoters voters = NEMap.fromAscList . NonEmpty.map @@ -283,8 +283,8 @@ fromPerasCertVoters voters = -- | Convert abstract committee voters to concrete Peras certificate voters toPerasCertVoters :: - NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) -> - Either PerasConversionError V1.PerasCertVoters + NE (Map SeatIndex (Maybe (VRFOutput (PerasBLSCrypto blk)))) -> + Either PerasConversionError (V1.PerasCertVoters blk) toPerasCertVoters voters = fmap V1.PerasCertVoters . fmap NEMap.fromAscList diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs index c67e6ff9a1..00315f83f5 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs @@ -7,7 +7,10 @@ module Test.Consensus.Peras.Serialisation ) where import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeFull, serialize) +import Cardano.Ledger.BaseTypes (SlotNo (..)) import qualified Data.ByteString.Lazy as LazyByteString +import Ouroboros.Consensus.Block (Point) +import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), realPointToPoint) import Test.Consensus.Peras.Util ( genPerasCert , genPerasVote @@ -15,8 +18,10 @@ import Test.Consensus.Peras.Util , tabulatePerasCert , tabulatePerasVote ) +import Test.Ouroboros.Storage.TestBlock (TestBlock, TestHeaderHash (..)) import Test.QuickCheck - ( Gen + ( Arbitrary (..) + , Gen , Property , counterexample , forAll @@ -27,6 +32,15 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.TestEnv (adjustQuickCheckTests) +-- | Generate an arbitrary 'Point' for 'TestBlock'. +-- We reuse 'TestBlock' from "Test.Ouroboros.Storage.TestBlock" which already +-- provides 'ConvertRawHash' (needed by the CBOR instances of Peras types). +genTestPoint :: Gen (Point TestBlock) +genTestPoint = do + slotNo <- SlotNo <$> arbitrary + hash <- TestHeaderHash <$> arbitrary + pure $ realPointToPoint $ RealPoint slotNo hash + tests :: TestTree tests = testGroup @@ -35,13 +49,13 @@ tests = testProperty "Roundtrip for PerasVote" $ prop_roundtrip -- Generate both persistent and non-persistent votes - (genPerasVote True) + (genPerasVote genTestPoint True) tabulatePerasVote , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasCert" $ prop_roundtrip -- Generate certs with both persistent and non-persistent votes - (genPerasCert True) + (genPerasCert genTestPoint True) tabulatePerasCert ] diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs index b1c4007be2..0647073bbd 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs @@ -22,11 +22,8 @@ module Test.Consensus.Peras.Util ) where import Cardano.Crypto.Hash (ByteString) -import Cardano.Ledger.BaseTypes (SlotNo (..)) import Control.Monad (forM) import qualified Data.ByteString as ByteString -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as ShortByteString import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.NonEmpty as NEMap import Data.Maybe (catMaybes, fromMaybe) @@ -35,8 +32,7 @@ import Data.String (IsString (..)) import Data.Traversable (mapAccumM) import Data.Word (Word8) import GHC.Word (Word16) -import Ouroboros.Consensus.Block (HeaderHash) -import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), toBytes32RealPoint) +import Ouroboros.Consensus.Block (Point) import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import Ouroboros.Consensus.Peras.Crypto.BLS @@ -45,8 +41,7 @@ import Ouroboros.Consensus.Peras.Crypto.BLS , VoteSignature (..) ) import Ouroboros.Consensus.Peras.Types - ( PerasBoostedBlock (..) - , PerasRoundNo (..) + ( PerasRoundNo (..) , PerasSeatIndex (..) ) import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 @@ -64,13 +59,13 @@ import Test.QuickCheck -- * Predicates -- | Whether a Peras vote is a persistent one -perasVoteIsPersistent :: V1.PerasVote -> Bool +perasVoteIsPersistent :: V1.PerasVote blk -> Bool perasVoteIsPersistent vote | V1.PersistentPerasVoteEligibilityProof{} <- V1.pvEligibilityProof vote = True | otherwise = False -- | Whether a Peras certifcate only contains persistent votes -perasCertContainsOnlyPersistentVotes :: V1.PerasCert -> Bool +perasCertContainsOnlyPersistentVotes :: V1.PerasCert blk -> Bool perasCertContainsOnlyPersistentVotes cert = all ( \case @@ -88,18 +83,6 @@ perasCertContainsOnlyPersistentVotes cert = genRoundNo :: Gen PerasRoundNo genRoundNo = PerasRoundNo <$> arbitrary -data BlockWith32BytesHeaderHash -type instance HeaderHash BlockWith32BytesHeaderHash = ShortByteString - -genBoostedBlock :: Gen PerasBoostedBlock -genBoostedBlock = do - slotNo <- SlotNo <$> arbitrary - hash <- ShortByteString.pack <$> vectorOf 32 arbitrary - let bytes32realPoint = - toBytes32RealPoint @BlockWith32BytesHeaderHash $ - RealPoint slotNo hash - pure (PerasBoostedBlock bytes32realPoint) - genSeatIndex :: Gen PerasSeatIndex genSeatIndex = PerasSeatIndex <$> arbitrary @@ -120,7 +103,7 @@ genSignature _ = do msg <- fromString @ByteString <$> arbitrary pure $ BLS.signWithRole key msg -genVoteEligibilityProof :: Bool -> Gen V1.PerasVoteEligibilityProof +genVoteEligibilityProof :: Bool -> Gen (V1.PerasVoteEligibilityProof blk) genVoteEligibilityProof shouldGenNonPersistent = do frequency [ @@ -135,7 +118,7 @@ genVoteEligibilityProof shouldGenNonPersistent = do ) ] -genVoters :: Bool -> Gen V1.PerasCertVoters +genVoters :: Bool -> Gen (V1.PerasCertVoters blk) genVoters shouldGenNonPersistent = do numVoters <- sized $ \size -> @@ -179,8 +162,8 @@ genVoters shouldGenNonPersistent = do pure $ V1.PerasCertVoters (NEMap.fromList (NonEmpty.fromList voters)) -genPerasVote :: Bool -> Gen V1.PerasVote -genPerasVote shouldGenNonPersistent = do +genPerasVote :: Gen (Point blk) -> Bool -> Gen (V1.PerasVote blk) +genPerasVote genBoostedBlock shouldGenNonPersistent = do pvRoundNo <- genRoundNo pvBoostedBlock <- genBoostedBlock pvSeatIndex <- genSeatIndex @@ -197,8 +180,8 @@ genPerasVote shouldGenNonPersistent = do , V1.pvSignature } -genPerasCert :: Bool -> Gen V1.PerasCert -genPerasCert shouldGenNonPersistent = do +genPerasCert :: Gen (Point blk) -> Bool -> Gen (V1.PerasCert blk) +genPerasCert genBoostedBlock shouldGenNonPersistent = do pcRoundNo <- genRoundNo pcBoostedBlock <- genBoostedBlock pcVoters <- genVoters shouldGenNonPersistent @@ -223,7 +206,7 @@ mkBucket bucketSize x suffix lower = (x `div` bucketSize) * bucketSize upper = lower + bucketSize -tabulatePerasCert :: V1.PerasCert -> Property -> Property +tabulatePerasCert :: V1.PerasCert blk -> Property -> Property tabulatePerasCert cert = foldr (flip (.)) id $ [ tabulate @@ -241,7 +224,11 @@ tabulatePerasCert cert = $ cert numPersistentVoters = length - . filter (== V1.PersistentPerasVoteEligibilityProof) + . filter + ( \case + V1.PersistentPerasVoteEligibilityProof -> True + V1.NonPersistentPerasVoteEligibilityProof{} -> False + ) . NonEmpty.toList . NEMap.elems . V1.unPerasCertVoters @@ -252,7 +239,7 @@ tabulatePerasCert cert = | numVoters == 0 = 0 | otherwise = numPersistentVoters * 100 `div` numVoters -tabulatePerasVote :: V1.PerasVote -> Property -> Property +tabulatePerasVote :: V1.PerasVote blk -> Property -> Property tabulatePerasVote vote = foldr (flip (.)) id $ [ tabulate diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs index ab9d800919..8cf1a1b5bd 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs @@ -7,7 +7,10 @@ module Test.Consensus.Peras.Voting.Committee ( tests ) where +import Cardano.Ledger.BaseTypes (SlotNo (..)) import Data.Proxy (Proxy (..)) +import Ouroboros.Consensus.Block (Point) +import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), realPointToPoint) import qualified Ouroboros.Consensus.Committee.Class as Committee import Ouroboros.Consensus.Committee.EveryoneVotes (EveryoneVotes) import Ouroboros.Consensus.Committee.WFALS (WFALS) @@ -25,8 +28,10 @@ import Test.Consensus.Peras.Util , tabulatePerasCert , tabulatePerasVote ) +import Test.Ouroboros.Storage.TestBlock (TestBlock, TestHeaderHash (..)) import Test.QuickCheck - ( Gen + ( Arbitrary (..) + , Gen , Property , Testable (..) , counterexample @@ -39,6 +44,15 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.TestEnv (adjustQuickCheckTests) +-- | Generate an arbitrary 'Point' for 'TestBlock'. +-- We reuse 'TestBlock' from "Test.Ouroboros.Storage.TestBlock" which already +-- provides 'ConvertRawHash'. +genTestPoint :: Gen (Point TestBlock) +genTestPoint = do + slotNo <- SlotNo <$> arbitrary + hash <- TestHeaderHash <$> arbitrary + pure $ realPointToPoint $ RealPoint slotNo hash + tests :: TestTree tests = testGroup @@ -46,44 +60,44 @@ tests = [ adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasVote via WFALS" $ prop_roundtrip_vote - (Proxy @V1.PerasVote) + (Proxy @(V1.PerasVote TestBlock)) (Proxy @WFALS) -- WFALS supports both persistent and non-persistent of votes (const True) -- Generate both persistent and non-persistent votes - (genPerasVote True) + (genPerasVote genTestPoint True) tabulatePerasVote , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasVote via EveryoneVotes" $ prop_roundtrip_vote - (Proxy @V1.PerasVote) + (Proxy @(V1.PerasVote TestBlock)) (Proxy @EveryoneVotes) -- EveryoneVotes only supports non-persistent votes perasVoteIsPersistent -- Generate both persistent and non-persistent votes to trigger -- conversion errors in a reasonable amount of tests - (genPerasVote =<< frequency [(2, pure True), (1, pure False)]) + (genPerasVote genTestPoint =<< frequency [(2, pure True), (1, pure False)]) tabulatePerasVote , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasCert via WFALS" $ prop_roundtrip_cert - (Proxy @V1.PerasCert) + (Proxy @(V1.PerasCert TestBlock)) (Proxy @WFALS) -- WFALS supports certs with both persistent and non-persistent votes (const True) -- Generate certs with both persistent and non-persistent votes - (genPerasCert True) + (genPerasCert genTestPoint True) tabulatePerasCert , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasCert via EveryoneVotes" $ prop_roundtrip_cert - (Proxy @V1.PerasCert) + (Proxy @(V1.PerasCert TestBlock)) (Proxy @EveryoneVotes) -- EveryoneVotes only supports certs with persistent votes perasCertContainsOnlyPersistentVotes -- Only sometimes generate certs with non-persistent votes to -- trigger conversion errors in a reasonable amount of tests - (genPerasCert =<< frequency [(2, pure False), (1, pure True)]) + (genPerasCert genTestPoint =<< frequency [(2, pure False), (1, pure True)]) tabulatePerasCert ] From b0d6731feae61686dc6ca1c4b1e77bf621fe77d8 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 19 May 2026 16:30:09 +0200 Subject: [PATCH 26/62] Define differentiated BlockSupportsPeras instances for ShelleyBlocks --- .../Ouroboros/Consensus/Shelley/Node.hs | 68 +++++++++-- .../Ouroboros/Consensus/Shelley/Node/Peras.hs | 26 +++-- .../Consensus/Shelley/Node/Serialisation.hs | 53 ++++++--- .../Ouroboros/Consensus/Shelley/ShelleyHFC.hs | 109 ++++++++++++++++-- .../ThreadNet/Infra/ShelleyBasedHardFork.hs | 2 + 5 files changed, 220 insertions(+), 38 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs index 86967e3b4b..dd7634985d 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -24,7 +25,6 @@ import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Abstract.NoHardForks -import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) @@ -32,6 +32,7 @@ import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.TPraos +import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.Inspect () import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion () @@ -107,11 +108,64 @@ instance ConsensusProtocol proto => BlockSupportsSanityCheck (ShelleyBlock proto configAllSecurityParams = pure . protocolSecurityParam . topLevelConfigProtocol instance - ( ShelleyCompatible proto era - , LedgerSupportsProtocol (ShelleyBlock proto era) - , BlockSupportsSanityCheck (ShelleyBlock proto era) - , TxLimits (ShelleyBlock proto era) - , NoHardForks (ShelleyBlock proto era) + ( ShelleyCompatible proto ShelleyEra + , LedgerSupportsProtocol (ShelleyBlock proto ShelleyEra) + , BlockSupportsSanityCheck (ShelleyBlock proto ShelleyEra) + , NoHardForks (ShelleyBlock proto ShelleyEra) , Crypto (ProtoCrypto proto) ) => - RunNode (ShelleyBlock proto era) + RunNode (ShelleyBlock proto ShelleyEra) + +instance + ( ShelleyCompatible proto AllegraEra + , LedgerSupportsProtocol (ShelleyBlock proto AllegraEra) + , BlockSupportsSanityCheck (ShelleyBlock proto AllegraEra) + , NoHardForks (ShelleyBlock proto AllegraEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto AllegraEra) + +instance + ( ShelleyCompatible proto MaryEra + , LedgerSupportsProtocol (ShelleyBlock proto MaryEra) + , BlockSupportsSanityCheck (ShelleyBlock proto MaryEra) + , NoHardForks (ShelleyBlock proto MaryEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto MaryEra) + +instance + ( ShelleyCompatible proto AlonzoEra + , LedgerSupportsProtocol (ShelleyBlock proto AlonzoEra) + , BlockSupportsSanityCheck (ShelleyBlock proto AlonzoEra) + , NoHardForks (ShelleyBlock proto AlonzoEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto AlonzoEra) + +instance + ( ShelleyCompatible proto BabbageEra + , LedgerSupportsProtocol (ShelleyBlock proto BabbageEra) + , BlockSupportsSanityCheck (ShelleyBlock proto BabbageEra) + , NoHardForks (ShelleyBlock proto BabbageEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto BabbageEra) + +instance + ( ShelleyCompatible proto ConwayEra + , LedgerSupportsProtocol (ShelleyBlock proto ConwayEra) + , BlockSupportsSanityCheck (ShelleyBlock proto ConwayEra) + , NoHardForks (ShelleyBlock proto ConwayEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto ConwayEra) + +instance + ( ShelleyCompatible proto DijkstraEra + , LedgerSupportsProtocol (ShelleyBlock proto DijkstraEra) + , BlockSupportsSanityCheck (ShelleyBlock proto DijkstraEra) + , NoHardForks (ShelleyBlock proto DijkstraEra) + , Crypto (ProtoCrypto proto) + ) => + RunNode (ShelleyBlock proto DijkstraEra) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs index b9ececeffe..73674823d1 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,6 +13,7 @@ -- defining it there would be too confusing. module Ouroboros.Consensus.Shelley.Node.Peras () where +import Cardano.Ledger.Api import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) , VoidPerasError @@ -34,18 +36,26 @@ import Ouroboros.Consensus.Shelley.Ledger.Block BlockSupportsPeras -------------------------------------------------------------------------------} --- NOTE: this is a mocked up implementation without crypto! +-- Peras support starts with DijkstraEra, so earlier eras use the default void +-- implementation. --- TODO: replace this with a concrete implementation using 'Peras.Vote.V1' and --- 'Peras.Cert.V1', either forall eras or for @forall era. era >= DijkstraEra@. +instance ShelleyCompatible proto ShelleyEra => BlockSupportsPeras (ShelleyBlock proto ShelleyEra) +instance ShelleyCompatible proto AllegraEra => BlockSupportsPeras (ShelleyBlock proto AllegraEra) +instance ShelleyCompatible proto MaryEra => BlockSupportsPeras (ShelleyBlock proto MaryEra) +instance ShelleyCompatible proto AlonzoEra => BlockSupportsPeras (ShelleyBlock proto AlonzoEra) +instance ShelleyCompatible proto BabbageEra => BlockSupportsPeras (ShelleyBlock proto BabbageEra) +instance ShelleyCompatible proto ConwayEra => BlockSupportsPeras (ShelleyBlock proto ConwayEra) +-- NOTE: this is a mocked up implementation without crypto! +-- TODO: replace this with a concrete implementation using 'Peras.Vote.V1' and +-- 'Peras.Cert.V1' for era >= DijkstraEra. instance - ShelleyCompatible proto era => - BlockSupportsPeras (ShelleyBlock proto era) + ShelleyCompatible proto DijkstraEra => + BlockSupportsPeras (ShelleyBlock proto DijkstraEra) where - type PerasVote (ShelleyBlock proto era) = MockPerasVote (ShelleyBlock proto era) - type PerasCert (ShelleyBlock proto era) = MockPerasCert (ShelleyBlock proto era) - type PerasError (ShelleyBlock proto era) = VoidPerasError (ShelleyBlock proto era) + type PerasVote (ShelleyBlock proto DijkstraEra) = MockPerasVote (ShelleyBlock proto DijkstraEra) + type PerasCert (ShelleyBlock proto DijkstraEra) = MockPerasCert (ShelleyBlock proto DijkstraEra) + type PerasError (ShelleyBlock proto DijkstraEra) = VoidPerasError (ShelleyBlock proto DijkstraEra) validatePerasVote = validateMockPerasVote validatePerasCert = validateMockPerasCert diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs index 4d541def62..d972613b4e 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs @@ -127,22 +127,47 @@ instance SerialiseNodeToNode -------------------------------------------------------------------------------} -instance +-- | Shared implementation of 'estimateBlockSize' for all Shelley-based eras. +estimateBlockSizeShelley :: ShelleyCompatible proto era => - SerialiseNodeToNodeConstraints (ShelleyBlock proto era) + Header (ShelleyBlock proto era) -> + SizeInBytes +estimateBlockSizeShelley hdr = overhead + hdrSize + bodySize + where + -- The maximum block size is 65536, the CBOR-in-CBOR tag for this block + -- is: + -- + -- > D8 18 # tag(24) + -- > 1A 00010000 # bytes(65536) + -- + -- Which is 7 bytes, enough for up to 4294967295 bytes. + overhead = 7 {- CBOR-in-CBOR -} + 1 {- encodeListLen -} + bodySize = fromIntegral . pHeaderBlockSize . shelleyHeaderRaw $ hdr + hdrSize = fromIntegral . pHeaderSize . shelleyHeaderRaw $ hdr + +instance ShelleyCompatible proto ShelleyEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto ShelleyEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance ShelleyCompatible proto AllegraEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto AllegraEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance ShelleyCompatible proto MaryEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto MaryEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance ShelleyCompatible proto AlonzoEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto AlonzoEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance ShelleyCompatible proto BabbageEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto BabbageEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance ShelleyCompatible proto ConwayEra => SerialiseNodeToNodeConstraints (ShelleyBlock proto ConwayEra) where + estimateBlockSize = estimateBlockSizeShelley + +instance + ShelleyCompatible proto DijkstraEra => + SerialiseNodeToNodeConstraints (ShelleyBlock proto DijkstraEra) where - estimateBlockSize hdr = overhead + hdrSize + bodySize - where - -- The maximum block size is 65536, the CBOR-in-CBOR tag for this block - -- is: - -- - -- > D8 18 # tag(24) - -- > 1A 00010000 # bytes(65536) - -- - -- Which is 7 bytes, enough for up to 4294967295 bytes. - overhead = 7 {- CBOR-in-CBOR -} + 1 {- encodeListLen -} - bodySize = fromIntegral . pHeaderBlockSize . shelleyHeaderRaw $ hdr - hdrSize = fromIntegral . pHeaderSize . shelleyHeaderRaw $ hdr + estimateBlockSize = estimateBlockSizeShelley -- | CBOR-in-CBOR for the annotation. This also makes it compatible with the -- wrapped ('Serialised') variant. diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 4e045bfd84..07618ee158 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -163,21 +163,112 @@ instance -- includes an era wrapper. Each block should do this from the start to be -- prepared for future hard forks without having to do any bit twiddling. instance - ( ShelleyCompatible proto era - , LedgerSupportsProtocol (ShelleyBlock proto era) - , LedgerSupportsPeras (ShelleyBlock proto era) - , TxLimits (ShelleyBlock proto era) + ( ShelleyCompatible proto ShelleyEra + , LedgerSupportsProtocol (ShelleyBlock proto ShelleyEra) + , LedgerSupportsPeras (ShelleyBlock proto ShelleyEra) + , TxLimits (ShelleyBlock proto ShelleyEra) , Crypto (ProtoCrypto proto) ) => - SerialiseHFC '[ShelleyBlock proto era] + SerialiseHFC '[ShelleyBlock proto ShelleyEra] instance - ( ShelleyCompatible proto era - , LedgerSupportsProtocol (ShelleyBlock proto era) - , TxLimits (ShelleyBlock proto era) + ( ShelleyCompatible proto AllegraEra + , LedgerSupportsProtocol (ShelleyBlock proto AllegraEra) + , LedgerSupportsPeras (ShelleyBlock proto AllegraEra) + , TxLimits (ShelleyBlock proto AllegraEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto AllegraEra] +instance + ( ShelleyCompatible proto MaryEra + , LedgerSupportsProtocol (ShelleyBlock proto MaryEra) + , LedgerSupportsPeras (ShelleyBlock proto MaryEra) + , TxLimits (ShelleyBlock proto MaryEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto MaryEra] +instance + ( ShelleyCompatible proto AlonzoEra + , LedgerSupportsProtocol (ShelleyBlock proto AlonzoEra) + , LedgerSupportsPeras (ShelleyBlock proto AlonzoEra) + , TxLimits (ShelleyBlock proto AlonzoEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto AlonzoEra] +instance + ( ShelleyCompatible proto BabbageEra + , LedgerSupportsProtocol (ShelleyBlock proto BabbageEra) + , LedgerSupportsPeras (ShelleyBlock proto BabbageEra) + , TxLimits (ShelleyBlock proto BabbageEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto BabbageEra] +instance + ( ShelleyCompatible proto ConwayEra + , LedgerSupportsProtocol (ShelleyBlock proto ConwayEra) + , LedgerSupportsPeras (ShelleyBlock proto ConwayEra) + , TxLimits (ShelleyBlock proto ConwayEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto ConwayEra] +instance + ( ShelleyCompatible proto DijkstraEra + , LedgerSupportsProtocol (ShelleyBlock proto DijkstraEra) + , LedgerSupportsPeras (ShelleyBlock proto DijkstraEra) + , TxLimits (ShelleyBlock proto DijkstraEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseHFC '[ShelleyBlock proto DijkstraEra] + +instance + ( ShelleyCompatible proto ShelleyEra + , LedgerSupportsProtocol (ShelleyBlock proto ShelleyEra) + , TxLimits (ShelleyBlock proto ShelleyEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto ShelleyEra) +instance + ( ShelleyCompatible proto AllegraEra + , LedgerSupportsProtocol (ShelleyBlock proto AllegraEra) + , TxLimits (ShelleyBlock proto AllegraEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto AllegraEra) +instance + ( ShelleyCompatible proto MaryEra + , LedgerSupportsProtocol (ShelleyBlock proto MaryEra) + , TxLimits (ShelleyBlock proto MaryEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto MaryEra) +instance + ( ShelleyCompatible proto AlonzoEra + , LedgerSupportsProtocol (ShelleyBlock proto AlonzoEra) + , TxLimits (ShelleyBlock proto AlonzoEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto AlonzoEra) +instance + ( ShelleyCompatible proto BabbageEra + , LedgerSupportsProtocol (ShelleyBlock proto BabbageEra) + , TxLimits (ShelleyBlock proto BabbageEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto BabbageEra) +instance + ( ShelleyCompatible proto ConwayEra + , LedgerSupportsProtocol (ShelleyBlock proto ConwayEra) + , TxLimits (ShelleyBlock proto ConwayEra) + , Crypto (ProtoCrypto proto) + ) => + SerialiseConstraintsHFC (ShelleyBlock proto ConwayEra) +instance + ( ShelleyCompatible proto DijkstraEra + , LedgerSupportsProtocol (ShelleyBlock proto DijkstraEra) + , TxLimits (ShelleyBlock proto DijkstraEra) , Crypto (ProtoCrypto proto) ) => - SerialiseConstraintsHFC (ShelleyBlock proto era) + SerialiseConstraintsHFC (ShelleyBlock proto DijkstraEra) {------------------------------------------------------------------------------- Protocol type definition diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs index 8c50f1767a..b1486bd4cc 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs @@ -186,6 +186,8 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 = , LedgerSupportsProtocol (ShelleyBlock proto2 era2) , LedgerSupportsPeras (ShelleyBlock proto1 era1) , LedgerSupportsPeras (ShelleyBlock proto2 era2) + , SerialiseConstraintsHFC (ShelleyBlock proto1 era1) + , SerialiseConstraintsHFC (ShelleyBlock proto2 era2) , TxLimits (ShelleyBlock proto1 era1) , TxLimits (ShelleyBlock proto2 era2) , TranslateTxMeasure (TxMeasure (ShelleyBlock proto1 era1)) (TxMeasure (ShelleyBlock proto2 era2)) From ca37123b801dd10bf2299faead0ff45c872911ae Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 20 May 2026 12:42:10 +0200 Subject: [PATCH 27/62] Revert "Re-change Peras target to use `Point blk` instead of `PerasBoostedBlock`" This reverts commit e2f6e656fa3dc56b4f59f176fc0b3039bfd0edb5. --- .../Ouroboros/Consensus/Peras/Cert/V1.hs | 54 ++++------- .../Ouroboros/Consensus/Peras/Crypto/BLS.hs | 96 +++++++++---------- .../Ouroboros/Consensus/Peras/Vote/V1.hs | 42 +++----- .../Consensus/Peras/Voting/Committee.hs | 24 ++--- .../Test/Consensus/Peras/Serialisation.hs | 20 +--- .../Test/Consensus/Peras/Util.hs | 47 +++++---- .../Test/Consensus/Peras/Voting/Committee.hs | 32 ++----- 7 files changed, 132 insertions(+), 183 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs index 960ae32dbe..889fe06cc2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs @@ -2,7 +2,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -- | Concrete Peras certificate types using BLS signatures. @@ -30,17 +29,10 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.NonEmpty as NEMap import Data.Map.Strict (Map) import Data.Maybe (catMaybes) -import Data.Proxy (Proxy (..)) -import Data.Typeable (Typeable) import Data.Word (Word16) -import Ouroboros.Consensus.Block - ( ConvertRawHash (..) - , Point - , decodeRawHash - , encodeRawHash - ) import Ouroboros.Consensus.Block.SupportsPeras - ( PerasRoundNo + ( PerasBoostedBlock + , PerasRoundNo , PerasSeatIndex (..) ) import Ouroboros.Consensus.Committee.Crypto @@ -53,33 +45,27 @@ import Ouroboros.Consensus.Peras.Crypto.BLS import Ouroboros.Consensus.Peras.Vote.V1 (PerasVoteEligibilityProof (..)) import Ouroboros.Consensus.Util.Bitmap (Bitmap) import qualified Ouroboros.Consensus.Util.Bitmap as Bitmap -import Ouroboros.Network.Block (decodePoint, encodePoint) -- | Concrete Peras certificates using BLS signatures --- 'blk' is mainly used here to ensure type family injectivity. --- For convenience/preventing annoying conversions, we also use it to indicate --- in 'Point blk' for the boosted block. -data PerasCert blk +data PerasCert = PerasCert { pcRoundNo :: !PerasRoundNo -- ^ Election identifier - , pcBoostedBlock :: !(Point blk) + , pcBoostedBlock :: !PerasBoostedBlock -- ^ Certificate message, i.e., the hash of the block being boosted - -- TODO: 'blk' here may not refer to the actual era of the boosted block, - -- see https://github.com/tweag/cardano-peras/issues/251 - , pcVoters :: !(PerasCertVoters blk) + , pcVoters :: !PerasCertVoters -- ^ Voters who contributed to this certificate - , pcSignature :: !(AggregateVoteSignature (PerasBLSCrypto blk)) + , pcSignature :: !(AggregateVoteSignature PerasBLSCrypto) -- ^ Aggregate BLS signature on the hash of the election identifier and -- the certificate message } deriving (Show, Eq) -instance (Typeable blk, ConvertRawHash blk) => FromCBOR (PerasCert blk) where +instance FromCBOR PerasCert where fromCBOR = do decodeListLenOf 4 pcRoundNo <- fromCBOR - pcBoostedBlock <- decodePoint (decodeRawHash (Proxy @blk)) + pcBoostedBlock <- fromCBOR pcVoters <- fromCBOR pcSignature <- fromCBOR pure @@ -90,23 +76,23 @@ instance (Typeable blk, ConvertRawHash blk) => FromCBOR (PerasCert blk) where , pcSignature } -instance (Typeable blk, ConvertRawHash blk) => ToCBOR (PerasCert blk) where +instance ToCBOR PerasCert where toCBOR cert = encodeListLen 4 <> toCBOR (pcRoundNo cert) - <> encodePoint (encodeRawHash (Proxy @blk)) (pcBoostedBlock cert) + <> toCBOR (pcBoostedBlock cert) <> toCBOR (pcVoters cert) <> toCBOR (pcSignature cert) -- | Voters contained in a certificate with their appropriate eligibility proof -newtype PerasCertVoters blk +newtype PerasCertVoters = PerasCertVoters { unPerasCertVoters :: - NE (Map PerasSeatIndex (PerasVoteEligibilityProof blk)) + NE (Map PerasSeatIndex PerasVoteEligibilityProof) } deriving (Eq, Show) -instance Typeable blk => FromCBOR (PerasCertVoters blk) where +instance FromCBOR PerasCertVoters where fromCBOR = do decodeListLenOf 2 votersBitmap <- fromCBOR @@ -119,7 +105,7 @@ instance Typeable blk => FromCBOR (PerasCertVoters blk) where , nonPersistentSigs } -instance Typeable blk => ToCBOR (PerasCertVoters blk) where +instance ToCBOR PerasCertVoters where toCBOR voters = encodeListLen 2 <> toCBOR votersBitmap @@ -155,10 +141,10 @@ instance Typeable blk => ToCBOR (PerasCertVoters blk) where -- 7 => non-persistent(np3) -- } -- @ -data CompactPerasCertVoters blk +data CompactPerasCertVoters = CompactPerasCertVoters { votersBitmap :: !(Bitmap Word16) - , nonPersistentSigs :: ![VRFOutput (PerasBLSCrypto blk)] + , nonPersistentSigs :: ![VRFOutput PerasBLSCrypto] } deriving (Eq, Show) @@ -166,8 +152,8 @@ data CompactPerasCertVoters blk -- -- See 'CompactPerasCertVoters' for the encoding scheme used here. fromCompactRepr :: - CompactPerasCertVoters blk -> - Either String (PerasCertVoters blk) + CompactPerasCertVoters -> + Either String PerasCertVoters fromCompactRepr CompactPerasCertVoters { votersBitmap @@ -209,8 +195,8 @@ fromCompactRepr -- -- See 'CompactPerasCertVoters' for the encoding scheme used here. toCompactRepr :: - PerasCertVoters blk -> - CompactPerasCertVoters blk + PerasCertVoters -> + CompactPerasCertVoters toCompactRepr (PerasCertVoters voters) = CompactPerasCertVoters { votersBitmap diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs index 4ac2072a32..aa23a44e10 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs @@ -1,10 +1,6 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -39,15 +35,13 @@ import Cardano.Ledger.Hashes (HASH) import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Builder.Extra as BS import qualified Data.ByteString.Short as BS -import Data.Proxy (Proxy (..)) -import Ouroboros.Consensus.Block - ( ConvertRawHash (..) - , Point - , pattern BlockPoint - , pattern GenesisPoint +import Ouroboros.Consensus.Block.RealPoint + ( bytes32RealPointHash + , bytes32RealPointSlot ) import Ouroboros.Consensus.Block.SupportsPeras - ( PerasRoundNo (..) + ( PerasBoostedBlock (..) + , PerasRoundNo (..) ) import Ouroboros.Consensus.Committee.Crypto ( CryptoSupportsAggregateVoteSigning (..) @@ -64,10 +58,10 @@ import Ouroboros.Consensus.Committee.Crypto.BLS (KeyRole (..)) import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS -- | BLS-based crypto scheme used in Peras voting committees -data PerasBLSCrypto blk +data PerasBLSCrypto -type instance ElectionId (PerasBLSCrypto blk) = PerasRoundNo -type instance VoteCandidate (PerasBLSCrypto blk) = Point blk +type instance ElectionId PerasBLSCrypto = PerasRoundNo +type instance VoteCandidate PerasBLSCrypto = PerasBoostedBlock -- | Private key of a Peras committee member data PerasPrivateKey @@ -76,7 +70,7 @@ data PerasPrivateKey , perasVRFSignKey :: BLS.PrivateKey VRF } -type instance PrivateKey (PerasBLSCrypto blk) = PerasPrivateKey +type instance PrivateKey PerasBLSCrypto = PerasPrivateKey -- | Public key of a Peras committee member data PerasPublicKey @@ -85,49 +79,47 @@ data PerasPublicKey , perasVRFVerKey :: BLS.PublicKey VRF } -type instance PublicKey (PerasBLSCrypto blk) = PerasPublicKey +type instance PublicKey PerasBLSCrypto = PerasPublicKey -- | Hash the message of a Peras vote -- -- NOTE: this is inspired by the implementation used by the Praos VRF check in -- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. hashVoteSignature :: - forall blk. - ConvertRawHash blk => - ElectionId (PerasBLSCrypto blk) -> - VoteCandidate (PerasBLSCrypto blk) -> + ElectionId PerasBLSCrypto -> + VoteCandidate PerasBLSCrypto -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN) -hashVoteSignature roundNo point = +hashVoteSignature roundNo boostedBlock = Hash.castHash . Hash.hashWith id . runByteBuilder (8 + 8 + 32) $ roundNoBytes - <> pointSlotBytes - <> pointHashBytes + <> boostedBlockSlotBytes + <> boostedBlockHashBytes where roundNoBytes = BS.word64BE . unPerasRoundNo $ roundNo - (pointSlotBytes, pointHashBytes) = case point of - GenesisPoint -> - ( BS.word64BE 0 - , mempty - ) - BlockPoint slotNo headerHash -> - ( BS.word64BE (unSlotNo slotNo) - , BS.byteStringCopy - . BS.fromShort - . toShortRawHash (Proxy @blk) - $ headerHash - ) + boostedBlockSlotBytes = + BS.word64BE + . unSlotNo + . bytes32RealPointSlot + . unPerasBoostedBlock + $ boostedBlock + boostedBlockHashBytes = + BS.byteStringCopy + . BS.fromShort + . bytes32RealPointHash + . unPerasBoostedBlock + $ boostedBlock -- | Hash the input for the VRF used in Peras elections -- -- NOTE: this is inspired by the implementation used by the Praos VRF check in -- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. hashVRFInput :: - ElectionId (PerasBLSCrypto blk) -> + ElectionId PerasBLSCrypto -> Nonce -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN) hashVRFInput roundNo epochNonce = @@ -145,11 +137,11 @@ hashVRFInput roundNo epochNonce = -- * Crypto instances -instance ConvertRawHash blk => CryptoSupportsVoteSigning (PerasBLSCrypto blk) where - type VoteSigningKey (PerasBLSCrypto blk) = BLS.PrivateKey SIGN - type VoteVerificationKey (PerasBLSCrypto blk) = BLS.PublicKey SIGN +instance CryptoSupportsVoteSigning PerasBLSCrypto where + type VoteSigningKey PerasBLSCrypto = BLS.PrivateKey SIGN + type VoteVerificationKey PerasBLSCrypto = BLS.PublicKey SIGN - newtype VoteSignature (PerasBLSCrypto blk) + newtype VoteSignature PerasBLSCrypto = PerasBLSCryptoVoteSignature { unPerasBLSCryptoVoteSignature :: BLS.Signature BLS.SIGN @@ -165,7 +157,7 @@ instance ConvertRawHash blk => CryptoSupportsVoteSigning (PerasBLSCrypto blk) wh signVote sk roundNo boostedBlock = PerasBLSCryptoVoteSignature . BLS.signWithRole @SIGN sk - $ hashVoteSignature @blk roundNo boostedBlock + $ hashVoteSignature roundNo boostedBlock verifyVoteSignature pk @@ -174,21 +166,21 @@ instance ConvertRawHash blk => CryptoSupportsVoteSigning (PerasBLSCrypto blk) wh (PerasBLSCryptoVoteSignature sig) = BLS.verifyWithRole @SIGN pk - (hashVoteSignature @blk roundNo boostedBlock) + (hashVoteSignature roundNo boostedBlock) sig -instance CryptoSupportsVRF (PerasBLSCrypto blk) where - type VRFSigningKey (PerasBLSCrypto blk) = BLS.PrivateKey VRF - type VRFVerificationKey (PerasBLSCrypto blk) = BLS.PublicKey VRF +instance CryptoSupportsVRF PerasBLSCrypto where + type VRFSigningKey PerasBLSCrypto = BLS.PrivateKey VRF + type VRFVerificationKey PerasBLSCrypto = BLS.PublicKey VRF - newtype VRFElectionInput (PerasBLSCrypto blk) + newtype VRFElectionInput PerasBLSCrypto = PerasBLSCryptoVRFElectionInput { unPerasBLSCryptoVRFElectionInput :: Hash HASH (SigDSIGN BLS12381MinSigDSIGN) } deriving stock (Eq, Show) - newtype VRFOutput (PerasBLSCrypto blk) + newtype VRFOutput PerasBLSCrypto = PerasBLSCryptoVRFOutput { unPerasBLSCryptoVRFOutput :: BLS.Signature VRF @@ -237,12 +229,12 @@ newtype PerasBLSCryptoAggregateVoteSignature deriving stock (Eq, Show) deriving newtype (FromCBOR, ToCBOR) -instance ConvertRawHash blk => CryptoSupportsAggregateVoteSigning (PerasBLSCrypto blk) where +instance CryptoSupportsAggregateVoteSigning PerasBLSCrypto where type - AggregateVoteVerificationKey (PerasBLSCrypto blk) = + AggregateVoteVerificationKey PerasBLSCrypto = PerasBLSCryptoAggregateVoteVerificationKey type - AggregateVoteSignature (PerasBLSCrypto blk) = + AggregateVoteSignature PerasBLSCrypto = PerasBLSCryptoAggregateVoteSignature aggregateVoteVerificationKeys _ pks = do @@ -264,10 +256,10 @@ instance ConvertRawHash blk => CryptoSupportsAggregateVoteSigning (PerasBLSCrypt aggSig = do BLS.verifyWithRole @SIGN (unPerasBLSCryptoAggregateVoteVerificationKey aggPk) - (hashVoteSignature @blk roundNo boostedBlock) + (hashVoteSignature roundNo boostedBlock) (unPerasBLSCryptoAggregateVoteSignature aggSig) -instance CryptoSupportsBatchVRFVerification (PerasBLSCrypto blk) where +instance CryptoSupportsBatchVRFVerification PerasBLSCrypto where -- NOTE: in contrast to vote signatures, we cannot aggregate multiple VRF -- outputs into a single one when forging a certificate (because we need to -- derive non-persistent seat numbers from each individual one). This means diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs index d0f737aba1..4f32a31ca0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} @@ -21,17 +20,10 @@ import Cardano.Binary , decodeListLenOf , encodeListLen ) -import Data.Proxy (Proxy (..)) -import Data.Typeable (Typeable) import Data.Word (Word8) -import Ouroboros.Consensus.Block - ( ConvertRawHash (..) - , Point - , decodeRawHash - , encodeRawHash - ) import Ouroboros.Consensus.Block.SupportsPeras - ( PerasRoundNo + ( PerasBoostedBlock + , PerasRoundNo , PerasSeatIndex ) import Ouroboros.Consensus.Committee.Crypto (CryptoSupportsVoteSigning (..)) @@ -39,35 +31,29 @@ import Ouroboros.Consensus.Peras.Crypto.BLS ( PerasBLSCrypto , VRFOutput ) -import Ouroboros.Network.Block (decodePoint, encodePoint) -- | Concrete Peras votes using BLS signatures --- 'blk' is mainly used here to ensure type family injectivity. --- For convenience/preventing annoying conversions, we also use it to indicate --- in 'Point blk' for the boosted block. -data PerasVote blk +data PerasVote = PerasVote { pvRoundNo :: !PerasRoundNo -- ^ Election identifier - , pvBoostedBlock :: !(Point blk) + , pvBoostedBlock :: !PerasBoostedBlock -- ^ Vote message, i.e., the hash of the block being voted for - -- TODO: 'blk' here may not refer to the actual era of the boosted block, - -- see https://github.com/tweag/cardano-peras/issues/251 , pvSeatIndex :: !PerasSeatIndex -- ^ Seat index assigned to the committee member (identifies the voter) - , pvEligibilityProof :: !(PerasVoteEligibilityProof blk) + , pvEligibilityProof :: !PerasVoteEligibilityProof -- ^ Proof of eligibility for voting, depending on the type of membership to -- the committee (persistent vs non-persistent) - , pvSignature :: !(VoteSignature (PerasBLSCrypto blk)) + , pvSignature :: !(VoteSignature PerasBLSCrypto) -- ^ BLS signature on the hash of the election identifier and vote message } deriving (Show, Eq) -instance (Typeable blk, ConvertRawHash blk) => FromCBOR (PerasVote blk) where +instance FromCBOR PerasVote where fromCBOR = do decodeListLenOf 5 pvRoundNo <- fromCBOR - pvBoostedBlock <- decodePoint (decodeRawHash (Proxy @blk)) + pvBoostedBlock <- fromCBOR pvSeatIndex <- fromCBOR pvEligibilityProof <- fromCBOR pvSignature <- fromCBOR @@ -80,24 +66,24 @@ instance (Typeable blk, ConvertRawHash blk) => FromCBOR (PerasVote blk) where , pvSignature } -instance (Typeable blk, ConvertRawHash blk) => ToCBOR (PerasVote blk) where +instance ToCBOR PerasVote where toCBOR vote = encodeListLen 5 <> toCBOR (pvRoundNo vote) - <> encodePoint (encodeRawHash (Proxy @blk)) (pvBoostedBlock vote) + <> toCBOR (pvBoostedBlock vote) <> toCBOR (pvSeatIndex vote) <> toCBOR (pvEligibilityProof vote) <> toCBOR (pvSignature vote) -- | Proof of eligibility for voting for committee members -data PerasVoteEligibilityProof blk +data PerasVoteEligibilityProof = -- | Persistent committee members require no additional proof of eligibility PersistentPerasVoteEligibilityProof | -- | Non-persistent committee members provide a VRF proof of eligibility - NonPersistentPerasVoteEligibilityProof !(VRFOutput (PerasBLSCrypto blk)) + NonPersistentPerasVoteEligibilityProof !(VRFOutput PerasBLSCrypto) deriving stock (Eq, Show) -instance Typeable blk => FromCBOR (PerasVoteEligibilityProof blk) where +instance FromCBOR PerasVoteEligibilityProof where fromCBOR = do len <- decodeListLen tag <- fromCBOR @Word8 @@ -109,7 +95,7 @@ instance Typeable blk => FromCBOR (PerasVoteEligibilityProof blk) where "Invalid PerasVoteEligibilityProof length/tag: " <> show (len, tag) -instance Typeable blk => ToCBOR (PerasVoteEligibilityProof blk) where +instance ToCBOR PerasVoteEligibilityProof where toCBOR = \case PersistentPerasVoteEligibilityProof -> encodeListLen 1 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs index 2fb2ace2d1..745196a356 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs @@ -79,8 +79,8 @@ class -- overflowing their `Word16` seat index. instance PerasVoteCompatibleWithVotingCommittee - (V1.PerasVote blk) - (PerasBLSCrypto blk) + V1.PerasVote + PerasBLSCrypto WFALS where toPerasVote = \case @@ -130,8 +130,8 @@ instance -- overflowing the `Word16` seat index of each voter. instance PerasCertCompatibleWithVotingCommittee - (V1.PerasCert blk) - (PerasBLSCrypto blk) + V1.PerasCert + PerasBLSCrypto WFALS where toPerasCert = \case @@ -160,8 +160,8 @@ instance -- avoiding overflowing their `Word16` seat index). instance PerasVoteCompatibleWithVotingCommittee - (V1.PerasVote blk) - (PerasBLSCrypto blk) + V1.PerasVote + PerasBLSCrypto EveryoneVotes where toPerasVote = \case @@ -196,8 +196,8 @@ instance -- (in addition to avoiding overflowing the `Word16` seat index of each voter). instance PerasCertCompatibleWithVotingCommittee - (V1.PerasCert blk) - (PerasBLSCrypto blk) + V1.PerasCert + PerasBLSCrypto EveryoneVotes where toPerasCert = \case @@ -263,8 +263,8 @@ toPerasSeatIndex (SeatIndex seatIndex) -- | Convert concrete Peras certificate voters to abstract committee voters fromPerasCertVoters :: - V1.PerasCertVoters blk -> - NE (Map SeatIndex (Maybe (VRFOutput (PerasBLSCrypto blk)))) + V1.PerasCertVoters -> + NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) fromPerasCertVoters voters = NEMap.fromAscList . NonEmpty.map @@ -283,8 +283,8 @@ fromPerasCertVoters voters = -- | Convert abstract committee voters to concrete Peras certificate voters toPerasCertVoters :: - NE (Map SeatIndex (Maybe (VRFOutput (PerasBLSCrypto blk)))) -> - Either PerasConversionError (V1.PerasCertVoters blk) + NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) -> + Either PerasConversionError V1.PerasCertVoters toPerasCertVoters voters = fmap V1.PerasCertVoters . fmap NEMap.fromAscList diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs index 00315f83f5..c67e6ff9a1 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs @@ -7,10 +7,7 @@ module Test.Consensus.Peras.Serialisation ) where import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeFull, serialize) -import Cardano.Ledger.BaseTypes (SlotNo (..)) import qualified Data.ByteString.Lazy as LazyByteString -import Ouroboros.Consensus.Block (Point) -import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), realPointToPoint) import Test.Consensus.Peras.Util ( genPerasCert , genPerasVote @@ -18,10 +15,8 @@ import Test.Consensus.Peras.Util , tabulatePerasCert , tabulatePerasVote ) -import Test.Ouroboros.Storage.TestBlock (TestBlock, TestHeaderHash (..)) import Test.QuickCheck - ( Arbitrary (..) - , Gen + ( Gen , Property , counterexample , forAll @@ -32,15 +27,6 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.TestEnv (adjustQuickCheckTests) --- | Generate an arbitrary 'Point' for 'TestBlock'. --- We reuse 'TestBlock' from "Test.Ouroboros.Storage.TestBlock" which already --- provides 'ConvertRawHash' (needed by the CBOR instances of Peras types). -genTestPoint :: Gen (Point TestBlock) -genTestPoint = do - slotNo <- SlotNo <$> arbitrary - hash <- TestHeaderHash <$> arbitrary - pure $ realPointToPoint $ RealPoint slotNo hash - tests :: TestTree tests = testGroup @@ -49,13 +35,13 @@ tests = testProperty "Roundtrip for PerasVote" $ prop_roundtrip -- Generate both persistent and non-persistent votes - (genPerasVote genTestPoint True) + (genPerasVote True) tabulatePerasVote , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasCert" $ prop_roundtrip -- Generate certs with both persistent and non-persistent votes - (genPerasCert genTestPoint True) + (genPerasCert True) tabulatePerasCert ] diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs index 0647073bbd..b1c4007be2 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs @@ -22,8 +22,11 @@ module Test.Consensus.Peras.Util ) where import Cardano.Crypto.Hash (ByteString) +import Cardano.Ledger.BaseTypes (SlotNo (..)) import Control.Monad (forM) import qualified Data.ByteString as ByteString +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as ShortByteString import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.NonEmpty as NEMap import Data.Maybe (catMaybes, fromMaybe) @@ -32,7 +35,8 @@ import Data.String (IsString (..)) import Data.Traversable (mapAccumM) import Data.Word (Word8) import GHC.Word (Word16) -import Ouroboros.Consensus.Block (Point) +import Ouroboros.Consensus.Block (HeaderHash) +import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), toBytes32RealPoint) import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import Ouroboros.Consensus.Peras.Crypto.BLS @@ -41,7 +45,8 @@ import Ouroboros.Consensus.Peras.Crypto.BLS , VoteSignature (..) ) import Ouroboros.Consensus.Peras.Types - ( PerasRoundNo (..) + ( PerasBoostedBlock (..) + , PerasRoundNo (..) , PerasSeatIndex (..) ) import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 @@ -59,13 +64,13 @@ import Test.QuickCheck -- * Predicates -- | Whether a Peras vote is a persistent one -perasVoteIsPersistent :: V1.PerasVote blk -> Bool +perasVoteIsPersistent :: V1.PerasVote -> Bool perasVoteIsPersistent vote | V1.PersistentPerasVoteEligibilityProof{} <- V1.pvEligibilityProof vote = True | otherwise = False -- | Whether a Peras certifcate only contains persistent votes -perasCertContainsOnlyPersistentVotes :: V1.PerasCert blk -> Bool +perasCertContainsOnlyPersistentVotes :: V1.PerasCert -> Bool perasCertContainsOnlyPersistentVotes cert = all ( \case @@ -83,6 +88,18 @@ perasCertContainsOnlyPersistentVotes cert = genRoundNo :: Gen PerasRoundNo genRoundNo = PerasRoundNo <$> arbitrary +data BlockWith32BytesHeaderHash +type instance HeaderHash BlockWith32BytesHeaderHash = ShortByteString + +genBoostedBlock :: Gen PerasBoostedBlock +genBoostedBlock = do + slotNo <- SlotNo <$> arbitrary + hash <- ShortByteString.pack <$> vectorOf 32 arbitrary + let bytes32realPoint = + toBytes32RealPoint @BlockWith32BytesHeaderHash $ + RealPoint slotNo hash + pure (PerasBoostedBlock bytes32realPoint) + genSeatIndex :: Gen PerasSeatIndex genSeatIndex = PerasSeatIndex <$> arbitrary @@ -103,7 +120,7 @@ genSignature _ = do msg <- fromString @ByteString <$> arbitrary pure $ BLS.signWithRole key msg -genVoteEligibilityProof :: Bool -> Gen (V1.PerasVoteEligibilityProof blk) +genVoteEligibilityProof :: Bool -> Gen V1.PerasVoteEligibilityProof genVoteEligibilityProof shouldGenNonPersistent = do frequency [ @@ -118,7 +135,7 @@ genVoteEligibilityProof shouldGenNonPersistent = do ) ] -genVoters :: Bool -> Gen (V1.PerasCertVoters blk) +genVoters :: Bool -> Gen V1.PerasCertVoters genVoters shouldGenNonPersistent = do numVoters <- sized $ \size -> @@ -162,8 +179,8 @@ genVoters shouldGenNonPersistent = do pure $ V1.PerasCertVoters (NEMap.fromList (NonEmpty.fromList voters)) -genPerasVote :: Gen (Point blk) -> Bool -> Gen (V1.PerasVote blk) -genPerasVote genBoostedBlock shouldGenNonPersistent = do +genPerasVote :: Bool -> Gen V1.PerasVote +genPerasVote shouldGenNonPersistent = do pvRoundNo <- genRoundNo pvBoostedBlock <- genBoostedBlock pvSeatIndex <- genSeatIndex @@ -180,8 +197,8 @@ genPerasVote genBoostedBlock shouldGenNonPersistent = do , V1.pvSignature } -genPerasCert :: Gen (Point blk) -> Bool -> Gen (V1.PerasCert blk) -genPerasCert genBoostedBlock shouldGenNonPersistent = do +genPerasCert :: Bool -> Gen V1.PerasCert +genPerasCert shouldGenNonPersistent = do pcRoundNo <- genRoundNo pcBoostedBlock <- genBoostedBlock pcVoters <- genVoters shouldGenNonPersistent @@ -206,7 +223,7 @@ mkBucket bucketSize x suffix lower = (x `div` bucketSize) * bucketSize upper = lower + bucketSize -tabulatePerasCert :: V1.PerasCert blk -> Property -> Property +tabulatePerasCert :: V1.PerasCert -> Property -> Property tabulatePerasCert cert = foldr (flip (.)) id $ [ tabulate @@ -224,11 +241,7 @@ tabulatePerasCert cert = $ cert numPersistentVoters = length - . filter - ( \case - V1.PersistentPerasVoteEligibilityProof -> True - V1.NonPersistentPerasVoteEligibilityProof{} -> False - ) + . filter (== V1.PersistentPerasVoteEligibilityProof) . NonEmpty.toList . NEMap.elems . V1.unPerasCertVoters @@ -239,7 +252,7 @@ tabulatePerasCert cert = | numVoters == 0 = 0 | otherwise = numPersistentVoters * 100 `div` numVoters -tabulatePerasVote :: V1.PerasVote blk -> Property -> Property +tabulatePerasVote :: V1.PerasVote -> Property -> Property tabulatePerasVote vote = foldr (flip (.)) id $ [ tabulate diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs index 8cf1a1b5bd..ab9d800919 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs @@ -7,10 +7,7 @@ module Test.Consensus.Peras.Voting.Committee ( tests ) where -import Cardano.Ledger.BaseTypes (SlotNo (..)) import Data.Proxy (Proxy (..)) -import Ouroboros.Consensus.Block (Point) -import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), realPointToPoint) import qualified Ouroboros.Consensus.Committee.Class as Committee import Ouroboros.Consensus.Committee.EveryoneVotes (EveryoneVotes) import Ouroboros.Consensus.Committee.WFALS (WFALS) @@ -28,10 +25,8 @@ import Test.Consensus.Peras.Util , tabulatePerasCert , tabulatePerasVote ) -import Test.Ouroboros.Storage.TestBlock (TestBlock, TestHeaderHash (..)) import Test.QuickCheck - ( Arbitrary (..) - , Gen + ( Gen , Property , Testable (..) , counterexample @@ -44,15 +39,6 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.TestEnv (adjustQuickCheckTests) --- | Generate an arbitrary 'Point' for 'TestBlock'. --- We reuse 'TestBlock' from "Test.Ouroboros.Storage.TestBlock" which already --- provides 'ConvertRawHash'. -genTestPoint :: Gen (Point TestBlock) -genTestPoint = do - slotNo <- SlotNo <$> arbitrary - hash <- TestHeaderHash <$> arbitrary - pure $ realPointToPoint $ RealPoint slotNo hash - tests :: TestTree tests = testGroup @@ -60,44 +46,44 @@ tests = [ adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasVote via WFALS" $ prop_roundtrip_vote - (Proxy @(V1.PerasVote TestBlock)) + (Proxy @V1.PerasVote) (Proxy @WFALS) -- WFALS supports both persistent and non-persistent of votes (const True) -- Generate both persistent and non-persistent votes - (genPerasVote genTestPoint True) + (genPerasVote True) tabulatePerasVote , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasVote via EveryoneVotes" $ prop_roundtrip_vote - (Proxy @(V1.PerasVote TestBlock)) + (Proxy @V1.PerasVote) (Proxy @EveryoneVotes) -- EveryoneVotes only supports non-persistent votes perasVoteIsPersistent -- Generate both persistent and non-persistent votes to trigger -- conversion errors in a reasonable amount of tests - (genPerasVote genTestPoint =<< frequency [(2, pure True), (1, pure False)]) + (genPerasVote =<< frequency [(2, pure True), (1, pure False)]) tabulatePerasVote , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasCert via WFALS" $ prop_roundtrip_cert - (Proxy @(V1.PerasCert TestBlock)) + (Proxy @V1.PerasCert) (Proxy @WFALS) -- WFALS supports certs with both persistent and non-persistent votes (const True) -- Generate certs with both persistent and non-persistent votes - (genPerasCert genTestPoint True) + (genPerasCert True) tabulatePerasCert , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasCert via EveryoneVotes" $ prop_roundtrip_cert - (Proxy @(V1.PerasCert TestBlock)) + (Proxy @V1.PerasCert) (Proxy @EveryoneVotes) -- EveryoneVotes only supports certs with persistent votes perasCertContainsOnlyPersistentVotes -- Only sometimes generate certs with non-persistent votes to -- trigger conversion errors in a reasonable amount of tests - (genPerasCert genTestPoint =<< frequency [(2, pure False), (1, pure True)]) + (genPerasCert =<< frequency [(2, pure False), (1, pure True)]) tabulatePerasCert ] From 4f26fc57fb45713dadcc426e90921690b432f146 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 20 May 2026 13:10:50 +0200 Subject: [PATCH 28/62] Add WithOrigin to PerasBoostedBlock --- .../Ouroboros/Consensus/Peras/Crypto/BLS.hs | 21 +++++++++++-------- .../Ouroboros/Consensus/Peras/Types.hs | 9 ++++---- .../Test/Consensus/Peras/Util.hs | 21 ++++++++++++------- 3 files changed, 31 insertions(+), 20 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs index aa23a44e10..31903225ca 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs @@ -35,6 +35,7 @@ import Cardano.Ledger.Hashes (HASH) import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Builder.Extra as BS import qualified Data.ByteString.Short as BS +import Ouroboros.Consensus.Block.Abstract (WithOrigin (..)) import Ouroboros.Consensus.Block.RealPoint ( bytes32RealPointHash , bytes32RealPointSlot @@ -93,26 +94,28 @@ hashVoteSignature roundNo boostedBlock = Hash.castHash . Hash.hashWith id . runByteBuilder (8 + 8 + 32) - $ roundNoBytes - <> boostedBlockSlotBytes - <> boostedBlockHashBytes + $ roundNoBytes <> boostedBlockBytes where roundNoBytes = BS.word64BE . unPerasRoundNo $ roundNo - boostedBlockSlotBytes = + boostedBlockBytes = + case unPerasBoostedBlock boostedBlock of + Origin -> + mempty + NotOrigin point -> + bytes32RealPointSlotBytes point + <> bytes32RealPointHashBytes point + + bytes32RealPointSlotBytes = BS.word64BE . unSlotNo . bytes32RealPointSlot - . unPerasBoostedBlock - $ boostedBlock - boostedBlockHashBytes = + bytes32RealPointHashBytes = BS.byteStringCopy . BS.fromShort . bytes32RealPointHash - . unPerasBoostedBlock - $ boostedBlock -- | Hash the input for the VRF used in Peras elections -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs index 86a2f7adf6..1327eb6045 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -39,7 +39,7 @@ import Data.Semigroup (Sum (..)) import Data.Word (Word16, Word64) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) -import Ouroboros.Consensus.Block.Abstract (Point) +import Ouroboros.Consensus.Block.Abstract (Point, WithOrigin) import Ouroboros.Consensus.Block.RealPoint ( Bytes32RealPoint , decodeBytes32RealPoint @@ -51,6 +51,7 @@ import Ouroboros.Consensus.Peras.Params , PerasQuorumStakeThresholdSafetyMargin (..) ) import Ouroboros.Consensus.Util (ShowProxy (..)) +import Ouroboros.Consensus.Util.CBOR (decodeWithOrigin, encodeWithOrigin) import Ouroboros.Consensus.Util.Condense (Condense (..)) import Quiet (Quiet (..)) @@ -86,15 +87,15 @@ onPerasRoundNo = coerce -- mocked votes and certificates generally use the more abstract 'Point blk'. newtype PerasBoostedBlock = PerasBoostedBlock - { unPerasBoostedBlock :: Bytes32RealPoint + { unPerasBoostedBlock :: WithOrigin Bytes32RealPoint } deriving stock (Eq, Show) instance FromCBOR PerasBoostedBlock where - fromCBOR = PerasBoostedBlock <$> decodeBytes32RealPoint + fromCBOR = PerasBoostedBlock <$> decodeWithOrigin decodeBytes32RealPoint instance ToCBOR PerasBoostedBlock where - toCBOR = encodeBytes32RealPoint . unPerasBoostedBlock + toCBOR = encodeWithOrigin encodeBytes32RealPoint . unPerasBoostedBlock -- ** Seat indices diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs index b1c4007be2..13cce494da 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs @@ -36,6 +36,7 @@ import Data.Traversable (mapAccumM) import Data.Word (Word8) import GHC.Word (Word16) import Ouroboros.Consensus.Block (HeaderHash) +import Ouroboros.Consensus.Block.Abstract (WithOrigin (..)) import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), toBytes32RealPoint) import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 @@ -92,13 +93,19 @@ data BlockWith32BytesHeaderHash type instance HeaderHash BlockWith32BytesHeaderHash = ShortByteString genBoostedBlock :: Gen PerasBoostedBlock -genBoostedBlock = do - slotNo <- SlotNo <$> arbitrary - hash <- ShortByteString.pack <$> vectorOf 32 arbitrary - let bytes32realPoint = - toBytes32RealPoint @BlockWith32BytesHeaderHash $ - RealPoint slotNo hash - pure (PerasBoostedBlock bytes32realPoint) +genBoostedBlock = PerasBoostedBlock <$> genWithOrigin genBytes32RealPoint + where + genWithOrigin gen = + frequency + [ (1, pure Origin) + , (9, NotOrigin <$> gen) + ] + genBytes32RealPoint = do + slotNo <- SlotNo <$> arbitrary + hash <- ShortByteString.pack <$> vectorOf 32 arbitrary + pure $ + toBytes32RealPoint @BlockWith32BytesHeaderHash $ + RealPoint slotNo hash genSeatIndex :: Gen PerasSeatIndex genSeatIndex = PerasSeatIndex <$> arbitrary From caf0ea7f34dd345ecf5d1d239488531b48c659b7 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 20 May 2026 14:35:49 +0200 Subject: [PATCH 29/62] Rename Peras.Voting.Committee to Peras.Voting.Adapter --- ouroboros-consensus.cabal | 4 ++-- .../Consensus/Peras/Voting/{Committee.hs => Adapter.hs} | 2 +- ouroboros-consensus/test/consensus-test/Main.hs | 4 ++-- .../Consensus/Peras/Voting/{Committee.hs => Adapter.hs} | 8 +++----- 4 files changed, 8 insertions(+), 10 deletions(-) rename ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/{Committee.hs => Adapter.hs} (99%) rename ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/{Committee.hs => Adapter.hs} (97%) diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 31d7af5e83..9d582b4c91 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -246,7 +246,7 @@ library Ouroboros.Consensus.Peras.Vote.Aggregation Ouroboros.Consensus.Peras.Vote.Mock Ouroboros.Consensus.Peras.Vote.V1 - Ouroboros.Consensus.Peras.Voting.Committee + Ouroboros.Consensus.Peras.Voting.Adapter Ouroboros.Consensus.Peras.Voting.Rules Ouroboros.Consensus.Peras.Voting.View Ouroboros.Consensus.Peras.Weight @@ -682,7 +682,7 @@ test-suite consensus-test Test.Consensus.Peras.Cert.Inclusion Test.Consensus.Peras.Serialisation Test.Consensus.Peras.Util - Test.Consensus.Peras.Voting.Committee + Test.Consensus.Peras.Voting.Adapter Test.Consensus.Peras.Voting.Rules Test.Consensus.Peras.WeightSnapshot Test.Consensus.Util.Bitmap diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs similarity index 99% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs rename to ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs index 745196a356..c6a77501ac 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Committee.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs @@ -6,7 +6,7 @@ -- | Support for using concrete votes and certificates with multiple voting -- committee implementations. -module Ouroboros.Consensus.Peras.Voting.Committee +module Ouroboros.Consensus.Peras.Voting.Adapter ( -- * Peras support for multiple voting committee implementations PerasConversionError (..) , PerasVoteCompatibleWithVotingCommittee (..) diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index c66e29766d..cb4181c933 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -24,7 +24,7 @@ import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke (te import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke (tests) import qualified Test.Consensus.Peras.Cert.Inclusion (tests) import qualified Test.Consensus.Peras.Serialisation (tests) -import qualified Test.Consensus.Peras.Voting.Committee (tests) +import qualified Test.Consensus.Peras.Voting.Adapter (tests) import qualified Test.Consensus.Peras.Voting.Rules (tests) import qualified Test.Consensus.Peras.WeightSnapshot (tests) import qualified Test.Consensus.Util.Bitmap (tests) @@ -69,7 +69,7 @@ tests = , testGroup "Peras" [ Test.Consensus.Peras.Cert.Inclusion.tests - , Test.Consensus.Peras.Voting.Committee.tests + , Test.Consensus.Peras.Voting.Adapter.tests , Test.Consensus.Peras.Voting.Rules.tests , Test.Consensus.Peras.WeightSnapshot.tests , Test.Consensus.Peras.Serialisation.tests diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs similarity index 97% rename from ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs rename to ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs index ab9d800919..f605e02dfc 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Committee.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs @@ -2,10 +2,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} --- | Test properties relating Peras and voting committee types. -module Test.Consensus.Peras.Voting.Committee - ( tests - ) where +-- | Test properties of the adapters between Peras and voting committee types. +module Test.Consensus.Peras.Voting.Adapter (tests) where import Data.Proxy (Proxy (..)) import qualified Ouroboros.Consensus.Committee.Class as Committee @@ -13,7 +11,7 @@ import Ouroboros.Consensus.Committee.EveryoneVotes (EveryoneVotes) import Ouroboros.Consensus.Committee.WFALS (WFALS) import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 -import Ouroboros.Consensus.Peras.Voting.Committee +import Ouroboros.Consensus.Peras.Voting.Adapter ( PerasCertCompatibleWithVotingCommittee (..) , PerasVoteCompatibleWithVotingCommittee (..) ) From 29714af8e2c84c9023e13f6ada0e3c7566087f1d Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 21 May 2026 11:31:59 +0200 Subject: [PATCH 30/62] Add phantom type parameter to `V1.Peras{Vote,Cert}` --- .../Ouroboros/Consensus/Peras/Cert/V1.hs | 11 ++++++++--- .../Ouroboros/Consensus/Peras/Vote/V1.hs | 11 ++++++++--- .../Ouroboros/Consensus/Peras/Voting/Adapter.hs | 8 ++++---- .../Test/Consensus/Peras/Serialisation.hs | 7 +++++-- .../test/consensus-test/Test/Consensus/Peras/Util.hs | 12 ++++++------ .../Test/Consensus/Peras/Voting/Adapter.hs | 8 ++++---- 6 files changed, 35 insertions(+), 22 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs index 889fe06cc2..a9351c4ee9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs @@ -29,6 +29,7 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.NonEmpty as NEMap import Data.Map.Strict (Map) import Data.Maybe (catMaybes) +import Data.Typeable (Typeable) import Data.Word (Word16) import Ouroboros.Consensus.Block.SupportsPeras ( PerasBoostedBlock @@ -47,7 +48,11 @@ import Ouroboros.Consensus.Util.Bitmap (Bitmap) import qualified Ouroboros.Consensus.Util.Bitmap as Bitmap -- | Concrete Peras certificates using BLS signatures -data PerasCert +-- +-- NOTE: the 'tag' parameter is a phantom type used to track the block type that +-- the certificate is associated with, to ensure injectivity when 'V1.PerasCert' +-- is used as a type instance for 'BlockSupportsPeras' class. +data PerasCert tag = PerasCert { pcRoundNo :: !PerasRoundNo -- ^ Election identifier @@ -61,7 +66,7 @@ data PerasCert } deriving (Show, Eq) -instance FromCBOR PerasCert where +instance Typeable tag => FromCBOR (PerasCert tag) where fromCBOR = do decodeListLenOf 4 pcRoundNo <- fromCBOR @@ -76,7 +81,7 @@ instance FromCBOR PerasCert where , pcSignature } -instance ToCBOR PerasCert where +instance Typeable tag => ToCBOR (PerasCert tag) where toCBOR cert = encodeListLen 4 <> toCBOR (pcRoundNo cert) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs index 4f32a31ca0..de9b37f84d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs @@ -20,6 +20,7 @@ import Cardano.Binary , decodeListLenOf , encodeListLen ) +import Data.Typeable (Typeable) import Data.Word (Word8) import Ouroboros.Consensus.Block.SupportsPeras ( PerasBoostedBlock @@ -33,7 +34,11 @@ import Ouroboros.Consensus.Peras.Crypto.BLS ) -- | Concrete Peras votes using BLS signatures -data PerasVote +-- +-- NOTE: the 'tag' parameter is a phantom type used to track the block type that +-- the vote is associated with, to ensure injectivity when 'V1.PerasVote' is +-- used as a type instance for 'BlockSupportsPeras' class. +data PerasVote tag = PerasVote { pvRoundNo :: !PerasRoundNo -- ^ Election identifier @@ -49,7 +54,7 @@ data PerasVote } deriving (Show, Eq) -instance FromCBOR PerasVote where +instance Typeable tag => FromCBOR (PerasVote tag) where fromCBOR = do decodeListLenOf 5 pvRoundNo <- fromCBOR @@ -66,7 +71,7 @@ instance FromCBOR PerasVote where , pvSignature } -instance ToCBOR PerasVote where +instance Typeable tag => ToCBOR (PerasVote tag) where toCBOR vote = encodeListLen 5 <> toCBOR (pvRoundNo vote) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs index c6a77501ac..86a0ee9bba 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs @@ -79,7 +79,7 @@ class -- overflowing their `Word16` seat index. instance PerasVoteCompatibleWithVotingCommittee - V1.PerasVote + (V1.PerasVote tag) PerasBLSCrypto WFALS where @@ -130,7 +130,7 @@ instance -- overflowing the `Word16` seat index of each voter. instance PerasCertCompatibleWithVotingCommittee - V1.PerasCert + (V1.PerasCert tag) PerasBLSCrypto WFALS where @@ -160,7 +160,7 @@ instance -- avoiding overflowing their `Word16` seat index). instance PerasVoteCompatibleWithVotingCommittee - V1.PerasVote + (V1.PerasVote tag) PerasBLSCrypto EveryoneVotes where @@ -196,7 +196,7 @@ instance -- (in addition to avoiding overflowing the `Word16` seat index of each voter). instance PerasCertCompatibleWithVotingCommittee - V1.PerasCert + (V1.PerasCert tag) PerasBLSCrypto EveryoneVotes where diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs index c67e6ff9a1..02a9c8b0b9 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | Serialisation roundtrip tests for Peras types module Test.Consensus.Peras.Serialisation @@ -8,6 +9,8 @@ module Test.Consensus.Peras.Serialisation import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeFull, serialize) import qualified Data.ByteString.Lazy as LazyByteString +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 import Test.Consensus.Peras.Util ( genPerasCert , genPerasVote @@ -33,13 +36,13 @@ tests = "Serialization roundtrip for Peras types" [ adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasVote" $ - prop_roundtrip + prop_roundtrip @(V1.PerasVote ()) -- Generate both persistent and non-persistent votes (genPerasVote True) tabulatePerasVote , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasCert" $ - prop_roundtrip + prop_roundtrip @(V1.PerasCert ()) -- Generate certs with both persistent and non-persistent votes (genPerasCert True) tabulatePerasCert diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs index 13cce494da..cabea97e26 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs @@ -65,13 +65,13 @@ import Test.QuickCheck -- * Predicates -- | Whether a Peras vote is a persistent one -perasVoteIsPersistent :: V1.PerasVote -> Bool +perasVoteIsPersistent :: V1.PerasVote tag -> Bool perasVoteIsPersistent vote | V1.PersistentPerasVoteEligibilityProof{} <- V1.pvEligibilityProof vote = True | otherwise = False -- | Whether a Peras certifcate only contains persistent votes -perasCertContainsOnlyPersistentVotes :: V1.PerasCert -> Bool +perasCertContainsOnlyPersistentVotes :: V1.PerasCert tag -> Bool perasCertContainsOnlyPersistentVotes cert = all ( \case @@ -186,7 +186,7 @@ genVoters shouldGenNonPersistent = do pure $ V1.PerasCertVoters (NEMap.fromList (NonEmpty.fromList voters)) -genPerasVote :: Bool -> Gen V1.PerasVote +genPerasVote :: Bool -> Gen (V1.PerasVote tag) genPerasVote shouldGenNonPersistent = do pvRoundNo <- genRoundNo pvBoostedBlock <- genBoostedBlock @@ -204,7 +204,7 @@ genPerasVote shouldGenNonPersistent = do , V1.pvSignature } -genPerasCert :: Bool -> Gen V1.PerasCert +genPerasCert :: Bool -> Gen (V1.PerasCert tag) genPerasCert shouldGenNonPersistent = do pcRoundNo <- genRoundNo pcBoostedBlock <- genBoostedBlock @@ -230,7 +230,7 @@ mkBucket bucketSize x suffix lower = (x `div` bucketSize) * bucketSize upper = lower + bucketSize -tabulatePerasCert :: V1.PerasCert -> Property -> Property +tabulatePerasCert :: V1.PerasCert tag -> Property -> Property tabulatePerasCert cert = foldr (flip (.)) id $ [ tabulate @@ -259,7 +259,7 @@ tabulatePerasCert cert = | numVoters == 0 = 0 | otherwise = numPersistentVoters * 100 `div` numVoters -tabulatePerasVote :: V1.PerasVote -> Property -> Property +tabulatePerasVote :: V1.PerasVote tag -> Property -> Property tabulatePerasVote vote = foldr (flip (.)) id $ [ tabulate diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs index f605e02dfc..3cd82dd231 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs @@ -44,7 +44,7 @@ tests = [ adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasVote via WFALS" $ prop_roundtrip_vote - (Proxy @V1.PerasVote) + (Proxy @(V1.PerasVote ())) (Proxy @WFALS) -- WFALS supports both persistent and non-persistent of votes (const True) @@ -54,7 +54,7 @@ tests = , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasVote via EveryoneVotes" $ prop_roundtrip_vote - (Proxy @V1.PerasVote) + (Proxy @(V1.PerasVote ())) (Proxy @EveryoneVotes) -- EveryoneVotes only supports non-persistent votes perasVoteIsPersistent @@ -65,7 +65,7 @@ tests = , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasCert via WFALS" $ prop_roundtrip_cert - (Proxy @V1.PerasCert) + (Proxy @(V1.PerasCert ())) (Proxy @WFALS) -- WFALS supports certs with both persistent and non-persistent votes (const True) @@ -75,7 +75,7 @@ tests = , adjustQuickCheckTests (* 10) $ testProperty "Roundtrip for PerasCert via EveryoneVotes" $ prop_roundtrip_cert - (Proxy @V1.PerasCert) + (Proxy @(V1.PerasCert ())) (Proxy @EveryoneVotes) -- EveryoneVotes only supports certs with persistent votes perasCertContainsOnlyPersistentVotes From cd35001b311d1b50bfee4c0f5ad1f78e0a292534 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 21 May 2026 16:03:47 +0200 Subject: [PATCH 31/62] WIP implementing PerasVotingCommittee opaque adapter --- .../Consensus/Protocol/Praos/Peras.hs | 263 ++++++++++++++++++ ouroboros-consensus.cabal | 4 + 2 files changed, 267 insertions(+) create mode 100644 ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs new file mode 100644 index 0000000000..ddb49fa4e4 --- /dev/null +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Voting interface for Peras derived from the Praos ledger view. +module Ouroboros.Consensus.Protocol.Praos.Peras + ( PerasSupportedVotingCommittee (..) + , PerasVotingError (..) + , PerasVotingCommittee + , mkPerasVotingCommittee + , perasForgeVoteIfEligible + ) +where + +import qualified Cardano.Ledger.Shelley.State as SL +import Control.Exception (Exception) +import Data.Aeson (eitherDecodeFileStrict') +import Data.Bifunctor (Bifunctor (..)) +import qualified Data.ByteString.Char8 as ByteString +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Ouroboros.Consensus.Block.SupportsPeras (PerasBoostedBlock, PerasRoundNo) +import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) +import qualified Ouroboros.Consensus.Committee.Class as Committee +import Ouroboros.Consensus.Committee.Crypto (PrivateKey, PublicKey) +import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS +import Ouroboros.Consensus.Committee.EveryoneVotes + ( EveryoneVotes + , VotingCommitteeInput (..) + ) +import Ouroboros.Consensus.Committee.Types + ( LedgerStake (..) + , PoolId (..) + , TargetCommitteeSize + ) +import Ouroboros.Consensus.Committee.WFA + ( WFAError + , mkExtWFAStakeDistr + , wFATiebreakerWithEpochNonce + ) +import Ouroboros.Consensus.Committee.WFALS + ( VotingCommitteeInput (..) + , WFALS + ) +import Ouroboros.Consensus.Peras.Crypto.BLS + ( PerasBLSCrypto + , PerasPublicKey (..) + ) +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import Ouroboros.Consensus.Peras.Voting.Adapter + ( PerasConversionError + , PerasVoteCompatibleWithVotingCommittee (..) + ) +import Ouroboros.Consensus.Protocol.Praos + ( PraosState (..) + , Ticked (..) + ) +import Ouroboros.Consensus.Protocol.Praos.Views (LedgerView (..)) +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) + +-- | Voting committee schemes supported by Peras. +-- +-- NOTE: this is used internally as a singleton to determine which voting +-- committee scheme to use when constructing votes, certificates, and errors. +data PerasSupportedVotingCommittee committee where + PerasWFALSVotingCommittee :: + TargetCommitteeSize -> + PerasSupportedVotingCommittee WFALS + PerasEveryoneVotesVotingCommittee :: + PerasSupportedVotingCommittee EveryoneVotes + +-- | Collection of voting-related errors for Peras +data PerasVotingError + = PerasVotingWFAError + WFAError + | PerasVotingWFALSError + (VotingCommitteeError PerasBLSCrypto WFALS) + | PerasVotingEveryoneVotesError + (VotingCommitteeError PerasBLSCrypto EveryoneVotes) + | PerasVotingConversionError + PerasConversionError + | PerasVotingPublicKeyError + PerasPublicKeyError + deriving (Show, Exception) + +-- | Opaque voting committee for Peras +data PerasVotingCommittee where + PerasVotingCommittee :: + CryptoSupportsVotingCommittee PerasBLSCrypto committee => + PerasSupportedVotingCommittee committee -> + VotingCommittee PerasBLSCrypto committee -> + PerasVotingCommittee + +-- | Construct a 'PerasVotingCommittee' from a 'Ticked PraosState'. +-- +-- NOTE: the Praos 'LedgerView' needs to be extended with the public keys of the +-- pools in the stake distribution. These are needed to validate Peras votes and +-- certificates. +-- +-- FIXME: for now, public keys are read from a JSON file specified by an +-- environment variable using 'unsafePerformIO'. This is a temporary hack until +-- we have a proper solution to retrieve public keys from the ledger state. +mkPerasVotingCommittee :: + PerasSupportedVotingCommittee committee -> + Ticked PraosState -> + Either PerasVotingError PerasVotingCommittee +mkPerasVotingCommittee + committeeType + tickedPraosState = do + let epochNonce = + praosStateEpochNonce + . tickedPraosStateChainDepState + $ tickedPraosState + let wFATiebreaker = + wFATiebreakerWithEpochNonce epochNonce + stakeDistrWithPublicKeys <- + bimap PerasVotingPublicKeyError id $ + getStakeDistrWithPublicKeys tickedPraosState + extWFAStakeDistr <- + bimap PerasVotingWFAError id $ + mkExtWFAStakeDistr + wFATiebreaker + stakeDistrWithPublicKeys + case committeeType of + PerasWFALSVotingCommittee targetCommitteeSize -> + bimap PerasVotingWFALSError (PerasVotingCommittee committeeType) + . Committee.mkVotingCommittee + $ WFALSVotingCommitteeInput + epochNonce + targetCommitteeSize + extWFAStakeDistr + PerasEveryoneVotesVotingCommittee -> + bimap PerasVotingEveryoneVotesError (PerasVotingCommittee committeeType) + . Committee.mkVotingCommittee + $ EveryoneVotesVotingCommitteeInput + extWFAStakeDistr + +getStakeDistrWithPublicKeys :: + Ticked PraosState -> + Either + PerasPublicKeyError + (Map PoolId (LedgerStake, PublicKey PerasBLSCrypto)) +getStakeDistrWithPublicKeys tickedPraosState = do + let stakeDistr = + Map.mapKeysMonotonic PoolId + . Map.map (LedgerStake . SL.individualPoolStake) + . SL.unPoolDistr + . lvPoolDistr + . tickedPraosStateLedgerView + $ tickedPraosState + + publicKeys <- perasPublicKeysFromEnv -- Uses 'unsafePerformIO' + Map.traverseWithKey (addPublicKey publicKeys) stakeDistr + where + addPublicKey publicKeys poolId stake = + case Map.lookup poolId publicKeys of + Nothing -> + failWith $ "Public key not found for pool: " <> show poolId + Just pk -> + pure (stake, pk) + + failWith msg = + Left (PerasPublicKeyError msg) + +-- * Retrieveing public keys from a JSON file (temporary) + +data PerasPublicKeyError + = PerasPublicKeyError String + deriving (Show, Exception) + +perasPublicKeysFromEnv :: Either PerasPublicKeyError (Map PoolId PerasPublicKey) +perasPublicKeysFromEnv = + unsafePerformIO $ do + lookupEnv envVar >>= \case + Nothing -> do + pure $ failWith $ "Environment variable " <> envVar <> " not set." + Just keysFile -> do + eitherDecodeFileStrict' keysFile >>= \case + Left err -> do + pure $ failWith $ "Failed to parse public keys from file: " <> err + Right rawKeys -> do + pure $ decodeKeys rawKeys + where + envVar = + "PERAS_PUBLIC_KEY_FILE" + + keyScope = + "TESTNET" + + decodeKeys = + fmap (Map.mapKeysMonotonic PoolId) + . traverse decodeKey + + decodeKey key = + case BLS.rawDeserialisePublicKey keyScope (ByteString.pack key) of + Nothing -> + failWith $ "Invalid public key format: " <> key + Just pk -> + Right $ + PerasPublicKey + { perasVoteVerKey = BLS.coercePublicKey @BLS.SIGN pk + , perasVRFVerKey = BLS.coercePublicKey @BLS.VRF pk + } + + failWith msg = + Left (PerasPublicKeyError msg) + +-- * Partially applied 'CryptoSupportsVotingCommittee' interface + +perasForgeVoteIfEligible :: + PerasVotingCommittee -> + PoolId -> + PrivateKey PerasBLSCrypto -> + PerasRoundNo -> + PerasBoostedBlock -> + proxy blk -> + Either PerasVotingError (Maybe (V1.PerasVote blk)) +perasForgeVoteIfEligible + (PerasVotingCommittee committeeType votingCommittee) + ourId + ourPrivateKey + roundNo + boostedBlock + _ = + case ( Committee.checkShouldVote + votingCommittee + ourId + ourPrivateKey + roundNo + ) of + Left err -> + case committeeType of + PerasWFALSVotingCommittee _ -> + Left (PerasVotingWFALSError err) + PerasEveryoneVotesVotingCommittee -> + Left (PerasVotingEveryoneVotesError err) + Right Nothing -> + Right Nothing + Right (Just witness) -> do + let abstractVote = + Committee.forgeVote + witness + ourPrivateKey + roundNo + boostedBlock + case committeeType of + PerasWFALSVotingCommittee _ -> + case toPerasVote abstractVote of + Left err -> + Left $ PerasVotingConversionError err + Right perasVote -> + Right (Just perasVote) + PerasEveryoneVotesVotingCommittee -> + case toPerasVote abstractVote of + Left err -> + Left $ PerasVotingConversionError err + Right perasVote -> + Right (Just perasVote) diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 9d582b4c91..8bd1da9a5c 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1,4 +1,6 @@ cabal-version: 3.0 + + name: ouroboros-consensus version: 3.0.1.0 synopsis: Consensus layer for the Ouroboros blockchain protocol @@ -951,11 +953,13 @@ library protocol Ouroboros.Consensus.Protocol.Praos.AgentClient Ouroboros.Consensus.Protocol.Praos.Common Ouroboros.Consensus.Protocol.Praos.Header + Ouroboros.Consensus.Protocol.Praos.Peras Ouroboros.Consensus.Protocol.Praos.Views Ouroboros.Consensus.Protocol.Praos.VRF Ouroboros.Consensus.Protocol.TPraos build-depends: + aeson, base, bytestring, cardano-binary, From db09f6e1f895359a7814e092de94c4bb67128aae Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 21 May 2026 17:11:30 +0200 Subject: [PATCH 32/62] Refactor --- .../Consensus/Protocol/Praos/Peras.hs | 385 ++++++++++-------- .../Consensus/Block/SupportsPeras.hs | 26 +- .../Consensus/Committee/Crypto/BLS.hs | 7 +- .../Consensus/Committee/EveryoneVotes.hs | 8 +- .../Ouroboros/Consensus/Committee/Types.hs | 11 +- .../Ouroboros/Consensus/Committee/WFA.hs | 14 +- .../Ouroboros/Consensus/Committee/WFALS.hs | 8 +- .../Ouroboros/Consensus/Peras/Cert/V1.hs | 41 +- .../Ouroboros/Consensus/Peras/Crypto/BLS.hs | 13 +- .../Ouroboros/Consensus/Peras/Types.hs | 6 +- .../Ouroboros/Consensus/Peras/Vote/V1.hs | 31 +- .../Consensus/Peras/Voting/Adapter.hs | 7 +- 12 files changed, 374 insertions(+), 183 deletions(-) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs index ddb49fa4e4..8ad740ac4f 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -1,29 +1,39 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Voting interface for Peras derived from the Praos ledger view. -module Ouroboros.Consensus.Protocol.Praos.Peras - ( PerasSupportedVotingCommittee (..) - , PerasVotingError (..) - , PerasVotingCommittee - , mkPerasVotingCommittee - , perasForgeVoteIfEligible - ) -where +module Ouroboros.Consensus.Protocol.Praos.Peras where import qualified Cardano.Ledger.Shelley.State as SL import Control.Exception (Exception) import Data.Aeson (eitherDecodeFileStrict') import Data.Bifunctor (Bifunctor (..)) import qualified Data.ByteString.Char8 as ByteString +import Data.ByteString.Short (ShortByteString) +import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Ouroboros.Consensus.Block.SupportsPeras (PerasBoostedBlock, PerasRoundNo) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract (HeaderHash, StandardHash) +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , PerasBoostedBlock + , PerasCommitteeScheme + , PerasCrypto + , PerasParams + , PerasRoundNo + ) import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) import qualified Ouroboros.Consensus.Committee.Class as Committee import Ouroboros.Consensus.Committee.Crypto (PrivateKey, PublicKey) @@ -35,7 +45,7 @@ import Ouroboros.Consensus.Committee.EveryoneVotes import Ouroboros.Consensus.Committee.Types ( LedgerStake (..) , PoolId (..) - , TargetCommitteeSize + , TargetCommitteeSize (..) ) import Ouroboros.Consensus.Committee.WFA ( WFAError @@ -46,10 +56,8 @@ import Ouroboros.Consensus.Committee.WFALS ( VotingCommitteeInput (..) , WFALS ) -import Ouroboros.Consensus.Peras.Crypto.BLS - ( PerasBLSCrypto - , PerasPublicKey (..) - ) +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 import Ouroboros.Consensus.Peras.Voting.Adapter ( PerasConversionError @@ -63,117 +71,133 @@ import Ouroboros.Consensus.Protocol.Praos.Views (LedgerView (..)) import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) --- | Voting committee schemes supported by Peras. --- --- NOTE: this is used internally as a singleton to determine which voting --- committee scheme to use when constructing votes, certificates, and errors. -data PerasSupportedVotingCommittee committee where - PerasWFALSVotingCommittee :: - TargetCommitteeSize -> - PerasSupportedVotingCommittee WFALS - PerasEveryoneVotesVotingCommittee :: - PerasSupportedVotingCommittee EveryoneVotes +-------------------------------------------------------------------------------- +-- This is a mocked up instance + +data RealBlock + +type instance PerasCrypto RealBlock = BLS.PerasBLSCrypto +type instance PerasCommitteeScheme RealBlock = WFALS +type instance HeaderHash RealBlock = ShortByteString + +instance StandardHash RealBlock + +instance BlockSupportsPeras RealBlock where + type PerasVote RealBlock = V1.PerasVote RealBlock + type PerasCert RealBlock = V1.PerasCert RealBlock + type PerasError RealBlock = V1PerasError RealBlock + forgePerasCert = undefined + validatePerasVote = undefined + validatePerasCert = undefined -- | Collection of voting-related errors for Peras -data PerasVotingError +data V1PerasError blk = PerasVotingWFAError WFAError - | PerasVotingWFALSError - (VotingCommitteeError PerasBLSCrypto WFALS) - | PerasVotingEveryoneVotesError - (VotingCommitteeError PerasBLSCrypto EveryoneVotes) + | PerasVotingCommitteeError + (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) | PerasVotingConversionError PerasConversionError | PerasVotingPublicKeyError PerasPublicKeyError - deriving (Show, Exception) --- | Opaque voting committee for Peras -data PerasVotingCommittee where - PerasVotingCommittee :: - CryptoSupportsVotingCommittee PerasBLSCrypto committee => - PerasSupportedVotingCommittee committee -> - VotingCommittee PerasBLSCrypto committee -> - PerasVotingCommittee +deriving instance + Show (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => + Show (V1PerasError blk) +deriving instance + Eq (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => + Eq (V1PerasError blk) +deriving instance + NoThunks (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => + NoThunks (V1PerasError blk) +deriving instance + Generic (V1PerasError blk) --- | Construct a 'PerasVotingCommittee' from a 'Ticked PraosState'. -- --- NOTE: the Praos 'LedgerView' needs to be extended with the public keys of the --- pools in the stake distribution. These are needed to validate Peras votes and --- certificates. +-- class +-- BlockSupportsPeras blk => +-- PraosStateSupportsPerasVoting blk +-- where +-- praosStatePerasVotingCommitteeInput :: +-- proxy blk -> +-- PerasParams -> +-- Ticked PraosState -> +-- Either +-- (PerasError blk) +-- (VotingCommitteeInput (PerasCrypto blk) (PerasCommitteeScheme blk)) +-- +-- praosStateGetPerasVotingCommittee :: +-- proxy blk -> +-- PerasParams -> +-- Ticked PraosState -> +-- Either +-- (PerasError blk) +-- (PerasVotingCommittee blk) +-- praosStateGetPerasVotingCommittee p perasParams tickedPraosState = do +-- committeeInput <- +-- praosStatePerasVotingCommitteeInput p perasParams tickedPraosState +-- bimap PerasVotingCommitteeError $ +-- Committee.mkVotingCommittee committeeInput +-- +-- instance PraosStateSupportsPerasVoting RealBlock where +-- praosStatePerasVotingCommitteeInput _ perasParams tickedPraosState = do +-- let epochNonce = +-- praosStateEpochNonce +-- . tickedPraosStateChainDepState +-- $ tickedPraosState +-- let wFATiebreaker = +-- wFATiebreakerWithEpochNonce epochNonce +-- stakeDistrWithPublicKeys <- +-- bimap PerasVotingPublicKeyError id $ +-- getStakeDistrWithPublicKeys tickedPraosState +-- extWFAStakeDistr <- +-- bimap PerasVotingWFAError id $ +-- mkExtWFAStakeDistr +-- wFATiebreaker +-- stakeDistrWithPublicKeys +-- let targetCommitteeSize = TargetCommitteeSize 100 -- hack +-- pure $ +-- WFALSVotingCommitteeInput +-- epochNonce +-- targetCommitteeSize +-- extWFAStakeDistr +-- +-- getStakeDistrWithPublicKeys :: +-- Ticked PraosState -> +-- Either +-- PerasPublicKeyError +-- (Map PoolId (LedgerStake, PublicKey PerasBLSCrypto)) +-- getStakeDistrWithPublicKeys tickedPraosState = do +-- let stakeDistr = +-- Map.mapKeysMonotonic PoolId +-- . Map.map (LedgerStake . SL.individualPoolStake) +-- . SL.unPoolDistr +-- . lvPoolDistr +-- . tickedPraosStateLedgerView +-- $ tickedPraosState +-- +-- publicKeys <- perasPublicKeysFromEnv -- Uses 'unsafePerformIO' +-- Map.traverseWithKey (addPublicKey publicKeys) stakeDistr +-- where +-- addPublicKey publicKeys poolId stake = +-- case Map.lookup poolId publicKeys of +-- Nothing -> +-- failWith $ "Public key not found for pool: " <> show poolId +-- Just pk -> +-- pure (stake, pk) +-- +-- failWith msg = +-- Left (PerasPublicKeyError msg) -- --- FIXME: for now, public keys are read from a JSON file specified by an --- environment variable using 'unsafePerformIO'. This is a temporary hack until --- we have a proper solution to retrieve public keys from the ledger state. -mkPerasVotingCommittee :: - PerasSupportedVotingCommittee committee -> - Ticked PraosState -> - Either PerasVotingError PerasVotingCommittee -mkPerasVotingCommittee - committeeType - tickedPraosState = do - let epochNonce = - praosStateEpochNonce - . tickedPraosStateChainDepState - $ tickedPraosState - let wFATiebreaker = - wFATiebreakerWithEpochNonce epochNonce - stakeDistrWithPublicKeys <- - bimap PerasVotingPublicKeyError id $ - getStakeDistrWithPublicKeys tickedPraosState - extWFAStakeDistr <- - bimap PerasVotingWFAError id $ - mkExtWFAStakeDistr - wFATiebreaker - stakeDistrWithPublicKeys - case committeeType of - PerasWFALSVotingCommittee targetCommitteeSize -> - bimap PerasVotingWFALSError (PerasVotingCommittee committeeType) - . Committee.mkVotingCommittee - $ WFALSVotingCommitteeInput - epochNonce - targetCommitteeSize - extWFAStakeDistr - PerasEveryoneVotesVotingCommittee -> - bimap PerasVotingEveryoneVotesError (PerasVotingCommittee committeeType) - . Committee.mkVotingCommittee - $ EveryoneVotesVotingCommitteeInput - extWFAStakeDistr - -getStakeDistrWithPublicKeys :: - Ticked PraosState -> - Either - PerasPublicKeyError - (Map PoolId (LedgerStake, PublicKey PerasBLSCrypto)) -getStakeDistrWithPublicKeys tickedPraosState = do - let stakeDistr = - Map.mapKeysMonotonic PoolId - . Map.map (LedgerStake . SL.individualPoolStake) - . SL.unPoolDistr - . lvPoolDistr - . tickedPraosStateLedgerView - $ tickedPraosState - - publicKeys <- perasPublicKeysFromEnv -- Uses 'unsafePerformIO' - Map.traverseWithKey (addPublicKey publicKeys) stakeDistr - where - addPublicKey publicKeys poolId stake = - case Map.lookup poolId publicKeys of - Nothing -> - failWith $ "Public key not found for pool: " <> show poolId - Just pk -> - pure (stake, pk) - - failWith msg = - Left (PerasPublicKeyError msg) -- * Retrieveing public keys from a JSON file (temporary) data PerasPublicKeyError = PerasPublicKeyError String - deriving (Show, Exception) + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks -perasPublicKeysFromEnv :: Either PerasPublicKeyError (Map PoolId PerasPublicKey) +perasPublicKeysFromEnv :: Either PerasPublicKeyError (Map PoolId BLS.PerasPublicKey) perasPublicKeysFromEnv = unsafePerformIO $ do lookupEnv envVar >>= \case @@ -202,62 +226,105 @@ perasPublicKeysFromEnv = failWith $ "Invalid public key format: " <> key Just pk -> Right $ - PerasPublicKey - { perasVoteVerKey = BLS.coercePublicKey @BLS.SIGN pk - , perasVRFVerKey = BLS.coercePublicKey @BLS.VRF pk + BLS.PerasPublicKey + { BLS.perasVoteVerKey = BLS.coercePublicKey @BLS.SIGN pk + , BLS.perasVRFVerKey = BLS.coercePublicKey @BLS.VRF pk } failWith msg = Left (PerasPublicKeyError msg) +-------------------------------------------------------------------------------- +-- This needs to stay in this file + +-- | Construct a 'PerasVotingCommittee' from a 'Ticked PraosState'. +-- +-- NOTE: the Praos 'LedgerView' needs to be extended with the public keys of the +-- pools in the stake distribution. These are needed to validate Peras votes and +-- certificates. +-- +-- FIXME: for now, public keys are read from a JSON file specified by an +-- environment variable using 'unsafePerformIO'. This is a temporary hack until +-- we have a proper solution to retrieve public keys from the ledger state. +-- mkPerasVotingCommittee :: +-- CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasCommitteeScheme blk) => +-- VotingCommitteeInput (PerasCrypto blk) (PerasCommitteeScheme blk) -> +-- Ticked PraosState -> +-- Either +-- (PerasVotingError blk) +-- (PerasVotingCommittee blk) +-- mkPerasVotingCommittee +-- committeeInput +-- tickedPraosState = do +-- let epochNonce = +-- praosStateEpochNonce +-- . tickedPraosStateChainDepState +-- $ tickedPraosState +-- let wFATiebreaker = +-- wFATiebreakerWithEpochNonce epochNonce +-- stakeDistrWithPublicKeys <- +-- bimap PerasVotingPublicKeyError id $ +-- getStakeDistrWithPublicKeys tickedPraosState +-- extWFAStakeDistr <- +-- bimap PerasVotingWFAError id $ +-- mkExtWFAStakeDistr +-- wFATiebreaker +-- stakeDistrWithPublicKeys +-- bimap PerasVotingCommitteeError id +-- . Committee.mkVotingCommittee +-- $ WFALSVotingCommitteeInput +-- epochNonce +-- targetCommitteeSize +-- extWFAStakeDistr + -- * Partially applied 'CryptoSupportsVotingCommittee' interface -perasForgeVoteIfEligible :: - PerasVotingCommittee -> - PoolId -> - PrivateKey PerasBLSCrypto -> - PerasRoundNo -> - PerasBoostedBlock -> - proxy blk -> - Either PerasVotingError (Maybe (V1.PerasVote blk)) -perasForgeVoteIfEligible - (PerasVotingCommittee committeeType votingCommittee) - ourId - ourPrivateKey - roundNo - boostedBlock - _ = - case ( Committee.checkShouldVote - votingCommittee - ourId - ourPrivateKey - roundNo - ) of - Left err -> - case committeeType of - PerasWFALSVotingCommittee _ -> - Left (PerasVotingWFALSError err) - PerasEveryoneVotesVotingCommittee -> - Left (PerasVotingEveryoneVotesError err) - Right Nothing -> - Right Nothing - Right (Just witness) -> do - let abstractVote = - Committee.forgeVote - witness - ourPrivateKey - roundNo - boostedBlock - case committeeType of - PerasWFALSVotingCommittee _ -> - case toPerasVote abstractVote of - Left err -> - Left $ PerasVotingConversionError err - Right perasVote -> - Right (Just perasVote) - PerasEveryoneVotesVotingCommittee -> - case toPerasVote abstractVote of - Left err -> - Left $ PerasVotingConversionError err - Right perasVote -> - Right (Just perasVote) +-- perasForgeVoteIfEligible :: +-- PerasVotingCommittee -> +-- PoolId -> +-- PrivateKey PerasBLSCrypto -> +-- PerasRoundNo -> +-- PerasBoostedBlock -> +-- proxy blk -> +-- Either PerasVotingError (Maybe (V1.PerasVote blk)) +-- perasForgeVoteIfEligible +-- (PerasVotingCommittee committeeType votingCommittee) +-- ourId +-- ourPrivateKey +-- roundNo +-- boostedBlock +-- _ = +-- case ( Committee.checkShouldVote +-- votingCommittee +-- ourId +-- ourPrivateKey +-- roundNo +-- ) of +-- Left err -> +-- case committeeType of +-- PerasWFALSVotingCommittee _ -> +-- Left (PerasVotingWFALSError err) +-- PerasEveryoneVotesVotingCommittee -> +-- Left (PerasVotingEveryoneVotesError err) +-- Right Nothing -> +-- Right Nothing +-- Right (Just witness) -> do +-- let abstractVote = +-- Committee.forgeVote +-- witness +-- ourPrivateKey +-- roundNo +-- boostedBlock +-- case committeeType of +-- PerasWFALSVotingCommittee _ -> +-- case toPerasVote abstractVote of +-- Left err -> +-- Left (PerasVotingConversionError err) +-- Right perasVote -> +-- Right (Just perasVote) +-- PerasEveryoneVotesVotingCommittee -> +-- case toPerasVote abstractVote of +-- Left err -> +-- Left (PerasVotingConversionError err) +-- Right perasVote -> +-- Right (Just perasVote) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 66c6a91b57..2b2efb659a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -14,7 +14,10 @@ {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Block.SupportsPeras - ( BlockSupportsPeras (..) + ( PerasCrypto + , PerasCommitteeScheme + , PerasVotingCommittee + , BlockSupportsPeras (..) , VoidPerasVote (..) , VoidPerasCert (..) , VoidPerasError (..) @@ -45,10 +48,31 @@ import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) +import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) import Ouroboros.Consensus.Peras.Params import Ouroboros.Consensus.Peras.Types import Ouroboros.Consensus.Util (ShowProxy) +-- | The crypto scheme used for Peras votes and certificates +-- +-- Used to dispatch a block type to a its corresponding voting crypto scheme. +-- +-- TODO: maybe move this inside 'BlockSupportsPeras'. +type family PerasCrypto blk :: Type + +-- | The voting committee scheme used for Peras. +-- +-- Used to dispatch a block type to a its corresponding voting committee scheme. +-- +-- TODO: maybe move this inside 'BlockSupportsPeras'. +type family PerasCommitteeScheme blk :: Type + +-- | Voting committee for Peras indexed by block type +type PerasVotingCommittee blk = + VotingCommittee + (PerasCrypto blk) + (PerasCommitteeScheme blk) + -- * BlockSupportsPeras class class diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs index 6dadea7745..6494443209 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} @@ -66,7 +68,9 @@ import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic) import GHC.Natural (Natural) +import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Committee.Crypto (NormalizedVRFOutput (..)) -- * BLS crypto helpers to instantiate voting committees @@ -161,8 +165,9 @@ type Signature :: KeyRole -> Type newtype Signature r = Signature { unSignature :: SigDSIGN BLS12381MinSigDSIGN } - deriving stock (Eq, Show) + deriving stock (Show, Eq, Generic) deriving newtype (FromCBOR, ToCBOR) + deriving anyclass NoThunks -- | BLS proof of possession type newtype ProofOfPossession = ProofOfPossession diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index cacee6b7fa..b48209b82b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -33,6 +36,8 @@ import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (..)) import Data.Set (Set) import qualified Data.Set.NonEmpty as NESet +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Committee.Class ( CryptoSupportsVotingCommittee (..) , UniqueVotesWithSameTarget @@ -99,7 +104,8 @@ instance InvalidCertSignature String | -- We triggered an unexpected cryptographic error CryptoError String - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks data EligibilityWitness crypto EveryoneVotes = EveryoneVotesMember diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs index 1dcbffaa0a..83b71d1486 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} -- | Types common to any generic committee selection scheme module Ouroboros.Consensus.Committee.Types @@ -13,12 +14,14 @@ module Ouroboros.Consensus.Committee.Types import Cardano.Ledger.BaseTypes (HasZero) import Cardano.Ledger.Core (KeyHash, KeyRole (..)) import Data.Word (Word64) +import NoThunks.Class (NoThunks) +import Cardano.Prelude (Generic) -- | Identifier of a given voter in the committee selection scheme newtype PoolId = PoolId { unPoolId :: KeyHash StakePool } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, NoThunks, Generic) -- | Stake of a voter as reflected by the ledger state newtype LedgerStake = LedgerStake @@ -31,16 +34,16 @@ newtype LedgerStake = LedgerStake newtype VoteWeight = VoteWeight { unVoteWeight :: Rational } - deriving (Show, Eq) + deriving (Show, Eq, NoThunks, Generic) -- | Target committee size newtype TargetCommitteeSize = TargetCommitteeSize { unTargetCommitteeSize :: Word64 } - deriving (Show, Eq) + deriving (Show, Eq, NoThunks, Generic) -- | Wrapper to tag accumulated resources newtype Cumulative a = Cumulative { unCumulative :: a } - deriving (Show, Eq) + deriving (Show, Eq, NoThunks, Generic) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs index e4752d4b57..c97dbc37cb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Deterministic portion of the Weighted Fait-Accompli committee selection scheme @@ -39,6 +42,8 @@ import qualified Data.List as List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Word (Word64) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Committee.Types ( Cumulative (..) , LedgerStake (..) @@ -88,7 +93,7 @@ data WFAError NotEnoughPoolsWithPositiveStake TargetCommitteeSize NumPoolsWithPositiveStake - deriving (Show, Eq) + deriving (Show, Eq, NoThunks, Generic) -- | Split a stake distrubution into persistent and non-persistent committee -- seats according to the weighted Fait-Accompli scheme. @@ -231,14 +236,17 @@ newtype SeatIndex = SeatIndex { unSeatIndex :: Word64 } - deriving (Show, Eq, Ord, Enum, Ix) + deriving stock (Show, Eq, Ord, Ix, Generic) + deriving newtype Enum + deriving anyclass NoThunks -- | Number of pools with positive stake in the underlying stake distribution newtype NumPoolsWithPositiveStake = NumPoolsWithPositiveStake { unNumPoolsWithPositiveStake :: Word64 } - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks -- | Tiebreaker for voters with the same stake in the cumulative stake. -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index d637134ccd..97fd6acefa 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -4,6 +4,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} -- | Weighted Fait-Accompli with Local Sortition (wFA^LS) committee selection. -- @@ -94,6 +97,8 @@ import Ouroboros.Consensus.Committee.WFA , unsafeGetCandidateInSeat , weightedFaitAccompliSplitSeats ) +import NoThunks.Class (NoThunks) +import GHC.Generics (Generic) -- | Tag for weighted Fait-Accompli with Local Sortition (wFA^LS) data WFALS @@ -161,7 +166,8 @@ instance InvalidCertSignature String | -- We triggered an unexpected cryptographic error CryptoError String - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks data EligibilityWitness crypto WFALS = -- A persistent member of the voting committee diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs index a9351c4ee9..57d6b56169 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs @@ -1,7 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -- | Concrete Peras certificate types using BLS signatures. @@ -24,6 +31,8 @@ import Cardano.Binary ) import Control.Monad (when) import Control.Monad.Error.Class (MonadError (..)) +import Data.ByteString.Short (ShortByteString) +import Data.Coerce (Coercible) import Data.Containers.NonEmpty (HasNonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.NonEmpty as NEMap @@ -31,8 +40,16 @@ import Data.Map.Strict (Map) import Data.Maybe (catMaybes) import Data.Typeable (Typeable) import Data.Word (Word16) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) +import Ouroboros.Consensus.Block.Abstract (HeaderHash) +import Ouroboros.Consensus.Block.RealPoint + ( fromBytes32RealPoint + , withOriginRealPointToPoint + ) import Ouroboros.Consensus.Block.SupportsPeras - ( PerasBoostedBlock + ( IsPerasCert (..) + , PerasBoostedBlock (..) , PerasRoundNo , PerasSeatIndex (..) ) @@ -64,7 +81,20 @@ data PerasCert tag -- ^ Aggregate BLS signature on the hash of the election identifier and -- the certificate message } - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks + +instance + Coercible (HeaderHash blk) ShortByteString => + IsPerasCert (PerasCert blk) blk + where + getPerasCertRound = + pcRoundNo + getPerasCertBlock = + withOriginRealPointToPoint + . fmap fromBytes32RealPoint + . unPerasBoostedBlock + . pcBoostedBlock instance Typeable tag => FromCBOR (PerasCert tag) where fromCBOR = do @@ -95,7 +125,12 @@ newtype PerasCertVoters { unPerasCertVoters :: NE (Map PerasSeatIndex PerasVoteEligibilityProof) } - deriving (Eq, Show) + deriving stock (Show, Eq, Generic) + +deriving via + OnlyCheckWhnfNamed "PerasCertVoters" PerasCertVoters + instance + NoThunks PerasCertVoters instance FromCBOR PerasCertVoters where fromCBOR = do diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs index 31903225ca..34e9c954c8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -35,6 +37,8 @@ import Cardano.Ledger.Hashes (HASH) import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Builder.Extra as BS import qualified Data.ByteString.Short as BS +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract (WithOrigin (..)) import Ouroboros.Consensus.Block.RealPoint ( bytes32RealPointHash @@ -149,8 +153,9 @@ instance CryptoSupportsVoteSigning PerasBLSCrypto where { unPerasBLSCryptoVoteSignature :: BLS.Signature BLS.SIGN } - deriving stock (Eq, Show) + deriving stock (Show, Eq, Generic) deriving newtype (FromCBOR, ToCBOR) + deriving anyclass NoThunks getVoteSigningKey _ = perasVoteSignKey @@ -188,8 +193,9 @@ instance CryptoSupportsVRF PerasBLSCrypto where { unPerasBLSCryptoVRFOutput :: BLS.Signature VRF } - deriving stock (Eq, Show) + deriving stock (Show, Eq, Generic) deriving newtype (FromCBOR, ToCBOR) + deriving anyclass NoThunks getVRFSigningKey _ = perasVRFSignKey @@ -229,8 +235,9 @@ newtype PerasBLSCryptoAggregateVoteSignature { unPerasBLSCryptoAggregateVoteSignature :: BLS.Signature SIGN } - deriving stock (Eq, Show) + deriving stock (Show, Eq, Generic) deriving newtype (FromCBOR, ToCBOR) + deriving anyclass NoThunks instance CryptoSupportsAggregateVoteSigning PerasBLSCrypto where type diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs index 1327eb6045..68006eeada 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -89,7 +89,8 @@ newtype PerasBoostedBlock = PerasBoostedBlock { unPerasBoostedBlock :: WithOrigin Bytes32RealPoint } - deriving stock (Eq, Show) + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks instance FromCBOR PerasBoostedBlock where fromCBOR = PerasBoostedBlock <$> decodeWithOrigin decodeBytes32RealPoint @@ -104,8 +105,9 @@ newtype PerasSeatIndex = PerasSeatIndex { unPerasSeatIndex :: Word16 } - deriving stock (Eq, Ord, Show) + deriving stock (Show, Eq, Ord, Generic) deriving newtype (FromCBOR, ToCBOR, Enum, Bounded) + deriving anyclass NoThunks -- ** Vote parameters diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs index de9b37f84d..fd66a99b8a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | Concrete Peras vote types using BLS signatures. -- @@ -22,16 +26,22 @@ import Cardano.Binary ) import Data.Typeable (Typeable) import Data.Word (Word8) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.SupportsPeras - ( PerasBoostedBlock + ( PerasBoostedBlock (..) , PerasRoundNo - , PerasSeatIndex + , PerasSeatIndex, IsPerasCert, IsPerasVote (..) ) import Ouroboros.Consensus.Committee.Crypto (CryptoSupportsVoteSigning (..)) import Ouroboros.Consensus.Peras.Crypto.BLS ( PerasBLSCrypto , VRFOutput ) +import Data.Coerce (Coercible) +import Ouroboros.Consensus.Block.Abstract (HeaderHash) +import Data.ByteString.Short (ShortByteString) +import Ouroboros.Consensus.Block.RealPoint (withOriginRealPointToPoint, fromBytes32RealPoint) -- | Concrete Peras votes using BLS signatures -- @@ -52,7 +62,19 @@ data PerasVote tag , pvSignature :: !(VoteSignature PerasBLSCrypto) -- ^ BLS signature on the hash of the election identifier and vote message } - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks + +instance + Coercible (HeaderHash blk) ShortByteString => + IsPerasVote (PerasVote blk) blk where + getPerasVoteRound = + pvRoundNo + getPerasVoteBlock = + withOriginRealPointToPoint + . fmap fromBytes32RealPoint + . unPerasBoostedBlock + . pvBoostedBlock instance Typeable tag => FromCBOR (PerasVote tag) where fromCBOR = do @@ -86,7 +108,8 @@ data PerasVoteEligibilityProof PersistentPerasVoteEligibilityProof | -- | Non-persistent committee members provide a VRF proof of eligibility NonPersistentPerasVoteEligibilityProof !(VRFOutput PerasBLSCrypto) - deriving stock (Eq, Show) + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks instance FromCBOR PerasVoteEligibilityProof where fromCBOR = do diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs index 86a0ee9bba..21521ccc28 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} @@ -20,6 +22,8 @@ import qualified Data.Map as Map import qualified Data.Map.NonEmpty as NEMap import Data.Maybe (isJust) import Data.Word (Word16, Word64) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) import qualified Ouroboros.Consensus.Committee.Class as Committee import Ouroboros.Consensus.Committee.Crypto (CryptoSupportsVRF (..)) import Ouroboros.Consensus.Committee.EveryoneVotes @@ -42,7 +46,8 @@ data PerasConversionError | EveryoneVotesButFoundNonPersistentVotersInCert (NE [SeatIndex]) | SeatIndexOverflowError Word64 | CryptoError String - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving anyclass NoThunks -- | Conversion between (concrete) Peras votes and (abstract) committee votes. -- From c8629cde8b2b1b3f2dc2a4334334afd0fd9ab7fa Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Fri, 22 May 2026 12:50:02 +0200 Subject: [PATCH 33/62] Refactor 2 --- .../Consensus/Protocol/Praos/Peras.hs | 312 ++++++------------ ouroboros-consensus.cabal | 2 +- .../Consensus/Block/SupportsPeras.hs | 140 +++++++- .../Ouroboros/Consensus/Committee/Types.hs | 4 +- .../Ouroboros/Consensus/Committee/WFALS.hs | 10 +- .../Ouroboros/Consensus/Peras/Cert/Mock.hs | 3 + .../Ouroboros/Consensus/Peras/Cert/V1.hs | 148 ++++++++- .../Ouroboros/Consensus/Peras/Error/V1.hs | 45 +++ .../Ouroboros/Consensus/Peras/Types.hs | 77 ++++- .../Consensus/Peras/Vote/Aggregation.hs | 6 +- .../Ouroboros/Consensus/Peras/Vote/Mock.hs | 3 + .../Ouroboros/Consensus/Peras/Vote/V1.hs | 129 +++++++- .../Consensus/Peras/Voting/Adapter.hs | 307 ----------------- .../Ouroboros/Consensus/Peras/Voting/View.hs | 2 +- .../Storage/ChainDB/Impl/Background.hs | 2 +- .../Storage/ChainDB/Impl/ChainSel.hs | 2 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 2 +- .../Consensus/Storage/PerasCertDB/API.hs | 2 +- .../Consensus/Storage/PerasCertDB/Impl.hs | 4 +- .../Consensus/Storage/PerasVoteDB/API.hs | 2 +- .../Test/Consensus/Peras/Cert/Inclusion.hs | 5 +- .../Test/Consensus/Peras/Voting/Adapter.hs | 8 +- .../Test/Consensus/Peras/Voting/Rules.hs | 5 +- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 4 +- .../Ouroboros/Storage/PerasCertDB/Model.hs | 4 +- .../Storage/PerasCertDB/StateMachine.hs | 6 +- .../Ouroboros/Storage/PerasVoteDB/Model.hs | 4 +- .../Storage/PerasVoteDB/StateMachine.hs | 2 +- 28 files changed, 641 insertions(+), 599 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs delete mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs index 8ad740ac4f..52623ef84a 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -9,47 +9,39 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Voting interface for Peras derived from the Praos ledger view. module Ouroboros.Consensus.Protocol.Praos.Peras where import qualified Cardano.Ledger.Shelley.State as SL -import Control.Exception (Exception) import Data.Aeson (eitherDecodeFileStrict') import Data.Bifunctor (Bifunctor (..)) import qualified Data.ByteString.Char8 as ByteString import Data.ByteString.Short (ShortByteString) -import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract (HeaderHash, StandardHash) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) - , PerasBoostedBlock , PerasCommitteeScheme , PerasCrypto , PerasParams - , PerasRoundNo + , PerasVotingCommittee + , injectCommitteeError ) import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) import qualified Ouroboros.Consensus.Committee.Class as Committee -import Ouroboros.Consensus.Committee.Crypto (PrivateKey, PublicKey) +import Ouroboros.Consensus.Committee.Crypto (PublicKey) import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS -import Ouroboros.Consensus.Committee.EveryoneVotes - ( EveryoneVotes - , VotingCommitteeInput (..) - ) import Ouroboros.Consensus.Committee.Types ( LedgerStake (..) , PoolId (..) , TargetCommitteeSize (..) ) import Ouroboros.Consensus.Committee.WFA - ( WFAError - , mkExtWFAStakeDistr + ( mkExtWFAStakeDistr , wFATiebreakerWithEpochNonce ) import Ouroboros.Consensus.Committee.WFALS @@ -58,11 +50,8 @@ import Ouroboros.Consensus.Committee.WFALS ) import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS +import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 -import Ouroboros.Consensus.Peras.Voting.Adapter - ( PerasConversionError - , PerasVoteCompatibleWithVotingCommittee (..) - ) import Ouroboros.Consensus.Protocol.Praos ( PraosState (..) , Ticked (..) @@ -85,128 +74,77 @@ instance StandardHash RealBlock instance BlockSupportsPeras RealBlock where type PerasVote RealBlock = V1.PerasVote RealBlock type PerasCert RealBlock = V1.PerasCert RealBlock - type PerasError RealBlock = V1PerasError RealBlock + type PerasError RealBlock = V1.PerasError RealBlock + + -- TODO: uncomment as soon as we add this method to 'BlockSupportsPeras' + -- forgePerasVoteIfEligible = implPerasForgeVoteIfEligible forgePerasCert = undefined validatePerasVote = undefined validatePerasCert = undefined --- | Collection of voting-related errors for Peras -data V1PerasError blk - = PerasVotingWFAError - WFAError - | PerasVotingCommitteeError - (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) - | PerasVotingConversionError - PerasConversionError - | PerasVotingPublicKeyError - PerasPublicKeyError +instance PraosStateSupportsPerasVoting RealBlock where + praosStatePerasVotingCommitteeInput _ _perasParams tickedPraosState = do + let epochNonce = + praosStateEpochNonce + . tickedPraosStateChainDepState + $ tickedPraosState + let wFATiebreaker = + wFATiebreakerWithEpochNonce epochNonce + stakeDistrWithPublicKeys <- + bimap V1.PerasTemporaryPublicKeyHackError id $ + getStakeDistrWithBLSPublicKeys tickedPraosState + extWFAStakeDistr <- + bimap V1.PerasVotingWFAError id $ + mkExtWFAStakeDistr + wFATiebreaker + stakeDistrWithPublicKeys + let targetCommitteeSize = TargetCommitteeSize 100 -- TODO: use perams params to get this value instead + pure $ + WFALSVotingCommitteeInput + epochNonce + targetCommitteeSize + extWFAStakeDistr -deriving instance - Show (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => - Show (V1PerasError blk) -deriving instance - Eq (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => - Eq (V1PerasError blk) -deriving instance - NoThunks (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => - NoThunks (V1PerasError blk) -deriving instance - Generic (V1PerasError blk) +-------------------------------------------------------------------------------- +-- Helpers to deal with public keys and stake +-------------------------------------------------------------------------------- --- --- class --- BlockSupportsPeras blk => --- PraosStateSupportsPerasVoting blk --- where --- praosStatePerasVotingCommitteeInput :: --- proxy blk -> --- PerasParams -> --- Ticked PraosState -> --- Either --- (PerasError blk) --- (VotingCommitteeInput (PerasCrypto blk) (PerasCommitteeScheme blk)) --- --- praosStateGetPerasVotingCommittee :: --- proxy blk -> --- PerasParams -> --- Ticked PraosState -> --- Either --- (PerasError blk) --- (PerasVotingCommittee blk) --- praosStateGetPerasVotingCommittee p perasParams tickedPraosState = do --- committeeInput <- --- praosStatePerasVotingCommitteeInput p perasParams tickedPraosState --- bimap PerasVotingCommitteeError $ --- Committee.mkVotingCommittee committeeInput --- --- instance PraosStateSupportsPerasVoting RealBlock where --- praosStatePerasVotingCommitteeInput _ perasParams tickedPraosState = do --- let epochNonce = --- praosStateEpochNonce --- . tickedPraosStateChainDepState --- $ tickedPraosState --- let wFATiebreaker = --- wFATiebreakerWithEpochNonce epochNonce --- stakeDistrWithPublicKeys <- --- bimap PerasVotingPublicKeyError id $ --- getStakeDistrWithPublicKeys tickedPraosState --- extWFAStakeDistr <- --- bimap PerasVotingWFAError id $ --- mkExtWFAStakeDistr --- wFATiebreaker --- stakeDistrWithPublicKeys --- let targetCommitteeSize = TargetCommitteeSize 100 -- hack --- pure $ --- WFALSVotingCommitteeInput --- epochNonce --- targetCommitteeSize --- extWFAStakeDistr --- --- getStakeDistrWithPublicKeys :: --- Ticked PraosState -> --- Either --- PerasPublicKeyError --- (Map PoolId (LedgerStake, PublicKey PerasBLSCrypto)) --- getStakeDistrWithPublicKeys tickedPraosState = do --- let stakeDistr = --- Map.mapKeysMonotonic PoolId --- . Map.map (LedgerStake . SL.individualPoolStake) --- . SL.unPoolDistr --- . lvPoolDistr --- . tickedPraosStateLedgerView --- $ tickedPraosState --- --- publicKeys <- perasPublicKeysFromEnv -- Uses 'unsafePerformIO' --- Map.traverseWithKey (addPublicKey publicKeys) stakeDistr --- where --- addPublicKey publicKeys poolId stake = --- case Map.lookup poolId publicKeys of --- Nothing -> --- failWith $ "Public key not found for pool: " <> show poolId --- Just pk -> --- pure (stake, pk) --- --- failWith msg = --- Left (PerasPublicKeyError msg) --- +getStakeDistrWithBLSPublicKeys :: + Ticked PraosState -> + Either + String + (Map PoolId (LedgerStake, PublicKey BLS.PerasBLSCrypto)) +getStakeDistrWithBLSPublicKeys tickedPraosState = do + let stakeDistr = + Map.mapKeysMonotonic PoolId + . Map.map (LedgerStake . SL.individualPoolStake) + . SL.unPoolDistr + . lvPoolDistr + . tickedPraosStateLedgerView + $ tickedPraosState + + publicKeys <- perasBLSPublicKeysFromEnv -- Uses 'unsafePerformIO' + Map.traverseWithKey (addPublicKey publicKeys) stakeDistr + where + addPublicKey publicKeys poolId stake = + case Map.lookup poolId publicKeys of + Nothing -> + Left $ "Public key not found for pool: " <> show poolId + Just pk -> + pure (stake, pk) -- * Retrieveing public keys from a JSON file (temporary) -data PerasPublicKeyError - = PerasPublicKeyError String - deriving stock (Show, Eq, Generic) - deriving anyclass NoThunks - -perasPublicKeysFromEnv :: Either PerasPublicKeyError (Map PoolId BLS.PerasPublicKey) -perasPublicKeysFromEnv = +perasBLSPublicKeysFromEnv :: Either String (Map PoolId BLS.PerasPublicKey) +perasBLSPublicKeysFromEnv = unsafePerformIO $ do lookupEnv envVar >>= \case Nothing -> do - pure $ failWith $ "Environment variable " <> envVar <> " not set." + pure $ Left $ "Environment variable " <> envVar <> " not set." Just keysFile -> do eitherDecodeFileStrict' keysFile >>= \case Left err -> do - pure $ failWith $ "Failed to parse public keys from file: " <> err + pure $ Left $ "Failed to parse public keys from file: " <> err Right rawKeys -> do pure $ decodeKeys rawKeys where @@ -223,7 +161,7 @@ perasPublicKeysFromEnv = decodeKey key = case BLS.rawDeserialisePublicKey keyScope (ByteString.pack key) of Nothing -> - failWith $ "Invalid public key format: " <> key + Left $ "Invalid public key format: " <> key Just pk -> Right $ BLS.PerasPublicKey @@ -231,100 +169,34 @@ perasPublicKeysFromEnv = , BLS.perasVRFVerKey = BLS.coercePublicKey @BLS.VRF pk } - failWith msg = - Left (PerasPublicKeyError msg) - -------------------------------------------------------------------------------- --- This needs to stay in this file - --- | Construct a 'PerasVotingCommittee' from a 'Ticked PraosState'. --- --- NOTE: the Praos 'LedgerView' needs to be extended with the public keys of the --- pools in the stake distribution. These are needed to validate Peras votes and --- certificates. --- --- FIXME: for now, public keys are read from a JSON file specified by an --- environment variable using 'unsafePerformIO'. This is a temporary hack until --- we have a proper solution to retrieve public keys from the ledger state. --- mkPerasVotingCommittee :: --- CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasCommitteeScheme blk) => --- VotingCommitteeInput (PerasCrypto blk) (PerasCommitteeScheme blk) -> --- Ticked PraosState -> --- Either --- (PerasVotingError blk) --- (PerasVotingCommittee blk) --- mkPerasVotingCommittee --- committeeInput --- tickedPraosState = do --- let epochNonce = --- praosStateEpochNonce --- . tickedPraosStateChainDepState --- $ tickedPraosState --- let wFATiebreaker = --- wFATiebreakerWithEpochNonce epochNonce --- stakeDistrWithPublicKeys <- --- bimap PerasVotingPublicKeyError id $ --- getStakeDistrWithPublicKeys tickedPraosState --- extWFAStakeDistr <- --- bimap PerasVotingWFAError id $ --- mkExtWFAStakeDistr --- wFATiebreaker --- stakeDistrWithPublicKeys --- bimap PerasVotingCommitteeError id --- . Committee.mkVotingCommittee --- $ WFALSVotingCommitteeInput --- epochNonce --- targetCommitteeSize --- extWFAStakeDistr - --- * Partially applied 'CryptoSupportsVotingCommittee' interface --- perasForgeVoteIfEligible :: --- PerasVotingCommittee -> --- PoolId -> --- PrivateKey PerasBLSCrypto -> --- PerasRoundNo -> --- PerasBoostedBlock -> --- proxy blk -> --- Either PerasVotingError (Maybe (V1.PerasVote blk)) --- perasForgeVoteIfEligible --- (PerasVotingCommittee committeeType votingCommittee) --- ourId --- ourPrivateKey --- roundNo --- boostedBlock --- _ = --- case ( Committee.checkShouldVote --- votingCommittee --- ourId --- ourPrivateKey --- roundNo --- ) of --- Left err -> --- case committeeType of --- PerasWFALSVotingCommittee _ -> --- Left (PerasVotingWFALSError err) --- PerasEveryoneVotesVotingCommittee -> --- Left (PerasVotingEveryoneVotesError err) --- Right Nothing -> --- Right Nothing --- Right (Just witness) -> do --- let abstractVote = --- Committee.forgeVote --- witness --- ourPrivateKey --- roundNo --- boostedBlock --- case committeeType of --- PerasWFALSVotingCommittee _ -> --- case toPerasVote abstractVote of --- Left err -> --- Left (PerasVotingConversionError err) --- Right perasVote -> --- Right (Just perasVote) --- PerasEveryoneVotesVotingCommittee -> --- case toPerasVote abstractVote of --- Left err -> --- Left (PerasVotingConversionError err) --- Right perasVote -> --- Right (Just perasVote) +class + ( BlockSupportsPeras blk + , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasCommitteeScheme blk) -- TODO remove this constraint when it becomes a superclass constraint of 'BlockSupportsPeras' + ) => + PraosStateSupportsPerasVoting blk + where + -- | How to extract a 'PerasVotingCommitteeInput' from a 'Ticked PraosState'. + -- This is used to construct the 'PerasVotingCommittee' used for voting at a given ledger/praos state. + praosStatePerasVotingCommitteeInput :: + proxy blk -> + PerasParams -> + Ticked PraosState -> + Either + (PerasError blk) + (VotingCommitteeInput (PerasCrypto blk) (PerasCommitteeScheme blk)) + + -- | How to build a new 'PerasVotingCommittee' from a 'Ticked PraosState'. The implementation provided here relies on 'praosStatePerasVotingCommitteeInput'. + praosStateGetPerasVotingCommittee :: + proxy blk -> + PerasParams -> + Ticked PraosState -> + Either + (PerasError blk) + (PerasVotingCommittee blk) + praosStateGetPerasVotingCommittee p perasParams tickedPraosState = do + committeeInput <- + praosStatePerasVotingCommitteeInput p perasParams tickedPraosState + bimap injectCommitteeError id $ + Committee.mkVotingCommittee committeeInput diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 8bd1da9a5c..2cdcf5be74 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -242,13 +242,13 @@ library Ouroboros.Consensus.Peras.Cert.Mock Ouroboros.Consensus.Peras.Cert.V1 Ouroboros.Consensus.Peras.Crypto.BLS + Ouroboros.Consensus.Peras.Error.V1 Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.Types Ouroboros.Consensus.Peras.Vote.Aggregation Ouroboros.Consensus.Peras.Vote.Mock Ouroboros.Consensus.Peras.Vote.V1 - Ouroboros.Consensus.Peras.Voting.Adapter Ouroboros.Consensus.Peras.Voting.Rules Ouroboros.Consensus.Peras.Voting.View Ouroboros.Consensus.Peras.Weight diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 2b2efb659a..a5e2199b21 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -9,6 +9,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -28,17 +29,24 @@ module Ouroboros.Consensus.Block.SupportsPeras , vpvqVotes , vpvqPerasParams ) + , injectCommitteeError , votesReachQuorum , IsPerasVote (..) , getPerasVoteId , getPerasVoteTarget , IsPerasCert (..) + , PerasVoteCompatibleWithVotingCommittee (..) + , PerasCertCompatibleWithVotingCommittee (..) + , injectConversionError + , implPerasForgeVoteIfEligible -- * Convenience re-exports , module Ouroboros.Consensus.Peras.Params , module Ouroboros.Consensus.Peras.Types ) where +import Data.Bifunctor (bimap) +import Data.Coerce (coerce) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty @@ -49,6 +57,9 @@ import NoThunks.Class import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) +import qualified Ouroboros.Consensus.Committee.Class as Committee +import Ouroboros.Consensus.Committee.Crypto (ElectionId, PrivateKey, VoteCandidate) +import Ouroboros.Consensus.Committee.Types (PoolId, VoteWeight (..)) import Ouroboros.Consensus.Peras.Params import Ouroboros.Consensus.Peras.Types import Ouroboros.Consensus.Util (ShowProxy) @@ -58,6 +69,9 @@ import Ouroboros.Consensus.Util (ShowProxy) -- Used to dispatch a block type to a its corresponding voting crypto scheme. -- -- TODO: maybe move this inside 'BlockSupportsPeras'. +-- TODO: add eq constraints ( ElectionId (PerasCrypto blk) ~ PerasRoundNo +-- , VoteCandidate (PerasCrypto blk) ~ Point blk) +-- in BlockSupportsPeras type family PerasCrypto blk :: Type -- | The voting committee scheme used for Peras. @@ -67,6 +81,15 @@ type family PerasCrypto blk :: Type -- TODO: maybe move this inside 'BlockSupportsPeras'. type family PerasCommitteeScheme blk :: Type +-- This witness the fact that 'PerasError blk' should have a way to represent a 'VotingCommitteeError' for the corresponding 'PerasCommitteeScheme blk' and 'PerasCrypto blk'. +-- +-- TODO: maybe move this inside 'BlockSupportsPeras' +injectCommitteeError :: + VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk) -> PerasError blk +injectCommitteeError = undefined + +-- TODO: Add CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasCommitteeScheme blk) as a superclass constraint of 'BlockSupportsPeras' + -- | Voting committee for Peras indexed by block type type PerasVotingCommittee blk = VotingCommittee @@ -152,6 +175,91 @@ class getPerasCertInBlock _ = Nothing +-- This witness the fact that 'PerasError blk' should have a way to represent a 'PerasConversionError'. +-- +-- TODO: maybe move this inside 'BlockSupportsPeras' +injectConversionError :: PerasConversionError -> PerasError blk +injectConversionError = undefined + +-- * Conversion between concrete Peras types and abstract committee types + +-- | Conversion between (concrete) Peras votes and (abstract) committee votes. +-- +-- NOTE: the functional dependency @vote -> crypto@ explicitly ties each +-- concrete Peras vote type to a specific crypto scheme. +class + PerasVoteCompatibleWithVotingCommittee vote crypto committee + | vote -> crypto + where + toPerasVote :: + Committee.Vote crypto committee -> + Either PerasConversionError vote + fromPerasVote :: + vote -> + Either PerasConversionError (Committee.Vote crypto committee) + +-- | Conversion between (concrete) Peras certificates and (abstract) committee +-- certificates. +-- +-- NOTE: the functional dependency @cert -> crypto@ explicitly ties each +-- concrete Peras certificate type to a specific crypto scheme. +class + PerasCertCompatibleWithVotingCommittee cert crypto committee + | cert -> crypto + where + toPerasCert :: + Committee.Cert crypto committee -> + Either PerasConversionError cert + fromPerasCert :: + cert -> + Either PerasConversionError (Committee.Cert crypto committee) + +implPerasForgeVoteIfEligible :: + forall blk. + ( ElectionId (PerasCrypto blk) ~ PerasRoundNo -- TODO Remove later + , VoteCandidate (PerasCrypto blk) ~ Point blk -- TODO Remove later + , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasCommitteeScheme blk) -- TODO maybe remove this once part of 'BlockSupportsPeras' constraints + , PerasVoteCompatibleWithVotingCommittee (PerasVote blk) (PerasCrypto blk) (PerasCommitteeScheme blk) + ) => + PerasVotingCommittee blk -> + PoolId -> + PrivateKey (PerasCrypto blk) -> + PerasRoundNo -> + Point blk -> + Either (PerasError blk) (Maybe (ValidatedPerasVote blk)) +implPerasForgeVoteIfEligible + committee + ourId + ourPrivateKey + roundNo + boostedBlock = + do + mWitness <- + bimap injectCommitteeError id $ + Committee.checkShouldVote + committee + ourId + ourPrivateKey + roundNo + case mWitness of + Nothing -> + Right Nothing + Just witness -> + Just <$> do + let voteWeight = eligiblePartyVoteWeight committee witness + abstractVote = + Committee.forgeVote + witness + ourPrivateKey + roundNo + (boostedBlockToPoint boostedBlock) + concreteVote <- bimap injectConversionError id $ toPerasVote @(PerasVote blk) abstractVote + pure $ + ValidatedPerasVote + { vpvVote = concreteVote + , vpvVoteStake = coerce voteWeight + } + -- * Helpers to derive @BlockSupportsPeras@ for block types without Peras support -- | Imposible Peras vote for @blk@. @@ -172,6 +280,9 @@ newtype VoidPerasCert blk } deriving newtype (Show, Eq, NoThunks, ShowProxy) +type instance BoostedBlock (VoidPerasVote blk) = Point blk +type instance BoostedBlock (VoidPerasCert blk) = Point blk + instance IsPerasVote (VoidPerasVote blk) blk where getPerasVoteRound = absurd . unVoidPerasVote getPerasVoteBlock = absurd . unVoidPerasVote @@ -289,11 +400,14 @@ votesReachQuorum params votes = -- * Convenience projection classes -- | Types that support being treated as Peras votes -class IsPerasVote vote blk | vote -> blk where +class BoostedBlockCompatibleWithPoint (BoostedBlock vote) blk => IsPerasVote vote blk | vote -> blk where getPerasVoteRound :: vote -> PerasRoundNo - getPerasVoteBlock :: vote -> Point blk + getPerasVoteBlock :: vote -> BoostedBlock vote getPerasVoteVoterId :: vote -> PerasVoterId + getPerasVotePoint :: vote -> Point blk + getPerasVotePoint = boostedBlockToPoint . getPerasVoteBlock + -- | Extract the vote ID from a Peras vote container getPerasVoteId :: IsPerasVote vote blk => vote -> PerasVoteId blk getPerasVoteId vote = @@ -307,11 +421,14 @@ getPerasVoteTarget :: IsPerasVote vote blk => vote -> PerasVoteTarget blk getPerasVoteTarget vote = PerasVoteTarget { pvtRoundNo = getPerasVoteRound vote - , pvtBlock = getPerasVoteBlock vote + , pvtBlock = getPerasVotePoint vote } +type instance BoostedBlock (ValidatedPerasVote blk) = BoostedBlock (PerasVote blk) instance - IsPerasVote (PerasVote blk) blk => + ( IsPerasVote (PerasVote blk) blk + , BoostedBlockCompatibleWithPoint (BoostedBlock (PerasVote blk)) blk + ) => IsPerasVote (ValidatedPerasVote blk) blk where getPerasVoteRound = getPerasVoteRound . vpvVote @@ -327,12 +444,19 @@ instance getPerasVoteVoterId = getPerasVoteVoterId . forgetArrivalTime -- | Types that support being treated as Peras certificates -class IsPerasCert cert blk | cert -> blk where +class BoostedBlockCompatibleWithPoint (BoostedBlock cert) blk => IsPerasCert cert blk | cert -> blk where getPerasCertRound :: cert -> PerasRoundNo - getPerasCertBlock :: cert -> Point blk + getPerasCertBlock :: cert -> BoostedBlock cert + + getPerasCertPoint :: cert -> Point blk + getPerasCertPoint = boostedBlockToPoint . getPerasCertBlock + +type instance BoostedBlock (ValidatedPerasCert blk) = BoostedBlock (PerasCert blk) instance - IsPerasCert (PerasCert blk) blk => + ( IsPerasCert (PerasCert blk) blk + , BoostedBlockCompatibleWithPoint (BoostedBlock (PerasCert blk)) blk + ) => IsPerasCert (ValidatedPerasCert blk) blk where getPerasCertRound = getPerasCertRound . vpcCert @@ -341,3 +465,5 @@ instance instance IsPerasCert cert blk => IsPerasCert (WithArrivalTime cert) blk where getPerasCertRound = getPerasCertRound . forgetArrivalTime getPerasCertBlock = getPerasCertBlock . forgetArrivalTime + +type instance BoostedBlock (WithArrivalTime voteOrCert) = BoostedBlock voteOrCert diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs index 83b71d1486..35215c67bd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} -- | Types common to any generic committee selection scheme module Ouroboros.Consensus.Committee.Types @@ -13,9 +13,9 @@ module Ouroboros.Consensus.Committee.Types import Cardano.Ledger.BaseTypes (HasZero) import Cardano.Ledger.Core (KeyHash, KeyRole (..)) +import Cardano.Prelude (Generic) import Data.Word (Word64) import NoThunks.Class (NoThunks) -import Cardano.Prelude (Generic) -- | Identifier of a given voter in the committee selection scheme newtype PoolId = PoolId diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index 97fd6acefa..135ada58d2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -1,12 +1,12 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -- | Weighted Fait-Accompli with Local Sortition (wFA^LS) committee selection. -- @@ -56,6 +56,8 @@ import qualified Data.Map.NonEmpty as NEMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Committee.Class ( CryptoSupportsVotingCommittee (..) , UniqueVotesWithSameTarget @@ -97,8 +99,6 @@ import Ouroboros.Consensus.Committee.WFA , unsafeGetCandidateInSeat , weightedFaitAccompliSplitSeats ) -import NoThunks.Class (NoThunks) -import GHC.Generics (Generic) -- | Tag for weighted Fait-Accompli with Local Sortition (wFA^LS) data WFALS diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs index 6401f06437..d113dc0e66 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -31,6 +32,7 @@ import Ouroboros.Consensus.Block.Abstract ) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) + , BoostedBlock , IsPerasCert (..) , PerasParams (..) , PerasRoundNo @@ -58,6 +60,7 @@ deriving instance StandardHash blk => NoThunks (MockPerasCert blk) deriving instance StandardHash blk => NFData (MockPerasCert blk) deriving instance Generic (MockPerasCert blk) +type instance BoostedBlock (MockPerasCert blk) = Point blk instance IsPerasCert (MockPerasCert blk) blk where getPerasCertRound = mockCertRound getPerasCertBlock = mockCertBlock diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs index 57d6b56169..763c41360c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs @@ -9,6 +9,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | Concrete Peras certificate types using BLS signatures. @@ -37,28 +38,36 @@ import Data.Containers.NonEmpty (HasNonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.NonEmpty as NEMap import Data.Map.Strict (Map) -import Data.Maybe (catMaybes) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, isJust) import Data.Typeable (Typeable) import Data.Word (Word16) import GHC.Generics (Generic) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) import Ouroboros.Consensus.Block.Abstract (HeaderHash) -import Ouroboros.Consensus.Block.RealPoint - ( fromBytes32RealPoint - , withOriginRealPointToPoint - ) import Ouroboros.Consensus.Block.SupportsPeras - ( IsPerasCert (..) + ( BoostedBlock + , IsPerasCert (..) , PerasBoostedBlock (..) + , PerasCertCompatibleWithVotingCommittee (..) + , PerasConversionError (..) , PerasRoundNo , PerasSeatIndex (..) + , fromPerasSeatIndex + , toPerasSeatIndex ) import Ouroboros.Consensus.Committee.Crypto ( CryptoSupportsAggregateVoteSigning (..) + , CryptoSupportsVRF (..) + ) +import Ouroboros.Consensus.Committee.EveryoneVotes + ( Cert (..) + , EveryoneVotes ) +import Ouroboros.Consensus.Committee.WFA (SeatIndex (..)) +import Ouroboros.Consensus.Committee.WFALS (Cert (..), WFALS) import Ouroboros.Consensus.Peras.Crypto.BLS ( PerasBLSCrypto - , VRFOutput ) import Ouroboros.Consensus.Peras.Vote.V1 (PerasVoteEligibilityProof (..)) import Ouroboros.Consensus.Util.Bitmap (Bitmap) @@ -90,11 +99,9 @@ instance where getPerasCertRound = pcRoundNo - getPerasCertBlock = - withOriginRealPointToPoint - . fmap fromBytes32RealPoint - . unPerasBoostedBlock - . pcBoostedBlock + getPerasCertBlock = pcBoostedBlock + +type instance BoostedBlock (PerasCert tag) = PerasBoostedBlock instance Typeable tag => FromCBOR (PerasCert tag) where fromCBOR = do @@ -256,3 +263,120 @@ toCompactRepr (PerasCertVoters voters) = getNonPersistentSig = \case (_, PersistentPerasVoteEligibilityProof) -> Nothing (_, NonPersistentPerasVoteEligibilityProof p) -> Just p + +-- * Compatibility with voting committee implementations + +-- | Convert concrete Peras certificate voters to abstract committee voters +fromPerasCertVoters :: + PerasCertVoters -> + NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) +fromPerasCertVoters voters = + NEMap.fromAscList + . NonEmpty.map + ( \(seatIndex, proof) -> + ( fromPerasSeatIndex seatIndex + , fromPerasVoteEligibilityProof proof + ) + ) + . NEMap.toAscList + . unPerasCertVoters + $ voters + where + fromPerasVoteEligibilityProof = \case + PersistentPerasVoteEligibilityProof -> Nothing + NonPersistentPerasVoteEligibilityProof vrfOutput -> Just vrfOutput + +-- | Convert abstract committee voters to concrete Peras certificate voters +toPerasCertVoters :: + NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) -> + Either PerasConversionError PerasCertVoters +toPerasCertVoters voters = + fmap PerasCertVoters + . fmap NEMap.fromAscList + . traverse + ( \(seatIndex, proof) -> do + seatIndex' <- toPerasSeatIndex seatIndex + let proof' = toPerasVoteEligibilityProof proof + pure (seatIndex', proof') + ) + . NEMap.toAscList + $ voters + where + toPerasVoteEligibilityProof = \case + Nothing -> PersistentPerasVoteEligibilityProof + Just vrfOutput -> NonPersistentPerasVoteEligibilityProof vrfOutput + +-- 'PerasCert's are compatible with 'WFALS' as long as we make sure to avoid +-- overflowing the `Word16` seat index of each voter. +instance + PerasCertCompatibleWithVotingCommittee + (PerasCert tag) + PerasBLSCrypto + WFALS + where + toPerasCert = \case + WFALSCert electionId candidate voters sig -> do + voters' <- toPerasCertVoters voters + pure $ + PerasCert + { pcRoundNo = electionId + , pcBoostedBlock = candidate + , pcVoters = voters' + , pcSignature = sig + } + + fromPerasCert = \case + PerasCert electionId candidate voters sig -> do + let voters' = fromPerasCertVoters voters + pure $ + WFALSCert + electionId + candidate + voters' + sig + +-- 'PerasCert's are compatible with 'EveryoneVotes' as long as we make sure +-- to only accept certificates containing only persistent eligibility proofs +-- (in addition to avoiding overflowing the `Word16` seat index of each voter). +instance + PerasCertCompatibleWithVotingCommittee + (PerasCert tag) + PerasBLSCrypto + EveryoneVotes + where + toPerasCert = \case + EveryoneVotesCert electionId candidate voters sig -> do + voters' <- + toPerasCertVoters + . NEMap.fromSet (const Nothing) + $ voters + pure $ + PerasCert + { pcRoundNo = electionId + , pcBoostedBlock = candidate + , pcVoters = voters' + , pcSignature = sig + } + + fromPerasCert = \case + PerasCert electionId candidate voters sig -> do + let voters' = fromPerasCertVoters voters + case nonPersistentVoters voters' of + Nothing -> + pure $ + EveryoneVotesCert + electionId + candidate + (NEMap.keysSet voters') + sig + Just nonPersistentSeatIndices -> + Left $ + EveryoneVotesButFoundNonPersistentVotersInCert + nonPersistentSeatIndices + where + nonPersistentVoters voters' = + case Map.keys (NEMap.filter isJust voters') of + [] -> + Nothing + nonPersistentSeats -> + Just (NonEmpty.fromList nonPersistentSeats) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs new file mode 100644 index 0000000000..5a1b81a831 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Concrete Peras error types for the V1 voting protocol. +-- +-- NOTE: this module is meant to be imported qualified. +module Ouroboros.Consensus.Peras.Error.V1 + ( PerasError (..) + ) where + +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.SupportsPeras + ( PerasCommitteeScheme + , PerasCrypto + ) +import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) +import Ouroboros.Consensus.Committee.WFA (WFAError) +import Ouroboros.Consensus.Peras.Types (PerasConversionError) + +-- | Collection of voting-related errors for Peras +data PerasError blk + = PerasVotingWFAError + WFAError + | PerasVotingCommitteeError + (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) + | PerasVotingConversionError + PerasConversionError + | PerasTemporaryPublicKeyHackError + String + +deriving instance + Show (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => + Show (PerasError blk) +deriving instance + Eq (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => + Eq (PerasError blk) +deriving instance + NoThunks (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => + NoThunks (PerasError blk) +deriving instance + Generic (PerasError blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs index 68006eeada..7f302e7264 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -1,10 +1,15 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- | Base Peras types used throughout the implementation. module Ouroboros.Consensus.Peras.Types @@ -13,12 +18,17 @@ module Ouroboros.Consensus.Peras.Types , PerasBoostedBlock (..) , PerasSeatIndex (..) , PerasVoteStake (..) + , BoostedBlock + , BoostedBlockCompatibleWithPoint (..) , stakeAboveThreshold , PerasVoteTarget (..) , PerasVoteId (..) , PerasVoterId (..) , PerasVoteStakeDistr (..) , lookupPerasVoteStake + , PerasConversionError (..) + , fromPerasSeatIndex + , toPerasSeatIndex ) where @@ -31,7 +41,10 @@ import Cardano.Binary import Cardano.Ledger.Hashes (KeyHash, KeyRole (..)) import Codec.Serialise.Class (Serialise (..)) import Control.DeepSeq (NFData) -import Data.Coerce (coerce) +import Data.ByteString.Short (ShortByteString) +import Data.Coerce (Coercible, coerce) +import Data.Containers.NonEmpty (HasNonEmpty (..)) +import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (..)) @@ -39,12 +52,17 @@ import Data.Semigroup (Sum (..)) import Data.Word (Word16, Word64) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) -import Ouroboros.Consensus.Block.Abstract (Point, WithOrigin) +import Ouroboros.Consensus.Block.Abstract (HeaderHash, Point, WithOrigin) import Ouroboros.Consensus.Block.RealPoint ( Bytes32RealPoint , decodeBytes32RealPoint , encodeBytes32RealPoint + , fromBytes32RealPoint + , pointToWithOriginRealPoint + , toBytes32RealPoint + , withOriginRealPointToPoint ) +import Ouroboros.Consensus.Committee.WFA (SeatIndex (..)) import Ouroboros.Consensus.Peras.Params ( PerasParams (..) , PerasQuorumStakeThreshold (..) @@ -57,6 +75,16 @@ import Quiet (Quiet (..)) -- * Peras types +class BoostedBlockCompatibleWithPoint boostedBlock blk where + boostedBlockToPoint :: boostedBlock -> Point blk + pointToBoostedBlock :: Point blk -> boostedBlock + +type family BoostedBlock voteOrCert :: Type + +instance BoostedBlockCompatibleWithPoint (Point blk) blk where + boostedBlockToPoint = id + pointToBoostedBlock = id + -- ** Round numbers newtype PerasRoundNo @@ -98,6 +126,16 @@ instance FromCBOR PerasBoostedBlock where instance ToCBOR PerasBoostedBlock where toCBOR = encodeWithOrigin encodeBytes32RealPoint . unPerasBoostedBlock +instance Coercible (HeaderHash blk) ShortByteString => BoostedBlockCompatibleWithPoint PerasBoostedBlock blk where + boostedBlockToPoint = + withOriginRealPointToPoint + . fmap fromBytes32RealPoint + . unPerasBoostedBlock + pointToBoostedBlock = + PerasBoostedBlock + . fmap toBytes32RealPoint + . pointToWithOriginRealPoint + -- ** Seat indices -- | Seat index in the voting committee used for Peras @@ -215,3 +253,38 @@ lookupPerasVoteStake voterId distr = Map.lookup voterId (unPerasVoteStakeDistr distr) + +-- ** Conversion errors + +-- | Errors that can occur when converting between Peras and committee types +data PerasConversionError + = EveryoneVotesButFoundNonPersistentVoterInVote SeatIndex + | EveryoneVotesButFoundNonPersistentVotersInCert (NE [SeatIndex]) + | SeatIndexOverflowError Word64 + | CryptoError String + deriving stock (Eq, Show, Generic) + deriving anyclass NoThunks + +-- ** Seat index conversions + +-- | Convert a Peras seat index to a committee seat index. +fromPerasSeatIndex :: + PerasSeatIndex -> + SeatIndex +fromPerasSeatIndex (PerasSeatIndex seatIndex) = + SeatIndex (fromIntegral @Word16 @Word64 seatIndex) + +-- | Convert a committee seat index to a Peras seat index +-- +-- NOTE: this can fail if the seat index in the committee vote or certificate +-- overflows the smaller 'Word16' type used by Peras votes and certificates. +-- In practice, this should never happen unless there is a bug in the voting +-- committee logic. +toPerasSeatIndex :: + SeatIndex -> + Either PerasConversionError PerasSeatIndex +toPerasSeatIndex (SeatIndex seatIndex) + | seatIndex <= fromIntegral @Word16 @Word64 maxBound = + Right (PerasSeatIndex (fromIntegral @Word64 @Word16 seatIndex)) + | otherwise = + Left (SeatIndexOverflowError seatIndex) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs index d9f82e7a71..cf1feae313 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs @@ -279,7 +279,7 @@ updatePerasRoundVoteState vote params roundState = let oldCandidateState = Map.findWithDefault (freshCandidateVoteState (getPerasVoteTarget vote)) - (getPerasVoteBlock vote) + (getPerasVotePoint vote) candidateStates candidateOrWinnerState <- updateCandidateVoteState params vote oldCandidateState @@ -290,7 +290,7 @@ updatePerasRoundVoteState vote params roundState = -- Quorum still not reached for this round let prvsCandidateStates' = Map.insert - (getPerasVoteBlock vote) + (getPerasVotePoint vote) newCandidateState candidateStates pure $ @@ -331,7 +331,7 @@ updatePerasRoundVoteState vote params roundState = } } -> do let votePoint = - getPerasVoteBlock vote + getPerasVotePoint vote winnerPoint = pvtBlock (ptvtTarget (ptvsVoteTally winnerState)) if votePoint == winnerPoint diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs index 7df3e19d73..894e74b625 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -31,6 +32,7 @@ import Ouroboros.Consensus.Block.Abstract ) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) + , BoostedBlock , IsPerasVote (..) , PerasRoundNo , PerasVoteStake @@ -63,6 +65,7 @@ deriving instance StandardHash blk => NoThunks (MockPerasVote blk) deriving instance StandardHash blk => NFData (MockPerasVote blk) deriving instance Generic (MockPerasVote blk) +type instance BoostedBlock (MockPerasVote blk) = Point blk instance IsPerasVote (MockPerasVote blk) blk where getPerasVoteRound = mockVoteRound getPerasVoteBlock = mockVoteBlock diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs index fd66a99b8a..8501c3e9a4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs @@ -2,12 +2,13 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -- | Concrete Peras vote types using BLS signatures. -- @@ -24,24 +25,34 @@ import Cardano.Binary , decodeListLenOf , encodeListLen ) +import Data.ByteString.Short (ShortByteString) +import Data.Coerce (Coercible) import Data.Typeable (Typeable) import Data.Word (Word8) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract (HeaderHash) import Ouroboros.Consensus.Block.SupportsPeras - ( PerasBoostedBlock (..) + ( BoostedBlock + , IsPerasVote (..) + , PerasBoostedBlock (..) + , PerasConversionError (..) , PerasRoundNo - , PerasSeatIndex, IsPerasCert, IsPerasVote (..) + , PerasSeatIndex + , PerasVoteCompatibleWithVotingCommittee (..) + , fromPerasSeatIndex + , toPerasSeatIndex ) import Ouroboros.Consensus.Committee.Crypto (CryptoSupportsVoteSigning (..)) +import Ouroboros.Consensus.Committee.EveryoneVotes + ( EveryoneVotes + , Vote (..) + ) +import Ouroboros.Consensus.Committee.WFALS (Vote (..), WFALS) import Ouroboros.Consensus.Peras.Crypto.BLS ( PerasBLSCrypto , VRFOutput ) -import Data.Coerce (Coercible) -import Ouroboros.Consensus.Block.Abstract (HeaderHash) -import Data.ByteString.Short (ShortByteString) -import Ouroboros.Consensus.Block.RealPoint (withOriginRealPointToPoint, fromBytes32RealPoint) -- | Concrete Peras votes using BLS signatures -- @@ -65,16 +76,13 @@ data PerasVote tag deriving stock (Show, Eq, Generic) deriving anyclass NoThunks +type instance BoostedBlock (PerasVote tag) = PerasBoostedBlock instance Coercible (HeaderHash blk) ShortByteString => - IsPerasVote (PerasVote blk) blk where - getPerasVoteRound = - pvRoundNo - getPerasVoteBlock = - withOriginRealPointToPoint - . fmap fromBytes32RealPoint - . unPerasBoostedBlock - . pvBoostedBlock + IsPerasVote (PerasVote blk) blk + where + getPerasVoteRound = pvRoundNo + getPerasVoteBlock = pvBoostedBlock instance Typeable tag => FromCBOR (PerasVote tag) where fromCBOR = do @@ -132,3 +140,92 @@ instance ToCBOR PerasVoteEligibilityProof where encodeListLen 2 <> toCBOR (1 :: Word8) <> toCBOR vrfOutput + +-- * Compatibility with voting committee implementations + +-- 'PerasVote's are compatible with 'WFALS' as long as we make sure to avoid +-- overflowing their `Word16` seat index. +instance + PerasVoteCompatibleWithVotingCommittee + (PerasVote tag) + PerasBLSCrypto + WFALS + where + toPerasVote = \case + WFALSPersistentVote seatIndex electionId candidate sig -> do + perasSeatIndex <- toPerasSeatIndex seatIndex + pure $ + PerasVote + { pvRoundNo = electionId + , pvBoostedBlock = candidate + , pvSeatIndex = perasSeatIndex + , pvEligibilityProof = PersistentPerasVoteEligibilityProof + , pvSignature = sig + } + WFALSNonPersistentVote seatIndex electionId candidate vrfOutput sig -> do + perasSeatIndex <- toPerasSeatIndex seatIndex + let proof = NonPersistentPerasVoteEligibilityProof vrfOutput + pure $ + PerasVote + { pvRoundNo = electionId + , pvBoostedBlock = candidate + , pvSeatIndex = perasSeatIndex + , pvEligibilityProof = proof + , pvSignature = sig + } + + fromPerasVote = \case + PerasVote electionId candidate seatIndex proof sig -> do + let seatIndex' = fromPerasSeatIndex seatIndex + case proof of + PersistentPerasVoteEligibilityProof -> + pure $ + WFALSPersistentVote + seatIndex' + electionId + candidate + sig + NonPersistentPerasVoteEligibilityProof vrfOutput -> + pure $ + WFALSNonPersistentVote + seatIndex' + electionId + candidate + vrfOutput + sig + +-- 'PerasVote's are compatible with 'EveryoneVotes' as long as we make sure +-- to only accept votes with persistent eligibility proofs (in addition to +-- avoiding overflowing their `Word16` seat index). +instance + PerasVoteCompatibleWithVotingCommittee + (PerasVote tag) + PerasBLSCrypto + EveryoneVotes + where + toPerasVote = \case + EveryoneVotesVote seatIndex electionId candidate sig -> do + perasSeatIndex <- toPerasSeatIndex seatIndex + pure $ + PerasVote + { pvRoundNo = electionId + , pvBoostedBlock = candidate + , pvSeatIndex = perasSeatIndex + , pvEligibilityProof = PersistentPerasVoteEligibilityProof + , pvSignature = sig + } + + fromPerasVote = \case + PerasVote electionId candidate seatIndex proof sig -> do + let seatIndex' = fromPerasSeatIndex seatIndex + case proof of + PersistentPerasVoteEligibilityProof -> + pure $ + EveryoneVotesVote + seatIndex' + electionId + candidate + sig + NonPersistentPerasVoteEligibilityProof _ -> + Left $ + EveryoneVotesButFoundNonPersistentVoterInVote seatIndex' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs deleted file mode 100644 index 21521ccc28..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Adapter.hs +++ /dev/null @@ -1,307 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | Support for using concrete votes and certificates with multiple voting --- committee implementations. -module Ouroboros.Consensus.Peras.Voting.Adapter - ( -- * Peras support for multiple voting committee implementations - PerasConversionError (..) - , PerasVoteCompatibleWithVotingCommittee (..) - , PerasCertCompatibleWithVotingCommittee (..) - ) where - -import Data.Containers.NonEmpty (HasNonEmpty (..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Map.NonEmpty as NEMap -import Data.Maybe (isJust) -import Data.Word (Word16, Word64) -import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) -import qualified Ouroboros.Consensus.Committee.Class as Committee -import Ouroboros.Consensus.Committee.Crypto (CryptoSupportsVRF (..)) -import Ouroboros.Consensus.Committee.EveryoneVotes - ( Cert (..) - , EveryoneVotes - , Vote (..) - ) -import Ouroboros.Consensus.Committee.WFA (SeatIndex (..)) -import Ouroboros.Consensus.Committee.WFALS (Cert (..), Vote (..), WFALS) -import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 -import Ouroboros.Consensus.Peras.Crypto.BLS (PerasBLSCrypto) -import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) -import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 - --- * Peras support for multiple voting committee implementations - --- | Errors that can occur when converting between Peras and committee types -data PerasConversionError - = EveryoneVotesButFoundNonPersistentVoterInVote SeatIndex - | EveryoneVotesButFoundNonPersistentVotersInCert (NE [SeatIndex]) - | SeatIndexOverflowError Word64 - | CryptoError String - deriving stock (Eq, Show, Generic) - deriving anyclass NoThunks - --- | Conversion between (concrete) Peras votes and (abstract) committee votes. --- --- NOTE: the functional dependency @vote -> crypto@ explicitly ties each --- concrete Peras vote type to a specific crypto scheme. -class - PerasVoteCompatibleWithVotingCommittee vote crypto committee - | vote -> crypto - where - toPerasVote :: - Committee.Vote crypto committee -> - Either PerasConversionError vote - fromPerasVote :: - vote -> - Either PerasConversionError (Committee.Vote crypto committee) - --- | Conversion between (concrete) Peras certificates and (abstract) committee --- certificates. --- --- NOTE: the functional dependency @cert -> crypto@ explicitly ties each --- concrete Peras certificate type to a specific crypto scheme. -class - PerasCertCompatibleWithVotingCommittee cert crypto committee - | cert -> crypto - where - toPerasCert :: - Committee.Cert crypto committee -> - Either PerasConversionError cert - fromPerasCert :: - cert -> - Either PerasConversionError (Committee.Cert crypto committee) - --- 'V1.PerasVote's are compatible with 'WFALS' as long as we make sure to avoid --- overflowing their `Word16` seat index. -instance - PerasVoteCompatibleWithVotingCommittee - (V1.PerasVote tag) - PerasBLSCrypto - WFALS - where - toPerasVote = \case - WFALSPersistentVote seatIndex electionId candidate sig -> do - perasSeatIndex <- toPerasSeatIndex seatIndex - pure $ - V1.PerasVote - { V1.pvRoundNo = electionId - , V1.pvBoostedBlock = candidate - , V1.pvSeatIndex = perasSeatIndex - , V1.pvEligibilityProof = V1.PersistentPerasVoteEligibilityProof - , V1.pvSignature = sig - } - WFALSNonPersistentVote seatIndex electionId candidate vrfOutput sig -> do - perasSeatIndex <- toPerasSeatIndex seatIndex - let proof = V1.NonPersistentPerasVoteEligibilityProof vrfOutput - pure $ - V1.PerasVote - { V1.pvRoundNo = electionId - , V1.pvBoostedBlock = candidate - , V1.pvSeatIndex = perasSeatIndex - , V1.pvEligibilityProof = proof - , V1.pvSignature = sig - } - - fromPerasVote = \case - V1.PerasVote electionId candidate seatIndex proof sig -> do - let seatIndex' = fromPerasSeatIndex seatIndex - case proof of - V1.PersistentPerasVoteEligibilityProof -> - pure $ - WFALSPersistentVote - seatIndex' - electionId - candidate - sig - V1.NonPersistentPerasVoteEligibilityProof vrfOutput -> - pure $ - WFALSNonPersistentVote - seatIndex' - electionId - candidate - vrfOutput - sig - --- 'V1.PerasCert's are compatible with 'WFALS' as long as we make sure to avoid --- overflowing the `Word16` seat index of each voter. -instance - PerasCertCompatibleWithVotingCommittee - (V1.PerasCert tag) - PerasBLSCrypto - WFALS - where - toPerasCert = \case - WFALSCert electionId candidate voters sig -> do - voters' <- toPerasCertVoters voters - pure $ - V1.PerasCert - { V1.pcRoundNo = electionId - , V1.pcBoostedBlock = candidate - , V1.pcVoters = voters' - , V1.pcSignature = sig - } - - fromPerasCert = \case - V1.PerasCert electionId candidate voters sig -> do - let voters' = fromPerasCertVoters voters - pure $ - WFALSCert - electionId - candidate - voters' - sig - --- 'V1.PerasVote's are compatible with 'EveryoneVotes' as long as we make sure --- to only accept votes with persistent eligibility proofs (in addition to --- avoiding overflowing their `Word16` seat index). -instance - PerasVoteCompatibleWithVotingCommittee - (V1.PerasVote tag) - PerasBLSCrypto - EveryoneVotes - where - toPerasVote = \case - EveryoneVotesVote seatIndex electionId candidate sig -> do - perasSeatIndex <- toPerasSeatIndex seatIndex - pure $ - V1.PerasVote - { V1.pvRoundNo = electionId - , V1.pvBoostedBlock = candidate - , V1.pvSeatIndex = perasSeatIndex - , V1.pvEligibilityProof = V1.PersistentPerasVoteEligibilityProof - , V1.pvSignature = sig - } - - fromPerasVote = \case - V1.PerasVote electionId candidate seatIndex proof sig -> do - let seatIndex' = fromPerasSeatIndex seatIndex - case proof of - V1.PersistentPerasVoteEligibilityProof -> - pure $ - EveryoneVotesVote - seatIndex' - electionId - candidate - sig - V1.NonPersistentPerasVoteEligibilityProof _ -> - Left $ - EveryoneVotesButFoundNonPersistentVoterInVote seatIndex' - --- 'V1.PerasCert's are compatible with 'EveryoneVotes' as long as we make sure --- to only accept certificates containing only persistent eligibility proofs --- (in addition to avoiding overflowing the `Word16` seat index of each voter). -instance - PerasCertCompatibleWithVotingCommittee - (V1.PerasCert tag) - PerasBLSCrypto - EveryoneVotes - where - toPerasCert = \case - EveryoneVotesCert electionId candidate voters sig -> do - voters' <- - toPerasCertVoters - . NEMap.fromSet (const Nothing) - $ voters - pure $ - V1.PerasCert - { V1.pcRoundNo = electionId - , V1.pcBoostedBlock = candidate - , V1.pcVoters = voters' - , V1.pcSignature = sig - } - - fromPerasCert = \case - V1.PerasCert electionId candidate voters sig -> do - let voters' = fromPerasCertVoters voters - case nonPersistentVoters voters' of - Nothing -> - pure $ - EveryoneVotesCert - electionId - candidate - (NEMap.keysSet voters') - sig - Just nonPersistentSeatIndices -> - Left $ - EveryoneVotesButFoundNonPersistentVotersInCert - nonPersistentSeatIndices - where - nonPersistentVoters voters' = - case Map.keys (NEMap.filter isJust voters') of - [] -> - Nothing - nonPersistentSeats -> - Just (NonEmpty.fromList nonPersistentSeats) - --- * Helpers - --- | Convert a Peras seat index to a committee seat index. -fromPerasSeatIndex :: - PerasSeatIndex -> - SeatIndex -fromPerasSeatIndex (PerasSeatIndex seatIndex) = - SeatIndex (fromIntegral @Word16 @Word64 seatIndex) - --- | Convert a committee seat index to a Peras seat index --- --- NOTE: this can fail if the seat index in the committee vote or certificate --- overflows the smaller 'Word16' type used by Peras votes and certificates. --- In practice, this should never happen unless there is a bug in the voting --- committee logic. -toPerasSeatIndex :: - SeatIndex -> - Either PerasConversionError PerasSeatIndex -toPerasSeatIndex (SeatIndex seatIndex) - | seatIndex <= fromIntegral @Word16 @Word64 maxBound = - Right (PerasSeatIndex (fromIntegral @Word64 @Word16 seatIndex)) - | otherwise = - Left (SeatIndexOverflowError seatIndex) - --- | Convert concrete Peras certificate voters to abstract committee voters -fromPerasCertVoters :: - V1.PerasCertVoters -> - NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) -fromPerasCertVoters voters = - NEMap.fromAscList - . NonEmpty.map - ( \(seatIndex, proof) -> - ( fromPerasSeatIndex seatIndex - , fromPerasVoteEligibilityProof proof - ) - ) - . NEMap.toAscList - . V1.unPerasCertVoters - $ voters - where - fromPerasVoteEligibilityProof = \case - V1.PersistentPerasVoteEligibilityProof -> Nothing - V1.NonPersistentPerasVoteEligibilityProof vrfOutput -> Just vrfOutput - --- | Convert abstract committee voters to concrete Peras certificate voters -toPerasCertVoters :: - NE (Map SeatIndex (Maybe (VRFOutput PerasBLSCrypto))) -> - Either PerasConversionError V1.PerasCertVoters -toPerasCertVoters voters = - fmap V1.PerasCertVoters - . fmap NEMap.fromAscList - . traverse - ( \(seatIndex, proof) -> do - seatIndex' <- toPerasSeatIndex seatIndex - let proof' = toPerasVoteEligibilityProof proof - pure (seatIndex', proof') - ) - . NEMap.toAscList - $ voters - where - toPerasVoteEligibilityProof = \case - Nothing -> V1.PersistentPerasVoteEligibilityProof - Just vrfOutput -> V1.NonPersistentPerasVoteEligibilityProof vrfOutput diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs index 9454cb46d8..989ec9922e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs @@ -292,5 +292,5 @@ mkPerasVotingView -- Check whether the boosted block is within the volatile fragment leading -- to the candidate block. AF.withinFragmentBounds - (castPoint (getPerasCertBlock cert)) + (castPoint (getPerasCertPoint cert)) chainAtCandidateBlock 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 a25c1d8639..fe7c947ae7 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 @@ -617,7 +617,7 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do ChainSelAddPerasCert cert _varProcessed -> traceWith cdbTracer $ TraceAddPerasCertEvent $ - PoppedPerasCertFromQueue (getPerasCertRound cert) (getPerasCertBlock cert) + PoppedPerasCertFromQueue (getPerasCertRound cert) (getPerasCertPoint cert) chainSelSync cdb message lift $ atomically $ processedChainSelMessage cdbChainSelQueue message ) 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 a97509e061..621898a79e 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 @@ -540,7 +540,7 @@ chainSelSync cdb@CDB{..} (ChainSelAddPerasCert cert varProcessed) = do certRound = getPerasCertRound cert boostedBlock :: Point blk - boostedBlock = getPerasCertBlock cert + boostedBlock = getPerasCertPoint cert -- | Return 'True' when the given header should be ignored when adding it -- because it is too old, i.e., we wouldn't be able to switch to a chain diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index ade24f0213..21a9a1d27b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -659,7 +659,7 @@ addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do addedToQueue = AddedPerasCertToQueue (getPerasCertRound cert) - (getPerasCertBlock cert) + (getPerasCertPoint cert) -- | Try to add blocks again that were postponed due to the LoE. addReprocessLoEBlocks :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs index 045a692fa6..1cd51a9b21 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -176,7 +176,7 @@ prop_garbageCollectRemovesOldCerts db slotNo = do _ <- garbageCollect db slotNo getCertsAfter db zeroPerasCertTicketNo allCertValues <- sequence (Map.elems allCertActions) - let targetSlots = pointSlot . getPerasCertBlock . forgetArrivalTime <$> allCertValues + let targetSlots = pointSlot . getPerasCertPoint . forgetArrivalTime <$> allCertValues pure $ all (>= NotOrigin slotNo) targetSlots diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index aca2517b2f..71dcb012a4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -232,7 +232,7 @@ implGetWeightSnapshot PerasCertDbEnv{pcdbState} = do WithFingerprint pcds fp <- readTVar pcdbState let weights = mkPerasWeightSnapshot - [ (getPerasCertBlock cert, vpcCertBoost (forgetArrivalTime cert)) + [ (getPerasCertPoint cert, vpcCertBoost (forgetArrivalTime cert)) | cert <- Map.elems (pcdsCertsByTicket pcds) ] pure (WithFingerprint weights fp) @@ -289,7 +289,7 @@ implGarbageCollect PerasCertDbEnv{pcdbTracer, pcdbState} slotNo = do } = let pcdsCertsByTicket' = Map.filter - (\cert -> pointSlot (getPerasCertBlock cert) >= NotOrigin slotNo) + (\cert -> pointSlot (getPerasCertPoint cert) >= NotOrigin slotNo) pcdsCertsByTicket pcdsCertIds' = Set.fromList (getPerasCertRound <$> Map.elems pcdsCertsByTicket') diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs index 39cc4333cd..e22424bc51 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs @@ -202,7 +202,7 @@ prop_garbageCollectRemovesOldVotes db slotNo = atomically $ do _ <- garbageCollect db slotNo allVotes <- getVotesAfter db zeroPerasVoteTicketNo - let targetSlots = pointSlot . getPerasVoteBlock . forgetArrivalTime <$> Map.elems allVotes + let targetSlots = pointSlot . getPerasVotePoint . forgetArrivalTime <$> Map.elems allVotes pure $ all (>= NotOrigin slotNo) targetSlots diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs index 27c088ac1f..8b925b9d58 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Test that the Peras certificate inclusion rules can correctly decide when @@ -21,7 +22,8 @@ import qualified Data.Set as Set import GHC.Generics (Generic) import Ouroboros.Consensus.Block (Point (..), WithOrigin (..)) import Ouroboros.Consensus.Block.SupportsPeras - ( IsPerasCert (..) + ( BoostedBlock + , IsPerasCert (..) , PerasCertMaxRounds (..) , PerasParams (..) , PerasRoundNo (..) @@ -235,6 +237,7 @@ data TestCert } deriving (Show, Eq, Generic) +type instance BoostedBlock (TestCert) = Point TestBlock instance IsPerasCert TestCert TestBlock where getPerasCertRound = tcRoundNo diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs index 3cd82dd231..ef095eec99 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs @@ -6,15 +6,15 @@ module Test.Consensus.Peras.Voting.Adapter (tests) where import Data.Proxy (Proxy (..)) +import Ouroboros.Consensus.Block.SupportsPeras + ( PerasCertCompatibleWithVotingCommittee (..) + , PerasVoteCompatibleWithVotingCommittee (..) + ) import qualified Ouroboros.Consensus.Committee.Class as Committee import Ouroboros.Consensus.Committee.EveryoneVotes (EveryoneVotes) import Ouroboros.Consensus.Committee.WFALS (WFALS) import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 -import Ouroboros.Consensus.Peras.Voting.Adapter - ( PerasCertCompatibleWithVotingCommittee (..) - , PerasVoteCompatibleWithVotingCommittee (..) - ) import Test.Consensus.Peras.Util ( genPerasCert , genPerasVote diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs index aeb7c50086..029b8667a6 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Test that the Peras voting rules can correctly decide when to vote. @@ -21,7 +22,8 @@ import Ouroboros.Consensus.Block.Abstract , WithOrigin (..) ) import Ouroboros.Consensus.Block.SupportsPeras - ( IsPerasCert (..) + ( BoostedBlock + , IsPerasCert (..) , PerasBlockMinSlots (..) , PerasCertArrivalThreshold (..) , PerasCooldownRounds (..) @@ -256,6 +258,7 @@ data TestCert } deriving (Show, Eq, Generic) +type instance BoostedBlock (TestCert) = Point TestBlock instance IsPerasCert TestCert TestBlock where getPerasCertRound = tcRoundNo 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 599c1580a2..fde5f0863b 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 @@ -1775,7 +1775,7 @@ addPerasCertOutcomes = concatMap classifyEvent classifyEvent :: Event Blk m Symbolic -> [String] classifyEvent ev = case unAt (eventCmd ev) of AddPerasCert certWithTime _ -> - let targetPt = getPerasCertBlock (vpcCert (forgetArrivalTime certWithTime)) + let targetPt = getPerasCertPoint (vpcCert (forgetArrivalTime certWithTime)) in case (isBlockConnected targetPt (dbModel (eventBefore ev))) of False -> assert (chainSelOutcome ev == "no chain selection change") $ @@ -1793,7 +1793,7 @@ addPerasVoteOutcomes = concatMap classifyEvent classifyEvent :: Event Blk m Symbolic -> [String] classifyEvent ev = case unAt (eventCmd ev) of AddPerasVote voteWithTime _ -> - let targetPt = getPerasVoteBlock (vpvVote (forgetArrivalTime voteWithTime)) + let targetPt = getPerasVotePoint (vpvVote (forgetArrivalTime voteWithTime)) certsBefore = numCerts (eventBefore ev) certsAfter = numCerts (eventAfter ev) certProduced = certsAfter > certsBefore diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs index 7487edf5ef..c3e2202a4b 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -75,7 +75,7 @@ getWeightSnapshot :: Model blk -> PerasWeightSnapshot blk getWeightSnapshot Model{certs} = mkPerasWeightSnapshot - [ (getPerasCertBlock cert, vpcCertBoost (forgetArrivalTime cert)) + [ (getPerasCertPoint cert, vpcCertBoost (forgetArrivalTime cert)) | cert <- Set.toList certs ] @@ -90,4 +90,4 @@ garbageCollect :: garbageCollect slotNo model@Model{certs} = model{certs = Set.filter keepCert certs} where - keepCert cert = pointSlot (getPerasCertBlock cert) >= NotOrigin slotNo + keepCert cert = pointSlot (getPerasCertPoint cert) >= NotOrigin slotNo diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index 5833d57ad0..d4643231a8 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -138,7 +138,7 @@ instance StateModel Model where -- So we should enforce: round = round' => boostedBlock = boostedBlock' p cert' = getPerasCertRound cert /= getPerasCertRound cert' - || getPerasCertBlock cert == getPerasCertBlock cert' + || getPerasCertPoint cert == getPerasCertPoint cert' GetWeightSnapshot -> True GetLatestCertSeen -> True GarbageCollect _slotNo -> True @@ -195,7 +195,7 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where "Certificate block collision" [ show $ Set.member - (getPerasCertBlock cert) - (Set.map getPerasCertBlock model.certs) + (getPerasCertPoint cert) + (Set.map getPerasCertPoint model.certs) ] monitoring _ _ _ _ prop = prop diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs index 5f03f35a03..4dc49d4176 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs @@ -182,7 +182,7 @@ addVote vote model -- block in this round => integrity violation (shouldn't happen in practice) | reachedQuorum , Just existingCert <- certAtRound - , getPerasCertBlock freshCert /= getPerasCertBlock existingCert = + , getPerasCertPoint freshCert /= getPerasCertPoint existingCert = ( Left $ MultipleWinnersInRound roundNo , model @@ -222,7 +222,7 @@ addVote vote model roundNo = getPerasVoteRound vote votedBlock = - getPerasVoteBlock vote + getPerasVotePoint vote voter = getPerasVoteVoterId vote -- Compute the next ticket number associated to this vote. diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index 2dae37aa84..1d497b3d2f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -415,6 +415,6 @@ votesToReachQuorum model vote res = Set.empty PerasVoteTarget { pvtRoundNo = getPerasVoteRound vote - , pvtBlock = getPerasVoteBlock vote + , pvtBlock = getPerasVotePoint vote } (Model.votes model) From e21c782a424541dd4f8d569f8565c044bf9b70d1 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Fri, 22 May 2026 15:41:57 +0200 Subject: [PATCH 34/62] Remove `PerasVoteStake` in favor of `VoteWeight` --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 6 +- .../Consensus/Protocol/Praos/Peras.hs | 19 +++-- .../Consensus/Block/SupportsPeras.hs | 22 ++--- .../Ouroboros/Consensus/Committee/Types.hs | 12 ++- .../ObjectDiffusion/ObjectPool/PerasVote.hs | 24 +++--- .../Ouroboros/Consensus/Peras/Params.hs | 32 +++---- .../Ouroboros/Consensus/Peras/Types.hs | 83 +++++++------------ .../Consensus/Peras/Vote/Aggregation.hs | 50 +++++------ .../Ouroboros/Consensus/Peras/Vote/Mock.hs | 26 +++--- .../Consensus/Storage/PerasVoteDB/API.hs | 4 +- .../Consensus/Storage/PerasVoteDB/Impl.hs | 4 +- .../Test/Util/Orphans/ToExpr.hs | 2 +- .../ObjectDiffusion/PerasVote/Smoke.hs | 18 ++-- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 6 +- .../Ouroboros/Storage/PerasVoteDB/Model.hs | 32 +++---- .../Storage/PerasVoteDB/StateMachine.hs | 20 ++--- 16 files changed, 171 insertions(+), 189 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index fb0782ab35..e712959330 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -400,11 +400,11 @@ mkHandlers systemTime -- TODO: when actual plumbing for Peras is ready, we will have to -- extract the committee selection data from the chainDB to pass - -- it here, instead of relying on an empty the stake distribution. + -- it here, instead of relying on an empty the weight distribution. -- - -- Note that the empty stake distribution will cause all votes to + -- Note that the empty weight distribution will cause all votes to -- be considered invalid. - (pure (PerasVoteStakeDistr mempty)) + (pure (VoteWeightDistr mempty)) getChainDB ) version diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs index 52623ef84a..895c7d3e00 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Voting interface for Peras derived from the Praos ledger view. -module Ouroboros.Consensus.Protocol.Praos.Peras where +module Ouroboros.Consensus.Protocol.Praos.Peras + ( PraosStateSupportsPerasVoting (..) + , getStakeDistrWithBLSPublicKeys + , perasBLSPublicKeysFromEnv + ) where import qualified Cardano.Ledger.Shelley.State as SL import Data.Aeson (eitherDecodeFileStrict') @@ -91,10 +91,10 @@ instance PraosStateSupportsPerasVoting RealBlock where let wFATiebreaker = wFATiebreakerWithEpochNonce epochNonce stakeDistrWithPublicKeys <- - bimap V1.PerasTemporaryPublicKeyHackError id $ + first V1.PerasTemporaryPublicKeyHackError $ getStakeDistrWithBLSPublicKeys tickedPraosState extWFAStakeDistr <- - bimap V1.PerasVotingWFAError id $ + first V1.PerasVotingWFAError $ mkExtWFAStakeDistr wFATiebreaker stakeDistrWithPublicKeys @@ -136,8 +136,9 @@ getStakeDistrWithBLSPublicKeys tickedPraosState = do -- * Retrieveing public keys from a JSON file (temporary) perasBLSPublicKeysFromEnv :: Either String (Map PoolId BLS.PerasPublicKey) +{-# NOINLINE perasBLSPublicKeysFromEnv #-} perasBLSPublicKeysFromEnv = - unsafePerformIO $ do + unsafePerformIO $ lookupEnv envVar >>= \case Nothing -> do pure $ Left $ "Environment variable " <> envVar <> " not set." @@ -198,5 +199,5 @@ class praosStateGetPerasVotingCommittee p perasParams tickedPraosState = do committeeInput <- praosStatePerasVotingCommitteeInput p perasParams tickedPraosState - bimap injectCommitteeError id $ + first injectCommitteeError $ Committee.mkVotingCommittee committeeInput diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index a5e2199b21..6434761493 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -59,7 +59,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) import qualified Ouroboros.Consensus.Committee.Class as Committee import Ouroboros.Consensus.Committee.Crypto (ElectionId, PrivateKey, VoteCandidate) -import Ouroboros.Consensus.Committee.Types (PoolId, VoteWeight (..)) +import Ouroboros.Consensus.Committee.Types (PoolId) import Ouroboros.Consensus.Peras.Params import Ouroboros.Consensus.Peras.Types import Ouroboros.Consensus.Util (ShowProxy) @@ -129,13 +129,13 @@ class validatePerasVote :: PerasParams -> - PerasVoteStakeDistr -> + VoteWeightDistr -> PerasVote blk -> Either (PerasError blk) (ValidatedPerasVote blk) default validatePerasVote :: PerasVote blk ~ VoidPerasVote blk => PerasParams -> - PerasVoteStakeDistr -> + VoteWeightDistr -> PerasVote blk -> Either (PerasError blk) (ValidatedPerasVote blk) validatePerasVote _ _ vote = @@ -257,7 +257,7 @@ implPerasForgeVoteIfEligible pure $ ValidatedPerasVote { vpvVote = concreteVote - , vpvVoteStake = coerce voteWeight + , vpvVoteWeight = coerce voteWeight } -- * Helpers to derive @BlockSupportsPeras@ for block types without Peras support @@ -306,7 +306,7 @@ newtype VoidPerasError blk data ValidatedPerasVote blk = ValidatedPerasVote { vpvVote :: !(PerasVote blk) - , vpvVoteStake :: !PerasVoteStake + , vpvVoteWeight :: !VoteWeight } deriving instance Show (PerasVote blk) => Show (ValidatedPerasVote blk) @@ -376,11 +376,11 @@ votesReachQuorum params votes = -- can't vacuously reach a quorum, even if the quorum threshold is 0. [] -> Nothing -- If we have at least one vote, we must check that all votes are for the - -- same target, and that their total stake of is above the quorum threshold. + -- same target, and that their total weight is above the quorum threshold. (v0 : vs) | not (allVotesMatchTarget v0 vs) -> Nothing - | not votesHaveEnoughStake -> + | not votesHaveEnoughWeight -> Nothing | otherwise -> Just @@ -390,10 +390,10 @@ votesReachQuorum params votes = , vpvqPerasParams = params } where - totalVoteStake = - mconcat (vpvVoteStake <$> votes) - votesHaveEnoughStake = - stakeAboveThreshold params totalVoteStake + totalVoteWeight = + mconcat (vpvVoteWeight <$> votes) + votesHaveEnoughWeight = + weightAboveThreshold params totalVoteWeight allVotesMatchTarget target = all ((== (getPerasVoteTarget target)) . getPerasVoteTarget) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs index 35215c67bd..55db795ac9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Types common to any generic committee selection scheme @@ -14,6 +14,9 @@ module Ouroboros.Consensus.Committee.Types import Cardano.Ledger.BaseTypes (HasZero) import Cardano.Ledger.Core (KeyHash, KeyRole (..)) import Cardano.Prelude (Generic) +import Codec.Serialise (Serialise) +import Control.DeepSeq (NFData) +import Data.Semigroup (Sum (..)) import Data.Word (Word64) import NoThunks.Class (NoThunks) @@ -27,14 +30,17 @@ newtype PoolId = PoolId newtype LedgerStake = LedgerStake { unLedgerStake :: Rational } - deriving (Show, Eq) + deriving (Show, Eq, Ord) deriving newtype (Num, HasZero) -- | Voting power of a voter in the committee selection scheme newtype VoteWeight = VoteWeight { unVoteWeight :: Rational } - deriving (Show, Eq, NoThunks, Generic) + deriving newtype (Show, Eq, Ord, Num, Fractional, NoThunks, NFData, Serialise) + deriving stock Generic + deriving Semigroup via Sum Rational + deriving Monoid via Sum Rational -- | Target committee size newtype TargetCommitteeSize = TargetCommitteeSize diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs index 3dcbf4dbb5..ef9ceee4a7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs @@ -101,23 +101,21 @@ makePerasVotePoolWriterFromVoteDB :: , BlockSupportsPeras blk ) => SystemTime m -> - -- | This is needed for validating votes (since it is during the validation of - -- votes that we give them a verified weight. In the future, we won't read it - -- from the stake distr directly, but rather use the committee selection data) - STM m PerasVoteStakeDistr -> + -- | TODO: replace with a 'PerasVotingCommittee blk' + STM m VoteWeightDistr -> PerasVoteDB m blk -> ObjectPoolWriter (PerasVoteId blk) (PerasVote blk) m -makePerasVotePoolWriterFromVoteDB systemTime getStakeDistrSTM perasVoteDB = +makePerasVotePoolWriterFromVoteDB systemTime getVoteWeightDistrSTM perasVoteDB = ObjectPoolWriter { opwObjectId = getPerasVoteId , opwAddObjects = \votes -> processVotes systemTime (PerasVoteDB.getVoteIds perasVoteDB) - -- TODO: in the future we won't need just the stake distribution for + -- TODO: in the future we won't need just the vote weight distribution for -- validating votes, but also the whole committee selection context -- (containing vote weights of committee members = voters) - (\vote -> getStakeDistrSTM >>= \sd -> pure $ validatePerasVote mkPerasParams sd vote) + (\vote -> getVoteWeightDistrSTM >>= \sd -> pure $ validatePerasVote mkPerasParams sd vote) (void . join . atomically . PerasVoteDB.addVote perasVoteDB) votes , opwHasObject = do @@ -133,23 +131,21 @@ makePerasVotePoolWriterFromChainDB :: , BlockSupportsPeras blk ) => SystemTime m -> - -- | This is needed for validating votes (since its during the validation of - -- votes that we give them a verified weight. In the future, we won't read it - -- from the stake distr directly, but rather use the committee selection data) - STM m PerasVoteStakeDistr -> + -- \| TODO: replace with a 'PerasVotingCommittee blk' + STM m VoteWeightDistr -> ChainDB m blk -> ObjectPoolWriter (PerasVoteId blk) (PerasVote blk) m -makePerasVotePoolWriterFromChainDB systemTime getStakeDistrSTM chainDB = +makePerasVotePoolWriterFromChainDB systemTime getVoteWeightDistrSTM chainDB = ObjectPoolWriter { opwObjectId = getPerasVoteId , opwAddObjects = \votes -> processVotes systemTime (ChainDB.getPerasVoteIds chainDB) - -- TODO: in the future we won't need just the stake distribution for + -- TODO: in the future we won't need just the vote weight distribution for -- validating votes, but also the whole committee selection context -- (containing vote weights of committee members = voters) - (\vote -> getStakeDistrSTM >>= \sd -> pure $ validatePerasVote mkPerasParams sd vote) + (\vote -> getVoteWeightDistrSTM >>= \sd -> pure $ validatePerasVote mkPerasParams sd vote) -- We do not want to block the writer thread on waiting for ChainSel -- side-effects to complete, so we use the async version of adding -- votes to the ChainDB and ignore the returned promise. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs index 0a233444c4..050923dc99 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs @@ -14,8 +14,8 @@ module Ouroboros.Consensus.Peras.Params , PerasCertArrivalThreshold (..) , PerasRoundLength (..) , PerasWeight (..) - , PerasQuorumStakeThreshold (..) - , PerasQuorumStakeThresholdSafetyMargin (..) + , PerasQuorumWeightThreshold (..) + , PerasQuorumWeightThresholdSafetyMargin (..) -- * Protocol parameters bundle , PerasParams (..) @@ -90,21 +90,21 @@ newtype PerasWeight deriving via Sum Word64 instance Semigroup PerasWeight deriving via Sum Word64 instance Monoid PerasWeight --- | Total stake needed to forge a Peras certificate. -newtype PerasQuorumStakeThreshold - = PerasQuorumStakeThreshold {unPerasQuorumStakeThreshold :: Rational} - deriving Show via Quiet PerasQuorumStakeThreshold +-- | Total vote weight needed to forge a Peras certificate. +newtype PerasQuorumWeightThreshold + = PerasQuorumWeightThreshold {unPerasQuorumWeightThreshold :: Rational} + deriving Show via Quiet PerasQuorumWeightThreshold deriving stock Generic deriving newtype (Eq, Ord, NoThunks, Condense) --- | Safety margin needed on top of the quorum stake threshold. +-- | Safety margin needed on top of the quorum vote weight threshold. -- -- NOTE: this is needed to account for an extremely unlikely local sortition -- where not enough honest non-persistent parties decide to vote in a round. -- This mostly depend on the expected size of the voting committee. -newtype PerasQuorumStakeThresholdSafetyMargin - = PerasQuorumStakeThresholdSafetyMargin {unPerasQuorumStakeThresholdSafetyMargin :: Rational} - deriving Show via Quiet PerasQuorumStakeThresholdSafetyMargin +newtype PerasQuorumWeightThresholdSafetyMargin + = PerasQuorumWeightThresholdSafetyMargin {unPerasQuorumWeightThresholdSafetyMargin :: Rational} + deriving Show via Quiet PerasQuorumWeightThresholdSafetyMargin deriving stock Generic deriving newtype (Eq, Ord, NoThunks, Condense) @@ -126,8 +126,8 @@ data PerasParams = PerasParams , perasCertArrivalThreshold :: !PerasCertArrivalThreshold , perasRoundLength :: !PerasRoundLength , perasWeight :: !PerasWeight - , perasQuorumStakeThreshold :: !PerasQuorumStakeThreshold - , perasQuorumStakeThresholdSafetyMargin :: !PerasQuorumStakeThresholdSafetyMargin + , perasQuorumWeightThreshold :: !PerasQuorumWeightThreshold + , perasQuorumWeightThresholdSafetyMargin :: !PerasQuorumWeightThresholdSafetyMargin } deriving (Show, Eq, Generic, NoThunks) @@ -170,8 +170,8 @@ mkPerasParams = PerasRoundLength 90 , perasWeight = PerasWeight 15 - , perasQuorumStakeThreshold = - PerasQuorumStakeThreshold (3 / 4) - , perasQuorumStakeThresholdSafetyMargin = - PerasQuorumStakeThresholdSafetyMargin (2 / 100) + , perasQuorumWeightThreshold = + PerasQuorumWeightThreshold (3 / 4) + , perasQuorumWeightThresholdSafetyMargin = + PerasQuorumWeightThresholdSafetyMargin (2 / 100) } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs index 7f302e7264..a754f086ce 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -17,15 +16,15 @@ module Ouroboros.Consensus.Peras.Types , onPerasRoundNo , PerasBoostedBlock (..) , PerasSeatIndex (..) - , PerasVoteStake (..) , BoostedBlock , BoostedBlockCompatibleWithPoint (..) - , stakeAboveThreshold + , weightAboveThreshold , PerasVoteTarget (..) , PerasVoteId (..) , PerasVoterId (..) - , PerasVoteStakeDistr (..) - , lookupPerasVoteStake + , VoteWeight (..) -- Re-exported from Committee.Types for convenience + , VoteWeightDistr (..) + , lookupVoteWeight , PerasConversionError (..) , fromPerasSeatIndex , toPerasSeatIndex @@ -48,7 +47,6 @@ import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (..)) -import Data.Semigroup (Sum (..)) import Data.Word (Word16, Word64) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -62,11 +60,12 @@ import Ouroboros.Consensus.Block.RealPoint , toBytes32RealPoint , withOriginRealPointToPoint ) +import Ouroboros.Consensus.Committee.Types (VoteWeight (..)) import Ouroboros.Consensus.Committee.WFA (SeatIndex (..)) import Ouroboros.Consensus.Peras.Params ( PerasParams (..) - , PerasQuorumStakeThreshold (..) - , PerasQuorumStakeThresholdSafetyMargin (..) + , PerasQuorumWeightThreshold (..) + , PerasQuorumWeightThresholdSafetyMargin (..) ) import Ouroboros.Consensus.Util (ShowProxy (..)) import Ouroboros.Consensus.Util.CBOR (decodeWithOrigin, encodeWithOrigin) @@ -181,47 +180,25 @@ instance Serialise (PerasVoteId blk) where pviVoterId <- PerasVoterId <$> fromCBOR pure $ PerasVoteId{pviRoundNo, pviVoterId} --- NOTE: At the moment there is no consensus from researchers/engineers on how --- we go from the absolute stake of a voter in the ledger to the relative stake --- of their vote in the voting commitee (given that the quorum is expressed as --- a relative value of the voting commitee total stake). +-- | Check whether a given vote weight is above the quorum threshold. -- --- So, for now you can consider this 'Rational' as the best approximation we --- have at the moment of the concrete type for a relative vote stake that can be --- compared to the quorum threshold value (also currently a 'Rational'). -newtype PerasVoteStake - = PerasVoteStake - { unPerasVoteStake :: Rational - } - deriving newtype (Eq, Ord, Num, Fractional, NoThunks, NFData, Serialise) - deriving stock Generic - deriving Show via Quiet PerasVoteStake - deriving Semigroup via Sum Rational - deriving Monoid via Sum Rational - --- | Check whether a given vote stake is above the quorum threshold. --- --- TODO: this function assumes that the 'PerasVoteStake' and the quorum +-- NOTE: this function assumes that the 'VoteWeight' and the quorum -- threshold used in 'PerasParams' are expressed in the same units. That is, -- both are either absolute or relative (normalized) values. Under the current -- current implementation of 'PerasParams', this function only makes sense when --- both values are relative (normalized) values, so we should either normalize --- the 'PerasVoteStake' before calling this function, or change this function to --- accept a stake distribution and perform the normalization internally. -stakeAboveThreshold :: PerasParams -> PerasVoteStake -> Bool -stakeAboveThreshold params voteStake = - stake >= quorumThreshold + safetyMargin +-- both values are relative (normalized) values. +weightAboveThreshold :: PerasParams -> VoteWeight -> Bool +weightAboveThreshold params voteWeight = + weight >= quorumThreshold + safetyMargin where - stake = - unPerasVoteStake voteStake + weight = + unVoteWeight voteWeight quorumThreshold = - unPerasQuorumStakeThreshold - (perasQuorumStakeThreshold params) + unPerasQuorumWeightThreshold + (perasQuorumWeightThreshold params) safetyMargin = - unPerasQuorumStakeThresholdSafetyMargin - (perasQuorumStakeThresholdSafetyMargin params) - --- ** Voting stake distributions + unPerasQuorumWeightThresholdSafetyMargin + (perasQuorumWeightThresholdSafetyMargin params) -- | The identifier of a voter in a Peras election newtype PerasVoterId @@ -236,23 +213,25 @@ instance Serialise PerasVoterId where encode = toCBOR . unPerasVoterId decode = PerasVoterId <$> fromCBOR --- | Voting stake distribution for a Peras election -newtype PerasVoteStakeDistr - = PerasVoteStakeDistr - { unPerasVoteStakeDistr :: Map PerasVoterId PerasVoteStake +-- | Voting weight distribution for a Peras election +-- TODO: remove, at call site an argument of this type will be replaced by a 'PerasVotingCommittee blk'. +newtype VoteWeightDistr + = VoteWeightDistr + { unVoteWeightDistr :: Map PerasVoterId VoteWeight } deriving newtype NoThunks deriving stock (Show, Eq, Generic) --- | Lookup the stake of a vote cast by a member of a given stake distribution. -lookupPerasVoteStake :: +-- | Lookup the weight of a vote cast by a member of a given weight distribution. +-- TODO: remove this function since it will be replaced by 'eligiblePartyVoteWeight' from Committee.Class +lookupVoteWeight :: PerasVoterId -> - PerasVoteStakeDistr -> - Maybe PerasVoteStake -lookupPerasVoteStake voterId distr = + VoteWeightDistr -> + Maybe VoteWeight +lookupVoteWeight voterId distr = Map.lookup voterId - (unPerasVoteStakeDistr distr) + (unVoteWeightDistr distr) -- ** Conversion errors diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs index cf1feae313..74ef49ca43 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs @@ -18,19 +18,19 @@ -- | Peras vote aggregation and certificate forging -- -- This module implements the core voting logic for the Peras protocol, which --- aggregates stake-weighted votes on chain blocks and forges certificates when +-- aggregates weighted votes on chain blocks and forges certificates when -- quorum is reached. -- -- = Overview -- -- In Peras, validators vote on specific blocks during designated voting rounds. --- Each vote carries a stake weight, and votes are aggregated by: +-- Each vote carries a weight, and votes are aggregated by: -- -- * __Round__: each vote belongs to a specific 'PerasRoundNo' -- * __Target__: within a round, votes are cast for different block 'Point's -- --- As votes arrive, the system tracks the total stake backing each candidate --- block. When one target accumulates enough stake to exceed the configured +-- As votes arrive, the system tracks the total weight backing each candidate +-- block. When one target accumulates enough weight to exceed the configured -- quorum threshold, a certificate is automatically forged for that block, -- making it a winner for that round. -- @@ -39,7 +39,7 @@ -- For every round being voted for, the aggregation follows a state machine: -- -- 1. __Quorum not reached__: multiple block targets are candidates, each --- accumulating votes and stake. All targets compete to reach quorum first. +-- accumulating votes and weight. All targets compete to reach quorum first. -- -- 2. __Quorum reached__: once a target reaches quorum, it becomes the winner -- and a certificate is forged. All other targets become losers and continue @@ -48,7 +48,7 @@ -- = Quorum Threshold and Multiple Winners -- -- The quorum threshold is parameterized via 'PerasParams'. Depending on this --- configuration and the stake distribution, it may be theoretically possible +-- configuration and the weight distribution, it may be theoretically possible -- for multiple targets to exceed the threshold within the same round. -- -- This module treats multiple winners as an error condition and rejects votes @@ -57,10 +57,10 @@ -- * The quorum threshold is misconfigured, or that -- * We were extremely unlucky when randomly selecting the voting committee. -- --- With a correct threshold configuration (e.g., > 3/4 of total stake + a small +-- With a correct threshold configuration (e.g., > 3/4 of total weight + a small -- safety margin to account for an unlucky local sortition when selecting -- non-persistent voters during committee selection), multiple winners should be --- impossible given honest stake distribution. +-- impossible given honest weight distribution. -- -- = Key Types -- @@ -68,7 +68,7 @@ -- its logically split between separate 'NoQuorum' and 'Quorum' types -- representing the two states (1) and (2) described above, respectively. -- * 'PerasTargetVoteState': tracks votes for one specific block target --- * 'PerasTargetVoteTally': raw vote count and stake accumulation +-- * 'PerasTargetVoteTally': raw vote count and weight accumulation -- * 'PerasTargetVoteStatus': type-level status (Candidate/Winner/Loser) -- * 'UpdateRoundVoteStateError': errors from invalid state transitions -- @@ -88,7 +88,7 @@ module Ouroboros.Consensus.Peras.Vote.Aggregation , updatePerasRoundVoteStates , UpdateRoundVoteStateError (..) , PerasTargetVoteState - , getPerasTargetVoteStateTotalStake + , getPerasTargetVoteStateTotalWeight , getPerasTargetVoteStateBlock ) where @@ -471,8 +471,8 @@ data PerasTargetVoteTally blk = PerasTargetVoteTally -- ^ What we are tallying votes for , ptvtVotes :: !(Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))) -- ^ Votes received for this target, indexed by vote ID - , ptvtTotalStake :: !PerasVoteStake - -- ^ Total stake of the votes received for this target + , ptvtTotalWeight :: !VoteWeight + -- ^ Total weight of the votes received for this target } deriving instance @@ -501,11 +501,11 @@ freshTargetVoteTally target = PerasTargetVoteTally { ptvtTarget = target , ptvtVotes = Map.empty - , ptvtTotalStake = PerasVoteStake 0 + , ptvtTotalWeight = VoteWeight 0 } -- | Add a vote to an existing target tally if it isn't already present, --- and update the stake accordingly. +-- and update the weight accordingly. -- -- PRECONDITION: the vote's target must match the tally's target. updateTargetVoteTally :: @@ -520,12 +520,12 @@ updateTargetVoteTally ptvt@PerasTargetVoteTally { ptvtVotes , ptvtTarget - , ptvtTotalStake + , ptvtTotalWeight } = assert (getPerasVoteTarget vote == ptvtTarget) $ do ptvt { ptvtVotes = pvaVotes' - , ptvtTotalStake = pvaTotalStake' + , ptvtTotalWeight = pvaTotalWeight' } where swapVote = @@ -533,13 +533,13 @@ updateTargetVoteTally (\_k old _new -> old) (getPerasVoteId vote) - (pvaVotes', pvaTotalStake') - -- key WAS NOT present → vote inserted and stake updated + (pvaVotes', pvaTotalWeight') + -- key WAS NOT present → vote inserted and weight updated | (Nothing, votes') <- swapVote vote ptvtVotes = - (votes', ptvtTotalStake + vpvVoteStake (forgetArrivalTime vote)) - -- key WAS already present → votes and stake unchanged + (votes', ptvtTotalWeight + vpvVoteWeight (forgetArrivalTime vote)) + -- key WAS already present → votes and weight unchanged | otherwise = - (ptvtVotes, ptvtTotalStake) + (ptvtVotes, ptvtTotalWeight) {------------------------------------------------------------------------------- Peras target vote status @@ -605,9 +605,9 @@ instance noThunks ctx (PerasTargetVoteWinner tally cert) = noThunks ctx (tally, cert) --- | Extract the total stake from a target vote state -getPerasTargetVoteStateTotalStake :: PerasTargetVoteState blk status -> PerasVoteStake -getPerasTargetVoteStateTotalStake = ptvtTotalStake . ptvsVoteTally +-- | Extract the total weight from a target vote state +getPerasTargetVoteStateTotalWeight :: PerasTargetVoteState blk status -> VoteWeight +getPerasTargetVoteStateTotalWeight = ptvtTotalWeight . ptvsVoteTally -- | Extract the block point from a target vote state getPerasTargetVoteStateBlock :: PerasTargetVoteState blk status -> Point blk @@ -683,7 +683,7 @@ updateLoserVoteState :: updateLoserVoteState params vote oldState = assert (getPerasVoteTarget vote == ptvtTarget (ptvsVoteTally oldState)) $ do let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState) - aboveQuorum = stakeAboveThreshold params (ptvtTotalStake newVoteTally) + aboveQuorum = weightAboveThreshold params (ptvtTotalWeight newVoteTally) in if aboveQuorum then Left $ PerasTargetVoteLoser newVoteTally else Right $ PerasTargetVoteLoser newVoteTally diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs index 894e74b625..93ee27c1c3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs @@ -35,10 +35,10 @@ import Ouroboros.Consensus.Block.SupportsPeras , BoostedBlock , IsPerasVote (..) , PerasRoundNo - , PerasVoteStake - , PerasVoteStakeDistr , PerasVoterId (..) , ValidatedPerasVote (..) + , VoteWeight + , VoteWeightDistr ) import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..)) import Ouroboros.Consensus.Peras.Params (PerasParams) @@ -53,9 +53,9 @@ data MockPerasVote blk { mockVoteRound :: PerasRoundNo , mockVoteBlock :: Point blk , mockVoteVoterId :: PerasVoterId - , mockVoteStake :: PerasVoteStake + , mockVoteWeight :: VoteWeight -- ^ This field is unique to the mocked vote, and allows us to bypass the - -- need for a 'PerasVoteStakeDistr' when creating validated votes in tests. + -- need for a 'VoteWeightDistr' when creating validated votes in tests. } deriving instance StandardHash blk => Show (MockPerasVote blk) @@ -98,9 +98,9 @@ instance { mockVoteRound , mockVoteBlock , mockVoteVoterId - , mockVoteStake = 0 - -- NOTE: stakes are never sent over the wire, but computed locally from - -- the stake distribution. We might need to change this in the future if + , mockVoteWeight = 0 + -- NOTE: weights are never sent over the wire, but computed locally from + -- the voting committee. We might need to change this in the future if -- we ever need roundtrip tests using mocked votes, but for now this is -- sufficient for our needs. } @@ -131,9 +131,9 @@ instance { mockVoteRound , mockVoteBlock , mockVoteVoterId - , mockVoteStake = 0 - -- NOTE: stakes are never sent over the wire, but computed locally from - -- the stake distribution. We might need to change this in the future if + , mockVoteWeight = 0 + -- NOTE: weights are never sent over the wire, but computed locally from + -- the voting committee. We might need to change this in the future if -- we ever need roundtrip tests using mocked votes, but for now this is -- sufficient for our needs. } @@ -145,12 +145,12 @@ validateMockPerasVote :: forall blk. PerasVote blk ~ MockPerasVote blk => PerasParams -> - PerasVoteStakeDistr -> + VoteWeightDistr -> PerasVote blk -> Either (PerasError blk) (ValidatedPerasVote blk) -validateMockPerasVote _params _stakeDistr vote = +validateMockPerasVote _params _voteWeightDistr vote = Right ValidatedPerasVote { vpvVote = vote - , vpvVoteStake = mockVoteStake vote + , vpvVoteWeight = mockVoteWeight vote } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs index e22424bc51..c7f68f0661 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs @@ -108,11 +108,11 @@ deriving instance -------------------------------------------------------------------------------} newtype ExistingPerasRoundWinner blk - = ExistingPerasRoundWinner (Point blk, PerasVoteStake) + = ExistingPerasRoundWinner (Point blk, VoteWeight) deriving stock (Show, Eq) newtype BlockedPerasRoundWinner blk - = BlockedPerasRoundWinner (Point blk, PerasVoteStake) + = BlockedPerasRoundWinner (Point blk, VoteWeight) deriving stock (Show, Eq) data PerasVoteDbError blk where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index 8ef8170af1..734f4ef04f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -265,12 +265,12 @@ implAddVote params PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do (getPerasVoteRound vote) ( ExistingPerasRoundWinner ( getPerasTargetVoteStateBlock winnerState - , getPerasTargetVoteStateTotalStake winnerState + , getPerasTargetVoteStateTotalWeight winnerState ) ) ( BlockedPerasRoundWinner ( getPerasTargetVoteStateBlock loserState - , getPerasTargetVoteStateTotalStake loserState + , getPerasTargetVoteStateTotalWeight loserState ) ) -- Reached quorum but failed to forge a certificate diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index 34a7aee03d..640821c1f8 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -126,7 +126,7 @@ deriving anyclass instance ToExpr PerasRoundNo deriving anyclass instance ToExpr PerasWeight -deriving anyclass instance ToExpr PerasVoteStake +deriving anyclass instance ToExpr VoteWeight deriving anyclass instance ToExpr (PerasVoteId blk) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs index 058fa9fca9..2090f6ca25 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs @@ -8,7 +8,7 @@ module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke ( tests , genPerasVoterId - , genPerasVoteStake + , genVoteWeight , genPerasVote , genValidatedPerasVote ) where @@ -74,23 +74,23 @@ genPerasVoterId = do keyHash = SL.hashKey (SL.VKey verKey) pure (PerasVoterId keyHash) -genPerasVoteStake :: Gen PerasVoteStake -genPerasVoteStake = do - stake <- (1 %) <$> choose (2, 10) - pure (PerasVoteStake stake) +genVoteWeight :: Gen VoteWeight +genVoteWeight = do + weight <- (1 %) <$> choose (2, 10) + pure (VoteWeight weight) genPerasVote :: Gen (PerasVote TestBlock) genPerasVote = do mockVoteRound <- PerasRoundNo <$> arbitrary mockVoteBlock <- genPointTestBlock mockVoteVoterId <- genPerasVoterId - mockVoteStake <- genPerasVoteStake + mockVoteWeight <- genVoteWeight pure $ MockPerasVote { mockVoteRound , mockVoteBlock , mockVoteVoterId - , mockVoteStake + , mockVoteWeight } instance WithId (MockPerasVote blk) (PerasVoteId blk) where @@ -108,7 +108,7 @@ genValidatedPerasVote = do pure ValidatedPerasVote { vpvVote = mockVote - , vpvVoteStake = mockVoteStake mockVote + , vpvVoteWeight = mockVoteWeight mockVote } newVoteDB :: @@ -150,7 +150,7 @@ prop_smoke = inboundPoolWriter = makePerasVotePoolWriterFromVoteDB mockSystemTime - (pure (PerasVoteStakeDistr mempty)) -- mocked votes are self-validating + (pure (VoteWeightDistr mempty)) -- mocked votes are self-validating inboundPool getAllInboundPoolContent = do votesMap <- 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 fde5f0863b..f5261b3477 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 @@ -1321,7 +1321,7 @@ generator loe genBlock genPerasBlock m@Model{..} = Nothing -> PerasRoundNo 0 Just (PerasRoundNo r) -> PerasRoundNo (r + 1) voterId <- PerasVoteDB.SM.genVoterId - stake <- PerasVoteDB.SM.genVoteStake + weight <- PerasVoteDB.SM.genVoteWeight -- Include the voted block itself in the persisted seenBlocks let seenBlks = fmap (blk :) gapBlks -- Build the vote @@ -1334,9 +1334,9 @@ generator loe genBlock genPerasBlock m@Model{..} = { mockVoteRound = roundNo , mockVoteBlock = blockPoint blk , mockVoteVoterId = voterId - , mockVoteStake = stake + , mockVoteWeight = weight } - , vpvVoteStake = stake + , vpvVoteWeight = weight } pure $ AddPerasVote voteWithTime seenBlks diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs index 4dc49d4176..05b24e2ef8 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs @@ -33,13 +33,13 @@ import Ouroboros.Consensus.Block.SupportsPeras , PerasParams , PerasRoundNo , PerasVoteId (..) - , PerasVoteStake (..) , PerasVoteTarget (..) , PerasVoterId , ValidatedPerasCert (..) , ValidatedPerasVote (..) + , VoteWeight (..) , perasWeight - , stakeAboveThreshold + , weightAboveThreshold ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) @@ -192,7 +192,7 @@ addVote vote model | reachedQuorum , Nothing <- certAtRound = -- Also ensure that we didn't already have a quorum before adding this - -- vote in a more direct way: the stake represented by the existing votes + -- vote in a more direct way: the weight represented by the existing votes -- must be below the threshold. assert (not hadQuorum) $ ( Right $ @@ -245,29 +245,29 @@ addVote vote model -- The extended set of votes including the new one extendedVotes = Set.insert voteEntry existingVotes - -- Get the total stake of a set of votes - getTotalStake = - PerasVoteStake + -- Get the total weight of a set of votes + getTotalWeight = + VoteWeight . sum . fmap - ( unPerasVoteStake - . vpvVoteStake + ( unVoteWeight + . vpvVoteWeight . forgetArrivalTime . veVote ) . Set.toList - -- Total stake represented by the existing votes - existingVotesStake = - getTotalStake existingVotes - -- Total stake represented by the extended set of votes - extendedVotesStake = - getTotalStake extendedVotes + -- Total weight represented by the existing votes + existingVotesWeight = + getTotalWeight existingVotes + -- Total weight represented by the extended set of votes + extendedVotesWeight = + getTotalWeight extendedVotes -- Did we already have a quorum before adding this new vote? hadQuorum = - stakeAboveThreshold (params model) existingVotesStake + weightAboveThreshold (params model) existingVotesWeight -- Did we reach the quorum threshold with this new vote? reachedQuorum = - stakeAboveThreshold (params model) extendedVotesStake + weightAboveThreshold (params model) extendedVotesWeight -- The existing certificate (if any) for this round certAtRound = Map.lookup roundNo (certs model) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index 1d497b3d2f..54b94c0489 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -12,7 +12,7 @@ module Test.Ouroboros.Storage.PerasVoteDB.StateMachine -- * Reusable generators , genVoterId - , genVoteStake + , genVoteWeight ) where import qualified Cardano.Crypto.DSIGN.Class as SL @@ -45,11 +45,11 @@ import Ouroboros.Consensus.Block.SupportsPeras , PerasParams , PerasRoundNo (..) , PerasVoteId - , PerasVoteStake (..) , PerasVoteTarget (..) , PerasVoterId (..) , ValidatedPerasCert , ValidatedPerasVote (..) + , VoteWeight (..) , mkPerasParams ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types @@ -182,7 +182,7 @@ instance StateModel Model where roundNo <- genRoundNo point <- genPoint voterId <- genVoterId - stake <- genVoteStake + weight <- genVoteWeight now <- genRelativeTime let voteWithTime = WithArrivalTime now $ @@ -192,9 +192,9 @@ instance StateModel Model where { mockVoteRound = roundNo , mockVoteBlock = point , mockVoteVoterId = voterId - , mockVoteStake = stake + , mockVoteWeight = weight } - , vpvVoteStake = stake + , vpvVoteWeight = weight } return (AddVote voteWithTime) @@ -368,15 +368,15 @@ genVoterId = do let keyHash = SL.hashKey (SL.VKey verKey) pure (PerasVoterId keyHash) --- | Generate a random 'PerasVoteStake'. +-- | Generate a random 'VoteWeight'. -- -- Make it so that we always require multiple votes to reach a quorum. -- This is assuming a quorum threshold strictly larger than 50%, which is -- a very conservative assumption for Peras. -genVoteStake :: Gen PerasVoteStake -genVoteStake = do - stake <- (1 %) <$> choose (2, 10) -- stake between 1/2 and 1/10 - pure (PerasVoteStake stake) +genVoteWeight :: Gen VoteWeight +genVoteWeight = do + weight <- (1 %) <$> choose (2, 10) -- weight between 1/2 and 1/10 + pure (VoteWeight weight) -- * Helpers From 3907a4155ac5d02110b52fb640b60f4ba286c129 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 25 May 2026 12:45:45 +0200 Subject: [PATCH 35/62] Add perasTargetCommitteeSize to PerasParams --- .../Ouroboros/Consensus/Protocol/Praos/Peras.hs | 6 +++--- .../Ouroboros/Consensus/Peras/Params.hs | 7 +++++++ 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs index 895c7d3e00..010ca0cc55 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -38,7 +38,6 @@ import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS import Ouroboros.Consensus.Committee.Types ( LedgerStake (..) , PoolId (..) - , TargetCommitteeSize (..) ) import Ouroboros.Consensus.Committee.WFA ( mkExtWFAStakeDistr @@ -51,6 +50,7 @@ import Ouroboros.Consensus.Committee.WFALS import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 +import Ouroboros.Consensus.Peras.Params (PerasParams (..)) import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 import Ouroboros.Consensus.Protocol.Praos ( PraosState (..) @@ -83,7 +83,7 @@ instance BlockSupportsPeras RealBlock where validatePerasCert = undefined instance PraosStateSupportsPerasVoting RealBlock where - praosStatePerasVotingCommitteeInput _ _perasParams tickedPraosState = do + praosStatePerasVotingCommitteeInput _ perasParams tickedPraosState = do let epochNonce = praosStateEpochNonce . tickedPraosStateChainDepState @@ -98,7 +98,7 @@ instance PraosStateSupportsPerasVoting RealBlock where mkExtWFAStakeDistr wFATiebreaker stakeDistrWithPublicKeys - let targetCommitteeSize = TargetCommitteeSize 100 -- TODO: use perams params to get this value instead + let targetCommitteeSize = perasTargetCommitteeSize perasParams pure $ WFALSVotingCommitteeInput epochNonce diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs index 050923dc99..3d1d3af6d7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs @@ -20,12 +20,16 @@ module Ouroboros.Consensus.Peras.Params -- * Protocol parameters bundle , PerasParams (..) , mkPerasParams + + -- * Convenience re-exports + , Committee.TargetCommitteeSize (..) ) where import Data.Semigroup (Sum (..)) import Data.Word (Word64) import GHC.Generics (Generic) +import qualified Ouroboros.Consensus.Committee.Types as Committee import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.IOLike (NoThunks) import Quiet (Quiet (..)) @@ -128,6 +132,7 @@ data PerasParams = PerasParams , perasWeight :: !PerasWeight , perasQuorumWeightThreshold :: !PerasQuorumWeightThreshold , perasQuorumWeightThresholdSafetyMargin :: !PerasQuorumWeightThresholdSafetyMargin + , perasTargetCommitteeSize :: !Committee.TargetCommitteeSize } deriving (Show, Eq, Generic, NoThunks) @@ -174,4 +179,6 @@ mkPerasParams = PerasQuorumWeightThreshold (3 / 4) , perasQuorumWeightThresholdSafetyMargin = PerasQuorumWeightThresholdSafetyMargin (2 / 100) + , perasTargetCommitteeSize = + Committee.TargetCommitteeSize 800 } From f276e313f28ae2376c51a77ad2022fdc736d3b37 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 25 May 2026 14:52:46 +0200 Subject: [PATCH 36/62] Introduce IsPerasError and tweak instance to work with it --- .../Ouroboros/Consensus/Shelley/Node/Peras.hs | 4 +- .../Consensus/Protocol/Praos/Peras.hs | 19 +-- .../Consensus/Block/SupportsPeras.hs | 110 ++++++++++++------ .../Consensus/HardFork/Combinator/Basics.hs | 7 +- .../Ouroboros/Consensus/Peras/Error/V1.hs | 19 +-- .../Ouroboros/Consensus/Util/Orphans.hs | 1 + .../Test/Ouroboros/Storage/TestBlock.hs | 2 +- .../Test/Util/TestBlock.hs | 2 +- 8 files changed, 105 insertions(+), 59 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs index 73674823d1..b8a30119a7 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -16,7 +16,7 @@ module Ouroboros.Consensus.Shelley.Node.Peras () where import Cardano.Ledger.Api import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) - , VoidPerasError + , EmptyPerasError ) import Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) @@ -55,7 +55,7 @@ instance where type PerasVote (ShelleyBlock proto DijkstraEra) = MockPerasVote (ShelleyBlock proto DijkstraEra) type PerasCert (ShelleyBlock proto DijkstraEra) = MockPerasCert (ShelleyBlock proto DijkstraEra) - type PerasError (ShelleyBlock proto DijkstraEra) = VoidPerasError (ShelleyBlock proto DijkstraEra) + type PerasError (ShelleyBlock proto DijkstraEra) = EmptyPerasError (ShelleyBlock proto DijkstraEra) validatePerasVote = validateMockPerasVote validatePerasCert = validateMockPerasCert diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs index 010ca0cc55..a1b67f651b 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -25,13 +25,14 @@ import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block.Abstract (HeaderHash, StandardHash) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) - , PerasCommitteeScheme + , IsPerasError (..) , PerasCrypto , PerasParams , PerasVotingCommittee - , injectCommitteeError + , PerasVotingCommitteeInput + , PerasVotingCommitteeScheme ) -import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) +import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee) import qualified Ouroboros.Consensus.Committee.Class as Committee import Ouroboros.Consensus.Committee.Crypto (PublicKey) import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS @@ -66,7 +67,7 @@ import System.IO.Unsafe (unsafePerformIO) data RealBlock type instance PerasCrypto RealBlock = BLS.PerasBLSCrypto -type instance PerasCommitteeScheme RealBlock = WFALS +type instance PerasVotingCommitteeScheme RealBlock = WFALS type instance HeaderHash RealBlock = ShortByteString instance StandardHash RealBlock @@ -91,10 +92,10 @@ instance PraosStateSupportsPerasVoting RealBlock where let wFATiebreaker = wFATiebreakerWithEpochNonce epochNonce stakeDistrWithPublicKeys <- - first V1.PerasTemporaryPublicKeyHackError $ + bimap V1.PerasTemporaryPublicKeyHackError id $ getStakeDistrWithBLSPublicKeys tickedPraosState extWFAStakeDistr <- - first V1.PerasVotingWFAError $ + bimap V1.PerasVotingWFAError id $ mkExtWFAStakeDistr wFATiebreaker stakeDistrWithPublicKeys @@ -174,7 +175,7 @@ perasBLSPublicKeysFromEnv = class ( BlockSupportsPeras blk - , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasCommitteeScheme blk) -- TODO remove this constraint when it becomes a superclass constraint of 'BlockSupportsPeras' + , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) -- TODO remove this constraint when it becomes a superclass constraint of 'BlockSupportsPeras' ) => PraosStateSupportsPerasVoting blk where @@ -186,7 +187,7 @@ class Ticked PraosState -> Either (PerasError blk) - (VotingCommitteeInput (PerasCrypto blk) (PerasCommitteeScheme blk)) + (PerasVotingCommitteeInput blk) -- | How to build a new 'PerasVotingCommittee' from a 'Ticked PraosState'. The implementation provided here relies on 'praosStatePerasVotingCommitteeInput'. praosStateGetPerasVotingCommittee :: @@ -199,5 +200,5 @@ class praosStateGetPerasVotingCommittee p perasParams tickedPraosState = do committeeInput <- praosStatePerasVotingCommitteeInput p perasParams tickedPraosState - first injectCommitteeError $ + bimap injectVotingCommitteeError id $ Committee.mkVotingCommittee committeeInput diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 6434761493..f337fc4f10 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -16,12 +16,17 @@ module Ouroboros.Consensus.Block.SupportsPeras ( PerasCrypto - , PerasCommitteeScheme + , PerasVotingCommitteeScheme , PerasVotingCommittee + , PerasVotingCommitteeError + , PerasVotingCommitteeInput , BlockSupportsPeras (..) + , PerasVoteCompatibleWithVotingCommittee (..) + , PerasCertCompatibleWithVotingCommittee (..) + , implPerasForgeVoteIfEligible , VoidPerasVote (..) , VoidPerasCert (..) - , VoidPerasError (..) + , EmptyPerasError (..) , ValidatedPerasCert (..) , ValidatedPerasVote (..) , ValidatedPerasVotesWithQuorum @@ -29,16 +34,12 @@ module Ouroboros.Consensus.Block.SupportsPeras , vpvqVotes , vpvqPerasParams ) - , injectCommitteeError , votesReachQuorum , IsPerasVote (..) , getPerasVoteId , getPerasVoteTarget , IsPerasCert (..) - , PerasVoteCompatibleWithVotingCommittee (..) - , PerasCertCompatibleWithVotingCommittee (..) - , injectConversionError - , implPerasForgeVoteIfEligible + , IsPerasError (..) -- * Convenience re-exports , module Ouroboros.Consensus.Peras.Params @@ -79,25 +80,31 @@ type family PerasCrypto blk :: Type -- Used to dispatch a block type to a its corresponding voting committee scheme. -- -- TODO: maybe move this inside 'BlockSupportsPeras'. -type family PerasCommitteeScheme blk :: Type - --- This witness the fact that 'PerasError blk' should have a way to represent a 'VotingCommitteeError' for the corresponding 'PerasCommitteeScheme blk' and 'PerasCrypto blk'. --- --- TODO: maybe move this inside 'BlockSupportsPeras' -injectCommitteeError :: - VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk) -> PerasError blk -injectCommitteeError = undefined +type family PerasVotingCommitteeScheme blk :: Type --- TODO: Add CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasCommitteeScheme blk) as a superclass constraint of 'BlockSupportsPeras' -- | Voting committee for Peras indexed by block type type PerasVotingCommittee blk = VotingCommittee (PerasCrypto blk) - (PerasCommitteeScheme blk) + (PerasVotingCommitteeScheme blk) + +-- | Error type for Peras voting committee errors +type PerasVotingCommitteeError blk = + VotingCommitteeError + (PerasCrypto blk) + (PerasVotingCommitteeScheme blk) + +-- | Input needed to build a Peras voting committee +type PerasVotingCommitteeInput blk = + VotingCommitteeInput + (PerasCrypto blk) + (PerasVotingCommitteeScheme blk) -- * BlockSupportsPeras class +-- TODO: Add CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) as a superclass constraint of 'BlockSupportsPeras' + class ( StandardHash blk , Typeable blk @@ -115,6 +122,7 @@ class , NoThunks (PerasError blk) , IsPerasVote (PerasVote blk) blk , IsPerasCert (PerasCert blk) blk + , IsPerasError (PerasError blk) blk ) => BlockSupportsPeras blk where @@ -125,7 +133,7 @@ class type PerasCert blk = VoidPerasCert blk type PerasError blk = (err :: Type) | err -> blk - type PerasError blk = VoidPerasError blk + type PerasError blk = EmptyPerasError blk validatePerasVote :: PerasParams -> @@ -175,12 +183,6 @@ class getPerasCertInBlock _ = Nothing --- This witness the fact that 'PerasError blk' should have a way to represent a 'PerasConversionError'. --- --- TODO: maybe move this inside 'BlockSupportsPeras' -injectConversionError :: PerasConversionError -> PerasError blk -injectConversionError = undefined - -- * Conversion between concrete Peras types and abstract committee types -- | Conversion between (concrete) Peras votes and (abstract) committee votes. @@ -218,8 +220,12 @@ implPerasForgeVoteIfEligible :: forall blk. ( ElectionId (PerasCrypto blk) ~ PerasRoundNo -- TODO Remove later , VoteCandidate (PerasCrypto blk) ~ Point blk -- TODO Remove later - , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasCommitteeScheme blk) -- TODO maybe remove this once part of 'BlockSupportsPeras' constraints - , PerasVoteCompatibleWithVotingCommittee (PerasVote blk) (PerasCrypto blk) (PerasCommitteeScheme blk) + , IsPerasError (PerasError blk) blk + , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) -- TODO maybe remove this once part of 'BlockSupportsPeras' constraints + , PerasVoteCompatibleWithVotingCommittee + (PerasVote blk) + (PerasCrypto blk) + (PerasVotingCommitteeScheme blk) ) => PerasVotingCommittee blk -> PoolId -> @@ -235,7 +241,7 @@ implPerasForgeVoteIfEligible boostedBlock = do mWitness <- - bimap injectCommitteeError id $ + bimap injectVotingCommitteeError id $ Committee.checkShouldVote committee ourId @@ -253,7 +259,9 @@ implPerasForgeVoteIfEligible ourPrivateKey roundNo (boostedBlockToPoint boostedBlock) - concreteVote <- bimap injectConversionError id $ toPerasVote @(PerasVote blk) abstractVote + concreteVote <- + bimap injectConversionError id $ + toPerasVote @(PerasVote blk) abstractVote pure $ ValidatedPerasVote { vpvVote = concreteVote @@ -292,15 +300,23 @@ instance IsPerasCert (VoidPerasCert blk) blk where getPerasCertRound = absurd . unVoidPerasCert getPerasCertBlock = absurd . unVoidPerasCert --- | Imposible Peras error for @blk@. +-- | Empty Peras error for @blk@. -- -- NOTE: the phantom @blk@ is used to keep the 'PerasError' type family injective. -newtype VoidPerasError blk - = VoidPerasError - { unVoidPerasError :: Void +-- +-- NOTE: in contrast to 'VoidPerasVote' and 'VoidPerasCert', this type cannot be +-- uninhabited, or we would otherwise have to construct a `Void` when injecting +-- errors into this type, which would be impossible. +newtype EmptyPerasError blk + = EmptyPerasError + { unEmptyPerasError :: () } deriving newtype (Show, Eq, NoThunks, ShowProxy) +instance IsPerasError (EmptyPerasError blk) blk where + injectVotingCommitteeError _ = EmptyPerasError () + injectConversionError _ = EmptyPerasError () + -- * Validated types data ValidatedPerasVote blk @@ -397,10 +413,14 @@ votesReachQuorum params votes = allVotesMatchTarget target = all ((== (getPerasVoteTarget target)) . getPerasVoteTarget) --- * Convenience projection classes +-- * Convenience projection/injection classes -- | Types that support being treated as Peras votes -class BoostedBlockCompatibleWithPoint (BoostedBlock vote) blk => IsPerasVote vote blk | vote -> blk where +class + BoostedBlockCompatibleWithPoint (BoostedBlock vote) blk => + IsPerasVote vote blk + | vote -> blk + where getPerasVoteRound :: vote -> PerasRoundNo getPerasVoteBlock :: vote -> BoostedBlock vote getPerasVoteVoterId :: vote -> PerasVoterId @@ -425,6 +445,7 @@ getPerasVoteTarget vote = } type instance BoostedBlock (ValidatedPerasVote blk) = BoostedBlock (PerasVote blk) + instance ( IsPerasVote (PerasVote blk) blk , BoostedBlockCompatibleWithPoint (BoostedBlock (PerasVote blk)) blk @@ -444,7 +465,11 @@ instance getPerasVoteVoterId = getPerasVoteVoterId . forgetArrivalTime -- | Types that support being treated as Peras certificates -class BoostedBlockCompatibleWithPoint (BoostedBlock cert) blk => IsPerasCert cert blk | cert -> blk where +class + BoostedBlockCompatibleWithPoint (BoostedBlock cert) blk => + IsPerasCert cert blk + | cert -> blk + where getPerasCertRound :: cert -> PerasRoundNo getPerasCertBlock :: cert -> BoostedBlock cert @@ -462,8 +487,19 @@ instance getPerasCertRound = getPerasCertRound . vpcCert getPerasCertBlock = getPerasCertBlock . vpcCert -instance IsPerasCert cert blk => IsPerasCert (WithArrivalTime cert) blk where +type instance BoostedBlock (WithArrivalTime voteOrCert) = BoostedBlock voteOrCert + +instance + IsPerasCert cert blk => + IsPerasCert (WithArrivalTime cert) blk + where getPerasCertRound = getPerasCertRound . forgetArrivalTime getPerasCertBlock = getPerasCertBlock . forgetArrivalTime -type instance BoostedBlock (WithArrivalTime voteOrCert) = BoostedBlock voteOrCert +-- | Error types that support injecting certain types of Peras errors +class + IsPerasError err blk + | err -> blk + where + injectVotingCommitteeError :: PerasVotingCommitteeError blk -> err + injectConversionError :: PerasConversionError -> err diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index 9024aba930..fcca5ac9fe 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -47,7 +47,10 @@ import Data.Typeable import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract -import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras (..), VoidPerasError) +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , EmptyPerasError + ) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.AcrossEras @@ -290,7 +293,7 @@ instance where type PerasVote (HardForkBlock xs) = MockPerasVote (HardForkBlock xs) type PerasCert (HardForkBlock xs) = MockPerasCert (HardForkBlock xs) - type PerasError (HardForkBlock xs) = VoidPerasError (HardForkBlock xs) + type PerasError (HardForkBlock xs) = EmptyPerasError (HardForkBlock xs) validatePerasVote = validateMockPerasVote validatePerasCert = validateMockPerasCert diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs index 5a1b81a831..375ab4ac93 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} @@ -14,10 +16,9 @@ module Ouroboros.Consensus.Peras.Error.V1 import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.SupportsPeras - ( PerasCommitteeScheme - , PerasCrypto + ( IsPerasError (..) + , PerasVotingCommitteeError ) -import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) import Ouroboros.Consensus.Committee.WFA (WFAError) import Ouroboros.Consensus.Peras.Types (PerasConversionError) @@ -26,20 +27,24 @@ data PerasError blk = PerasVotingWFAError WFAError | PerasVotingCommitteeError - (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) + (PerasVotingCommitteeError blk) | PerasVotingConversionError PerasConversionError | PerasTemporaryPublicKeyHackError String deriving instance - Show (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => + Show (PerasVotingCommitteeError blk) => Show (PerasError blk) deriving instance - Eq (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => + Eq (PerasVotingCommitteeError blk) => Eq (PerasError blk) deriving instance - NoThunks (VotingCommitteeError (PerasCrypto blk) (PerasCommitteeScheme blk)) => + NoThunks (PerasVotingCommitteeError blk) => NoThunks (PerasError blk) deriving instance Generic (PerasError blk) + +instance IsPerasError (PerasError blk) blk where + injectVotingCommitteeError = PerasVotingCommitteeError + injectConversionError = PerasVotingConversionError diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index ec3e8a6259..8b7e867427 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -114,3 +114,4 @@ deriving via -------------------------------------------------------------------------------} instance ShowProxy Void +instance ShowProxy () diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index 39c97c33a4..ea2389ea0a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -739,7 +739,7 @@ instance LedgerSupportsPeras TestBlock where instance BlockSupportsPeras TestBlock where type PerasVote TestBlock = MockPerasVote TestBlock type PerasCert TestBlock = MockPerasCert TestBlock - type PerasError TestBlock = VoidPerasError TestBlock + type PerasError TestBlock = EmptyPerasError TestBlock validatePerasVote = validateMockPerasVote validatePerasCert = validateMockPerasCert diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index 63e0f721e7..aea2f2b93c 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -715,7 +715,7 @@ instance where type PerasVote (TestBlockWith ptype) = MockPerasVote (TestBlockWith ptype) type PerasCert (TestBlockWith ptype) = MockPerasCert (TestBlockWith ptype) - type PerasError (TestBlockWith ptype) = VoidPerasError (TestBlockWith ptype) + type PerasError (TestBlockWith ptype) = EmptyPerasError (TestBlockWith ptype) validatePerasVote = validateMockPerasVote validatePerasCert = validateMockPerasCert From e7476699fc092d41640e67a0848ddbef5bd0d4e3 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 25 May 2026 16:22:37 +0200 Subject: [PATCH 37/62] Normalise stake when computing eligiblePartyVoteWeight --- .../Ouroboros/Consensus/Committee/Class.hs | 14 ++++++- .../Consensus/Committee/EveryoneVotes.hs | 23 +++++++++--- .../Ouroboros/Consensus/Committee/Types.hs | 20 ++++++---- .../Ouroboros/Consensus/Committee/WFA.hs | 16 +++++++- .../Ouroboros/Consensus/Committee/WFALS.hs | 37 ++++++++++--------- 5 files changed, 79 insertions(+), 31 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs index f22de0da09..109355b288 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs @@ -100,7 +100,19 @@ class (VotingCommitteeError crypto committee) (EligibilityWitness crypto committee) - -- | Compute the voting weight of a eligibile party + -- | Compute the (relative) voting power of an eligibile party + -- + -- WARNING: there is a key difference between the "Ledger stake" and the "Vote + -- weight" of a given voter. On one hand, the ledger stake is the stake as + -- reflected directly by the ledger stake distribution under consideration. On + -- the other hand, the "Vote weight" refers to the relative (i.e. normalised) + -- voting power of that voter w.r.t. the rest of the committee. + -- + -- It is up to the implementation of the voting committee to decide how to + -- compute this value, but it should be implemented so that detecting a + -- quorum can be done by comparing the total vote weight of the votes received + -- against a fixed threshold, e.g., "a quorum is reached if the total weight + -- of the votes received exceeds 75% / 0.75 (of the total voting stake)". eligiblePartyVoteWeight :: VotingCommittee crypto committee -> EligibilityWitness crypto committee -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index b48209b82b..1ae86da83e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -54,7 +54,8 @@ import Ouroboros.Consensus.Committee.Crypto , VoteCandidate ) import Ouroboros.Consensus.Committee.Types - ( LedgerStake (..) + ( Cumulative (..) + , LedgerStake (..) , PoolId , VoteWeight (..) ) @@ -62,6 +63,7 @@ import Ouroboros.Consensus.Committee.WFA ( ExtWFAStakeDistr (..) , NumPoolsWithPositiveStake (..) , SeatIndex + , TotalStake (..) , WFAError , getCandidateIfSeatWithinBounds , unsafeGetCandidateInSeat @@ -82,6 +84,8 @@ instance candidateSeats :: !(Map PoolId SeatIndex) , -- Number of active voters (i.e., those with non-zero stake) numActiveVoters :: !NumPoolsWithPositiveStake + , -- Total stake of all voters (i.e., the sum of the stakes) + totalActiveStake :: !TotalStake } data VotingCommitteeInput crypto EveryoneVotes @@ -156,6 +160,7 @@ mkEveryoneVotesVotingCommittee { extWFAStakeDistr = stakeDistr , candidateSeats = seats , numActiveVoters = numPoolsWithPositiveStake stakeDistr + , totalActiveStake = totalStake stakeDistr } -- | Check whether we should vote in a given election @@ -239,15 +244,23 @@ implVerifyVote committee = \case -- | Compute the voting power of an eligible committee member. -- -- In this simple voting committee, the vote weight of a member is equal to --- their ledger stake, as long as it is positive. +-- their (normalised) ledger stake, as long as it is positive. implEligiblePartyVoteWeight :: VotingCommittee crypto EveryoneVotes -> EligibilityWitness crypto EveryoneVotes -> VoteWeight -implEligiblePartyVoteWeight _committee member = - VoteWeight (unLedgerStake (unNonZero voterStake)) +implEligiblePartyVoteWeight committee = \case + EveryoneVotesMember _ nonZeroStake -> + mkVoteWeight + . unLedgerStake + . unNonZero + $ nonZeroStake where - EveryoneVotesMember _ voterStake = member + TotalStake (Cumulative (LedgerStake activeStake)) = + totalActiveStake committee + + mkVoteWeight absoluteStake = + VoteWeight (absoluteStake / activeStake) -- | Forge a certificate attesting the winner of a given election implForgeCert :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs index 55db795ac9..38c859d9ec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -24,21 +25,24 @@ import NoThunks.Class (NoThunks) newtype PoolId = PoolId { unPoolId :: KeyHash StakePool } - deriving (Show, Eq, Ord, NoThunks, Generic) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks -- | Stake of a voter as reflected by the ledger state newtype LedgerStake = LedgerStake { unLedgerStake :: Rational } - deriving (Show, Eq, Ord) + deriving stock (Show, Eq, Ord, Generic) deriving newtype (Num, HasZero) + deriving anyclass NoThunks --- | Voting power of a voter in the committee selection scheme +-- | Relative voting power of a voter in the committee selection scheme newtype VoteWeight = VoteWeight { unVoteWeight :: Rational } - deriving newtype (Show, Eq, Ord, Num, Fractional, NoThunks, NFData, Serialise) - deriving stock Generic + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Num, Fractional, NFData, Serialise) + deriving anyclass NoThunks deriving Semigroup via Sum Rational deriving Monoid via Sum Rational @@ -46,10 +50,12 @@ newtype VoteWeight = VoteWeight newtype TargetCommitteeSize = TargetCommitteeSize { unTargetCommitteeSize :: Word64 } - deriving (Show, Eq, NoThunks, Generic) + deriving (Show, Eq, Generic) + deriving anyclass NoThunks -- | Wrapper to tag accumulated resources newtype Cumulative a = Cumulative { unCumulative :: a } - deriving (Show, Eq, NoThunks, Generic) + deriving (Show, Eq, Generic) + deriving anyclass NoThunks diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs index c97dbc37cb..018c1a4518 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs @@ -16,6 +16,7 @@ module Ouroboros.Consensus.Committee.WFA -- * Cumulative stake distributions , SeatIndex (..) , NumPoolsWithPositiveStake (..) + , TotalStake (..) , WFAError (..) , WFATiebreaker (..) , wFATiebreakerWithEpochNonce @@ -248,6 +249,14 @@ newtype NumPoolsWithPositiveStake deriving stock (Show, Eq, Generic) deriving anyclass NoThunks +-- | Total stake in the underlying stake distribution +newtype TotalStake + = TotalStake + { unTotalStake :: Cumulative LedgerStake + } + deriving (Show, Eq, Generic) + deriving anyclass NoThunks + -- | Tiebreaker for voters with the same stake in the cumulative stake. -- -- This is needed to ensure that the cumulative stake distribution is fair with @@ -364,6 +373,10 @@ data ExtWFAStakeDistr a -- weighted Fait-Accompli instantiations with a target committee size larger -- than the number of pools with positive stake, which would lead to incorrect -- results (e.g. granting persistent seats to voters with zero stake). + , totalStake :: TotalStake + -- ^ Total stake in the underlying stake distribution. This is also + -- precomputed at the beginning of each epoch to allow for quick + -- transformations between absolute and relative stakes. } deriving Show @@ -383,6 +396,7 @@ mkExtWFAStakeDistr tiebreaker pools ExtWFAStakeDistr { unExtWFAStakeDistr = stakeDistrArray , numPoolsWithPositiveStake = numPoolsWithPositiveStakeAcc + , totalStake = TotalStake totalStakeAcc } where stakeDistrArray = @@ -396,7 +410,7 @@ mkExtWFAStakeDistr tiebreaker pools -- * seat 0's cumulative stake == total stake, and -- * last seat's cumulative stake = its own stake. -- In addition, count the number of pools with positive stake in the same pass. - ((_totalStake, numPoolsWithPositiveStakeAcc), cumulativeStakeAndPools) = + ((totalStakeAcc, numPoolsWithPositiveStakeAcc), cumulativeStakeAndPools) = List.mapAccumR accumStakeAndCountPoolsWithPositiveStake ( Cumulative (LedgerStake 0) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index 135ada58d2..b2d813f1be 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -93,7 +93,7 @@ import Ouroboros.Consensus.Committee.WFA , PersistentCommitteeSize (..) , SeatIndex (..) , TotalNonPersistentStake (..) - , TotalPersistentStake + , TotalPersistentStake (..) , WFAError , getCandidateIfSeatWithinBounds , unsafeGetCandidateInSeat @@ -130,7 +130,7 @@ instance persistentCommitteeSize :: !PersistentCommitteeSize , -- Expected number of non-persistent voters nonPersistentCommitteeSize :: !NonPersistentCommitteeSize - , -- Total stake of persistent voters + , -- Total stake of persistent voters totalPersistentStake :: !TotalPersistentStake , -- Total stake of non-persistent voters totalNonPersistentStake :: !TotalNonPersistentStake @@ -398,18 +398,15 @@ implVerifyVote committee = \case -- | Compute the voting power of an eligible committee member -- --- NOTE: there is a subtle difference between the "Ledger stake" and the "Vote --- weight" of a given voter. On one hand, the ledger stake is the stake as --- reflected directly by the ledger stake distribution under consideration. On --- the other hand, the "Vote" weight refers to the voting power of that voter, --- i.e., the stake that a voter can effectively contribute to an election, --- which might be different from their ledger stake depending on their committee +-- In this voting committee scheme, the vote weight of a member depends on their -- membership type: -- * for a persistent committee member, their vote weight is equal to their --- ledger stake throughout their entire tenure in the committee, whereas --- * for a non-persistent committee member, their vote weight (provided that --- they are actually selected to vote via local sortition) is equal to their --- ledger stake normalized by the total non-persistent stake. +-- (normalised) ledger stake throughout their entire tenure in the +-- committee, whereas +-- * for a non-persistent committee member, their vote weight is equal to +-- their (normalised) non-persistent vote weight. This is computed as the +-- number of seats granted to them by local sortition, scaled by their +-- relative non-persistent stake w.r.t. other non-persistent voters. implEligiblePartyVoteWeight :: VotingCommittee crypto WFALS -> EligibilityWitness crypto WFALS -> @@ -419,7 +416,7 @@ implEligiblePartyVoteWeight committee = \case WFALSPersistentMember _seatIndex (LedgerStake stake) -> - VoteWeight stake + mkVoteWeight stake -- Non-persistent members have their voting power proportional to their -- number of seats granted by local sortition and their stake (normalized -- by the total non-persistent stake) @@ -428,13 +425,19 @@ implEligiblePartyVoteWeight committee = \case (LedgerStake stake) _vrfOutput numSeats -> - VoteWeight $ + mkVoteWeight $ fromIntegral (unLocalSortitionNumSeats (unNonZero numSeats)) * stake / nonPersistentStake - where - TotalNonPersistentStake (Cumulative (LedgerStake nonPersistentStake)) = - totalNonPersistentStake committee + where + TotalPersistentStake (Cumulative (LedgerStake persistentStake)) = + totalPersistentStake committee + TotalNonPersistentStake (Cumulative (LedgerStake nonPersistentStake)) = + totalNonPersistentStake committee + + mkVoteWeight absoluteStake = + VoteWeight (absoluteStake / (persistentStake + nonPersistentStake)) + -- | Forge a certificate attesting the winner of a given election implForgeCert :: From df3801ad1cde46d7f401cdd357fb3893d6dd9d35 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 26 May 2026 10:35:56 +0200 Subject: [PATCH 38/62] WIP refactor 3 --- .../Ouroboros/Consensus/Shelley/Node/Peras.hs | 4 +-- .../Consensus/Block/SupportsPeras.hs | 25 ++++++++----------- .../Ouroboros/Consensus/Committee/Class.hs | 9 ++++--- .../Consensus/HardFork/Combinator/Basics.hs | 4 +-- .../Ouroboros/Consensus/Peras/Types.hs | 5 +++- .../Test/Ouroboros/Storage/TestBlock.hs | 2 +- .../Test/Util/TestBlock.hs | 2 +- 7 files changed, 26 insertions(+), 25 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs index b8a30119a7..73674823d1 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -16,7 +16,7 @@ module Ouroboros.Consensus.Shelley.Node.Peras () where import Cardano.Ledger.Api import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) - , EmptyPerasError + , VoidPerasError ) import Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) @@ -55,7 +55,7 @@ instance where type PerasVote (ShelleyBlock proto DijkstraEra) = MockPerasVote (ShelleyBlock proto DijkstraEra) type PerasCert (ShelleyBlock proto DijkstraEra) = MockPerasCert (ShelleyBlock proto DijkstraEra) - type PerasError (ShelleyBlock proto DijkstraEra) = EmptyPerasError (ShelleyBlock proto DijkstraEra) + type PerasError (ShelleyBlock proto DijkstraEra) = VoidPerasError (ShelleyBlock proto DijkstraEra) validatePerasVote = validateMockPerasVote validatePerasCert = validateMockPerasCert diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index f337fc4f10..3e7130568c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -26,7 +26,7 @@ module Ouroboros.Consensus.Block.SupportsPeras , implPerasForgeVoteIfEligible , VoidPerasVote (..) , VoidPerasCert (..) - , EmptyPerasError (..) + , VoidPerasError (..) , ValidatedPerasCert (..) , ValidatedPerasVote (..) , ValidatedPerasVotesWithQuorum @@ -82,7 +82,6 @@ type family PerasCrypto blk :: Type -- TODO: maybe move this inside 'BlockSupportsPeras'. type family PerasVotingCommitteeScheme blk :: Type - -- | Voting committee for Peras indexed by block type type PerasVotingCommittee blk = VotingCommittee @@ -133,7 +132,7 @@ class type PerasCert blk = VoidPerasCert blk type PerasError blk = (err :: Type) | err -> blk - type PerasError blk = EmptyPerasError blk + type PerasError blk = VoidPerasError blk validatePerasVote :: PerasParams -> @@ -300,22 +299,20 @@ instance IsPerasCert (VoidPerasCert blk) blk where getPerasCertRound = absurd . unVoidPerasCert getPerasCertBlock = absurd . unVoidPerasCert --- | Empty Peras error for @blk@. +-- | Void Peras error for @blk@. -- -- NOTE: the phantom @blk@ is used to keep the 'PerasError' type family injective. --- --- NOTE: in contrast to 'VoidPerasVote' and 'VoidPerasCert', this type cannot be --- uninhabited, or we would otherwise have to construct a `Void` when injecting --- errors into this type, which would be impossible. -newtype EmptyPerasError blk - = EmptyPerasError - { unEmptyPerasError :: () +newtype VoidPerasError blk + = VoidPerasError + { unVoidPerasError :: Void } deriving newtype (Show, Eq, NoThunks, ShowProxy) -instance IsPerasError (EmptyPerasError blk) blk where - injectVotingCommitteeError _ = EmptyPerasError () - injectConversionError _ = EmptyPerasError () +instance IsPerasError (VoidPerasError blk) blk where + injectVotingCommitteeError _ = + error "injectVotingCommitteeError: VoidPerasError cannot be inhabited" + injectConversionError _ = + error "injectConversionError: VoidPerasError cannot be inhabited" -- * Validated types diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs index 109355b288..16fd2f61a0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs @@ -104,15 +104,16 @@ class -- -- WARNING: there is a key difference between the "Ledger stake" and the "Vote -- weight" of a given voter. On one hand, the ledger stake is the stake as - -- reflected directly by the ledger stake distribution under consideration. On - -- the other hand, the "Vote weight" refers to the relative (i.e. normalised) - -- voting power of that voter w.r.t. the rest of the committee. + -- reflected directly by the ledger stake distribution under consideration + -- (in its corresponding absolute unit). On the other hand, the "Vote weight" + -- refers to the relative (i.e. normalised) voting power of that voter w.r.t. + -- the rest of the committee. -- -- It is up to the implementation of the voting committee to decide how to -- compute this value, but it should be implemented so that detecting a -- quorum can be done by comparing the total vote weight of the votes received -- against a fixed threshold, e.g., "a quorum is reached if the total weight - -- of the votes received exceeds 75% / 0.75 (of the total voting stake)". + -- of the votes received exceeds 75% or 0.75 (of the total voting stake)". eligiblePartyVoteWeight :: VotingCommittee crypto committee -> EligibilityWitness crypto committee -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index fcca5ac9fe..3dbac94c18 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -49,7 +49,7 @@ import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) - , EmptyPerasError + , VoidPerasError ) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -293,7 +293,7 @@ instance where type PerasVote (HardForkBlock xs) = MockPerasVote (HardForkBlock xs) type PerasCert (HardForkBlock xs) = MockPerasCert (HardForkBlock xs) - type PerasError (HardForkBlock xs) = EmptyPerasError (HardForkBlock xs) + type PerasError (HardForkBlock xs) = VoidPerasError (HardForkBlock xs) validatePerasVote = validateMockPerasVote validatePerasCert = validateMockPerasCert diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs index a754f086ce..543fb99d68 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -125,7 +125,10 @@ instance FromCBOR PerasBoostedBlock where instance ToCBOR PerasBoostedBlock where toCBOR = encodeWithOrigin encodeBytes32RealPoint . unPerasBoostedBlock -instance Coercible (HeaderHash blk) ShortByteString => BoostedBlockCompatibleWithPoint PerasBoostedBlock blk where +instance + Coercible (HeaderHash blk) ShortByteString => + BoostedBlockCompatibleWithPoint PerasBoostedBlock blk + where boostedBlockToPoint = withOriginRealPointToPoint . fmap fromBytes32RealPoint diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index ea2389ea0a..39c97c33a4 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -739,7 +739,7 @@ instance LedgerSupportsPeras TestBlock where instance BlockSupportsPeras TestBlock where type PerasVote TestBlock = MockPerasVote TestBlock type PerasCert TestBlock = MockPerasCert TestBlock - type PerasError TestBlock = EmptyPerasError TestBlock + type PerasError TestBlock = VoidPerasError TestBlock validatePerasVote = validateMockPerasVote validatePerasCert = validateMockPerasCert diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index aea2f2b93c..63e0f721e7 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -715,7 +715,7 @@ instance where type PerasVote (TestBlockWith ptype) = MockPerasVote (TestBlockWith ptype) type PerasCert (TestBlockWith ptype) = MockPerasCert (TestBlockWith ptype) - type PerasError (TestBlockWith ptype) = EmptyPerasError (TestBlockWith ptype) + type PerasError (TestBlockWith ptype) = VoidPerasError (TestBlockWith ptype) validatePerasVote = validateMockPerasVote validatePerasCert = validateMockPerasCert From f1cc21374cf052dcb9c51b54b8b8fa6ea3e69d7a Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 26 May 2026 10:59:25 +0200 Subject: [PATCH 39/62] Remove `PerasVoterId` in favor of `PerasSeatIndex` --- .../Consensus/Block/SupportsPeras.hs | 10 ++--- .../Ouroboros/Consensus/Committee/WFALS.hs | 1 - .../Ouroboros/Consensus/Node/Serialisation.hs | 12 +++--- .../Ouroboros/Consensus/Peras/Types.hs | 37 +++++++------------ .../Ouroboros/Consensus/Peras/Vote/Mock.hs | 22 +++++------ .../Test/Util/Orphans/ToExpr.hs | 2 +- .../ObjectDiffusion/PerasVote/Smoke.hs | 19 +++------- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 4 +- .../Ouroboros/Storage/PerasVoteDB/Model.hs | 18 ++++----- .../Storage/PerasVoteDB/StateMachine.hs | 26 ++++--------- 10 files changed, 59 insertions(+), 92 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 3e7130568c..97342b3957 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -293,7 +293,7 @@ type instance BoostedBlock (VoidPerasCert blk) = Point blk instance IsPerasVote (VoidPerasVote blk) blk where getPerasVoteRound = absurd . unVoidPerasVote getPerasVoteBlock = absurd . unVoidPerasVote - getPerasVoteVoterId = absurd . unVoidPerasVote + getPerasVoteSeatIndex = absurd . unVoidPerasVote instance IsPerasCert (VoidPerasCert blk) blk where getPerasCertRound = absurd . unVoidPerasCert @@ -420,7 +420,7 @@ class where getPerasVoteRound :: vote -> PerasRoundNo getPerasVoteBlock :: vote -> BoostedBlock vote - getPerasVoteVoterId :: vote -> PerasVoterId + getPerasVoteSeatIndex :: vote -> PerasSeatIndex getPerasVotePoint :: vote -> Point blk getPerasVotePoint = boostedBlockToPoint . getPerasVoteBlock @@ -430,7 +430,7 @@ getPerasVoteId :: IsPerasVote vote blk => vote -> PerasVoteId blk getPerasVoteId vote = PerasVoteId { pviRoundNo = getPerasVoteRound vote - , pviVoterId = getPerasVoteVoterId vote + , pviSeatIndex = getPerasVoteSeatIndex vote } -- | Extract the vote target from a Peras vote container @@ -451,7 +451,7 @@ instance where getPerasVoteRound = getPerasVoteRound . vpvVote getPerasVoteBlock = getPerasVoteBlock . vpvVote - getPerasVoteVoterId = getPerasVoteVoterId . vpvVote + getPerasVoteSeatIndex = getPerasVoteSeatIndex . vpvVote instance IsPerasVote vote blk => @@ -459,7 +459,7 @@ instance where getPerasVoteRound = getPerasVoteRound . forgetArrivalTime getPerasVoteBlock = getPerasVoteBlock . forgetArrivalTime - getPerasVoteVoterId = getPerasVoteVoterId . forgetArrivalTime + getPerasVoteSeatIndex = getPerasVoteSeatIndex . forgetArrivalTime -- | Types that support being treated as Peras certificates class diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index b2d813f1be..721dfb2478 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -438,7 +438,6 @@ implEligiblePartyVoteWeight committee = \case mkVoteWeight absoluteStake = VoteWeight (absoluteStake / (persistentStake + nonPersistentStake)) - -- | Forge a certificate attesting the winner of a given election implForgeCert :: forall crypto. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs index a266cadb53..3fc3d3557a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs @@ -198,21 +198,21 @@ instance SerialiseNodeToNode blk PerasRoundNo where encodeNodeToNode _ccfg _version = encode decodeNodeToNode _ccfg _version = decode -instance SerialiseNodeToNode blk PerasVoterId where - encodeNodeToNode _ccfg _version = KeyHash.toCBOR . unPerasVoterId - decodeNodeToNode _ccfg _version = PerasVoterId <$> KeyHash.fromCBOR +instance SerialiseNodeToNode blk PerasSeatIndex where + encodeNodeToNode _ccfg _version = KeyHash.toCBOR . unPerasSeatIndex + decodeNodeToNode _ccfg _version = PerasSeatIndex <$> KeyHash.fromCBOR instance SerialiseNodeToNode blk (PerasVoteId blk) where -- Consistent with the 'Serialise' instance for 'PerasVoteId' defined in Ouroboros.Consensus.Block.SupportsPeras encodeNodeToNode ccfg version PerasVoteId{..} = encodeListLen 2 <> encodeNodeToNode ccfg version pviRoundNo - <> encodeNodeToNode ccfg version pviVoterId + <> encodeNodeToNode ccfg version pviSeatIndex decodeNodeToNode ccfg version = do decodeListLenOf 2 pviRoundNo <- decodeNodeToNode ccfg version - pviVoterId <- decodeNodeToNode ccfg version - pure $ PerasVoteId pviRoundNo pviVoterId + pviSeatIndex <- decodeNodeToNode ccfg version + pure $ PerasVoteId pviRoundNo pviSeatIndex instance SerialiseNodeToNode blk (VoidPerasVote blk) where encodeNodeToNode _ _ = absurd . unVoidPerasVote diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs index 543fb99d68..07f5d5b0d4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -21,7 +21,6 @@ module Ouroboros.Consensus.Peras.Types , weightAboveThreshold , PerasVoteTarget (..) , PerasVoteId (..) - , PerasVoterId (..) , VoteWeight (..) -- Re-exported from Committee.Types for convenience , VoteWeightDistr (..) , lookupVoteWeight @@ -37,7 +36,6 @@ import Cardano.Binary , decodeListLenOf , encodeListLen ) -import Cardano.Ledger.Hashes (KeyHash, KeyRole (..)) import Codec.Serialise.Class (Serialise (..)) import Control.DeepSeq (NFData) import Data.ByteString.Short (ShortByteString) @@ -146,7 +144,7 @@ newtype PerasSeatIndex { unPerasSeatIndex :: Word16 } deriving stock (Show, Eq, Ord, Generic) - deriving newtype (FromCBOR, ToCBOR, Enum, Bounded) + deriving newtype (FromCBOR, ToCBOR, Enum, Bounded, NFData) deriving anyclass NoThunks -- ** Vote parameters @@ -164,7 +162,7 @@ data PerasVoteTarget blk data PerasVoteId blk = PerasVoteId { pviRoundNo :: !PerasRoundNo - , pviVoterId :: !PerasVoterId + , pviSeatIndex :: !PerasSeatIndex } deriving stock (Show, Eq, Ord, Generic) deriving anyclass NoThunks @@ -173,15 +171,15 @@ instance ShowProxy blk => ShowProxy (PerasVoteId blk) where showProxy _ = "PerasVoteId " <> showProxy (Proxy @blk) instance Serialise (PerasVoteId blk) where - encode PerasVoteId{pviRoundNo, pviVoterId} = + encode PerasVoteId{pviRoundNo, pviSeatIndex} = encodeListLen 2 <> encode pviRoundNo - <> toCBOR (unPerasVoterId pviVoterId) + <> toCBOR (unPerasSeatIndex pviSeatIndex) decode = do decodeListLenOf 2 pviRoundNo <- decode - pviVoterId <- PerasVoterId <$> fromCBOR - pure $ PerasVoteId{pviRoundNo, pviVoterId} + pviSeatIndex <- PerasSeatIndex <$> fromCBOR + pure $ PerasVoteId{pviRoundNo, pviSeatIndex} -- | Check whether a given vote weight is above the quorum threshold. -- @@ -203,24 +201,15 @@ weightAboveThreshold params voteWeight = unPerasQuorumWeightThresholdSafetyMargin (perasQuorumWeightThresholdSafetyMargin params) --- | The identifier of a voter in a Peras election -newtype PerasVoterId - = PerasVoterId - { unPerasVoterId :: KeyHash StakePool - } - deriving newtype (NoThunks, NFData, FromCBOR, ToCBOR) - deriving stock (Eq, Ord, Generic) - deriving Show via Quiet PerasVoterId - -instance Serialise PerasVoterId where - encode = toCBOR . unPerasVoterId - decode = PerasVoterId <$> fromCBOR +instance Serialise PerasSeatIndex where + encode = toCBOR . unPerasSeatIndex + decode = PerasSeatIndex <$> fromCBOR -- | Voting weight distribution for a Peras election -- TODO: remove, at call site an argument of this type will be replaced by a 'PerasVotingCommittee blk'. newtype VoteWeightDistr = VoteWeightDistr - { unVoteWeightDistr :: Map PerasVoterId VoteWeight + { unVoteWeightDistr :: Map PerasSeatIndex VoteWeight } deriving newtype NoThunks deriving stock (Show, Eq, Generic) @@ -228,12 +217,12 @@ newtype VoteWeightDistr -- | Lookup the weight of a vote cast by a member of a given weight distribution. -- TODO: remove this function since it will be replaced by 'eligiblePartyVoteWeight' from Committee.Class lookupVoteWeight :: - PerasVoterId -> + PerasSeatIndex -> VoteWeightDistr -> Maybe VoteWeight -lookupVoteWeight voterId distr = +lookupVoteWeight seatIndex distr = Map.lookup - voterId + seatIndex (unVoteWeightDistr distr) -- ** Conversion errors diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs index 93ee27c1c3..297841dc4b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs @@ -35,7 +35,7 @@ import Ouroboros.Consensus.Block.SupportsPeras , BoostedBlock , IsPerasVote (..) , PerasRoundNo - , PerasVoterId (..) + , PerasSeatIndex (..) , ValidatedPerasVote (..) , VoteWeight , VoteWeightDistr @@ -52,7 +52,7 @@ data MockPerasVote blk = MockPerasVote { mockVoteRound :: PerasRoundNo , mockVoteBlock :: Point blk - , mockVoteVoterId :: PerasVoterId + , mockVoteSeatIndex :: PerasSeatIndex , mockVoteWeight :: VoteWeight -- ^ This field is unique to the mocked vote, and allows us to bypass the -- need for a 'VoteWeightDistr' when creating validated votes in tests. @@ -69,7 +69,7 @@ type instance BoostedBlock (MockPerasVote blk) = Point blk instance IsPerasVote (MockPerasVote blk) blk where getPerasVoteRound = mockVoteRound getPerasVoteBlock = mockVoteBlock - getPerasVoteVoterId = mockVoteVoterId + getPerasVoteSeatIndex = mockVoteSeatIndex instance ShowProxy blk => ShowProxy (MockPerasVote blk) where showProxy _ = "MockPerasVote(" <> showProxy (Proxy @blk) <> ")" @@ -82,22 +82,22 @@ instance MockPerasVote { mockVoteRound , mockVoteBlock - , mockVoteVoterId + , mockVoteSeatIndex } = encodeListLen 3 <> encode mockVoteRound <> encode mockVoteBlock - <> encode mockVoteVoterId + <> encode mockVoteSeatIndex decode = do decodeListLenOf 3 mockVoteRound <- decode mockVoteBlock <- decode - mockVoteVoterId <- decode + mockVoteSeatIndex <- decode pure $ MockPerasVote { mockVoteRound , mockVoteBlock - , mockVoteVoterId + , mockVoteSeatIndex , mockVoteWeight = 0 -- NOTE: weights are never sent over the wire, but computed locally from -- the voting committee. We might need to change this in the future if @@ -115,22 +115,22 @@ instance MockPerasVote { mockVoteRound , mockVoteBlock - , mockVoteVoterId + , mockVoteSeatIndex } = encodeListLen 3 <> encodeNodeToNode ccfg version mockVoteRound <> encodeNodeToNode ccfg version mockVoteBlock - <> encodeNodeToNode ccfg version mockVoteVoterId + <> encodeNodeToNode ccfg version mockVoteSeatIndex decodeNodeToNode ccfg version = do decodeListLenOf 3 mockVoteRound <- decodeNodeToNode ccfg version mockVoteBlock <- decodeNodeToNode ccfg version - mockVoteVoterId <- decodeNodeToNode ccfg version + mockVoteSeatIndex <- decodeNodeToNode ccfg version pure MockPerasVote { mockVoteRound , mockVoteBlock - , mockVoteVoterId + , mockVoteSeatIndex , mockVoteWeight = 0 -- NOTE: weights are never sent over the wire, but computed locally from -- the voting committee. We might need to change this in the future if diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index 640821c1f8..d191a0caad 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -132,7 +132,7 @@ deriving anyclass instance ToExpr (PerasVoteId blk) deriving anyclass instance ToExpr a => ToExpr (WithArrivalTime a) -instance ToExpr PerasVoterId where toExpr = defaultExprViaShow +instance ToExpr PerasSeatIndex where toExpr = defaultExprViaShow instance ToExpr (HeaderHash blk) => ToExpr (MockPerasVote blk) instance ToExpr (HeaderHash blk) => ToExpr (MockPerasCert blk) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs index 2090f6ca25..8caa7058fa 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs @@ -7,20 +7,16 @@ module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke ( tests - , genPerasVoterId + , genPerasSeatIndex , genVoteWeight , genPerasVote , genValidatedPerasVote ) where -import qualified Cardano.Crypto.DSIGN.Class as SL -import qualified Cardano.Crypto.Seed as SL -import qualified Cardano.Ledger.Keys as SL import Control.Monad (join) import Control.Tracer (contramap, nullTracer) import qualified Data.Map as Map import Data.Ratio ((%)) -import Data.String (IsString (..)) import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) import Ouroboros.Consensus.Block.SupportsPeras import Ouroboros.Consensus.BlockchainTime.WallClock.Types @@ -66,13 +62,8 @@ tests = [ testProperty "PerasVoteDiffusion smoke test" prop_smoke ] -genPerasVoterId :: Gen PerasVoterId -genPerasVoterId = do - bytes <- fromString <$> vectorOf 32 arbitrary - let signKey = SL.genKeyDSIGN (SL.mkSeedFromBytes bytes) - verKey = SL.deriveVerKeyDSIGN signKey - keyHash = SL.hashKey (SL.VKey verKey) - pure (PerasVoterId keyHash) +genPerasSeatIndex :: Gen PerasSeatIndex +genPerasSeatIndex = PerasSeatIndex <$> arbitrary genVoteWeight :: Gen VoteWeight genVoteWeight = do @@ -83,13 +74,13 @@ genPerasVote :: Gen (PerasVote TestBlock) genPerasVote = do mockVoteRound <- PerasRoundNo <$> arbitrary mockVoteBlock <- genPointTestBlock - mockVoteVoterId <- genPerasVoterId + mockVoteSeatIndex <- genPerasSeatIndex mockVoteWeight <- genVoteWeight pure $ MockPerasVote { mockVoteRound , mockVoteBlock - , mockVoteVoterId + , mockVoteSeatIndex , mockVoteWeight } 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 f5261b3477..ce6e3328af 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 @@ -1320,7 +1320,7 @@ generator loe genBlock genPerasBlock m@Model{..} = let roundNo = case Model.roundNoOfLatestCertSeen dbModel of Nothing -> PerasRoundNo 0 Just (PerasRoundNo r) -> PerasRoundNo (r + 1) - voterId <- PerasVoteDB.SM.genVoterId + seatIndex <- PerasVoteDB.SM.genPerasSeatIndex weight <- PerasVoteDB.SM.genVoteWeight -- Include the voted block itself in the persisted seenBlocks let seenBlks = fmap (blk :) gapBlks @@ -1333,7 +1333,7 @@ generator loe genBlock genPerasBlock m@Model{..} = MockPerasVote { mockVoteRound = roundNo , mockVoteBlock = blockPoint blk - , mockVoteVoterId = voterId + , mockVoteSeatIndex = seatIndex , mockVoteWeight = weight } , vpvVoteWeight = weight diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs index 05b24e2ef8..92cb0469df 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs @@ -32,9 +32,9 @@ import Ouroboros.Consensus.Block.SupportsPeras , IsPerasVote (..) , PerasParams , PerasRoundNo + , PerasSeatIndex , PerasVoteId (..) , PerasVoteTarget (..) - , PerasVoterId , ValidatedPerasCert (..) , ValidatedPerasVote (..) , VoteWeight (..) @@ -52,8 +52,8 @@ import Ouroboros.Consensus.Storage.PerasVoteDB.API data VoteEntry blk = VoteEntry { veTicketNo :: PerasVoteTicketNo -- ^ The ticket number assigned to this vote - , veVoter :: PerasVoterId - -- ^ The voter ID + , veVoter :: PerasSeatIndex + -- ^ The seat index of the voter , veVote :: WithArrivalTime (ValidatedPerasVote blk) -- ^ The vote itself } @@ -127,7 +127,7 @@ hasVote voteId model = ( \ve -> PerasVoteId { pviRoundNo = pvtRoundNo voteTarget - , pviVoterId = veVoter ve + , pviSeatIndex = veVoter ve } ) votesForTarget @@ -166,8 +166,8 @@ addVote :: , Model blk ) addVote vote model - -- The ID of a vote is a pair (voterId, roundNo). So checking if the voter has - -- already voted in this round means checking if the pair (voterId, roundNo) + -- The ID of a vote is a pair (seatIndex, roundNo). So checking if the voter has + -- already voted in this round means checking if the pair (seatIndex, roundNo) -- is already present in the model i.e. if the vote is already in the model. -- In which case, we can ignore it. -- @@ -224,14 +224,14 @@ addVote vote model votedBlock = getPerasVotePoint vote voter = - getPerasVoteVoterId vote + getPerasVoteSeatIndex vote -- Compute the next ticket number associated to this vote. -- NOTE: This is a 64-bit counter, so there's no practical risk of overflow. nextTicketNo = succ (lastTicketNo model) -- Prepare various data structures needed to update the model voteId = - PerasVoteId{pviRoundNo = roundNo, pviVoterId = voter} + PerasVoteId{pviRoundNo = roundNo, pviSeatIndex = voter} voteTarget = PerasVoteTarget{pvtRoundNo = roundNo, pvtBlock = votedBlock} voteEntry = @@ -291,7 +291,7 @@ getVoteIds model = ( \ve -> PerasVoteId { pviRoundNo = pvtRoundNo voteTarget - , pviVoterId = veVoter ve + , pviSeatIndex = veVoter ve } ) votesForTarget diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index 54b94c0489..3569a5d3ed 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -11,13 +11,10 @@ module Test.Ouroboros.Storage.PerasVoteDB.StateMachine ( tests -- * Reusable generators - , genVoterId + , genPerasSeatIndex , genVoteWeight ) where -import qualified Cardano.Crypto.DSIGN.Class as SL -import qualified Cardano.Crypto.Seed as SL -import qualified Cardano.Ledger.Keys as SL import Control.Concurrent.Class.MonadSTM (MonadSTM (..)) import Control.Monad (join) import Control.Monad.Class.MonadThrow (MonadCatch (..)) @@ -28,7 +25,6 @@ import Control.Monad.State , evalStateT ) import Control.Tracer (nullTracer) -import Data.Char (chr) import Data.Functor (($>)) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map @@ -36,7 +32,6 @@ import Data.Map.Strict (Map) import Data.Ratio ((%)) import Data.Set (Set) import qualified Data.Set as Set -import Data.String (IsString (..)) import Data.Word (Word64) import GHC.Generics (Generic) import Ouroboros.Consensus.Block.Abstract (Point (..), SlotNo (..)) @@ -44,9 +39,9 @@ import Ouroboros.Consensus.Block.SupportsPeras ( IsPerasVote (..) , PerasParams , PerasRoundNo (..) + , PerasSeatIndex (..) , PerasVoteId , PerasVoteTarget (..) - , PerasVoterId (..) , ValidatedPerasCert , ValidatedPerasVote (..) , VoteWeight (..) @@ -73,7 +68,6 @@ import Test.QuickCheck , Gen , Property , choose - , elements , frequency , ioProperty , tabulate @@ -181,7 +175,7 @@ instance StateModel Model where genAddVote = do roundNo <- genRoundNo point <- genPoint - voterId <- genVoterId + seatIndex <- genPerasSeatIndex weight <- genVoteWeight now <- genRelativeTime let voteWithTime = @@ -191,7 +185,7 @@ instance StateModel Model where MockPerasVote { mockVoteRound = roundNo , mockVoteBlock = point - , mockVoteVoterId = voterId + , mockVoteSeatIndex = seatIndex , mockVoteWeight = weight } , vpvVoteWeight = weight @@ -354,19 +348,13 @@ instance RunModel Model (StateT (PerasVoteDB IO TestBlock) IO) where -- * Reusable generators --- | Generate a random 'PerasVoterId'. +-- | Generate a random 'PerasSeatIndex'. -- -- We want to force collisions when adding votes, so we need to restrict -- the key space a lot here. Otherwise we might never hit the case where -- the same voter casts two votes for the same round/block. -genVoterId :: Gen PerasVoterId -genVoterId = do - let mkVoterKey = fromString . replicate 32 - bytes <- mkVoterKey <$> elements [chr c | c <- [0 .. 99]] - let signKey = SL.genKeyDSIGN (SL.mkSeedFromBytes bytes) - let verKey = SL.deriveVerKeyDSIGN signKey - let keyHash = SL.hashKey (SL.VKey verKey) - pure (PerasVoterId keyHash) +genPerasSeatIndex :: Gen PerasSeatIndex +genPerasSeatIndex = PerasSeatIndex <$> choose (0, 99) -- | Generate a random 'VoteWeight'. -- From 4660cd5767133345e1abda5a02fc101b712a39d8 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 26 May 2026 13:02:51 +0200 Subject: [PATCH 40/62] Move Peras public key hack to O.C.Peras.Crypto.BLS.Unsafe --- .../Consensus/Protocol/Praos/Peras.hs | 101 ++---------------- ouroboros-consensus.cabal | 2 +- .../Consensus/Peras/Crypto/BLS/Unsafe.hs | 90 ++++++++++++++++ 3 files changed, 102 insertions(+), 91 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs index a1b67f651b..9c7ad03a40 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -1,27 +1,17 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | Voting interface for Peras derived from the Praos ledger view. module Ouroboros.Consensus.Protocol.Praos.Peras ( PraosStateSupportsPerasVoting (..) - , getStakeDistrWithBLSPublicKeys - , perasBLSPublicKeysFromEnv ) where -import qualified Cardano.Ledger.Shelley.State as SL -import Data.Aeson (eitherDecodeFileStrict') import Data.Bifunctor (Bifunctor (..)) -import qualified Data.ByteString.Char8 as ByteString import Data.ByteString.Short (ShortByteString) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block.Abstract (HeaderHash, StandardHash) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) @@ -34,12 +24,6 @@ import Ouroboros.Consensus.Block.SupportsPeras ) import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee) import qualified Ouroboros.Consensus.Committee.Class as Committee -import Ouroboros.Consensus.Committee.Crypto (PublicKey) -import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS -import Ouroboros.Consensus.Committee.Types - ( LedgerStake (..) - , PoolId (..) - ) import Ouroboros.Consensus.Committee.WFA ( mkExtWFAStakeDistr , wFATiebreakerWithEpochNonce @@ -50,6 +34,9 @@ import Ouroboros.Consensus.Committee.WFALS ) import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS +import Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe + ( unsafeExtendPerasStakeDistrWithPublicKeysFromEnv + ) import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 import Ouroboros.Consensus.Peras.Params (PerasParams (..)) import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 @@ -58,8 +45,6 @@ import Ouroboros.Consensus.Protocol.Praos , Ticked (..) ) import Ouroboros.Consensus.Protocol.Praos.Views (LedgerView (..)) -import System.Environment (lookupEnv) -import System.IO.Unsafe (unsafePerformIO) -------------------------------------------------------------------------------- -- This is a mocked up instance @@ -89,88 +74,24 @@ instance PraosStateSupportsPerasVoting RealBlock where praosStateEpochNonce . tickedPraosStateChainDepState $ tickedPraosState - let wFATiebreaker = - wFATiebreakerWithEpochNonce epochNonce + -- TODO: replace the following hack with proper on-chain key registration. stakeDistrWithPublicKeys <- - bimap V1.PerasTemporaryPublicKeyHackError id $ - getStakeDistrWithBLSPublicKeys tickedPraosState + bimap V1.PerasTemporaryPublicKeyHackError id + . unsafeExtendPerasStakeDistrWithPublicKeysFromEnv + . lvPoolDistr + . tickedPraosStateLedgerView + $ tickedPraosState extWFAStakeDistr <- bimap V1.PerasVotingWFAError id $ mkExtWFAStakeDistr - wFATiebreaker + (wFATiebreakerWithEpochNonce epochNonce) stakeDistrWithPublicKeys - let targetCommitteeSize = perasTargetCommitteeSize perasParams pure $ WFALSVotingCommitteeInput epochNonce - targetCommitteeSize + (perasTargetCommitteeSize perasParams) extWFAStakeDistr --------------------------------------------------------------------------------- --- Helpers to deal with public keys and stake --------------------------------------------------------------------------------- - -getStakeDistrWithBLSPublicKeys :: - Ticked PraosState -> - Either - String - (Map PoolId (LedgerStake, PublicKey BLS.PerasBLSCrypto)) -getStakeDistrWithBLSPublicKeys tickedPraosState = do - let stakeDistr = - Map.mapKeysMonotonic PoolId - . Map.map (LedgerStake . SL.individualPoolStake) - . SL.unPoolDistr - . lvPoolDistr - . tickedPraosStateLedgerView - $ tickedPraosState - - publicKeys <- perasBLSPublicKeysFromEnv -- Uses 'unsafePerformIO' - Map.traverseWithKey (addPublicKey publicKeys) stakeDistr - where - addPublicKey publicKeys poolId stake = - case Map.lookup poolId publicKeys of - Nothing -> - Left $ "Public key not found for pool: " <> show poolId - Just pk -> - pure (stake, pk) - --- * Retrieveing public keys from a JSON file (temporary) - -perasBLSPublicKeysFromEnv :: Either String (Map PoolId BLS.PerasPublicKey) -{-# NOINLINE perasBLSPublicKeysFromEnv #-} -perasBLSPublicKeysFromEnv = - unsafePerformIO $ - lookupEnv envVar >>= \case - Nothing -> do - pure $ Left $ "Environment variable " <> envVar <> " not set." - Just keysFile -> do - eitherDecodeFileStrict' keysFile >>= \case - Left err -> do - pure $ Left $ "Failed to parse public keys from file: " <> err - Right rawKeys -> do - pure $ decodeKeys rawKeys - where - envVar = - "PERAS_PUBLIC_KEY_FILE" - - keyScope = - "TESTNET" - - decodeKeys = - fmap (Map.mapKeysMonotonic PoolId) - . traverse decodeKey - - decodeKey key = - case BLS.rawDeserialisePublicKey keyScope (ByteString.pack key) of - Nothing -> - Left $ "Invalid public key format: " <> key - Just pk -> - Right $ - BLS.PerasPublicKey - { BLS.perasVoteVerKey = BLS.coercePublicKey @BLS.SIGN pk - , BLS.perasVRFVerKey = BLS.coercePublicKey @BLS.VRF pk - } - -------------------------------------------------------------------------------- class diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 2cdcf5be74..eb6c087ad3 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -242,6 +242,7 @@ library Ouroboros.Consensus.Peras.Cert.Mock Ouroboros.Consensus.Peras.Cert.V1 Ouroboros.Consensus.Peras.Crypto.BLS + Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe Ouroboros.Consensus.Peras.Error.V1 Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView @@ -959,7 +960,6 @@ library protocol Ouroboros.Consensus.Protocol.TPraos build-depends: - aeson, base, bytestring, cardano-binary, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs new file mode 100644 index 0000000000..af5cb6af43 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +-- | Temporary hack for retrieving BLS public keys from a JSON file specified +-- in the environment variable 'PERAS_PUBLIC_KEY_FILE'. +-- +-- WARNING: this is a temporary hack for testing purposes, and should not be +-- used under any circumstances in production. This will be replaced with proper +-- on-chain key registration in the future. +module Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe + ( unsafeExtendPerasStakeDistrWithPublicKeysFromEnv + , unsafePerasBLSPublicKeysFromEnv + ) where + +import Cardano.Ledger.State (IndividualPoolStake (..), PoolDistr (..)) +import Data.Aeson (eitherDecodeFileStrict') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.String (IsString (..)) +import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS +import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId (..)) +import Ouroboros.Consensus.Peras.Crypto.BLS (PerasPublicKey (..)) +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) + +-- | Extend a given 'PoolDistr' with the corresponding BLS public keys for each +-- pool retrieved from the JSON file specified in the environment variable +-- 'PERAS_PUBLIC_KEY_FILE'. +-- +-- WARNING: this is a temporary hack for testing purposes, and should not be +-- used under any circumstances in production. This will be replaced with proper +-- on-chain key registration in the future. +unsafeExtendPerasStakeDistrWithPublicKeysFromEnv :: + PoolDistr -> + Either + String + (Map PoolId (LedgerStake, PerasPublicKey)) +unsafeExtendPerasStakeDistrWithPublicKeysFromEnv poolDistr = do + publicKeys <- unsafePerasBLSPublicKeysFromEnv -- uses 'unsafePerformIO' + Map.traverseWithKey + ( \poolId stake -> do + let ledgerStake = + LedgerStake (individualPoolStake stake) + case Map.lookup poolId publicKeys of + Nothing -> + Left ("Public key not found for pool: " <> show poolId) + Just publicKey -> + Right (ledgerStake, publicKey) + ) + . Map.mapKeysMonotonic PoolId + . unPoolDistr + $ poolDistr + +-- | Retrieve the BLS public keys for the Peras committee members from a JSON +-- file specified in the environment variable 'PERAS_PUBLIC_KEY_FILE'. +-- +-- WARNING: this is a temporary hack for testing purposes, and should not be +-- used under any circumstances in production. This will be replaced with proper +-- on-chain key registration in the future. +unsafePerasBLSPublicKeysFromEnv :: Either String (Map PoolId PerasPublicKey) +unsafePerasBLSPublicKeysFromEnv = + unsafePerformIO $ + lookupEnv envVar >>= \case + Nothing -> do + pure $ Left $ "Environment variable " <> envVar <> " not set." + Just keysFile -> do + eitherDecodeFileStrict' keysFile >>= \case + Left err -> do + pure $ Left $ "Failed to parse public keys from file: " <> err + Right rawKeys -> do + pure $ traverse decodeKey (Map.mapKeysMonotonic PoolId rawKeys) + where + envVar = + "PERAS_PUBLIC_KEY_FILE" + + keyScope = + "TESTNET" + + decodeKey key = + case BLS.rawDeserialisePublicKey keyScope (fromString key) of + Nothing -> + Left $ "Invalid public key format: " <> key + Just pk -> + Right $ + PerasPublicKey + { perasVoteVerKey = BLS.coercePublicKey @BLS.SIGN pk + , perasVRFVerKey = BLS.coercePublicKey @BLS.VRF pk + } +{-# NOINLINE unsafePerasBLSPublicKeysFromEnv #-} From 5c6efc59891f7af9763298a43a1743e552c83678 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 26 May 2026 14:22:13 +0200 Subject: [PATCH 41/62] Merge `PerasTargetVoteTally` and `ValidatedPerasVotesWithQuorum` --- .../Consensus/Block/SupportsPeras.hs | 262 ++++++++++++------ .../Ouroboros/Consensus/Peras/Cert/Mock.hs | 14 +- .../Consensus/Peras/Vote/Aggregation.hs | 241 ++++++---------- .../Ouroboros/Consensus/Util/Orphans.hs | 6 + 4 files changed, 286 insertions(+), 237 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 97342b3957..0857496803 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -29,41 +29,57 @@ module Ouroboros.Consensus.Block.SupportsPeras , VoidPerasError (..) , ValidatedPerasCert (..) , ValidatedPerasVote (..) - , ValidatedPerasVotesWithQuorum - ( vpvqTarget - , vpvqVotes - , vpvqPerasParams - ) - , votesReachQuorum , IsPerasVote (..) , getPerasVoteId , getPerasVoteTarget , IsPerasCert (..) , IsPerasError (..) + -- * Types and functions related to Peras vote collection and quorum checking + , PerasVoteCollectionWithQuorum (forgetQuorum) + , PerasVoteCollection + ( pvcTarget + , pvcVotes + , pvcTotalWeight + ) + , perasVoteCollectionSingleton + , perasVoteCollectionAddVote + , perasVoteCollectionCheckQuorum + , toUniqueVotesWithSameTarget + -- * Convenience re-exports , module Ouroboros.Consensus.Peras.Params , module Ouroboros.Consensus.Peras.Types ) where +import Control.Arrow ((&&&)) +import Control.Exception (assert) import Data.Bifunctor (bimap) import Data.Coerce (coerce) +import Data.Containers.NonEmpty (NE) import Data.Kind (Type) -import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty +import Data.Map (Map) +import qualified Data.Map.NonEmpty as NEMap +import Data.Ord (comparing) import Data.Typeable (Typeable) import Data.Void (Void, absurd) import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) -import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) +import Ouroboros.Consensus.Committee.Class + ( CryptoSupportsVotingCommittee (..) + , UniqueVotesWithSameTarget + , unsafeUniqueVotesWithSameTarget + ) import qualified Ouroboros.Consensus.Committee.Class as Committee import Ouroboros.Consensus.Committee.Crypto (ElectionId, PrivateKey, VoteCandidate) import Ouroboros.Consensus.Committee.Types (PoolId) import Ouroboros.Consensus.Peras.Params import Ouroboros.Consensus.Peras.Types import Ouroboros.Consensus.Util (ShowProxy) +import Ouroboros.Consensus.Util.Orphans () -- | The crypto scheme used for Peras votes and certificates -- @@ -162,15 +178,18 @@ class forgePerasCert :: PerasParams -> - ValidatedPerasVotesWithQuorum blk -> + PerasVoteCollectionWithQuorum blk -> Either (PerasError blk) (ValidatedPerasCert blk) default forgePerasCert :: PerasVote blk ~ VoidPerasVote blk => PerasParams -> - ValidatedPerasVotesWithQuorum blk -> + PerasVoteCollectionWithQuorum blk -> Either (PerasError blk) (ValidatedPerasCert blk) forgePerasCert _ votes = - absurd (unVoidPerasVote (vpvVote (NonEmpty.head (vpvqVotes votes)))) + absurd + ( unVoidPerasVote + (vpvVote . forgetArrivalTime . NonEmpty.head . NEMap.elems . pvcVotes . forgetQuorum $ votes) + ) -- | Extract a Peras certificate optionally stored in a block. -- @@ -340,76 +359,6 @@ deriving instance Ord (PerasCert blk) => Ord (ValidatedPerasCert blk) deriving instance NoThunks (PerasCert blk) => NoThunks (ValidatedPerasCert blk) deriving instance Generic (ValidatedPerasCert blk) --- | A collection of validated Peras votes that: --- 1. are all for the same target, and --- 2. have total stake above the quorum threshold for a given 'PerasCfg'. -data ValidatedPerasVotesWithQuorum blk - = ValidatedPerasVotesWithQuorum - { vpvqTarget :: !(PerasVoteTarget blk) - -- ^ The target that all the votes are for - , vpvqVotes :: !(NonEmpty (ValidatedPerasVote blk)) - -- ^ The votes that reached quorum for the given target - , vpvqPerasParams :: !PerasParams - -- ^ The Peras parameters used to validate that the votes reach quorum - } - -deriving instance - ( StandardHash blk - , Show (PerasVote blk) - ) => - Show (ValidatedPerasVotesWithQuorum blk) -deriving instance - ( StandardHash blk - , Eq (PerasVote blk) - ) => - Eq (ValidatedPerasVotesWithQuorum blk) -deriving instance - ( StandardHash blk - , NoThunks (PerasVote blk) - ) => - NoThunks (ValidatedPerasVotesWithQuorum blk) -deriving instance - Generic (ValidatedPerasVotesWithQuorum blk) - --- | Smart constructor for 'ValidatedPerasVotesReachingQuorum'. --- --- This function checks that all votes are for the same target, and that their --- total stake is above the quorum threshold defined in the given 'PerasCfg'. --- It returns 'Nothing' if either of these conditions is not met. -votesReachQuorum :: - ( StandardHash blk - , IsPerasVote (PerasVote blk) blk - ) => - PerasParams -> - [ValidatedPerasVote blk] -> - Maybe (ValidatedPerasVotesWithQuorum blk) -votesReachQuorum params votes = - case votes of - -- We need at least one vote to determine who these votes are for, so we - -- can't vacuously reach a quorum, even if the quorum threshold is 0. - [] -> Nothing - -- If we have at least one vote, we must check that all votes are for the - -- same target, and that their total weight is above the quorum threshold. - (v0 : vs) - | not (allVotesMatchTarget v0 vs) -> - Nothing - | not votesHaveEnoughWeight -> - Nothing - | otherwise -> - Just - ValidatedPerasVotesWithQuorum - { vpvqTarget = getPerasVoteTarget v0 - , vpvqVotes = v0 :| vs - , vpvqPerasParams = params - } - where - totalVoteWeight = - mconcat (vpvVoteWeight <$> votes) - votesHaveEnoughWeight = - weightAboveThreshold params totalVoteWeight - allVotesMatchTarget target = - all ((== (getPerasVoteTarget target)) . getPerasVoteTarget) - -- * Convenience projection/injection classes -- | Types that support being treated as Peras votes @@ -500,3 +449,154 @@ class where injectVotingCommitteeError :: PerasVotingCommitteeError blk -> err injectConversionError :: PerasConversionError -> err + +-------------------------------------------------------------------------------è + +-- | Collection of Peras votes for a given target. +-- +-- NOTE: votes in this collection are uniquely identified by their vote ID. +data PerasVoteCollection blk + = PerasVoteCollection + { pvcTarget :: !(PerasVoteTarget blk) + -- ^ The target of the votes in this collection + , pvcVotes :: !(NE (Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk)))) + -- ^ Votes received for this target, indexed by vote ID + , pvcTotalWeight :: !VoteWeight + -- ^ Total weight of the votes received for this target + } + +deriving instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (PerasVoteCollection blk) +deriving instance + ( StandardHash blk + , Eq (PerasVote blk) + , Eq (PerasCert blk) + ) => + Eq (PerasVoteCollection blk) +deriving instance + ( StandardHash blk + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + ) => + NoThunks (PerasVoteCollection blk) +deriving instance + Generic (PerasVoteCollection blk) + +-- | Smart constructor for 'PerasVoteCollection' from a single vote. +perasVoteCollectionSingleton :: + IsPerasVote (PerasVote blk) blk => + WithArrivalTime (ValidatedPerasVote blk) -> + PerasVoteCollection blk +perasVoteCollectionSingleton vote = + PerasVoteCollection + { pvcTarget = getPerasVoteTarget vote + , pvcVotes = NEMap.singleton (getPerasVoteId vote) vote + , pvcTotalWeight = vpvVoteWeight (forgetArrivalTime vote) + } + +-- | Add a vote to an existing vote collection if it isn't already present, and +-- update the total weight accordingly. +-- +-- PRECONDITION: the vote's target must match the collection's target. +perasVoteCollectionAddVote :: + ( StandardHash blk + , IsPerasVote (PerasVote blk) blk + ) => + WithArrivalTime (ValidatedPerasVote blk) -> + PerasVoteCollection blk -> + PerasVoteCollection blk +perasVoteCollectionAddVote vote pvc = + assert (getPerasVoteTarget vote == pvcTarget pvc) $ + pvc + { pvcVotes = pvcVotes' + , pvcTotalWeight = pvcTotalWeight' + } + where + swapVote = + NEMap.insertLookupWithKey + (\_k old _new -> old) + (getPerasVoteId vote) + + (pvcVotes', pvcTotalWeight') + -- key WAS NOT present → vote inserted and weight updated + | (Nothing, votes') <- swapVote vote (pvcVotes pvc) = + ( votes' + , pvcTotalWeight pvc + vpvVoteWeight (forgetArrivalTime vote) + ) + -- key WAS already present → votes and weight unchanged + | otherwise = + ( pvcVotes pvc + , pvcTotalWeight pvc + ) + +-- | A collection of Peras votes for a given target that has reached quorum +newtype PerasVoteCollectionWithQuorum blk + = PerasVoteCollectionWithQuorum {forgetQuorum :: PerasVoteCollection blk} + +deriving newtype instance + ( StandardHash blk + , Show (PerasVote blk) + , Show (PerasCert blk) + ) => + Show (PerasVoteCollectionWithQuorum blk) +deriving newtype instance + ( StandardHash blk + , Eq (PerasVote blk) + , Eq (PerasCert blk) + ) => + Eq (PerasVoteCollectionWithQuorum blk) +deriving newtype instance + ( StandardHash blk + , NoThunks (PerasVote blk) + , NoThunks (PerasCert blk) + ) => + NoThunks (PerasVoteCollectionWithQuorum blk) +deriving newtype instance + Generic (PerasVoteCollectionWithQuorum blk) + +-- | Smart constructor for 'PerasVoteCollectionWithQuorum' +perasVoteCollectionCheckQuorum :: + PerasParams -> + PerasVoteCollection blk -> + Maybe (PerasVoteCollectionWithQuorum blk) +perasVoteCollectionCheckQuorum params pvc = + case weightAboveThreshold params (pvcTotalWeight pvc) of + True -> Just (PerasVoteCollectionWithQuorum pvc) + False -> Nothing + +-- | Convert a collection of Peras votes that has reached quorum into the +-- corresponding abstract representation of votes used by the voting committee +-- to forge certificates. +-- +-- 'UniqueVotesWithSameTarget' and 'PerasVoteCollection' enforce the same +-- invariants, which are: +-- - The collection is not empty +-- - All votes have the same target +-- - All votes have a unique vote ID (or unique seat index, which is equivalent +-- assuming they also have the same target, see second point) +-- In addition to that, 'PerasVoteCollectionWithQuorum' guarantees that the +-- total weight of the votes is above the threshold. +toUniqueVotesWithSameTarget :: + ( vote ~ PerasVote blk + , crypto ~ PerasCrypto blk + , committee ~ PerasVotingCommitteeScheme blk + , ElectionId crypto ~ PerasRoundNo + , VoteCandidate crypto ~ BoostedBlock vote + , Eq (BoostedBlock vote) + , IsPerasVote vote blk + , Committee.Vote crypto committee ~ vote + ) => + PerasVoteCollectionWithQuorum blk -> + UniqueVotesWithSameTarget (PerasCrypto blk) (PerasVotingCommitteeScheme blk) +toUniqueVotesWithSameTarget (PerasVoteCollectionWithQuorum pvc) = + unsafeUniqueVotesWithSameTarget -- Skip redundant checks in production + (getPerasVoteRound &&& getPerasVoteBlock) + (comparing getPerasVoteId) + ( fmap (vpvVote . forgetArrivalTime) + . NEMap.elems + $ pvcVotes pvc + ) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs index d113dc0e66..63e1b7250b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs @@ -36,9 +36,10 @@ import Ouroboros.Consensus.Block.SupportsPeras , IsPerasCert (..) , PerasParams (..) , PerasRoundNo + , PerasVoteCollection (pvcTarget) + , PerasVoteCollectionWithQuorum (..) , PerasVoteTarget (..) , ValidatedPerasCert (..) - , ValidatedPerasVotesWithQuorum (..) ) import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..)) import Ouroboros.Consensus.Util (ShowProxy) @@ -134,15 +135,16 @@ forgeMockPerasCert :: forall blk. PerasCert blk ~ MockPerasCert blk => PerasParams -> - ValidatedPerasVotesWithQuorum blk -> + PerasVoteCollectionWithQuorum blk -> Either (PerasError blk) (ValidatedPerasCert blk) -forgeMockPerasCert params votes = - return $ +forgeMockPerasCert params votes = do + let target = pvcTarget . forgetQuorum $ votes + Right ValidatedPerasCert { vpcCert = MockPerasCert - { mockCertRound = pvtRoundNo (vpvqTarget votes) - , mockCertBlock = pvtBlock (vpvqTarget votes) + { mockCertRound = pvtRoundNo target + , mockCertBlock = pvtBlock target } , vpcCertBoost = perasWeight params } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs index 74ef49ca43..41cf23172b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs @@ -68,7 +68,7 @@ -- its logically split between separate 'NoQuorum' and 'Quorum' types -- representing the two states (1) and (2) described above, respectively. -- * 'PerasTargetVoteState': tracks votes for one specific block target --- * 'PerasTargetVoteTally': raw vote count and weight accumulation +-- * 'PerasVoteCollection': raw vote count and weight accumulation -- * 'PerasTargetVoteStatus': type-level status (Candidate/Winner/Loser) -- * 'UpdateRoundVoteStateError': errors from invalid state transitions -- @@ -90,6 +90,7 @@ module Ouroboros.Consensus.Peras.Vote.Aggregation , PerasTargetVoteState , getPerasTargetVoteStateTotalWeight , getPerasTargetVoteStateBlock + , PerasVoteCollectionWithQuorum (..) ) where import Cardano.Prelude (fromMaybe) @@ -101,7 +102,7 @@ import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block -import Ouroboros.Consensus.BlockchainTime (WithArrivalTime, forgetArrivalTime) +import Ouroboros.Consensus.BlockchainTime (WithArrivalTime) {------------------------------------------------------------------------------- Voting state for a given Peras round @@ -276,15 +277,13 @@ updatePerasRoundVoteState vote params roundState = { candidateStates } } -> do - let oldCandidateState = - Map.findWithDefault - (freshCandidateVoteState (getPerasVoteTarget vote)) - (getPerasVotePoint vote) - candidateStates + let updateMaybeCandidateState = \case + Nothing -> + candidateOrWinnerVoteStateSingleton params vote + Just oldCandidateState -> + updateCandidateVoteState params vote oldCandidateState candidateOrWinnerState <- - updateCandidateVoteState params vote oldCandidateState - `onErr` \err -> - RoundVoteStateForgingCertError err + updateMaybeCandidateState (Map.lookup (getPerasVotePoint vote) candidateStates) case candidateOrWinnerState of RemainedCandidate newCandidateState -> do -- Quorum still not reached for this round @@ -304,7 +303,7 @@ updatePerasRoundVoteState vote params roundState = BecameWinner winnerState -> do -- Quorum has been reached for the first time here for this round let winnerPoint = - pvtBlock (ptvtTarget (ptvsVoteTally winnerState)) + pvtBlock (pvcTarget (ptvsVoteCollection winnerState)) loserStates = candidateToLoser <$> Map.delete winnerPoint candidateStates pure $ @@ -333,7 +332,7 @@ updatePerasRoundVoteState vote params roundState = let votePoint = getPerasVotePoint vote winnerPoint = - pvtBlock (ptvtTarget (ptvsVoteTally winnerState)) + pvtBlock (pvcTarget (ptvsVoteCollection winnerState)) if votePoint == winnerPoint -- The vote ratifies the winner => update winner state then do @@ -352,14 +351,14 @@ updatePerasRoundVoteState vote params roundState = -- The vote is for a loser => update loser state else do - let existingOrFreshLoserVoteState = - fromMaybe (freshLoserVoteState (getPerasVoteTarget vote)) - updateMaybeLoserVoteState mState = - fmap Just $ - updateLoserVoteState params vote (existingOrFreshLoserVoteState mState) - `onErr` \err -> - RoundVoteStateLoserAboveQuorum winnerState err - loserStates' <- Map.alterF updateMaybeLoserVoteState votePoint loserStates + let updateMaybeLoserVoteState = \case + Nothing -> + loserVoteStateSingleton params winnerState vote + Just oldLoserState -> + updateLoserVoteState params winnerState vote oldLoserState + + loserStates' <- + Map.alterF (\mState -> Just <$> updateMaybeLoserVoteState mState) votePoint loserStates pure $ state { prvsState = @@ -461,86 +460,6 @@ voteGeneratedCert = \case _ -> Nothing -{------------------------------------------------------------------------------- - Peras target vote tally --------------------------------------------------------------------------------} - --- | Tally of votes for a given target (round number and block point) -data PerasTargetVoteTally blk = PerasTargetVoteTally - { ptvtTarget :: !(PerasVoteTarget blk) - -- ^ What we are tallying votes for - , ptvtVotes :: !(Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))) - -- ^ Votes received for this target, indexed by vote ID - , ptvtTotalWeight :: !VoteWeight - -- ^ Total weight of the votes received for this target - } - -deriving instance - ( StandardHash blk - , Show (PerasVoteTarget blk) - , Show (ValidatedPerasVote blk) - ) => - Show (PerasTargetVoteTally blk) -deriving instance - ( StandardHash blk - , Eq (PerasVoteTarget blk) - , Eq (ValidatedPerasVote blk) - ) => - Eq (PerasTargetVoteTally blk) -deriving instance - ( StandardHash blk - , NoThunks (PerasVoteTarget blk) - , NoThunks (ValidatedPerasVote blk) - ) => - NoThunks (PerasTargetVoteTally blk) -deriving instance - Generic (PerasTargetVoteTally blk) - -freshTargetVoteTally :: PerasVoteTarget blk -> PerasTargetVoteTally blk -freshTargetVoteTally target = - PerasTargetVoteTally - { ptvtTarget = target - , ptvtVotes = Map.empty - , ptvtTotalWeight = VoteWeight 0 - } - --- | Add a vote to an existing target tally if it isn't already present, --- and update the weight accordingly. --- --- PRECONDITION: the vote's target must match the tally's target. -updateTargetVoteTally :: - ( StandardHash blk - , IsPerasVote (PerasVote blk) blk - ) => - WithArrivalTime (ValidatedPerasVote blk) -> - PerasTargetVoteTally blk -> - PerasTargetVoteTally blk -updateTargetVoteTally - vote - ptvt@PerasTargetVoteTally - { ptvtVotes - , ptvtTarget - , ptvtTotalWeight - } = - assert (getPerasVoteTarget vote == ptvtTarget) $ do - ptvt - { ptvtVotes = pvaVotes' - , ptvtTotalWeight = pvaTotalWeight' - } - where - swapVote = - Map.insertLookupWithKey - (\_k old _new -> old) - (getPerasVoteId vote) - - (pvaVotes', pvaTotalWeight') - -- key WAS NOT present → vote inserted and weight updated - | (Nothing, votes') <- swapVote vote ptvtVotes = - (votes', ptvtTotalWeight + vpvVoteWeight (forgetArrivalTime vote)) - -- key WAS already present → votes and weight unchanged - | otherwise = - (ptvtVotes, ptvtTotalWeight) - {------------------------------------------------------------------------------- Peras target vote status -------------------------------------------------------------------------------} @@ -558,36 +477,36 @@ data PerasTargetVoteStatus -- We indicate at type level the status of the target w.r.t the voting process. data PerasTargetVoteState blk (status :: PerasTargetVoteStatus) where PerasTargetVoteCandidate :: - !(PerasTargetVoteTally blk) -> + !(PerasVoteCollection blk) -> PerasTargetVoteState blk 'Candidate PerasTargetVoteLoser :: - !(PerasTargetVoteTally blk) -> + !(PerasVoteCollection blk) -> PerasTargetVoteState blk 'Loser PerasTargetVoteWinner :: - !(PerasTargetVoteTally blk) -> + !(PerasVoteCollection blk) -> !(ValidatedPerasCert blk) -> PerasTargetVoteState blk 'Winner deriving stock instance - ( Eq (PerasTargetVoteTally blk) + ( Eq (PerasVoteCollection blk) , Eq (ValidatedPerasCert blk) ) => Eq (PerasTargetVoteState blk status) deriving stock instance - ( Ord (PerasTargetVoteTally blk) + ( Ord (PerasVoteCollection blk) , Ord (ValidatedPerasCert blk) ) => Ord (PerasTargetVoteState blk status) deriving stock instance - ( Show (PerasTargetVoteTally blk) + ( Show (PerasVoteCollection blk) , Show (ValidatedPerasCert blk) ) => Show (PerasTargetVoteState blk status) instance - ( NoThunks (PerasTargetVoteTally blk) + ( NoThunks (PerasVoteCollection blk) , NoThunks (ValidatedPerasCert blk) ) => NoThunks (PerasTargetVoteState blk status) @@ -598,35 +517,57 @@ instance -- we can just delegate wNoThunks to our custom noThunks wNoThunks = noThunks - noThunks ctx (PerasTargetVoteCandidate tally) = - noThunks ctx tally - noThunks ctx (PerasTargetVoteLoser tally) = - noThunks ctx tally - noThunks ctx (PerasTargetVoteWinner tally cert) = - noThunks ctx (tally, cert) + noThunks ctx (PerasTargetVoteCandidate voteCollection) = + noThunks ctx voteCollection + noThunks ctx (PerasTargetVoteLoser voteCollection) = + noThunks ctx voteCollection + noThunks ctx (PerasTargetVoteWinner voteCollection cert) = + noThunks ctx (voteCollection, cert) -- | Extract the total weight from a target vote state getPerasTargetVoteStateTotalWeight :: PerasTargetVoteState blk status -> VoteWeight -getPerasTargetVoteStateTotalWeight = ptvtTotalWeight . ptvsVoteTally +getPerasTargetVoteStateTotalWeight = pvcTotalWeight . ptvsVoteCollection -- | Extract the block point from a target vote state getPerasTargetVoteStateBlock :: PerasTargetVoteState blk status -> Point blk -getPerasTargetVoteStateBlock = pvtBlock . ptvtTarget . ptvsVoteTally +getPerasTargetVoteStateBlock = pvtBlock . pvcTarget . ptvsVoteCollection --- | Extract the underlying vote tally from a target vote state -ptvsVoteTally :: PerasTargetVoteState blk status -> PerasTargetVoteTally blk -ptvsVoteTally = \case - PerasTargetVoteCandidate tally -> tally - PerasTargetVoteLoser tally -> tally - PerasTargetVoteWinner tally _ -> tally +-- | Extract the underlying vote voteCollection from a target vote state +ptvsVoteCollection :: PerasTargetVoteState blk status -> PerasVoteCollection blk +ptvsVoteCollection = \case + PerasTargetVoteCandidate voteCollection -> voteCollection + PerasTargetVoteLoser voteCollection -> voteCollection + PerasTargetVoteWinner voteCollection _ -> voteCollection -freshCandidateVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Candidate -freshCandidateVoteState target = - PerasTargetVoteCandidate (freshTargetVoteTally target) - -freshLoserVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Loser -freshLoserVoteState target = - PerasTargetVoteLoser (freshTargetVoteTally target) +candidateOrWinnerVoteStateSingleton :: + BlockSupportsPeras blk => + PerasParams -> + WithArrivalTime (ValidatedPerasVote blk) -> + Either + (UpdateRoundVoteStateError blk) + (PerasVoteStateCandidateOrWinner blk) +candidateOrWinnerVoteStateSingleton params vote = + let voteCollection = perasVoteCollectionSingleton vote + in case perasVoteCollectionCheckQuorum params voteCollection of + Just votesWithQuorum -> do + cert <- forgePerasCert params votesWithQuorum `onErr` RoundVoteStateForgingCertError + pure $ BecameWinner $ PerasTargetVoteWinner voteCollection cert + Nothing -> + pure $ RemainedCandidate $ PerasTargetVoteCandidate voteCollection + +loserVoteStateSingleton :: + IsPerasVote (PerasVote blk) blk => + PerasParams -> + PerasTargetVoteState blk 'Winner -> + WithArrivalTime (ValidatedPerasVote blk) -> + Either (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser) +loserVoteStateSingleton params winnerState vote = + let voteCollection = perasVoteCollectionSingleton vote + in case perasVoteCollectionCheckQuorum params voteCollection of + Just _ -> + Left $ RoundVoteStateLoserAboveQuorum winnerState (PerasTargetVoteLoser voteCollection) + Nothing -> + Right $ PerasTargetVoteLoser voteCollection -- | Convert a 'Candidate' state to a 'Loser' state. -- @@ -635,8 +576,8 @@ freshLoserVoteState target = candidateToLoser :: PerasTargetVoteState blk 'Candidate -> PerasTargetVoteState blk 'Loser -candidateToLoser (PerasTargetVoteCandidate tally) = - PerasTargetVoteLoser tally +candidateToLoser (PerasTargetVoteCandidate voteCollection) = + PerasTargetVoteLoser voteCollection -- | Subtype of 'PerasTargetVoteState' to indicate whether the target remains a -- candidate or has been elected winner @@ -653,23 +594,22 @@ updateCandidateVoteState :: WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Candidate -> Either - (PerasError blk) + (UpdateRoundVoteStateError blk) (PerasVoteStateCandidateOrWinner blk) updateCandidateVoteState params vote oldState = let - newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState) - voteList = forgetArrivalTime <$> Map.elems (ptvtVotes newVoteTally) + newVoteCollection = perasVoteCollectionAddVote vote (ptvsVoteCollection oldState) in - case votesReachQuorum params voteList of + case perasVoteCollectionCheckQuorum params newVoteCollection of Just votesWithQuorum -> do - cert <- forgePerasCert params votesWithQuorum - pure $ BecameWinner (PerasTargetVoteWinner newVoteTally cert) + cert <- forgePerasCert params votesWithQuorum `onErr` RoundVoteStateForgingCertError + pure $ BecameWinner (PerasTargetVoteWinner newVoteCollection cert) Nothing -> do - pure $ RemainedCandidate (PerasTargetVoteCandidate newVoteTally) + pure $ RemainedCandidate (PerasTargetVoteCandidate newVoteCollection) -- | Add a vote to an existing target vote state if it isn't already present. -- --- PRECONDITION: the vote's target must match the underlying tally's target. +-- PRECONDITION: the vote's target must match the underlying voteCollection's target. -- -- May fail if the loser goes above quorum by adding the vote. updateLoserVoteState :: @@ -677,20 +617,21 @@ updateLoserVoteState :: , IsPerasVote (PerasVote blk) blk ) => PerasParams -> + PerasTargetVoteState blk 'Winner -> WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Loser -> - Either (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser) -updateLoserVoteState params vote oldState = - assert (getPerasVoteTarget vote == ptvtTarget (ptvsVoteTally oldState)) $ do - let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState) - aboveQuorum = weightAboveThreshold params (ptvtTotalWeight newVoteTally) - in if aboveQuorum - then Left $ PerasTargetVoteLoser newVoteTally - else Right $ PerasTargetVoteLoser newVoteTally + Either (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser) +updateLoserVoteState params winnerState vote oldState = + assert (getPerasVoteTarget vote == pvcTarget (ptvsVoteCollection oldState)) $ do + let newVoteCollection = perasVoteCollectionAddVote vote (ptvsVoteCollection oldState) + in case perasVoteCollectionCheckQuorum params newVoteCollection of + Just _ -> + Left $ RoundVoteStateLoserAboveQuorum winnerState (PerasTargetVoteLoser newVoteCollection) + Nothing -> Right $ PerasTargetVoteLoser newVoteCollection -- | Add a vote to an existing target vote state if it isn't already present. -- --- PRECONDITION: the vote's target must match the underlying tally's target. +-- PRECONDITION: the vote's target must match the underlying voteCollection's target. updateWinnerVoteState :: ( StandardHash blk , IsPerasVote (PerasVote blk) blk @@ -699,10 +640,10 @@ updateWinnerVoteState :: PerasTargetVoteState blk 'Winner -> PerasTargetVoteState blk 'Winner updateWinnerVoteState vote oldState = - assert (getPerasVoteTarget vote == ptvtTarget (ptvsVoteTally oldState)) $ do - let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState) + assert (getPerasVoteTarget vote == pvcTarget (ptvsVoteCollection oldState)) $ do + let newVoteCollection = perasVoteCollectionAddVote vote (ptvsVoteCollection oldState) (PerasTargetVoteWinner _ cert) = oldState - in PerasTargetVoteWinner newVoteTally cert + in PerasTargetVoteWinner newVoteCollection cert {------------------------------------------------------------------------------- Helpers diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index 8b7e867427..bf9199c278 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -19,6 +19,8 @@ import Codec.Serialise (Serialise (..)) import Control.Tracer (Tracer) import Data.IntPSQ (IntPSQ) import qualified Data.IntPSQ as PSQ +import Data.Map.NonEmpty (NEMap) +import qualified Data.Map.NonEmpty as NEMap import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MultiSet import Data.SOP.BasicFunctors @@ -90,6 +92,10 @@ instance NoThunks a => NoThunks (MultiSet a) where showTypeOf _ = "MultiSet" wNoThunks ctxt = wNoThunks ctxt . MultiSet.toMap +instance (NoThunks k, NoThunks v) => NoThunks (NEMap k v) where + showTypeOf _ = "NEMap" + wNoThunks ctxt = wNoThunks ctxt . NEMap.toMap + instance NoThunks StdGen where showTypeOf _ = "StdGen" wNoThunks ctx = wNoThunks ctx . OnlyCheckWhnf . Random.unStdGen From a9bcb0fde59c08e27606f4b12983aeeab4345422 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 27 May 2026 15:52:49 +0200 Subject: [PATCH 42/62] Update interface `BlockSupportsPeras` and add concrete default implementation properly using committee --- .../Ouroboros/Consensus/Shelley/Node/Peras.hs | 4 +- .../Consensus/Protocol/Praos/Peras.hs | 6 +- .../Consensus/Block/SupportsPeras.hs | 372 ++++++++++++------ .../Ouroboros/Consensus/Committee/Class.hs | 27 +- .../Consensus/HardFork/Combinator/Basics.hs | 4 +- .../ObjectDiffusion/ObjectPool/PerasCert.hs | 4 +- .../ObjectDiffusion/ObjectPool/PerasVote.hs | 4 +- .../Ouroboros/Consensus/Peras/Cert/Mock.hs | 2 +- .../Ouroboros/Consensus/Peras/Error/V1.hs | 4 + .../Consensus/Peras/Vote/Aggregation.hs | 59 ++- .../Ouroboros/Consensus/Peras/Vote/Mock.hs | 2 +- .../Test/Ouroboros/Storage/TestBlock.hs | 4 +- .../Test/Util/TestBlock.hs | 4 +- 13 files changed, 310 insertions(+), 186 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs index 73674823d1..8fcafa56f2 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -57,8 +57,8 @@ instance type PerasCert (ShelleyBlock proto DijkstraEra) = MockPerasCert (ShelleyBlock proto DijkstraEra) type PerasError (ShelleyBlock proto DijkstraEra) = VoidPerasError (ShelleyBlock proto DijkstraEra) - validatePerasVote = validateMockPerasVote - validatePerasCert = validateMockPerasCert + verifyPerasVote = validateMockPerasVote + verifyPerasCert = validateMockPerasCert forgePerasCert = forgeMockPerasCert -- TODO: extract actual Peras certificates from blocks diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs index 9c7ad03a40..c25b23cad1 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -63,10 +63,10 @@ instance BlockSupportsPeras RealBlock where type PerasError RealBlock = V1.PerasError RealBlock -- TODO: uncomment as soon as we add this method to 'BlockSupportsPeras' - -- forgePerasVoteIfEligible = implPerasForgeVoteIfEligible + -- forgePerasVoteIfEligible = implForgePerasVoteIfEligible forgePerasCert = undefined - validatePerasVote = undefined - validatePerasCert = undefined + verifyPerasVote = undefined + verifyPerasCert = undefined instance PraosStateSupportsPerasVoting RealBlock where praosStatePerasVotingCommitteeInput _ perasParams tickedPraosState = do diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 0857496803..726b9d48a9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -7,12 +7,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} module Ouroboros.Consensus.Block.SupportsPeras ( PerasCrypto @@ -23,7 +25,6 @@ module Ouroboros.Consensus.Block.SupportsPeras , BlockSupportsPeras (..) , PerasVoteCompatibleWithVotingCommittee (..) , PerasCertCompatibleWithVotingCommittee (..) - , implPerasForgeVoteIfEligible , VoidPerasVote (..) , VoidPerasCert (..) , VoidPerasError (..) @@ -55,14 +56,14 @@ module Ouroboros.Consensus.Block.SupportsPeras import Control.Arrow ((&&&)) import Control.Exception (assert) import Data.Bifunctor (bimap) -import Data.Coerce (coerce) import Data.Containers.NonEmpty (NE) import Data.Kind (Type) import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map.NonEmpty as NEMap import Data.Ord (comparing) -import Data.Typeable (Typeable) +import Data.Traversable (for) +import Data.Typeable (Proxy, Typeable) import Data.Void (Void, absurd) import GHC.Generics (Generic) import NoThunks.Class @@ -71,33 +72,23 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Committee.Class ( CryptoSupportsVotingCommittee (..) , UniqueVotesWithSameTarget + , getRawVotes , unsafeUniqueVotesWithSameTarget ) import qualified Ouroboros.Consensus.Committee.Class as Committee -import Ouroboros.Consensus.Committee.Crypto (ElectionId, PrivateKey, VoteCandidate) +import Ouroboros.Consensus.Committee.Crypto + ( CryptoSupportsVoteSigning (..) + , ElectionId + , PrivateKey + , PublicKey + , VoteCandidate + ) import Ouroboros.Consensus.Committee.Types (PoolId) import Ouroboros.Consensus.Peras.Params import Ouroboros.Consensus.Peras.Types import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Consensus.Util.Orphans () --- | The crypto scheme used for Peras votes and certificates --- --- Used to dispatch a block type to a its corresponding voting crypto scheme. --- --- TODO: maybe move this inside 'BlockSupportsPeras'. --- TODO: add eq constraints ( ElectionId (PerasCrypto blk) ~ PerasRoundNo --- , VoteCandidate (PerasCrypto blk) ~ Point blk) --- in BlockSupportsPeras -type family PerasCrypto blk :: Type - --- | The voting committee scheme used for Peras. --- --- Used to dispatch a block type to a its corresponding voting committee scheme. --- --- TODO: maybe move this inside 'BlockSupportsPeras'. -type family PerasVotingCommitteeScheme blk :: Type - -- | Voting committee for Peras indexed by block type type PerasVotingCommittee blk = VotingCommittee @@ -121,23 +112,39 @@ type PerasVotingCommitteeInput blk = -- TODO: Add CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) as a superclass constraint of 'BlockSupportsPeras' class - ( StandardHash blk + ( -- blk related constraints + StandardHash blk , Typeable blk - , Typeable (PerasVote blk) - , Typeable (PerasCert blk) - , Typeable (PerasError blk) + , -- PerasVote constraints + Typeable (PerasVote blk) , Show (PerasVote blk) - , Show (PerasCert blk) - , Show (PerasError blk) , Eq (PerasVote blk) - , Eq (PerasCert blk) - , Eq (PerasError blk) , NoThunks (PerasVote blk) - , NoThunks (PerasCert blk) - , NoThunks (PerasError blk) , IsPerasVote (PerasVote blk) blk + , -- PerasCert constraints + Typeable (PerasCert blk) + , Show (PerasCert blk) + , Eq (PerasCert blk) + , NoThunks (PerasCert blk) , IsPerasCert (PerasCert blk) blk + , -- PerasError constraints + Typeable (PerasError blk) + , Show (PerasError blk) + , Eq (PerasError blk) + , NoThunks (PerasError blk) , IsPerasError (PerasError blk) blk + , -- Compatiblity with committee/crypto + CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) + , ElectionId (PerasCrypto blk) ~ PerasRoundNo + , VoteCandidate (PerasCrypto blk) ~ Point blk + , PerasVoteCompatibleWithVotingCommittee + (PerasVote blk) + (PerasCrypto blk) + (PerasVotingCommitteeScheme blk) + , PerasCertCompatibleWithVotingCommittee + (PerasCert blk) + (PerasCrypto blk) + (PerasVotingCommitteeScheme blk) ) => BlockSupportsPeras blk where @@ -150,46 +157,142 @@ class type PerasError blk = (err :: Type) | err -> blk type PerasError blk = VoidPerasError blk - validatePerasVote :: - PerasParams -> - VoteWeightDistr -> + -- | The crypto scheme used for Peras votes and certificates + -- + -- Used to dispatch a block type to a its corresponding voting crypto scheme. + type PerasCrypto blk :: Type + + type PerasCrypto blk = VoidPerasCrypto blk + + -- | The voting committee scheme used for Peras. + -- + -- Used to dispatch a block type to a its corresponding voting committee scheme. + type PerasVotingCommitteeScheme blk :: Type + + type PerasVotingCommitteeScheme blk = VoidPerasVotingCommitteeScheme + + type PerasEpochContext blk = (context :: Type) | context -> blk + type PerasEpochContext blk = (PerasVotingCommittee blk, PerasParams) + + pecPerasParams :: PerasEpochContext blk -> PerasParams + default pecPerasParams :: + PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams) => + PerasEpochContext blk -> + PerasParams + pecPerasParams (_committee, params) = params + + forgePerasVoteIfEligible :: + PerasEpochContext blk -> + PoolId -> + PrivateKey (PerasCrypto blk) -> + PerasRoundNo -> + Point blk -> + Either (PerasError blk) (Maybe (ValidatedPerasVote blk)) + default forgePerasVoteIfEligible :: + PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams) => + PerasEpochContext blk -> + PoolId -> + PrivateKey (PerasCrypto blk) -> + PerasRoundNo -> + Point blk -> + Either (PerasError blk) (Maybe (ValidatedPerasVote blk)) + forgePerasVoteIfEligible (committee, _params) ourId ourPrivateKey roundNo point = do + mWitness <- + bimap injectVotingCommitteeError id $ + Committee.checkShouldVote committee ourId ourPrivateKey roundNo + for mWitness $ \witness -> do + let voteWeight = eligiblePartyVoteWeight committee witness + abstractVote = Committee.forgeVote witness ourPrivateKey roundNo point + concreteVote <- + bimap injectConversionError id $ + toPerasVote @(PerasVote blk) abstractVote + pure $ + ValidatedPerasVote + { vpvVote = concreteVote + , vpvVoteWeight = voteWeight + } + + verifyPerasVote :: + PerasEpochContext blk -> PerasVote blk -> Either (PerasError blk) (ValidatedPerasVote blk) - default validatePerasVote :: - PerasVote blk ~ VoidPerasVote blk => - PerasParams -> - VoteWeightDistr -> + default verifyPerasVote :: + PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams) => + PerasEpochContext blk -> PerasVote blk -> Either (PerasError blk) (ValidatedPerasVote blk) - validatePerasVote _ _ vote = - absurd (unVoidPerasVote vote) - - validatePerasCert :: - PerasParams -> - PerasCert blk -> - Either (PerasError blk) (ValidatedPerasCert blk) - default validatePerasCert :: - PerasCert blk ~ VoidPerasCert blk => - PerasParams -> - PerasCert blk -> - Either (PerasError blk) (ValidatedPerasCert blk) - validatePerasCert _ cert = - absurd (unVoidPerasCert cert) + verifyPerasVote (committee, _params) vote = do + -- NOTE: checking that the voted point is not from the future w.r.t. the + -- starting slot of the 'PerasRoundNo' will have to be done at the HFC level + -- since here we don't have 'PerasRoundNo' -> 'SlotNo' resolution device. + abstractVote <- + bimap injectConversionError id $ + fromPerasVote @(PerasVote blk) vote + witness <- + bimap injectVotingCommitteeError id $ + Committee.verifyVote committee abstractVote + let voteWeight = eligiblePartyVoteWeight committee witness + pure $ + ValidatedPerasVote + { vpvVote = vote + , vpvVoteWeight = voteWeight + } forgePerasCert :: - PerasParams -> + PerasEpochContext blk -> PerasVoteCollectionWithQuorum blk -> Either (PerasError blk) (ValidatedPerasCert blk) default forgePerasCert :: - PerasVote blk ~ VoidPerasVote blk => - PerasParams -> + PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams) => + PerasEpochContext blk -> PerasVoteCollectionWithQuorum blk -> Either (PerasError blk) (ValidatedPerasCert blk) - forgePerasCert _ votes = - absurd - ( unVoidPerasVote - (vpvVote . forgetArrivalTime . NonEmpty.head . NEMap.elems . pvcVotes . forgetQuorum $ votes) - ) + forgePerasCert (_committee, params) voteCollection = do + abstractVoteCollection <- + bimap injectConversionError id $ + toUniqueVotesWithSameTarget voteCollection + abstractCert <- + bimap injectVotingCommitteeError id $ + Committee.forgeCert abstractVoteCollection + concreteCert <- + bimap injectConversionError id $ + toPerasCert abstractCert + pure $ + ValidatedPerasCert + { vpcCert = concreteCert + , vpcCertBoost = perasWeight params + } + + verifyPerasCert :: + PerasEpochContext blk -> + PerasCert blk -> + Either (PerasError blk) (ValidatedPerasCert blk) + default verifyPerasCert :: + PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams) => + PerasEpochContext blk -> + PerasCert blk -> + Either (PerasError blk) (ValidatedPerasCert blk) + verifyPerasCert (committee, params) cert = do + -- NOTE: checking that the voted point is not from the future w.r.t. the + -- starting slot of the 'PerasRoundNo' will have to be done at the HFC level + -- since here we don't have 'PerasRoundNo' -> 'SlotNo' resolution device. + abstractCert <- + bimap injectConversionError id $ + fromPerasCert @(PerasCert blk) cert + witnesses <- + bimap injectVotingCommitteeError id $ + Committee.verifyCert committee abstractCert + let totalVoteWeight = sum (fmap (eligiblePartyVoteWeight committee) witnesses) + if weightAboveThreshold params totalVoteWeight + then + pure $ + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasWeight params + } + else + Left $ + injectQuorumNotReachedError totalVoteWeight -- | Extract a Peras certificate optionally stored in a block. -- @@ -234,58 +337,6 @@ class cert -> Either PerasConversionError (Committee.Cert crypto committee) -implPerasForgeVoteIfEligible :: - forall blk. - ( ElectionId (PerasCrypto blk) ~ PerasRoundNo -- TODO Remove later - , VoteCandidate (PerasCrypto blk) ~ Point blk -- TODO Remove later - , IsPerasError (PerasError blk) blk - , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) -- TODO maybe remove this once part of 'BlockSupportsPeras' constraints - , PerasVoteCompatibleWithVotingCommittee - (PerasVote blk) - (PerasCrypto blk) - (PerasVotingCommitteeScheme blk) - ) => - PerasVotingCommittee blk -> - PoolId -> - PrivateKey (PerasCrypto blk) -> - PerasRoundNo -> - Point blk -> - Either (PerasError blk) (Maybe (ValidatedPerasVote blk)) -implPerasForgeVoteIfEligible - committee - ourId - ourPrivateKey - roundNo - boostedBlock = - do - mWitness <- - bimap injectVotingCommitteeError id $ - Committee.checkShouldVote - committee - ourId - ourPrivateKey - roundNo - case mWitness of - Nothing -> - Right Nothing - Just witness -> - Just <$> do - let voteWeight = eligiblePartyVoteWeight committee witness - abstractVote = - Committee.forgeVote - witness - ourPrivateKey - roundNo - (boostedBlockToPoint boostedBlock) - concreteVote <- - bimap injectConversionError id $ - toPerasVote @(PerasVote blk) abstractVote - pure $ - ValidatedPerasVote - { vpvVote = concreteVote - , vpvVoteWeight = coerce voteWeight - } - -- * Helpers to derive @BlockSupportsPeras@ for block types without Peras support -- | Imposible Peras vote for @blk@. @@ -333,6 +384,69 @@ instance IsPerasError (VoidPerasError blk) blk where injectConversionError _ = error "injectConversionError: VoidPerasError cannot be inhabited" + injectQuorumNotReachedError _ = + error "injectQuorumNotReachedError: VoidPerasError cannot be inhabited" + +-- | Void Peras committee for @blk@. +data VoidPerasVotingCommitteeScheme + +data VoidPerasCrypto blk + +type instance ElectionId (VoidPerasCrypto blk) = PerasRoundNo +type instance VoteCandidate (VoidPerasCrypto blk) = Point blk + +type instance PrivateKey (VoidPerasCrypto blk) = Void +type instance PublicKey (VoidPerasCrypto blk) = Void + +instance CryptoSupportsVoteSigning (VoidPerasCrypto blk) where + type VoteSigningKey (VoidPerasCrypto blk) = Void + + -- \| Key used for verifying votes + type VoteVerificationKey (VoidPerasCrypto blk) = Void + + -- \| Cryptographic signature of a vote + data VoteSignature (VoidPerasCrypto blk) = VoidVoteSignature {unVoidVoteSignature :: Void} + getVoteSigningKey _proxy privateKey = absurd privateKey + getVoteVerificationKey _proxy publicKey = absurd publicKey + signVote signingKey _ _ = absurd signingKey + verifyVoteSignature verificationKey _ _ _ = absurd verificationKey + +instance CryptoSupportsVotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme where + data VotingCommitteeError (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme = VoidPerasVotingCommitteeError {unVoidPerasVotingCommitteeError :: Void} + data VotingCommitteeInput (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme = VoidPerasVotingCommitteeInput {unVoidPerasVotingCommitteeInput :: Void} + data VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme = VoidPerasVotingCommittee {unVoidPerasVotingCommittee :: Void} + data EligibilityWitness (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme = VoidPerasEligibilityWitness {unVoidPerasEligibilityWitness :: Void} + data Cert (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme = Cert {unCommitteeCert :: VoidPerasCert blk} + data Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme = Vote {unCommitteeVote :: VoidPerasVote blk} + + mkVotingCommittee (VoidPerasVotingCommitteeInput void) = absurd void + checkShouldVote (VoidPerasVotingCommittee void) _ _ _ = absurd void + forgeVote (VoidPerasEligibilityWitness void) _ _ _ = absurd void + verifyVote (VoidPerasVotingCommittee void) _ = absurd void + eligiblePartyVoteWeight (VoidPerasVotingCommittee void) _ = absurd void + forgeCert uniqueVotes = absurd . unVoidPerasVote . unCommitteeVote . NonEmpty.head . getRawVotes $ uniqueVotes + verifyCert (VoidPerasVotingCommittee void) _ = absurd void + voteTarget (Vote (VoidPerasVote void)) = absurd void + compareVotesById (Vote (VoidPerasVote void)) _ = absurd void + +instance + PerasVoteCompatibleWithVotingCommittee + (VoidPerasVote blk) + (VoidPerasCrypto blk) + VoidPerasVotingCommitteeScheme + where + toPerasVote = absurd . unVoidPerasVote . unCommitteeVote + fromPerasVote = absurd . unVoidPerasVote + +instance + PerasCertCompatibleWithVotingCommittee + (VoidPerasCert blk) + (VoidPerasCrypto blk) + VoidPerasVotingCommitteeScheme + where + toPerasCert = absurd . unVoidPerasCert . unCommitteeCert + fromPerasCert = absurd . unVoidPerasCert + -- * Validated types data ValidatedPerasVote blk @@ -449,6 +563,7 @@ class where injectVotingCommitteeError :: PerasVotingCommitteeError blk -> err injectConversionError :: PerasConversionError -> err + injectQuorumNotReachedError :: VoteWeight -> err -------------------------------------------------------------------------------è @@ -560,11 +675,12 @@ deriving newtype instance -- | Smart constructor for 'PerasVoteCollectionWithQuorum' perasVoteCollectionCheckQuorum :: - PerasParams -> + BlockSupportsPeras blk => + PerasEpochContext blk -> PerasVoteCollection blk -> Maybe (PerasVoteCollectionWithQuorum blk) -perasVoteCollectionCheckQuorum params pvc = - case weightAboveThreshold params (pvcTotalWeight pvc) of +perasVoteCollectionCheckQuorum epochContext pvc = + case weightAboveThreshold (pecPerasParams epochContext) (pvcTotalWeight pvc) of True -> Just (PerasVoteCollectionWithQuorum pvc) False -> Nothing @@ -585,18 +701,18 @@ toUniqueVotesWithSameTarget :: , crypto ~ PerasCrypto blk , committee ~ PerasVotingCommitteeScheme blk , ElectionId crypto ~ PerasRoundNo - , VoteCandidate crypto ~ BoostedBlock vote - , Eq (BoostedBlock vote) - , IsPerasVote vote blk - , Committee.Vote crypto committee ~ vote + , VoteCandidate crypto ~ Point blk + , PerasVoteCompatibleWithVotingCommittee vote crypto committee + , CryptoSupportsVotingCommittee crypto committee + , StandardHash blk ) => PerasVoteCollectionWithQuorum blk -> - UniqueVotesWithSameTarget (PerasCrypto blk) (PerasVotingCommitteeScheme blk) -toUniqueVotesWithSameTarget (PerasVoteCollectionWithQuorum pvc) = - unsafeUniqueVotesWithSameTarget -- Skip redundant checks in production - (getPerasVoteRound &&& getPerasVoteBlock) - (comparing getPerasVoteId) - ( fmap (vpvVote . forgetArrivalTime) - . NEMap.elems - $ pvcVotes pvc - ) + Either + PerasConversionError + (UniqueVotesWithSameTarget (PerasCrypto blk) (PerasVotingCommitteeScheme blk)) +toUniqueVotesWithSameTarget (PerasVoteCollectionWithQuorum pvc) = do + let concreteVoteNeList = (vpvVote . forgetArrivalTime) <$> NEMap.elems (pvcVotes pvc) + abstractVoteNeList <- traverse fromPerasVote concreteVoteNeList + pure $ + unsafeUniqueVotesWithSameTarget -- Skip redundant checks in production + abstractVoteNeList diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs index 16fd2f61a0..14649e7181 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs @@ -67,6 +67,16 @@ class -- | Abstract certificate attesting the winner of a given election data Cert crypto committee :: Type + -- | Project the target (election and candidate) from an abstract vote + voteTarget :: + Vote crypto committee -> (ElectionId crypto, VoteCandidate crypto) + + -- | Compare votes by ID, where EQ means that two votes have the same + -- ID and are either total duplicates, or are equivocating (i.e., they have + -- the same ID but a different target) + compareVotesById :: + Vote crypto committee -> Vote crypto committee -> Ordering + -- | Construct a voting committee mkVotingCommittee :: VotingCommitteeInput crypto committee -> @@ -226,25 +236,20 @@ ensureUniqueVotesWithSameTarget getTarget cmpVotes votes = -- guarantee that the input votes satisfy the contract. unsafeUniqueVotesWithSameTarget :: forall crypto committee. - ( Eq (ElectionId crypto) + ( CryptoSupportsVotingCommittee crypto committee + , Eq (ElectionId crypto) , Eq (VoteCandidate crypto) ) => - -- | How to project the target from an abstract vote - (Vote crypto committee -> (ElectionId crypto, VoteCandidate crypto)) -> - -- | How to compare votes by ID, where EQ means that two votes have the same - -- ID and are either total duplicates, or are equivocating (i.e., they have - -- the same ID but a different target) - (Vote crypto committee -> Vote crypto committee -> Ordering) -> -- | Collection of votes to check NE [Vote crypto committee] -> UniqueVotesWithSameTarget crypto committee -unsafeUniqueVotesWithSameTarget getTarget cmpVotes votes = +unsafeUniqueVotesWithSameTarget votes = assert ( isRight ( checkUniqueVotesWithSameTarget (Proxy @crypto) - getTarget - cmpVotes + voteTarget + compareVotesById votes ) ) @@ -254,7 +259,7 @@ unsafeUniqueVotesWithSameTarget getTarget cmpVotes votes = (firstVote :| nextVotes) where firstVote :| nextVotes = votes - (electionId, candidate) = getTarget firstVote + (electionId, candidate) = voteTarget firstVote -- | Validate that a non-empty collection of votes is well-formed for -- certificate forging: all votes target the same election and candidate diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index 3dbac94c18..12be952428 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -295,8 +295,8 @@ instance type PerasCert (HardForkBlock xs) = MockPerasCert (HardForkBlock xs) type PerasError (HardForkBlock xs) = VoidPerasError (HardForkBlock xs) - validatePerasVote = validateMockPerasVote - validatePerasCert = validateMockPerasCert + verifyPerasVote = validateMockPerasVote + verifyPerasCert = validateMockPerasCert forgePerasCert = forgeMockPerasCert -- TODO: extract actual Peras certificates from blocks diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index fe5e48340a..e29df5ed4a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -109,7 +109,7 @@ makePerasCertPoolWriterFromCertDB systemTime perasCertDB = processCerts systemTime (PerasCertDB.getCertIds perasCertDB) - (validatePerasCert mkPerasParams) -- TODO replace when actual plumbing is in place + (verifyPerasCert mkPerasParams) -- TODO replace when actual plumbing is in place (void . join . atomically . PerasCertDB.addCert perasCertDB) certs , opwHasObject = do @@ -134,7 +134,7 @@ makePerasCertPoolWriterFromChainDB systemTime chainDB = systemTime (ChainDB.getPerasCertIds chainDB) -- TODO replace when actual plumbing is in place - (validatePerasCert mkPerasParams) + (verifyPerasCert mkPerasParams) -- We do not want to block the writer thread on waiting for ChainSel -- side-effects to complete, so we use the async version of adding -- certs to the ChainDB and ignore the returned promise. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs index ef9ceee4a7..e50a0fdd06 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs @@ -115,7 +115,7 @@ makePerasVotePoolWriterFromVoteDB systemTime getVoteWeightDistrSTM perasVoteDB = -- TODO: in the future we won't need just the vote weight distribution for -- validating votes, but also the whole committee selection context -- (containing vote weights of committee members = voters) - (\vote -> getVoteWeightDistrSTM >>= \sd -> pure $ validatePerasVote mkPerasParams sd vote) + (\vote -> getVoteWeightDistrSTM >>= \sd -> pure $ verifyPerasVote mkPerasParams sd vote) (void . join . atomically . PerasVoteDB.addVote perasVoteDB) votes , opwHasObject = do @@ -145,7 +145,7 @@ makePerasVotePoolWriterFromChainDB systemTime getVoteWeightDistrSTM chainDB = -- TODO: in the future we won't need just the vote weight distribution for -- validating votes, but also the whole committee selection context -- (containing vote weights of committee members = voters) - (\vote -> getVoteWeightDistrSTM >>= \sd -> pure $ validatePerasVote mkPerasParams sd vote) + (\vote -> getVoteWeightDistrSTM >>= \sd -> pure $ verifyPerasVote mkPerasParams sd vote) -- We do not want to block the writer thread on waiting for ChainSel -- side-effects to complete, so we use the async version of adding -- votes to the ChainDB and ignore the returned promise. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs index 63e1b7250b..0bae55aecd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs @@ -115,7 +115,7 @@ instance , mockCertBlock } --- | Helper to write 'BlockSupportsPeras.validatePerasCert'. +-- | Helper to write 'BlockSupportsPeras.verifyPerasCert'. -- -- WARNING: we do not perform any validation whatsoever for mocked certificates. validateMockPerasCert :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs index 375ab4ac93..b5740639d6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs @@ -18,6 +18,7 @@ import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.SupportsPeras ( IsPerasError (..) , PerasVotingCommitteeError + , VoteWeight ) import Ouroboros.Consensus.Committee.WFA (WFAError) import Ouroboros.Consensus.Peras.Types (PerasConversionError) @@ -30,6 +31,8 @@ data PerasError blk (PerasVotingCommitteeError blk) | PerasVotingConversionError PerasConversionError + | PerasQuorumNotReachedError + VoteWeight | PerasTemporaryPublicKeyHackError String @@ -48,3 +51,4 @@ deriving instance instance IsPerasError (PerasError blk) blk where injectVotingCommitteeError = PerasVotingCommitteeError injectConversionError = PerasVotingConversionError + injectQuorumNotReachedError = PerasQuorumNotReachedError diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs index 41cf23172b..0dc572b4a8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs @@ -47,9 +47,10 @@ -- -- = Quorum Threshold and Multiple Winners -- --- The quorum threshold is parameterized via 'PerasParams'. Depending on this --- configuration and the weight distribution, it may be theoretically possible --- for multiple targets to exceed the threshold within the same round. +-- The quorum threshold is parameterized via 'PerasParams' inside +-- 'PerasEpochContext'. Depending on this configuration and the weight +-- distribution, it may be theoretically possible for multiple targets to exceed +-- the threshold within the same round. -- -- This module treats multiple winners as an error condition and rejects votes -- that would cause this, raising instead a 'RoundVoteStateLoserAboveQuorum' @@ -263,10 +264,10 @@ updatePerasRoundVoteState :: forall blk. BlockSupportsPeras blk => WithArrivalTime (ValidatedPerasVote blk) -> - PerasParams -> + PerasEpochContext blk -> PerasRoundVoteState blk -> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk) -updatePerasRoundVoteState vote params roundState = +updatePerasRoundVoteState vote epochContext roundState = assert (getPerasVoteRound vote == getPerasRoundVoteStateRound roundState) $ do case roundState of -- Quorum not yet reached @@ -279,9 +280,9 @@ updatePerasRoundVoteState vote params roundState = } -> do let updateMaybeCandidateState = \case Nothing -> - candidateOrWinnerVoteStateSingleton params vote + candidateOrWinnerVoteStateSingleton epochContext vote Just oldCandidateState -> - updateCandidateVoteState params vote oldCandidateState + updateCandidateVoteState epochContext vote oldCandidateState candidateOrWinnerState <- updateMaybeCandidateState (Map.lookup (getPerasVotePoint vote) candidateStates) case candidateOrWinnerState of @@ -353,9 +354,9 @@ updatePerasRoundVoteState vote params roundState = else do let updateMaybeLoserVoteState = \case Nothing -> - loserVoteStateSingleton params winnerState vote + loserVoteStateSingleton epochContext winnerState vote Just oldLoserState -> - updateLoserVoteState params winnerState vote oldLoserState + updateLoserVoteState epochContext winnerState vote oldLoserState loserStates' <- Map.alterF (\mState -> Just <$> updateMaybeLoserVoteState mState) votePoint loserStates @@ -381,12 +382,12 @@ updatePerasRoundVoteStates :: forall blk. BlockSupportsPeras blk => WithArrivalTime (ValidatedPerasVote blk) -> - PerasParams -> + PerasEpochContext blk -> Map PerasRoundNo (PerasRoundVoteState blk) -> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk, Map PerasRoundNo (PerasRoundVoteState blk)) -updatePerasRoundVoteStates vote params = +updatePerasRoundVoteStates vote epochContext = alterMapAndReturnUpdatedValue updateMaybePerasRoundVoteState (getPerasVoteRound vote) @@ -419,7 +420,7 @@ updatePerasRoundVoteStates vote params = (PerasRoundVoteState blk, PerasRoundVoteState blk) updateMaybePerasRoundVoteState mRoundState = do let roundState = existingOrFreshRoundVoteState mRoundState - newRoundState <- updatePerasRoundVoteState vote params roundState + newRoundState <- updatePerasRoundVoteState vote epochContext roundState pure (newRoundState, newRoundState) {------------------------------------------------------------------------------- @@ -541,29 +542,29 @@ ptvsVoteCollection = \case candidateOrWinnerVoteStateSingleton :: BlockSupportsPeras blk => - PerasParams -> + PerasEpochContext blk -> WithArrivalTime (ValidatedPerasVote blk) -> Either (UpdateRoundVoteStateError blk) (PerasVoteStateCandidateOrWinner blk) -candidateOrWinnerVoteStateSingleton params vote = +candidateOrWinnerVoteStateSingleton epochContext vote = let voteCollection = perasVoteCollectionSingleton vote - in case perasVoteCollectionCheckQuorum params voteCollection of + in case perasVoteCollectionCheckQuorum epochContext voteCollection of Just votesWithQuorum -> do - cert <- forgePerasCert params votesWithQuorum `onErr` RoundVoteStateForgingCertError + cert <- forgePerasCert epochContext votesWithQuorum `onErr` RoundVoteStateForgingCertError pure $ BecameWinner $ PerasTargetVoteWinner voteCollection cert Nothing -> pure $ RemainedCandidate $ PerasTargetVoteCandidate voteCollection loserVoteStateSingleton :: - IsPerasVote (PerasVote blk) blk => - PerasParams -> + BlockSupportsPeras blk => + PerasEpochContext blk -> PerasTargetVoteState blk 'Winner -> WithArrivalTime (ValidatedPerasVote blk) -> Either (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser) -loserVoteStateSingleton params winnerState vote = +loserVoteStateSingleton epochContext winnerState vote = let voteCollection = perasVoteCollectionSingleton vote - in case perasVoteCollectionCheckQuorum params voteCollection of + in case perasVoteCollectionCheckQuorum epochContext voteCollection of Just _ -> Left $ RoundVoteStateLoserAboveQuorum winnerState (PerasTargetVoteLoser voteCollection) Nothing -> @@ -590,19 +591,19 @@ data PerasVoteStateCandidateOrWinner blk -- May fail if the candidate is elected winner but forging the certificate fails. updateCandidateVoteState :: BlockSupportsPeras blk => - PerasParams -> + PerasEpochContext blk -> WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Candidate -> Either (UpdateRoundVoteStateError blk) (PerasVoteStateCandidateOrWinner blk) -updateCandidateVoteState params vote oldState = +updateCandidateVoteState epochContext vote oldState = let newVoteCollection = perasVoteCollectionAddVote vote (ptvsVoteCollection oldState) in - case perasVoteCollectionCheckQuorum params newVoteCollection of + case perasVoteCollectionCheckQuorum epochContext newVoteCollection of Just votesWithQuorum -> do - cert <- forgePerasCert params votesWithQuorum `onErr` RoundVoteStateForgingCertError + cert <- forgePerasCert epochContext votesWithQuorum `onErr` RoundVoteStateForgingCertError pure $ BecameWinner (PerasTargetVoteWinner newVoteCollection cert) Nothing -> do pure $ RemainedCandidate (PerasTargetVoteCandidate newVoteCollection) @@ -613,18 +614,16 @@ updateCandidateVoteState params vote oldState = -- -- May fail if the loser goes above quorum by adding the vote. updateLoserVoteState :: - ( StandardHash blk - , IsPerasVote (PerasVote blk) blk - ) => - PerasParams -> + BlockSupportsPeras blk => + PerasEpochContext blk -> PerasTargetVoteState blk 'Winner -> WithArrivalTime (ValidatedPerasVote blk) -> PerasTargetVoteState blk 'Loser -> Either (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser) -updateLoserVoteState params winnerState vote oldState = +updateLoserVoteState epochContext winnerState vote oldState = assert (getPerasVoteTarget vote == pvcTarget (ptvsVoteCollection oldState)) $ do let newVoteCollection = perasVoteCollectionAddVote vote (ptvsVoteCollection oldState) - in case perasVoteCollectionCheckQuorum params newVoteCollection of + in case perasVoteCollectionCheckQuorum epochContext newVoteCollection of Just _ -> Left $ RoundVoteStateLoserAboveQuorum winnerState (PerasTargetVoteLoser newVoteCollection) Nothing -> Right $ PerasTargetVoteLoser newVoteCollection diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs index 297841dc4b..5f851b2b58 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs @@ -138,7 +138,7 @@ instance -- sufficient for our needs. } --- | Helper to write 'BlockSupportsPeras.validatePerasVote'. +-- | Helper to write 'BlockSupportsPeras.verifyPerasVote'. -- -- WARNING: we do not perform any validation whatsoever for mocked votes. validateMockPerasVote :: diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index 39c97c33a4..aa3611a7b1 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -741,8 +741,8 @@ instance BlockSupportsPeras TestBlock where type PerasCert TestBlock = MockPerasCert TestBlock type PerasError TestBlock = VoidPerasError TestBlock - validatePerasVote = validateMockPerasVote - validatePerasCert = validateMockPerasCert + verifyPerasVote = validateMockPerasVote + verifyPerasCert = validateMockPerasCert forgePerasCert = forgeMockPerasCert getPerasCertInBlock = tbPerasCert . testBody diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index 63e0f721e7..581c747aaa 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -717,8 +717,8 @@ instance type PerasCert (TestBlockWith ptype) = MockPerasCert (TestBlockWith ptype) type PerasError (TestBlockWith ptype) = VoidPerasError (TestBlockWith ptype) - validatePerasVote = validateMockPerasVote - validatePerasCert = validateMockPerasCert + verifyPerasVote = validateMockPerasVote + verifyPerasCert = validateMockPerasCert forgePerasCert = forgeMockPerasCert -- TODO: extract actual Peras certificates from blocks From 0ca3480a4db5eb1d1c3ccb39f2ae82012f2b4746 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 28 May 2026 11:16:46 +0200 Subject: [PATCH 43/62] Make Mock{Vote,Cert}+MockCrypto compliant with new interface, using EveryoneVotes scheme --- ouroboros-consensus.cabal | 1 + .../Ouroboros/Consensus/Peras/Cert/Mock.hs | 74 ++++++++---- .../Ouroboros/Consensus/Peras/Crypto/Mock.hs | 109 ++++++++++++++++++ .../Ouroboros/Consensus/Peras/Vote/Mock.hs | 31 ++--- .../Ouroboros/Consensus/Util/Orphans.hs | 6 + 5 files changed, 179 insertions(+), 42 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index eb6c087ad3..530b97b28b 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -243,6 +243,7 @@ library Ouroboros.Consensus.Peras.Cert.V1 Ouroboros.Consensus.Peras.Crypto.BLS Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe + Ouroboros.Consensus.Peras.Crypto.Mock Ouroboros.Consensus.Peras.Error.V1 Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs index 0bae55aecd..c3830c995f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs @@ -14,8 +14,8 @@ -- | Mocked Peras certificates without crypto. module Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) - , validateMockPerasCert , forgeMockPerasCert + , validateMockPerasCert ) where import Cardano.Binary (decodeListLenOf, encodeListLen) @@ -36,14 +36,21 @@ import Ouroboros.Consensus.Block.SupportsPeras , IsPerasCert (..) , PerasParams (..) , PerasRoundNo - , PerasVoteCollection (pvcTarget) + , PerasVoteCollection (pvcTarget, pvcVotes) , PerasVoteCollectionWithQuorum (..) , PerasVoteTarget (..) - , ValidatedPerasCert (..) + , ValidatedPerasCert (..), PerasSeatIndex, ValidatedPerasVote (vpvVote), IsPerasVote (getPerasVoteSeatIndex) ) import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..)) import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Network.Util (ShowProxy (..)) +import Data.Containers.NonEmpty (NE) +import Data.Set (Set) +import qualified Data.Set.NonEmpty as NESet +import Ouroboros.Consensus.BlockchainTime (WithArrivalTime(forgetArrivalTime)) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote) +import qualified Data.Map.NonEmpty as NEMap +import qualified Data.List.NonEmpty as NonEmpty -- | Mocked Peras certificates without crypto. -- @@ -52,6 +59,7 @@ data MockPerasCert blk = MockPerasCert { mockCertRound :: PerasRoundNo , mockCertBlock :: Point blk + , mockCertVoters :: NE (Set PerasSeatIndex) } deriving instance StandardHash blk => Show (MockPerasCert blk) @@ -77,19 +85,28 @@ instance MockPerasCert { mockCertRound , mockCertBlock + , mockCertVoters } = - encodeListLen 2 + encodeListLen 3 <> encode mockCertRound <> encode mockCertBlock + <> encode (NonEmpty.toList . NESet.toList $ mockCertVoters) decode = do - decodeListLenOf 2 + decodeListLenOf 3 mockCertRound <- decode mockCertBlock <- decode + mockCertVoters <- decodeNonEmptySet pure $ MockPerasCert { mockCertRound , mockCertBlock + , mockCertVoters } + where decodeNonEmptySet = do + xs <- decode + case NonEmpty.nonEmpty xs of + Nothing -> fail "Expected a non-empty set of PerasSeatIndex" + Just neSet -> pure $ NESet.fromList neSet instance ConvertRawHash blk => @@ -101,50 +118,61 @@ instance MockPerasCert { mockCertRound , mockCertBlock + , mockCertVoters } = - encodeListLen 2 + encodeListLen 3 <> encodeNodeToNode ccfg version mockCertRound <> encodeNodeToNode ccfg version mockCertBlock + <> encode (NonEmpty.toList . NESet.toList $ mockCertVoters) decodeNodeToNode ccfg version = do - decodeListLenOf 2 + decodeListLenOf 3 mockCertRound <- decodeNodeToNode ccfg version mockCertBlock <- decodeNodeToNode ccfg version + mockCertVoters <- decodeNodeToNodeNonEmptySet ccfg version pure MockPerasCert { mockCertRound , mockCertBlock + , mockCertVoters } - --- | Helper to write 'BlockSupportsPeras.verifyPerasCert'. --- --- WARNING: we do not perform any validation whatsoever for mocked certificates. -validateMockPerasCert :: - forall blk. - PerasParams -> - PerasCert blk -> - Either (PerasError blk) (ValidatedPerasCert blk) -validateMockPerasCert params cert = - Right - ValidatedPerasCert - { vpcCert = cert - , vpcCertBoost = perasWeight params - } + where decodeNodeToNodeNonEmptySet _ccfg _version = do + xs <- decode + case NonEmpty.nonEmpty xs of + Nothing -> fail "Expected a non-empty set of PerasSeatIndex" + Just neSet -> pure $ NESet.fromList neSet -- | Helper to write 'BlockSupportsPeras.forgePerasCert'. forgeMockPerasCert :: forall blk. - PerasCert blk ~ MockPerasCert blk => + (PerasCert blk ~ MockPerasCert blk, PerasVote blk ~ MockPerasVote blk)=> PerasParams -> PerasVoteCollectionWithQuorum blk -> Either (PerasError blk) (ValidatedPerasCert blk) forgeMockPerasCert params votes = do let target = pvcTarget . forgetQuorum $ votes + let voters = NESet.fromList . fmap getPerasVoteSeatIndex . NEMap.elems . pvcVotes . forgetQuorum $ votes Right ValidatedPerasCert { vpcCert = MockPerasCert { mockCertRound = pvtRoundNo target , mockCertBlock = pvtBlock target + , mockCertVoters = voters } , vpcCertBoost = perasWeight params } + +-- | Helper to write 'BlockSupportsPeras.verifyPerasCert'. +-- +-- WARNING: we do not perform any validation whatsoever for mocked certificates. +validateMockPerasCert :: + forall blk. + PerasParams -> + PerasCert blk -> + Either (PerasError blk) (ValidatedPerasCert blk) +validateMockPerasCert params cert = + Right + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasWeight params + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs new file mode 100644 index 0000000000..fd4d074637 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Ouroboros.Consensus.Peras.Crypto.Mock where +import Ouroboros.Consensus.Committee.Crypto +import Ouroboros.Consensus.Block.SupportsPeras +import Ouroboros.Consensus.Block (Point) +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) +import qualified Data.Set.NonEmpty as NESet +import Ouroboros.Consensus.Committee.EveryoneVotes (EveryoneVotes, Vote (..), Cert (..)) +import qualified Data.List.NonEmpty as NonEmpty + +data MockPerasVotingCommitteeScheme + +data MockPerasCrypto blk + +type instance ElectionId (MockPerasCrypto blk) = PerasRoundNo +type instance VoteCandidate (MockPerasCrypto blk) = Point blk + +type instance PrivateKey (MockPerasCrypto blk) = () +type instance PublicKey (MockPerasCrypto blk) = () + +instance CryptoSupportsVoteSigning (MockPerasCrypto blk) where + type VoteSigningKey (MockPerasCrypto blk) = () + + -- \| Key used for verifying votes + type VoteVerificationKey (MockPerasCrypto blk) = () + + -- \| Cryptographic signature of a vote + data VoteSignature (MockPerasCrypto blk) = MockVoteSignature + getVoteSigningKey _proxy privateKey = privateKey + getVoteVerificationKey _proxy publicKey = publicKey + signVote _ _ _ = MockVoteSignature + verifyVoteSignature _ _ _ _ = Right () + +-- data Vote crypto EveryoneVotes +-- = EveryoneVotesVote +-- !SeatIndex +-- !(ElectionId crypto) +-- !(VoteCandidate crypto) +-- !(VoteSignature crypto) + +-- data Cert crypto EveryoneVotes +-- = EveryoneVotesCert +-- !(ElectionId crypto) +-- !(VoteCandidate crypto) +-- !(NE (Set SeatIndex)) +-- !(AggregateVoteSignature crypto) + +-- data MockPerasCert blk +-- = MockPerasCert +-- { mockCertRound :: PerasRoundNo +-- , mockCertBlock :: Point blk +-- } + +-- data MockPerasVote blk +-- = MockPerasVote +-- { mockVoteRound :: PerasRoundNo +-- , mockVoteBlock :: Point blk +-- , mockVoteSeatIndex :: PerasSeatIndex +-- } + +type instance ElectionId (MockPerasCrypto blk) = PerasRoundNo +type instance VoteCandidate (MockPerasCrypto blk) = Point blk + +instance CryptoSupportsAggregateVoteSigning (MockPerasCrypto blk) where + type AggregateVoteSignature (MockPerasCrypto blk) = () + type AggregateVoteVerificationKey (MockPerasCrypto blk) = () + aggregateVoteSignatures _ _ = Right () + verifyAggregateVoteSignature _ _ _ _ _ = Right () + aggregateVoteVerificationKeys _ _ = Right () + +instance + PerasVoteCompatibleWithVotingCommittee + (MockPerasVote blk) + (MockPerasCrypto blk) + EveryoneVotes + where + toPerasVote (EveryoneVotesVote seatIndex roundNo point _signature) = do + perasSeatIndex <- toPerasSeatIndex seatIndex + pure $ MockPerasVote + { mockVoteRound = roundNo + , mockVoteBlock = point + , mockVoteSeatIndex = perasSeatIndex + } + fromPerasVote MockPerasVote { mockVoteRound, mockVoteBlock, mockVoteSeatIndex } = + Right $ EveryoneVotesVote (fromPerasSeatIndex mockVoteSeatIndex) mockVoteRound mockVoteBlock MockVoteSignature + +instance + PerasCertCompatibleWithVotingCommittee + (MockPerasCert blk) + (MockPerasCrypto blk) + EveryoneVotes + where + toPerasCert (EveryoneVotesCert roundNo point voters _certSignature) = do + perasVoters <- do + perasSeatIndices <- traverse toPerasSeatIndex (NonEmpty.toList $ NESet.toList voters) + case NonEmpty.nonEmpty perasSeatIndices of + Nothing -> error "We started with a non-empty set of voters, so this should never happen" + Just neList -> pure $ NESet.fromList neList + pure $ MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = point + , mockCertVoters = perasVoters + } + fromPerasCert MockPerasCert { mockCertRound, mockCertBlock, mockCertVoters } = + Right $ EveryoneVotesCert mockCertRound mockCertBlock (NESet.mapMonotonic fromPerasSeatIndex mockCertVoters) () diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs index 5f851b2b58..85a750b912 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs @@ -15,6 +15,7 @@ -- | Mocked Peras votes without crypto. module Ouroboros.Consensus.Peras.Vote.Mock ( MockPerasVote (..) + , forgeMockPerasVote , validateMockPerasVote ) where @@ -53,9 +54,6 @@ data MockPerasVote blk { mockVoteRound :: PerasRoundNo , mockVoteBlock :: Point blk , mockVoteSeatIndex :: PerasSeatIndex - , mockVoteWeight :: VoteWeight - -- ^ This field is unique to the mocked vote, and allows us to bypass the - -- need for a 'VoteWeightDistr' when creating validated votes in tests. } deriving instance StandardHash blk => Show (MockPerasVote blk) @@ -98,11 +96,6 @@ instance { mockVoteRound , mockVoteBlock , mockVoteSeatIndex - , mockVoteWeight = 0 - -- NOTE: weights are never sent over the wire, but computed locally from - -- the voting committee. We might need to change this in the future if - -- we ever need roundtrip tests using mocked votes, but for now this is - -- sufficient for our needs. } instance @@ -131,13 +124,18 @@ instance { mockVoteRound , mockVoteBlock , mockVoteSeatIndex - , mockVoteWeight = 0 - -- NOTE: weights are never sent over the wire, but computed locally from - -- the voting committee. We might need to change this in the future if - -- we ever need roundtrip tests using mocked votes, but for now this is - -- sufficient for our needs. } +forgeMockPerasVote :: + forall blk. + PerasVote blk ~ MockPerasVote blk => + PerasParams -> + PerasRoundNo -> + Point blk -> + PerasSeatIndex -> + Either (PerasError blk) (ValidatedPerasVote blk) +forgeMockPerasVote _params roundNo point seatIndex = undefined + -- | Helper to write 'BlockSupportsPeras.verifyPerasVote'. -- -- WARNING: we do not perform any validation whatsoever for mocked votes. @@ -148,9 +146,4 @@ validateMockPerasVote :: VoteWeightDistr -> PerasVote blk -> Either (PerasError blk) (ValidatedPerasVote blk) -validateMockPerasVote _params _voteWeightDistr vote = - Right - ValidatedPerasVote - { vpvVote = vote - , vpvVoteWeight = mockVoteWeight vote - } +validateMockPerasVote _params _voteWeightDistr vote = undefined diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index bf9199c278..8404c1191e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -40,6 +40,8 @@ import System.FS.API.Types (FsPath, Handle) import System.FS.CRC (CRC (CRC)) import System.Random (StdGen) import qualified System.Random.Internal as Random +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NESet {------------------------------------------------------------------------------- Serialise @@ -96,6 +98,10 @@ instance (NoThunks k, NoThunks v) => NoThunks (NEMap k v) where showTypeOf _ = "NEMap" wNoThunks ctxt = wNoThunks ctxt . NEMap.toMap +instance (NoThunks v) => NoThunks (NESet v) where + showTypeOf _ = "NESet" + wNoThunks ctxt = wNoThunks ctxt . NESet.toSet + instance NoThunks StdGen where showTypeOf _ = "StdGen" wNoThunks ctx = wNoThunks ctx . OnlyCheckWhnf . Random.unStdGen From 3a0172eacbaea33e3510600b06eb1a95894e5f1a Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 28 May 2026 12:06:10 +0200 Subject: [PATCH 44/62] WIP fix things --- .../Ouroboros/Consensus/Shelley/Node/Peras.hs | 16 +- .../Ouroboros/Consensus/Network/NodeToNode.hs | 20 +- .../Consensus/Protocol/Praos/Peras.hs | 16 +- ouroboros-consensus.cabal | 8 + .../Consensus/Block/SupportsPeras.hs | 49 +-- .../Consensus/Committee/EveryoneVotes.hs | 12 +- .../Ouroboros/Consensus/Committee/WFALS.hs | 16 + .../Consensus/HardFork/Combinator/Basics.hs | 14 +- .../ObjectDiffusion/ObjectPool/PerasCert.hs | 123 +++---- .../ObjectDiffusion/ObjectPool/PerasVote.hs | 134 +++----- .../Consensus/Peras/Cert/Inclusion.hs | 4 +- .../Ouroboros/Consensus/Peras/Cert/Mock.hs | 88 ++--- .../Ouroboros/Consensus/Peras/Context.hs | 105 ++++++ .../Ouroboros/Consensus/Peras/Crypto/Mock.hs | 302 ++++++++++++++---- .../Ouroboros/Consensus/Peras/Error/Mock.hs | 56 ++++ .../Ouroboros/Consensus/Peras/Error/V1.hs | 7 + .../Ouroboros/Consensus/Peras/Params.hs | 4 +- .../Ouroboros/Consensus/Peras/Types.hs | 2 +- .../Ouroboros/Consensus/Peras/Vote/Mock.hs | 32 +- .../Ouroboros/Consensus/Peras/Vote/V1.hs | 1 + .../Ouroboros/Consensus/Peras/Voting/Rules.hs | 16 +- .../Ouroboros/Consensus/Peras/Voting/View.hs | 8 +- .../Consensus/Storage/ChainDB/Impl/Args.hs | 4 +- .../Consensus/Storage/PerasVoteDB/Impl.hs | 19 +- .../Ouroboros/Consensus/Util/Orphans.hs | 6 +- .../Test/Ouroboros/Storage/TestBlock.hs | 16 +- .../Test/Util/ChainDB.hs | 5 +- .../Test/Util/Orphans/ToExpr.hs | 3 + .../Test/Util/TestBlock.hs | 13 +- .../ObjectDiffusion/PerasCert/Smoke.hs | 108 +++---- .../ObjectDiffusion/PerasVote/Smoke.hs | 131 +++----- .../MiniProtocol/ObjectDiffusion/Smoke.hs | 74 +---- .../Test/Consensus/Peras/Cert/Inclusion.hs | 2 +- .../Test/Consensus/Peras/Util.hs | 276 +--------------- .../Test/Consensus/Peras/Util/Internal.hs | 92 ++++++ .../Test/Consensus/Peras/Util/Mock.hs | 112 +++++++ .../Test/Consensus/Peras/Util/V1.hs | 258 +++++++++++++++ .../Test/Consensus/Peras/Voting/Rules.hs | 6 +- .../Storage/PerasCertDB/StateMachine.hs | 14 +- .../Ouroboros/Storage/PerasVoteDB/Model.hs | 4 +- .../Storage/PerasVoteDB/StateMachine.hs | 3 +- 41 files changed, 1241 insertions(+), 938 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Internal.hs create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Mock.hs create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/V1.hs diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs index 8fcafa56f2..b76e3ddcfa 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -16,16 +16,14 @@ module Ouroboros.Consensus.Shelley.Node.Peras () where import Cardano.Ledger.Api import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) - , VoidPerasError ) import Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) - , forgeMockPerasCert - , validateMockPerasCert ) +import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCommittee, MockPerasCrypto) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) import Ouroboros.Consensus.Peras.Vote.Mock ( MockPerasVote (..) - , validateMockPerasVote ) import Ouroboros.Consensus.Shelley.Ledger.Block ( ShelleyBlock @@ -53,13 +51,13 @@ instance ShelleyCompatible proto DijkstraEra => BlockSupportsPeras (ShelleyBlock proto DijkstraEra) where + type PerasCrypto (ShelleyBlock proto DijkstraEra) = MockPerasCrypto (ShelleyBlock proto DijkstraEra) + type + PerasVotingCommitteeScheme (ShelleyBlock proto DijkstraEra) = + MockPerasCommittee (ShelleyBlock proto DijkstraEra) type PerasVote (ShelleyBlock proto DijkstraEra) = MockPerasVote (ShelleyBlock proto DijkstraEra) type PerasCert (ShelleyBlock proto DijkstraEra) = MockPerasCert (ShelleyBlock proto DijkstraEra) - type PerasError (ShelleyBlock proto DijkstraEra) = VoidPerasError (ShelleyBlock proto DijkstraEra) - - verifyPerasVote = validateMockPerasVote - verifyPerasCert = validateMockPerasCert - forgePerasCert = forgeMockPerasCert + type PerasError (ShelleyBlock proto DijkstraEra) = MockPerasError (ShelleyBlock proto DijkstraEra) -- TODO: extract actual Peras certificates from blocks getPerasCertInBlock _ = Nothing diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index e712959330..2010e9f579 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -380,7 +380,14 @@ mkHandlers , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 ) - (makePerasCertPoolWriterFromChainDB systemTime getChainDB) + ( makePerasCertPoolWriterFromChainDB + systemTime + getChainDB + -- [TODO EPOCH CONTEXT PLUMBING]: when actual plumbing for Peras is ready, we will have to + -- extract the 'PerasEpochContextResolverHandle' from the 'ExtLedgerState' to pass + -- it here + undefined + ) version controlMessageSTM , hPerasCertDiffusionServer = \version peer -> @@ -398,14 +405,11 @@ mkHandlers ) ( makePerasVotePoolWriterFromChainDB systemTime - -- TODO: when actual plumbing for Peras is ready, we will have to - -- extract the committee selection data from the chainDB to pass - -- it here, instead of relying on an empty the weight distribution. - -- - -- Note that the empty weight distribution will cause all votes to - -- be considered invalid. - (pure (VoteWeightDistr mempty)) getChainDB + -- [TODO EPOCH CONTEXT PLUMBING]: when actual plumbing for Peras is ready, we will have to + -- extract the 'PerasEpochContextResolverHandle' from the 'ExtLedgerState' to pass + -- it here + undefined ) version controlMessageSTM diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs index c25b23cad1..2abdedf64f 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -51,22 +51,18 @@ import Ouroboros.Consensus.Protocol.Praos.Views (LedgerView (..)) data RealBlock -type instance PerasCrypto RealBlock = BLS.PerasBLSCrypto -type instance PerasVotingCommitteeScheme RealBlock = WFALS type instance HeaderHash RealBlock = ShortByteString - instance StandardHash RealBlock instance BlockSupportsPeras RealBlock where type PerasVote RealBlock = V1.PerasVote RealBlock type PerasCert RealBlock = V1.PerasCert RealBlock type PerasError RealBlock = V1.PerasError RealBlock + type PerasCrypto RealBlock = BLS.PerasBLSCrypto + type PerasVotingCommitteeScheme RealBlock = WFALS - -- TODO: uncomment as soon as we add this method to 'BlockSupportsPeras' - -- forgePerasVoteIfEligible = implForgePerasVoteIfEligible - forgePerasCert = undefined - verifyPerasVote = undefined - verifyPerasCert = undefined + -- TODO: extract actual Peras certificates from blocks + getPerasCertInBlock _ = Nothing instance PraosStateSupportsPerasVoting RealBlock where praosStatePerasVotingCommitteeInput _ perasParams tickedPraosState = do @@ -104,7 +100,7 @@ class -- This is used to construct the 'PerasVotingCommittee' used for voting at a given ledger/praos state. praosStatePerasVotingCommitteeInput :: proxy blk -> - PerasParams -> + PerasParams blk -> Ticked PraosState -> Either (PerasError blk) @@ -113,7 +109,7 @@ class -- | How to build a new 'PerasVotingCommittee' from a 'Ticked PraosState'. The implementation provided here relies on 'praosStatePerasVotingCommitteeInput'. praosStateGetPerasVotingCommittee :: proxy blk -> - PerasParams -> + PerasParams blk -> Ticked PraosState -> Either (PerasError blk) diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 530b97b28b..318b744379 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -241,10 +241,12 @@ library Ouroboros.Consensus.Peras.Cert.Inclusion Ouroboros.Consensus.Peras.Cert.Mock Ouroboros.Consensus.Peras.Cert.V1 + Ouroboros.Consensus.Peras.Context Ouroboros.Consensus.Peras.Crypto.BLS Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe Ouroboros.Consensus.Peras.Crypto.Mock Ouroboros.Consensus.Peras.Error.V1 + Ouroboros.Consensus.Peras.Error.Mock Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.Types @@ -355,6 +357,7 @@ library Ouroboros.Consensus.Util.Versioned build-depends: + extra, aeson, array, base >=4.14 && <4.23, @@ -508,6 +511,7 @@ library unstable-consensus-testlib Test.Util.WithEq build-depends: + nonempty-containers, base, base16-bytestring, binary, @@ -686,6 +690,9 @@ test-suite consensus-test Test.Consensus.Peras.Cert.Inclusion Test.Consensus.Peras.Serialisation Test.Consensus.Peras.Util + Test.Consensus.Peras.Util.V1 + Test.Consensus.Peras.Util.Mock + Test.Consensus.Peras.Util.Internal Test.Consensus.Peras.Voting.Adapter Test.Consensus.Peras.Voting.Rules Test.Consensus.Peras.WeightSnapshot @@ -820,6 +827,7 @@ test-suite storage-test Test.Ouroboros.Storage.VolatileDB.StateMachine build-depends: + nonempty-containers, aeson, base, bifunctors, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 726b9d48a9..8e988ade3a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -7,7 +7,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -17,9 +16,7 @@ {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Ouroboros.Consensus.Block.SupportsPeras - ( PerasCrypto - , PerasVotingCommitteeScheme - , PerasVotingCommittee + ( PerasVotingCommittee , PerasVotingCommitteeError , PerasVotingCommitteeInput , BlockSupportsPeras (..) @@ -53,21 +50,20 @@ module Ouroboros.Consensus.Block.SupportsPeras , module Ouroboros.Consensus.Peras.Types ) where -import Control.Arrow ((&&&)) import Control.Exception (assert) +import Control.Exception.Base (Exception) import Data.Bifunctor (bimap) import Data.Containers.NonEmpty (NE) import Data.Kind (Type) import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map.NonEmpty as NEMap -import Data.Ord (comparing) import Data.Traversable (for) -import Data.Typeable (Proxy, Typeable) +import Data.Typeable (Typeable) import Data.Void (Void, absurd) import GHC.Generics (Generic) -import NoThunks.Class -import Ouroboros.Consensus.Block.Abstract +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract (Point, StandardHash) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Committee.Class ( CryptoSupportsVotingCommittee (..) @@ -121,22 +117,32 @@ class , Eq (PerasVote blk) , NoThunks (PerasVote blk) , IsPerasVote (PerasVote blk) blk + , Typeable (BoostedBlock (PerasVote blk)) + , Show (BoostedBlock (PerasVote blk)) + , Eq (BoostedBlock (PerasVote blk)) + , NoThunks (BoostedBlock (PerasVote blk)) , -- PerasCert constraints Typeable (PerasCert blk) , Show (PerasCert blk) , Eq (PerasCert blk) , NoThunks (PerasCert blk) , IsPerasCert (PerasCert blk) blk + , Typeable (BoostedBlock (PerasCert blk)) + , Show (BoostedBlock (PerasCert blk)) + , Eq (BoostedBlock (PerasCert blk)) + , NoThunks (BoostedBlock (PerasCert blk)) , -- PerasError constraints Typeable (PerasError blk) , Show (PerasError blk) , Eq (PerasError blk) , NoThunks (PerasError blk) , IsPerasError (PerasError blk) blk + , Exception (PerasError blk) , -- Compatiblity with committee/crypto CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) , ElectionId (PerasCrypto blk) ~ PerasRoundNo - , VoteCandidate (PerasCrypto blk) ~ Point blk + , VoteCandidate (PerasCrypto blk) ~ BoostedBlock (PerasVote blk) + , VoteCandidate (PerasCrypto blk) ~ BoostedBlock (PerasCert blk) , PerasVoteCompatibleWithVotingCommittee (PerasVote blk) (PerasCrypto blk) @@ -172,13 +178,13 @@ class type PerasVotingCommitteeScheme blk = VoidPerasVotingCommitteeScheme type PerasEpochContext blk = (context :: Type) | context -> blk - type PerasEpochContext blk = (PerasVotingCommittee blk, PerasParams) + type PerasEpochContext blk = (PerasVotingCommittee blk, PerasParams blk) - pecPerasParams :: PerasEpochContext blk -> PerasParams + pecPerasParams :: PerasEpochContext blk -> PerasParams blk default pecPerasParams :: - PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams) => + PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams blk) => PerasEpochContext blk -> - PerasParams + PerasParams blk pecPerasParams (_committee, params) = params forgePerasVoteIfEligible :: @@ -189,7 +195,7 @@ class Point blk -> Either (PerasError blk) (Maybe (ValidatedPerasVote blk)) default forgePerasVoteIfEligible :: - PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams) => + PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams blk) => PerasEpochContext blk -> PoolId -> PrivateKey (PerasCrypto blk) -> @@ -202,7 +208,7 @@ class Committee.checkShouldVote committee ourId ourPrivateKey roundNo for mWitness $ \witness -> do let voteWeight = eligiblePartyVoteWeight committee witness - abstractVote = Committee.forgeVote witness ourPrivateKey roundNo point + abstractVote = Committee.forgeVote witness ourPrivateKey roundNo (pointToBoostedBlock point) concreteVote <- bimap injectConversionError id $ toPerasVote @(PerasVote blk) abstractVote @@ -217,7 +223,7 @@ class PerasVote blk -> Either (PerasError blk) (ValidatedPerasVote blk) default verifyPerasVote :: - PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams) => + PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams blk) => PerasEpochContext blk -> PerasVote blk -> Either (PerasError blk) (ValidatedPerasVote blk) @@ -243,7 +249,7 @@ class PerasVoteCollectionWithQuorum blk -> Either (PerasError blk) (ValidatedPerasCert blk) default forgePerasCert :: - PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams) => + PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams blk) => PerasEpochContext blk -> PerasVoteCollectionWithQuorum blk -> Either (PerasError blk) (ValidatedPerasCert blk) @@ -268,7 +274,7 @@ class PerasCert blk -> Either (PerasError blk) (ValidatedPerasCert blk) default verifyPerasCert :: - PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams) => + PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams blk) => PerasEpochContext blk -> PerasCert blk -> Either (PerasError blk) (ValidatedPerasCert blk) @@ -376,7 +382,7 @@ newtype VoidPerasError blk = VoidPerasError { unVoidPerasError :: Void } - deriving newtype (Show, Eq, NoThunks, ShowProxy) + deriving newtype (Show, Eq, NoThunks, Generic, Typeable, ShowProxy, Exception) instance IsPerasError (VoidPerasError blk) blk where injectVotingCommitteeError _ = @@ -701,10 +707,9 @@ toUniqueVotesWithSameTarget :: , crypto ~ PerasCrypto blk , committee ~ PerasVotingCommitteeScheme blk , ElectionId crypto ~ PerasRoundNo - , VoteCandidate crypto ~ Point blk , PerasVoteCompatibleWithVotingCommittee vote crypto committee , CryptoSupportsVotingCommittee crypto committee - , StandardHash blk + , Eq (VoteCandidate crypto) ) => PerasVoteCollectionWithQuorum blk -> Either diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index 1ae86da83e..17425713fd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -1,12 +1,15 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | A simple voting committee where pools with positive stake can vote. module Ouroboros.Consensus.Committee.EveryoneVotes @@ -73,7 +76,7 @@ import Ouroboros.Consensus.Committee.WFA data EveryoneVotes instance - CryptoSupportsAggregateVoteSigning crypto => + (Ord (ElectionId crypto), CryptoSupportsAggregateVoteSigning crypto) => CryptoSupportsVotingCommittee crypto EveryoneVotes where data VotingCommittee crypto EveryoneVotes @@ -138,6 +141,13 @@ instance forgeCert = implForgeCert verifyCert = implVerifyCert + voteTarget (EveryoneVotesVote _ electionId candidate _) = + (electionId, candidate) + compareVotesById + (EveryoneVotesVote seatIndex1 electionId1 _ _) + (EveryoneVotesVote seatIndex2 electionId2 _ _) = + compare (electionId1, seatIndex1) (electionId2, seatIndex2) + -- | Construct a 'EveryoneVotesVotingCommittee' for a given epoch mkEveryoneVotesVotingCommittee :: VotingCommitteeInput crypto EveryoneVotes -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index 721dfb2478..942bc1f045 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -1,12 +1,14 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Weighted Fait-Accompli with Local Sortition (wFA^LS) committee selection. -- @@ -106,6 +108,7 @@ data WFALS instance ( CryptoSupportsAggregateVoteSigning crypto , CryptoSupportsBatchVRFVerification crypto + , Ord (ElectionId crypto) ) => CryptoSupportsVotingCommittee crypto WFALS where @@ -209,6 +212,19 @@ instance forgeCert = implForgeCert verifyCert = implVerifyCert + voteTarget = \case + WFALSPersistentVote _ electionId candidate _ -> + (electionId, candidate) + WFALSNonPersistentVote _ electionId candidate _ _ -> + (electionId, candidate) + compareVotesById vote1 vote2 = compare (getVoteId vote1) (getVoteId vote2) + where + getVoteId = \case + WFALSPersistentVote seatIndex electionId _ _ -> + (seatIndex, electionId) + WFALSNonPersistentVote seatIndex electionId _ _ _ -> + (seatIndex, electionId) + -- | Construct a 'WFALSVotingCommittee' for a given epoch mkWFALSVotingCommittee :: VotingCommitteeInput crypto WFALS -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index 12be952428..625051fb16 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -49,7 +49,6 @@ import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) - , VoidPerasError ) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -63,12 +62,11 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) - , forgeMockPerasCert - , validateMockPerasCert ) +import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCommittee, MockPerasCrypto) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) import Ouroboros.Consensus.Peras.Vote.Mock ( MockPerasVote (..) - , validateMockPerasVote ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers @@ -291,13 +289,11 @@ instance ) => BlockSupportsPeras (HardForkBlock xs) where + type PerasCrypto (HardForkBlock xs) = MockPerasCrypto (HardForkBlock xs) + type PerasVotingCommitteeScheme (HardForkBlock xs) = (MockPerasCommittee (HardForkBlock xs)) type PerasVote (HardForkBlock xs) = MockPerasVote (HardForkBlock xs) type PerasCert (HardForkBlock xs) = MockPerasCert (HardForkBlock xs) - type PerasError (HardForkBlock xs) = VoidPerasError (HardForkBlock xs) - - verifyPerasVote = validateMockPerasVote - verifyPerasCert = validateMockPerasCert - forgePerasCert = forgeMockPerasCert + type PerasError (HardForkBlock xs) = MockPerasError (HardForkBlock xs) -- TODO: extract actual Peras certificates from blocks getPerasCertInBlock _ = Nothing diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index e29df5ed4a..0f3c63a391 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -1,6 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} -- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras -- certificates from the 'PerasCertDB' (or the 'ChainDB' which is wrapping the @@ -12,20 +10,25 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert , makePerasCertPoolWriterFromChainDB ) where -import Control.Monad (join) -import Data.Either (partitionEithers) -import Data.Functor (void) +import Data.Foldable (traverse_) import Data.Map (Map) import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set -import GHC.Exception (throw) -import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (PerasCert) + , IsPerasCert (getPerasCertRound) + , PerasRoundNo + , ValidatedPerasCert (vpcCert) + ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( SystemTime (..) , WithArrivalTime (..) ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + ( ObjectPoolReader (..) + , ObjectPoolWriter (..) + ) +import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle, verifyPerasCertInContext) import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.PerasCertDB.API @@ -34,6 +37,9 @@ import Ouroboros.Consensus.Storage.PerasCertDB.API ) import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import Ouroboros.Consensus.Util.IOLike + ( IOLike + , MonadSTM (STM, atomically) + ) -- | TODO: replace by `Data.Map.take` as soon as we move to GHC 9.8 takeAscMap :: Int -> Map k v -> Map k v @@ -101,17 +107,22 @@ makePerasCertPoolWriterFromCertDB :: ) => SystemTime m -> PerasCertDB m blk -> + PerasEpochContextResolverHandle m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m -makePerasCertPoolWriterFromCertDB systemTime perasCertDB = +makePerasCertPoolWriterFromCertDB systemTime perasCertDB resolverHandle = ObjectPoolWriter { opwObjectId = getPerasCertRound - , opwAddObjects = \certs -> - processCerts - systemTime - (PerasCertDB.getCertIds perasCertDB) - (verifyPerasCert mkPerasParams) -- TODO replace when actual plumbing is in place - (void . join . atomically . PerasCertDB.addCert perasCertDB) - certs + , opwAddObjects = \certs -> do + now <- systemTimeCurrent systemTime + atomically $ do + alreadyInDb <- PerasCertDB.getCertIds perasCertDB + let certsNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasCertRound) certs + validatedCerts <- traverse (verifyPerasCertInContext resolverHandle) certsNotAlreadyInDb + -- Some certs are invalid => reject the whole batch + -- We could combine the two 'traverse' operations into one in which case + -- any validated cert would be immediately added no matter what is the + -- validity of the other certs in the batch. + traverse_ (PerasCertDB.addCert perasCertDB . WithArrivalTime now) validatedCerts , opwHasObject = do certIds <- PerasCertDB.getCertIds perasCertDB pure $ \roundNo -> Set.member roundNo certIds @@ -125,77 +136,23 @@ makePerasCertPoolWriterFromChainDB :: ) => SystemTime m -> ChainDB m blk -> + PerasEpochContextResolverHandle m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m -makePerasCertPoolWriterFromChainDB systemTime chainDB = +makePerasCertPoolWriterFromChainDB systemTime chainDB resolverHandle = ObjectPoolWriter { opwObjectId = getPerasCertRound - , opwAddObjects = \certs -> - processCerts - systemTime - (ChainDB.getPerasCertIds chainDB) - -- TODO replace when actual plumbing is in place - (verifyPerasCert mkPerasParams) - -- We do not want to block the writer thread on waiting for ChainSel - -- side-effects to complete, so we use the async version of adding - -- certs to the ChainDB and ignore the returned promise. - -- The async action is still launched and executed behind the scenes - -- even though we drop the promise. - (void . ChainDB.addPerasCertAsync chainDB) - certs + , opwAddObjects = \certs -> do + now <- systemTimeCurrent systemTime + validatedCerts <- atomically $ do + alreadyInDb <- ChainDB.getPerasCertIds chainDB + let certsNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasCertRound) certs + traverse (verifyPerasCertInContext resolverHandle) certsNotAlreadyInDb + -- Some certs are invalid => reject the whole batch + -- We could combine the two 'traverse' operations into one in which case + -- any validated cert would be immediately added no matter what is the + -- validity of the other certs in the batch. + traverse_ (ChainDB.addPerasCertAsync chainDB . WithArrivalTime now) validatedCerts , opwHasObject = do certIds <- ChainDB.getPerasCertIds chainDB pure $ \roundNo -> Set.member roundNo certIds } - -data PerasCertInboundException - = forall blk. - Show (PerasError blk) => - PerasCertValidationError [PerasError blk] - -deriving instance Show PerasCertInboundException - -instance Exception PerasCertInboundException - --- | Process a batch of inbound Peras certificates received from a peer. --- --- Certificates whose round number is already present in the database (as --- determined by @alreadyInDbSTM@) are silently skipped. The remaining --- certificates are validated; if /any/ certificate in the batch fails --- validation, the entire batch is rejected by throwing a --- 'PerasCertInboundException' (which should make us disconnect from the distant --- peer, see 'withPeer' bracket function from `ouroboros-network`). Otherwise, --- each valid certificate is timestamped with the current wall-clock time and --- added to the database via @addCert@. -processCerts :: - ( MonadSTM m - , Show (PerasError blk) - , IsPerasCert (PerasCert blk) blk - ) => - SystemTime m -> - STM m (Set PerasRoundNo) -> - (PerasCert blk -> Either (PerasError blk) (ValidatedPerasCert blk)) -> - (WithArrivalTime (ValidatedPerasCert blk) -> m ()) -> - [PerasCert blk] -> - m () -processCerts systemTime alreadyInDbSTM validateCert addCert certs = do - alreadyInDb <- atomically alreadyInDbSTM - let certsNotAlreadyInDb = filter (not . (`Set.member` alreadyInDb) . getPerasCertRound) certs - now <- systemTimeCurrent systemTime - case partitionEithers (validateCert <$> certsNotAlreadyInDb) of - -- All certs are valid => add them to the pool - ([], validatedCerts) -> - mapM_ - (addCert . WithArrivalTime now) - validatedCerts - -- Some certs are invalid => reject the whole batch - -- - -- N.B. it has been requested in PR review - -- https://github.com/IntersectMBO/ouroboros-consensus/pull/1768#discussion_r2747873186 - -- to gather all validation errors and report them together in the exception - -- rather than just report the first error encountered. - -- This assumes that cert validation is cheap, which may not be true in - -- practice depending on the actual crypto/committee selection scheme. - -- Hence we may revisit this to lazily abort validation upon the first error - -- encountered. - (errs, _) -> - throw (PerasCertValidationError errs) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs index e50a0fdd06..55153be652 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs @@ -1,6 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} -- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras -- votes from the 'PerasVoteDB' (or the 'ChainDB' which is wrapping the @@ -12,20 +10,26 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote , makePerasVotePoolWriterFromChainDB ) where -import Control.Monad (join) -import Data.Either (partitionEithers) -import Data.Functor (void) +import Data.Foldable (traverse_) import Data.Map (Map) import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set -import GHC.Exception (throw) -import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (PerasVote) + , IsPerasVote + , PerasVoteId + , ValidatedPerasVote (vpvVote) + , getPerasVoteId + ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( SystemTime (..) , WithArrivalTime (..) ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + ( ObjectPoolReader (..) + , ObjectPoolWriter (..) + ) +import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle, verifyPerasVoteInContext) import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.PerasVoteDB.API @@ -35,6 +39,9 @@ import Ouroboros.Consensus.Storage.PerasVoteDB.API ) import qualified Ouroboros.Consensus.Storage.PerasVoteDB.API as PerasVoteDB import Ouroboros.Consensus.Util.IOLike + ( IOLike + , MonadSTM (STM, atomically) + ) -- | TODO: replace by `Data.Map.take` as soon as we move to GHC 9.8 takeAscMap :: Int -> Map k v -> Map k v @@ -101,23 +108,23 @@ makePerasVotePoolWriterFromVoteDB :: , BlockSupportsPeras blk ) => SystemTime m -> - -- | TODO: replace with a 'PerasVotingCommittee blk' - STM m VoteWeightDistr -> PerasVoteDB m blk -> + PerasEpochContextResolverHandle m blk -> ObjectPoolWriter (PerasVoteId blk) (PerasVote blk) m -makePerasVotePoolWriterFromVoteDB systemTime getVoteWeightDistrSTM perasVoteDB = +makePerasVotePoolWriterFromVoteDB systemTime perasVoteDB resolverHandle = ObjectPoolWriter { opwObjectId = getPerasVoteId - , opwAddObjects = \votes -> - processVotes - systemTime - (PerasVoteDB.getVoteIds perasVoteDB) - -- TODO: in the future we won't need just the vote weight distribution for - -- validating votes, but also the whole committee selection context - -- (containing vote weights of committee members = voters) - (\vote -> getVoteWeightDistrSTM >>= \sd -> pure $ verifyPerasVote mkPerasParams sd vote) - (void . join . atomically . PerasVoteDB.addVote perasVoteDB) - votes + , opwAddObjects = \votes -> do + now <- systemTimeCurrent systemTime + atomically $ do + alreadyInDb <- PerasVoteDB.getVoteIds perasVoteDB + let votesNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasVoteId) votes + validatedVotes <- traverse (verifyPerasVoteInContext resolverHandle) votesNotAlreadyInDb + -- Some votes are invalid => reject the whole batch + -- We could combine the two 'traverse' operations into one in which case + -- any validated vote would be immediately added no matter what is the + -- validity of the other votes in the batch. + traverse_ (PerasVoteDB.addVote perasVoteDB . WithArrivalTime now) validatedVotes , opwHasObject = do voteIds <- PerasVoteDB.getVoteIds perasVoteDB pure $ \voteId -> Set.member voteId voteIds @@ -131,83 +138,24 @@ makePerasVotePoolWriterFromChainDB :: , BlockSupportsPeras blk ) => SystemTime m -> - -- \| TODO: replace with a 'PerasVotingCommittee blk' - STM m VoteWeightDistr -> ChainDB m blk -> + PerasEpochContextResolverHandle m blk -> ObjectPoolWriter (PerasVoteId blk) (PerasVote blk) m -makePerasVotePoolWriterFromChainDB systemTime getVoteWeightDistrSTM chainDB = +makePerasVotePoolWriterFromChainDB systemTime chainDB resolverHandle = ObjectPoolWriter { opwObjectId = getPerasVoteId - , opwAddObjects = \votes -> - processVotes - systemTime - (ChainDB.getPerasVoteIds chainDB) - -- TODO: in the future we won't need just the vote weight distribution for - -- validating votes, but also the whole committee selection context - -- (containing vote weights of committee members = voters) - (\vote -> getVoteWeightDistrSTM >>= \sd -> pure $ verifyPerasVote mkPerasParams sd vote) - -- We do not want to block the writer thread on waiting for ChainSel - -- side-effects to complete, so we use the async version of adding - -- votes to the ChainDB and ignore the returned promise. - -- The async action (if any) is still launched and executed behind the - -- scenes even though we drop the promise. - (void . ChainDB.addPerasVoteWithAsyncCertHandling chainDB) - votes + , opwAddObjects = \votes -> do + now <- systemTimeCurrent systemTime + validatedVotes <- atomically $ do + alreadyInDb <- ChainDB.getPerasVoteIds chainDB + let votesNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasVoteId) votes + traverse (verifyPerasVoteInContext resolverHandle) votesNotAlreadyInDb + -- Some votes are invalid => reject the whole batch + -- We could combine the two 'traverse' operations into one in which case + -- any validated vote would be immediately added no matter what is the + -- validity of the other votes in the batch. + traverse_ (ChainDB.addPerasVoteWithAsyncCertHandling chainDB . WithArrivalTime now) validatedVotes , opwHasObject = do voteIds <- ChainDB.getPerasVoteIds chainDB pure $ \voteId -> Set.member voteId voteIds } - -data PerasVoteInboundException - = forall blk. - Show (PerasError blk) => - PerasVoteValidationError [PerasError blk] - -deriving instance Show PerasVoteInboundException - -instance Exception PerasVoteInboundException - --- | Process a batch of inbound Peras votes received from a peer. --- --- Votes whose ID is already present in the database (as determined by --- @alreadyInDbSTM@) are silently skipped. The remaining votes are validated; --- if /any/ vote in the batch fails validation, the entire batch is rejected --- by throwing a 'PerasVoteInboundException' (which should make us disconnect --- from the distant peer, see 'withPeer' bracket function from --- `ouroboros-network`). Otherwise, each valid vote is timestamped with the --- current wall-clock time and added to the database via @addVote@. -processVotes :: - ( MonadSTM m - , Show (PerasError blk) - , IsPerasVote (PerasVote blk) blk - ) => - SystemTime m -> - STM m (Set (PerasVoteId blk)) -> - (PerasVote blk -> STM m (Either (PerasError blk) (ValidatedPerasVote blk))) -> - (WithArrivalTime (ValidatedPerasVote blk) -> m ()) -> - [PerasVote blk] -> - m () -processVotes systemTime alreadyInDbSTM validateVote addVote votes = do - validationResults <- atomically $ do - alreadyInDb <- alreadyInDbSTM - let votesNotAlreadyInDb = filter (not . (`Set.member` alreadyInDb) . getPerasVoteId) votes - mapM validateVote votesNotAlreadyInDb - now <- systemTimeCurrent systemTime - case partitionEithers validationResults of - -- All votes are valid => add them to the pool - ([], validatedVotes) -> - mapM_ - (addVote . WithArrivalTime now) - validatedVotes - -- Some votes are invalid => reject the whole batch - -- - -- N.B. it has been requested in PR review - -- https://github.com/IntersectMBO/ouroboros-consensus/pull/1768#discussion_r2747873186 - -- to gather all validation errors and report them together in the exception - -- rather than just report the first error encountered. - -- This assumes that vote validation is cheap, which may not be true in - -- practice depending on the actual crypto/committee selection scheme. - -- Hence we may revisit this to lazily abort validation upon the first error - -- encountered. - (errs, _) -> - throw (PerasVoteValidationError errs) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs index 55cb5266fa..7aab3b89c9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Inclusion.hs @@ -67,7 +67,7 @@ data LatestCertOnChainView cert -- | Interface needed to evaluate the Peras cert inclusion rules data PerasCertInclusionView cert blk = PerasCertInclusionView - { perasParams :: !PerasParams + { perasParams :: !(PerasParams blk) -- ^ Peras protocol parameters , currRoundNo :: !PerasRoundNo -- ^ The current Peras round number @@ -92,7 +92,7 @@ mkPerasCertInclusionView :: forall cert blk. IsPerasCert cert blk => -- | Peras protocol parameters - PerasParams -> + PerasParams blk -> -- | Current Peras round number PerasRoundNo -> -- | Most recent certificate seen by the voter diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs index c3830c995f..316abfdc49 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/Mock.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -8,20 +9,23 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | Mocked Peras certificates without crypto. module Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) - , forgeMockPerasCert - , validateMockPerasCert ) where import Cardano.Binary (decodeListLenOf, encodeListLen) import Codec.Serialise (Serialise (..)) import Control.DeepSeq (NFData) +import Data.Containers.NonEmpty (NE) import Data.Data (Proxy (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Set (Set) +import qualified Data.Set.NonEmpty as NESet +import Data.Set.NonEmpty.Internal (NESet (..)) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract @@ -31,26 +35,14 @@ import Ouroboros.Consensus.Block.Abstract , StandardHash ) import Ouroboros.Consensus.Block.SupportsPeras - ( BlockSupportsPeras (..) - , BoostedBlock + ( BoostedBlock , IsPerasCert (..) - , PerasParams (..) , PerasRoundNo - , PerasVoteCollection (pvcTarget, pvcVotes) - , PerasVoteCollectionWithQuorum (..) - , PerasVoteTarget (..) - , ValidatedPerasCert (..), PerasSeatIndex, ValidatedPerasVote (vpvVote), IsPerasVote (getPerasVoteSeatIndex) + , PerasSeatIndex ) import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..)) import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Network.Util (ShowProxy (..)) -import Data.Containers.NonEmpty (NE) -import Data.Set (Set) -import qualified Data.Set.NonEmpty as NESet -import Ouroboros.Consensus.BlockchainTime (WithArrivalTime(forgetArrivalTime)) -import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote) -import qualified Data.Map.NonEmpty as NEMap -import qualified Data.List.NonEmpty as NonEmpty -- | Mocked Peras certificates without crypto. -- @@ -102,11 +94,12 @@ instance , mockCertBlock , mockCertVoters } - where decodeNonEmptySet = do - xs <- decode - case NonEmpty.nonEmpty xs of - Nothing -> fail "Expected a non-empty set of PerasSeatIndex" - Just neSet -> pure $ NESet.fromList neSet + where + decodeNonEmptySet = do + xs <- decode + case NonEmpty.nonEmpty xs of + Nothing -> fail "Expected a non-empty set of PerasSeatIndex" + Just neSet -> pure $ NESet.fromList neSet instance ConvertRawHash blk => @@ -135,44 +128,17 @@ instance , mockCertBlock , mockCertVoters } - where decodeNodeToNodeNonEmptySet _ccfg _version = do - xs <- decode - case NonEmpty.nonEmpty xs of - Nothing -> fail "Expected a non-empty set of PerasSeatIndex" - Just neSet -> pure $ NESet.fromList neSet + where + decodeNodeToNodeNonEmptySet _ccfg _version = do + xs <- decode + case NonEmpty.nonEmpty xs of + Nothing -> fail "Expected a non-empty set of PerasSeatIndex" + Just neSet -> pure $ NESet.fromList neSet --- | Helper to write 'BlockSupportsPeras.forgePerasCert'. -forgeMockPerasCert :: - forall blk. - (PerasCert blk ~ MockPerasCert blk, PerasVote blk ~ MockPerasVote blk)=> - PerasParams -> - PerasVoteCollectionWithQuorum blk -> - Either (PerasError blk) (ValidatedPerasCert blk) -forgeMockPerasCert params votes = do - let target = pvcTarget . forgetQuorum $ votes - let voters = NESet.fromList . fmap getPerasVoteSeatIndex . NEMap.elems . pvcVotes . forgetQuorum $ votes - Right - ValidatedPerasCert - { vpcCert = - MockPerasCert - { mockCertRound = pvtRoundNo target - , mockCertBlock = pvtBlock target - , mockCertVoters = voters - } - , vpcCertBoost = perasWeight params - } +-------------------------------------------------------------------------------- +-- Orphan instances +-------------------------------------------------------------------------------- --- | Helper to write 'BlockSupportsPeras.verifyPerasCert'. --- --- WARNING: we do not perform any validation whatsoever for mocked certificates. -validateMockPerasCert :: - forall blk. - PerasParams -> - PerasCert blk -> - Either (PerasError blk) (ValidatedPerasCert blk) -validateMockPerasCert params cert = - Right - ValidatedPerasCert - { vpcCert = cert - , vpcCertBoost = perasWeight params - } +-- NOTE: we need this to be able to derive a couple of other classes for +-- 'NESet PerasSeatIndex'. +deriving instance Generic (NESet a) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs new file mode 100644 index 0000000000..3784aa1ab3 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} + +module Ouroboros.Consensus.Peras.Context + ( PerasEpochContextResolver + , PerasEpochContextNotFoundForRound (..) + , PerasEpochContextResolverHandle + , verifyPerasVoteInContext + , verifyPerasCertInContext + , resolveRoundNoWithHandle + , constPerasEpochContextResolverHandle + , extractPerasEpochContextResolverHandleFromExtLedgerState + ) +where + +import Control.Exception (Exception) +import Control.Monad.Class.MonadSTM (STM) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Ouroboros.Consensus.Block.SupportsPeras + ( BlockSupportsPeras (..) + , IsPerasCert (getPerasCertRound) + , PerasCert + , PerasRoundNo + , PerasVote + , ValidatedPerasCert + , ValidatedPerasVote + , getPerasVoteRound + ) +import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) +import Ouroboros.Consensus.Util.IOLike + ( IOLike + , MonadSTM + , MonadThrow + , NoThunks + , StrictTVar + , newTVarIO + , readTVar + , throwSTM + ) + +-- stored inside PraosState ? +type PerasEpochContextResolver blk = + PerasRoundNo -> Either PerasEpochContextNotFoundForRound (PerasEpochContext blk) + +data PerasEpochContextNotFoundForRound = PerasEpochContextNotFoundForRound PerasRoundNo + deriving (Show, Eq, Generic, NoThunks, Typeable, Exception) + +newtype PerasEpochContextResolverHandle m blk + = PerasEpochContextResolverHandle (StrictTVar m (PerasEpochContextResolver blk)) + +resolveRoundNoWithHandle :: + MonadSTM m => + PerasEpochContextResolverHandle m blk -> + PerasRoundNo -> + STM m (Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)) +resolveRoundNoWithHandle (PerasEpochContextResolverHandle resolverHandle) roundNo = do + resolver <- readTVar resolverHandle + pure $ resolver roundNo + +verifyPerasVoteInContext :: + ( MonadSTM m + , MonadThrow (STM m) + , BlockSupportsPeras blk + ) => + PerasEpochContextResolverHandle m blk -> + PerasVote blk -> + STM m (ValidatedPerasVote blk) +verifyPerasVoteInContext handle vote = do + let roundNo = getPerasVoteRound vote + resolveRoundNoWithHandle handle roundNo >>= \case + Left err -> throwSTM err + Right epochContext -> + case verifyPerasVote epochContext vote of + Left err -> throwSTM err + Right validatedVote -> pure validatedVote + +verifyPerasCertInContext :: + ( MonadSTM m + , MonadThrow (STM m) + , BlockSupportsPeras blk + ) => + PerasEpochContextResolverHandle m blk -> + PerasCert blk -> + STM m (ValidatedPerasCert blk) +verifyPerasCertInContext handle cert = do + let roundNo = getPerasCertRound cert + in resolveRoundNoWithHandle handle roundNo >>= \case + Left err -> throwSTM err + Right epochContext -> + case verifyPerasCert epochContext cert of + Left err -> throwSTM err + Right validatedCert -> pure validatedCert + +constPerasEpochContextResolverHandle :: + IOLike m => PerasEpochContext blk -> m (PerasEpochContextResolverHandle m blk) +constPerasEpochContextResolverHandle epochContext = + let resolver = \_ -> Right epochContext + in PerasEpochContextResolverHandle <$> newTVarIO resolver + +extractPerasEpochContextResolverHandleFromExtLedgerState :: + ExtLedgerState blk mk -> PerasEpochContextResolverHandle m blk +extractPerasEpochContextResolverHandleFromExtLedgerState = undefined -- TODO: implement as part of future effort diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs index fd4d074637..3b574d72b3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs @@ -1,16 +1,71 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Ouroboros.Consensus.Peras.Crypto.Mock where -import Ouroboros.Consensus.Committee.Crypto + +module Ouroboros.Consensus.Peras.Crypto.Mock + ( MockPerasVotingCommitteeScheme + , MockPerasCrypto + , MockPerasCommittee + , VotingCommittee (..) + , VotingCommitteeInput (..) + , VotingCommitteeError (..) + , EligibilityWitness (..) + , Vote (..) + , Cert (..) + , seatIndexToInt + , unsafeIntToSeatIndex + , getEligibility + ) where + +import Cardano.Prelude (Bifunctor (second)) +import Control.Exception.Base (Exception) +import Data.Either.Extra (maybeToEither) +import qualified Data.List as List +import Data.List.Extra ((!?)) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set.NonEmpty as NESet +import Data.Typeable (Typeable) +import Data.Word (Word16) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract (Point) import Ouroboros.Consensus.Block.SupportsPeras -import Ouroboros.Consensus.Block (Point) + ( PerasCertCompatibleWithVotingCommittee (..) + , PerasRoundNo + , PerasSeatIndex + , PerasVoteCompatibleWithVotingCommittee (..) + , VoteWeight (..) + ) +import Ouroboros.Consensus.Committee.Class + ( CryptoSupportsVotingCommittee (..) + , getElectionIdFromVotes + , getRawVotes + , getVoteCandidateFromVotes + ) +import Ouroboros.Consensus.Committee.Crypto + ( CryptoSupportsAggregateVoteSigning (..) + , CryptoSupportsVoteSigning (..) + , ElectionId + , PrivateKey + , PublicKey + , VoteCandidate + ) +import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId) import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) +import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) -import qualified Data.Set.NonEmpty as NESet -import Ouroboros.Consensus.Committee.EveryoneVotes (EveryoneVotes, Vote (..), Cert (..)) -import qualified Data.List.NonEmpty as NonEmpty data MockPerasVotingCommitteeScheme @@ -35,33 +90,6 @@ instance CryptoSupportsVoteSigning (MockPerasCrypto blk) where signVote _ _ _ = MockVoteSignature verifyVoteSignature _ _ _ _ = Right () --- data Vote crypto EveryoneVotes --- = EveryoneVotesVote --- !SeatIndex --- !(ElectionId crypto) --- !(VoteCandidate crypto) --- !(VoteSignature crypto) - --- data Cert crypto EveryoneVotes --- = EveryoneVotesCert --- !(ElectionId crypto) --- !(VoteCandidate crypto) --- !(NE (Set SeatIndex)) --- !(AggregateVoteSignature crypto) - --- data MockPerasCert blk --- = MockPerasCert --- { mockCertRound :: PerasRoundNo --- , mockCertBlock :: Point blk --- } - --- data MockPerasVote blk --- = MockPerasVote --- { mockVoteRound :: PerasRoundNo --- , mockVoteBlock :: Point blk --- , mockVoteSeatIndex :: PerasSeatIndex --- } - type instance ElectionId (MockPerasCrypto blk) = PerasRoundNo type instance VoteCandidate (MockPerasCrypto blk) = Point blk @@ -72,38 +100,192 @@ instance CryptoSupportsAggregateVoteSigning (MockPerasCrypto blk) where verifyAggregateVoteSignature _ _ _ _ _ = Right () aggregateVoteVerificationKeys _ _ = Right () +-------------------------------------------------------------------------------- +-- Uncomment if we ever need to use 'MockPeras{Vote,Cert}' with 'EveryoneVotes' scheme +-------------------------------------------------------------------------------- +-- instance +-- PerasVoteCompatibleWithVotingCommittee +-- (MockPerasVote blk) +-- (MockPerasCrypto blk) +-- EveryoneVotes +-- where +-- toPerasVote (EveryoneVotesVote seatIndex roundNo point _signature) = do +-- perasSeatIndex <- toPerasSeatIndex seatIndex +-- pure $ +-- MockPerasVote +-- { mockVoteRound = roundNo +-- , mockVoteBlock = point +-- , mockVoteSeatIndex = perasSeatIndex +-- } +-- fromPerasVote MockPerasVote{mockVoteRound, mockVoteBlock, mockVoteSeatIndex} = +-- Right $ +-- EveryoneVotesVote +-- (fromPerasSeatIndex mockVoteSeatIndex) +-- mockVoteRound +-- mockVoteBlock +-- MockVoteSignature + +-- instance +-- PerasCertCompatibleWithVotingCommittee +-- (MockPerasCert blk) +-- (MockPerasCrypto blk) +-- EveryoneVotes +-- where +-- toPerasCert (EveryoneVotesCert roundNo point voters _certSignature) = do +-- perasVoters <- do +-- perasSeatIndices <- traverse toPerasSeatIndex (NonEmpty.toList $ NESet.toList voters) +-- case NonEmpty.nonEmpty perasSeatIndices of +-- Nothing -> error "We started with a non-empty set of voters, so this should never happen" +-- Just neList -> pure $ NESet.fromList neList +-- pure $ +-- MockPerasCert +-- { mockCertRound = roundNo +-- , mockCertBlock = point +-- , mockCertVoters = perasVoters +-- } +-- fromPerasCert MockPerasCert{mockCertRound, mockCertBlock, mockCertVoters} = +-- Right $ +-- EveryoneVotesCert +-- mockCertRound +-- mockCertBlock +-- (NESet.mapMonotonic fromPerasSeatIndex mockCertVoters) +-- () +-------------------------------------------------------------------------------- + +data MockPerasCommittee blk + +instance + ( Ord (ElectionId crypto) + , ElectionId crypto ~ PerasRoundNo + , VoteCandidate crypto ~ Point blk + , CryptoSupportsAggregateVoteSigning crypto + ) => + CryptoSupportsVotingCommittee crypto (MockPerasCommittee blk) + where + newtype VotingCommittee crypto (MockPerasCommittee blk) + = MockPerasVotingCommittee + { -- Stake distribution + weightDistr :: NonEmpty (PoolId, VoteWeight) + } + deriving stock (Show, Eq, Generic, Typeable) + deriving anyclass NoThunks + + newtype VotingCommitteeInput crypto (MockPerasCommittee blk) + = MockPerasVotingCommitteeInput (NonEmpty (PoolId, LedgerStake)) + deriving stock (Show, Eq, Generic, Typeable) + deriving anyclass NoThunks + + newtype VotingCommitteeError crypto (MockPerasCommittee blk) + = -- Seat index is out of bounds for the voting committee + MissingSeatIndex PerasSeatIndex + deriving stock (Show, Eq, Generic, Typeable) + deriving anyclass (NoThunks, Exception) + + data EligibilityWitness crypto (MockPerasCommittee blk) + = MockPerasCommitteeMember + !PerasSeatIndex + !VoteWeight + deriving stock (Show, Eq, Generic, Typeable) + deriving anyclass NoThunks + + newtype Vote crypto (MockPerasCommittee blk) + = MockPerasCommitteeVote (MockPerasVote blk) + deriving stock (Show, Eq, Generic, Typeable) + deriving anyclass NoThunks + + newtype Cert crypto (MockPerasCommittee blk) + = MockPerasCommitteeCert (MockPerasCert blk) + deriving stock (Show, Eq, Generic, Typeable) + deriving anyclass NoThunks + + mkVotingCommittee (MockPerasVotingCommitteeInput stakeDistr) = + let LedgerStake totalStake = sum (snd <$> stakeDistr) + normalize (LedgerStake stake) = if totalStake == 0 then 0 else VoteWeight (stake / totalStake) + in Right MockPerasVotingCommittee{weightDistr = second normalize <$> stakeDistr} + checkShouldVote MockPerasVotingCommittee{weightDistr} poolId _ _ = + case findWithIndex (\(pid, _) -> pid == poolId) weightDistr of + Just (rawIndex, (_pid, voteWeight)) -> Right . Just $ MockPerasCommitteeMember (unsafeIntToSeatIndex rawIndex) voteWeight + _ -> Right Nothing + where + findWithIndex :: (a -> Bool) -> NonEmpty a -> Maybe (Int, a) + findWithIndex p xs = List.find (p . snd) (zip [0 ..] (NonEmpty.toList xs)) + forgeVote (MockPerasCommitteeMember seatIndex _) _ roundNo block = + MockPerasCommitteeVote $ + MockPerasVote + { mockVoteRound = roundNo + , mockVoteBlock = block + , mockVoteSeatIndex = seatIndex + } + verifyVote MockPerasVotingCommittee{weightDistr} (MockPerasCommitteeVote mockVote) = + let seatIndex = mockVoteSeatIndex mockVote + in case NonEmpty.toList weightDistr !? seatIndexToInt seatIndex of + Just (_pid, voteWeight) -> Right $ MockPerasCommitteeMember seatIndex voteWeight + _ -> Left (MissingSeatIndex seatIndex) + eligiblePartyVoteWeight _ (MockPerasCommitteeMember _seatIndex voteWeight) = voteWeight + forgeCert uniqueVoteWithSameTarget = do + let roundNo = getElectionIdFromVotes uniqueVoteWithSameTarget + block = getVoteCandidateFromVotes uniqueVoteWithSameTarget + rawVotes = getRawVotes uniqueVoteWithSameTarget + let voters = NESet.fromList $ (\(MockPerasCommitteeVote mockVote) -> mockVoteSeatIndex mockVote) <$> rawVotes + pure $ + MockPerasCommitteeCert $ + MockPerasCert + { mockCertRound = roundNo + , mockCertBlock = block + , mockCertVoters = voters + } + verifyCert committee (MockPerasCommitteeCert mockCert) = do + let voterList = NESet.toList $ mockCertVoters mockCert + traverse + (\seatIndex -> maybeToEither (MissingSeatIndex seatIndex) (getEligibility committee seatIndex)) + voterList + + voteTarget (MockPerasCommitteeVote MockPerasVote{mockVoteRound, mockVoteBlock}) = + (mockVoteRound, mockVoteBlock) + compareVotesById + ( MockPerasCommitteeVote + MockPerasVote{mockVoteRound = mockVoteRound1, mockVoteSeatIndex = mockVoteSeatIndex1} + ) + ( MockPerasCommitteeVote + MockPerasVote{mockVoteRound = mockVoteRound2, mockVoteSeatIndex = mockVoteSeatIndex2} + ) = + compare (mockVoteRound1, mockVoteSeatIndex1) (mockVoteRound2, mockVoteSeatIndex2) + instance PerasVoteCompatibleWithVotingCommittee (MockPerasVote blk) - (MockPerasCrypto blk) - EveryoneVotes + (MockPerasCrypto blk) -- We can theoretically use an arbitrary crypto scheme, but we must abide by 'vote -> crypto' fun dep + (MockPerasCommittee blk) where - toPerasVote (EveryoneVotesVote seatIndex roundNo point _signature) = do - perasSeatIndex <- toPerasSeatIndex seatIndex - pure $ MockPerasVote - { mockVoteRound = roundNo - , mockVoteBlock = point - , mockVoteSeatIndex = perasSeatIndex - } - fromPerasVote MockPerasVote { mockVoteRound, mockVoteBlock, mockVoteSeatIndex } = - Right $ EveryoneVotesVote (fromPerasSeatIndex mockVoteSeatIndex) mockVoteRound mockVoteBlock MockVoteSignature + toPerasVote (MockPerasCommitteeVote mockVote) = + Right $ mockVote + fromPerasVote mockVote = + Right $ MockPerasCommitteeVote mockVote instance PerasCertCompatibleWithVotingCommittee (MockPerasCert blk) - (MockPerasCrypto blk) - EveryoneVotes + (MockPerasCrypto blk) -- We can theoretically use an arbitrary crypto scheme, but we must abide by 'vote -> crypto' fun dep + (MockPerasCommittee blk) where - toPerasCert (EveryoneVotesCert roundNo point voters _certSignature) = do - perasVoters <- do - perasSeatIndices <- traverse toPerasSeatIndex (NonEmpty.toList $ NESet.toList voters) - case NonEmpty.nonEmpty perasSeatIndices of - Nothing -> error "We started with a non-empty set of voters, so this should never happen" - Just neList -> pure $ NESet.fromList neList - pure $ MockPerasCert - { mockCertRound = roundNo - , mockCertBlock = point - , mockCertVoters = perasVoters - } - fromPerasCert MockPerasCert { mockCertRound, mockCertBlock, mockCertVoters } = - Right $ EveryoneVotesCert mockCertRound mockCertBlock (NESet.mapMonotonic fromPerasSeatIndex mockCertVoters) () + toPerasCert (MockPerasCommitteeCert mockCert) = + Right $ mockCert + fromPerasCert mockCert = + Right $ MockPerasCommitteeCert mockCert + +seatIndexToInt :: PerasSeatIndex -> Int +seatIndexToInt (PerasSeatIndex seatIndex) = fromIntegral @Word16 @Int seatIndex + +unsafeIntToSeatIndex :: Int -> PerasSeatIndex +unsafeIntToSeatIndex int + | int >= 0 && int <= fromIntegral @Word16 @Int maxBound = + PerasSeatIndex (fromIntegral @Int @Word16 int) + | otherwise = error $ "unsafeIntToSeatIndex: Int out of bounds for PerasSeatIndex: " <> show int + +getEligibility :: + VotingCommittee crypto (MockPerasCommittee blk) -> + PerasSeatIndex -> + Maybe (EligibilityWitness crypto (MockPerasCommittee blk)) +getEligibility MockPerasVotingCommittee{weightDistr} seatIndex = do + (_poolId, voteWeight) <- NonEmpty.toList weightDistr !? seatIndexToInt seatIndex + pure $ MockPerasCommitteeMember seatIndex voteWeight diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs new file mode 100644 index 0000000000..6c408ef7fe --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Concrete Peras error types for the V1 voting protocol. +-- +-- NOTE: this module is meant to be imported qualified. +module Ouroboros.Consensus.Peras.Error.Mock + ( MockPerasError (..) + ) where + +import Control.Exception (Exception) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.SupportsPeras + ( IsPerasError (..) + , PerasVotingCommitteeError + , VoteWeight + ) +import Ouroboros.Consensus.Peras.Types (PerasConversionError) + +-- | Collection of voting-related errors for Peras +data MockPerasError blk + = PerasVotingCommitteeError + (PerasVotingCommitteeError blk) + | PerasVotingConversionError + PerasConversionError + | PerasQuorumNotReachedError + VoteWeight + +deriving instance + Show (PerasVotingCommitteeError blk) => + Show (MockPerasError blk) +deriving instance + Eq (PerasVotingCommitteeError blk) => + Eq (MockPerasError blk) +deriving instance + NoThunks (PerasVotingCommitteeError blk) => + NoThunks (MockPerasError blk) +deriving instance + Generic (MockPerasError blk) +deriving instance + Typeable (MockPerasError blk) +deriving instance + (Show (PerasVotingCommitteeError blk), Typeable blk) => + Exception (MockPerasError blk) + +instance IsPerasError (MockPerasError blk) blk where + injectVotingCommitteeError = PerasVotingCommitteeError + injectConversionError = PerasVotingConversionError + injectQuorumNotReachedError = PerasQuorumNotReachedError diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs index b5740639d6..affd71ee47 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs @@ -13,6 +13,8 @@ module Ouroboros.Consensus.Peras.Error.V1 ( PerasError (..) ) where +import Control.Exception (Exception) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.SupportsPeras @@ -47,6 +49,11 @@ deriving instance NoThunks (PerasError blk) deriving instance Generic (PerasError blk) +deriving instance + Typeable (PerasError blk) +deriving instance + (Show (PerasVotingCommitteeError blk), Typeable blk) => + Exception (PerasError blk) instance IsPerasError (PerasError blk) blk where injectVotingCommitteeError = PerasVotingCommitteeError diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs index 3d1d3af6d7..0d53146609 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs @@ -122,7 +122,7 @@ newtype PerasQuorumWeightThresholdSafetyMargin -- https://tweag.github.io/cardano-peras/peras-design.pdf#section.2.1 -- -- TODO: make fields strict when we have concrete default values for them. -data PerasParams = PerasParams +data PerasParams blk = PerasParams { perasIgnoranceRounds :: !PerasIgnoranceRounds , perasCooldownRounds :: !PerasCooldownRounds , perasBlockMinSlots :: !PerasBlockMinSlots @@ -139,7 +139,7 @@ data PerasParams = PerasParams -- | Instantiate default Peras protocol parameters. -- -- NOTE: in the future this will depend on a concrete 'BlockConfig'. -mkPerasParams :: PerasParams +mkPerasParams :: PerasParams blk mkPerasParams = -- Many of these parameters are provided with sensible default values for now, -- waiting for a final decision (in a future stage of the project) on the diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs index 07f5d5b0d4..6d58d3b529 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -188,7 +188,7 @@ instance Serialise (PerasVoteId blk) where -- both are either absolute or relative (normalized) values. Under the current -- current implementation of 'PerasParams', this function only makes sense when -- both values are relative (normalized) values. -weightAboveThreshold :: PerasParams -> VoteWeight -> Bool +weightAboveThreshold :: PerasParams blk -> VoteWeight -> Bool weightAboveThreshold params voteWeight = weight >= quorumThreshold + safetyMargin where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs index 85a750b912..946e96052c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Mock.hs @@ -9,14 +9,11 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Mocked Peras votes without crypto. module Ouroboros.Consensus.Peras.Vote.Mock ( MockPerasVote (..) - , forgeMockPerasVote - , validateMockPerasVote ) where import Cardano.Binary (decodeListLenOf, encodeListLen) @@ -32,17 +29,12 @@ import Ouroboros.Consensus.Block.Abstract , StandardHash ) import Ouroboros.Consensus.Block.SupportsPeras - ( BlockSupportsPeras (..) - , BoostedBlock + ( BoostedBlock , IsPerasVote (..) , PerasRoundNo , PerasSeatIndex (..) - , ValidatedPerasVote (..) - , VoteWeight - , VoteWeightDistr ) import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..)) -import Ouroboros.Consensus.Peras.Params (PerasParams) import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Network.Util (ShowProxy (..)) @@ -125,25 +117,3 @@ instance , mockVoteBlock , mockVoteSeatIndex } - -forgeMockPerasVote :: - forall blk. - PerasVote blk ~ MockPerasVote blk => - PerasParams -> - PerasRoundNo -> - Point blk -> - PerasSeatIndex -> - Either (PerasError blk) (ValidatedPerasVote blk) -forgeMockPerasVote _params roundNo point seatIndex = undefined - --- | Helper to write 'BlockSupportsPeras.verifyPerasVote'. --- --- WARNING: we do not perform any validation whatsoever for mocked votes. -validateMockPerasVote :: - forall blk. - PerasVote blk ~ MockPerasVote blk => - PerasParams -> - VoteWeightDistr -> - PerasVote blk -> - Either (PerasError blk) (ValidatedPerasVote blk) -validateMockPerasVote _params _voteWeightDistr vote = undefined diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs index 8501c3e9a4..1b1cbf751e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs @@ -81,6 +81,7 @@ instance Coercible (HeaderHash blk) ShortByteString => IsPerasVote (PerasVote blk) blk where + getPerasVoteSeatIndex = pvSeatIndex getPerasVoteRound = pvRoundNo getPerasVoteBlock = pvBoostedBlock diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs index d088bae441..44b2750ebf 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs @@ -74,7 +74,7 @@ instance Explainable PerasVotingRulesDecision where -- | Evaluate whether voting is allowed or not according to the voting rules isPerasVotingAllowed :: IsPerasCert cert blk => - PerasVotingView cert -> + PerasVotingView cert blk -> PerasVotingRulesDecision isPerasVotingAllowed pvv = evalPred (perasVotingRules pvv) $ \e -> @@ -125,7 +125,7 @@ instance Explainable PerasVotingRule where -- certificate was received in the first X slots after the start of the round. perasVR1A :: IsPerasCert cert blk => - PerasVotingView cert -> + PerasVotingView cert blk -> Pred PerasVotingRule perasVR1A PerasVotingView @@ -163,7 +163,7 @@ perasVR1A -- | VR-1B: the block being voted upon extends the most recently certified one. perasVR1B :: - PerasVotingView cert -> + PerasVotingView cert blk -> Pred PerasVotingRule perasVR1B PerasVotingView @@ -188,7 +188,7 @@ perasVR1B -- cooldown period. perasVR2A :: IsPerasCert cert blk => - PerasVotingView cert -> + PerasVotingView cert blk -> Pred PerasVotingRule perasVR2A PerasVotingView @@ -221,7 +221,7 @@ perasVR2A -- period. perasVR2B :: IsPerasCert cert blk => - PerasVotingView cert -> + PerasVotingView cert blk -> Pred PerasVotingRule perasVR2B PerasVotingView @@ -265,7 +265,7 @@ perasVR2B -- the voting has regularly occurred in preceding rounds. perasVR1 :: IsPerasCert cert blk => - PerasVotingView cert -> + PerasVotingView cert blk -> Pred PerasVotingRule perasVR1 pvv = perasVR1A pvv :/\: perasVR1B pvv @@ -274,7 +274,7 @@ perasVR1 pvv = -- the chain is about to exit a cooldown period. perasVR2 :: IsPerasCert cert blk => - PerasVotingView cert -> + PerasVotingView cert blk -> Pred PerasVotingRule perasVR2 pvv = perasVR2A pvv :/\: perasVR2B pvv @@ -282,7 +282,7 @@ perasVR2 pvv = -- | Voting is allowed if either VR-1A and VR-1B hold, or VR-2A and VR-2B hold. perasVotingRules :: IsPerasCert cert blk => - PerasVotingView cert -> + PerasVotingView cert blk -> Pred PerasVotingRule perasVotingRules pvv = perasVR1 pvv :\/: perasVR2 pvv diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs index 989ec9922e..5fa101619d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs @@ -189,8 +189,8 @@ newtype LatestCertOnChainView cert -- block or its point, but only whether the candidate block extends the block -- boosted by the most recent certificate seen by the voter, which is provided -- to the rules via 'lcsCandidateBlockExtendsCert' inside 'latestCertSeen'. -data PerasVotingView cert = PerasVotingView - { perasParams :: !PerasParams +data PerasVotingView cert blk = PerasVotingView + { perasParams :: !(PerasParams blk) -- ^ Peras protocol parameters , currRoundNo :: !PerasRoundNo -- ^ The current Peras round number @@ -226,7 +226,7 @@ mkPerasVotingView :: , IsPerasCert (PerasCert blk) blk ) => -- | Peras protocol parameters - PerasParams -> + PerasParams blk -> -- | Current Peras round number PerasRoundNo -> -- | Most recent certificate seen by the voter @@ -237,7 +237,7 @@ mkPerasVotingView :: -- preferred chain AnchoredFragment (Header blk) -> -- | Constructed voting view - PerasQry xs (PerasVotingView cert) + PerasQry xs (PerasVotingView cert blk) mkPerasVotingView perasParams currRoundNo diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index a595a690f3..3cfbdd4832 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -26,6 +26,7 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Context (extractPerasEpochContextResolverHandleFromExtLedgerState) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( GetLoEFragment @@ -229,7 +230,8 @@ completeChainDbArgs , cdbPerasVoteDbArgs = PerasVoteDB.PerasVoteDbArgs { PerasVoteDB.pvdbaTracer = PerasVoteDB.pvdbaTracer (cdbPerasVoteDbArgs defArgs) - , PerasVoteDB.pvdbaPerasParams = mkPerasParams + , PerasVoteDB.pvdbaPerasEpochContextResolverHandle = + extractPerasEpochContextResolverHandleFromExtLedgerState initLedger } , cdbsArgs = (cdbsArgs defArgs) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index 734f4ef04f..b8f85208a4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -35,6 +35,7 @@ import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (WithArrivalTime (..)) +import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle, resolveRoundNoWithHandle) import Ouroboros.Consensus.Peras.Vote.Aggregation import Ouroboros.Consensus.Storage.PerasVoteDB.API import Ouroboros.Consensus.Util.Args @@ -169,14 +170,14 @@ deriving instance type PerasVoteDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type data PerasVoteDbArgs f m blk = PerasVoteDbArgs { pvdbaTracer :: Tracer m (TraceEvent blk) - , pvdbaPerasParams :: HKD f PerasParams + , pvdbaPerasEpochContextResolverHandle :: HKD f (PerasEpochContextResolverHandle m blk) } defaultArgs :: Applicative m => Incomplete PerasVoteDbArgs m blk defaultArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer - , pvdbaPerasParams = noDefault + , pvdbaPerasEpochContextResolverHandle = noDefault } createDB :: @@ -186,7 +187,7 @@ createDB :: ) => Complete PerasVoteDbArgs m blk -> m (PerasVoteDB m blk) -createDB args@PerasVoteDbArgs{pvdbaPerasParams} = do +createDB args@PerasVoteDbArgs{pvdbaPerasEpochContextResolverHandle} = do pvdeState <- newTVarWithInvariantIO (either Just (const Nothing) . invariantForPerasVoteDbState) @@ -198,7 +199,7 @@ createDB args@PerasVoteDbArgs{pvdbaPerasParams} = do } pure PerasVoteDB - { addVote = implAddVote pvdbaPerasParams env + { addVote = implAddVote pvdbaPerasEpochContextResolverHandle env , getVoteIds = implGetVoteIds env , getVotesAfter = implGetVotesAfter env , getForgedCertForRound = implGetForgedCertForRound env @@ -219,11 +220,11 @@ implAddVote :: ( IOLike m , BlockSupportsPeras blk ) => - PerasParams -> + PerasEpochContextResolverHandle m blk -> PerasVoteDbEnv m blk -> WithArrivalTime (ValidatedPerasVote blk) -> STM m (m (AddPerasVoteResult blk)) -implAddVote params PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do +implAddVote resolverHandle PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do let voteId = getPerasVoteId vote addPerasVoteRes <- do WithFingerprint pvds fp <- readTVar pvdeState @@ -243,12 +244,16 @@ implAddVote params PerasVoteDbEnv{pvdeTracer, pvdeState} vote = do voteAlreadyInDB pvds = pure (PerasVoteAlreadyInDB, pvds) tryAddVote pvds voteId = do + -- We need to get the 'PerasEpochContext' corresponding to the vote 'PerasRoundNo' + epochContext <- + either throwSTM pure =<< resolveRoundNoWithHandle resolverHandle (getPerasVoteRound vote) + let pvsVoteIds' = Set.insert voteId (pvdsVoteIds pvds) pvsLastTicketNo' = succ (pvdsLastTicketNo pvds) pvsVotesByTicket' = Map.insert pvsLastTicketNo' vote (pvdsVotesByTicket pvds) (addPerasVoteRes, pvsRoundVoteStates') <- - case updatePerasRoundVoteStates vote params (pvdsRoundVoteStates pvds) of + case updatePerasRoundVoteStates vote epochContext (pvdsRoundVoteStates pvds) of -- Added vote and reached a quorum, forging a new certificate Right (VoteGeneratedNewCert cert, pvsRoundVoteStates') -> pure (AddedPerasVoteAndGeneratedNewCert cert, pvsRoundVoteStates') diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index 8404c1191e..5e17b3cb7f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -24,6 +24,8 @@ import qualified Data.Map.NonEmpty as NEMap import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MultiSet import Data.SOP.BasicFunctors +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NESet import Data.Typeable (Typeable) import Data.Void (Void) import NoThunks.Class @@ -40,8 +42,6 @@ import System.FS.API.Types (FsPath, Handle) import System.FS.CRC (CRC (CRC)) import System.Random (StdGen) import qualified System.Random.Internal as Random -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NESet {------------------------------------------------------------------------------- Serialise @@ -98,7 +98,7 @@ instance (NoThunks k, NoThunks v) => NoThunks (NEMap k v) where showTypeOf _ = "NEMap" wNoThunks ctxt = wNoThunks ctxt . NEMap.toMap -instance (NoThunks v) => NoThunks (NESet v) where +instance NoThunks v => NoThunks (NESet v) where showTypeOf _ = "NESet" wNoThunks ctxt = wNoThunks ctxt . NESet.toSet diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index aa3611a7b1..d83b3df9d2 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -86,6 +86,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe (maybeToList) +import Data.Set.NonEmpty.Internal (NESet (..)) import Data.TreeDiff import Data.Void (Void) import Data.Word @@ -116,12 +117,11 @@ import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) - , forgeMockPerasCert - , validateMockPerasCert ) +import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCommittee, MockPerasCrypto) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) import Ouroboros.Consensus.Peras.Vote.Mock ( MockPerasVote (..) - , validateMockPerasVote ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT @@ -737,13 +737,11 @@ instance LedgerSupportsPeras TestBlock where -- NOTE: this is a mocked up implementation without crypto! instance BlockSupportsPeras TestBlock where + type PerasCrypto TestBlock = MockPerasCrypto TestBlock + type PerasVotingCommitteeScheme TestBlock = MockPerasCommittee TestBlock type PerasVote TestBlock = MockPerasVote TestBlock type PerasCert TestBlock = MockPerasCert TestBlock - type PerasError TestBlock = VoidPerasError TestBlock - - verifyPerasVote = validateMockPerasVote - verifyPerasCert = validateMockPerasCert - forgePerasCert = forgeMockPerasCert + type PerasError TestBlock = MockPerasError TestBlock getPerasCertInBlock = tbPerasCert . testBody instance HasHardForkHistory TestBlock where @@ -965,6 +963,8 @@ instance Hashable TestHeader instance Hashable TestBlock instance Hashable (Block SlotNo TestHeaderHash) instance Hashable (Point TestBlock) +instance Hashable PerasSeatIndex +instance Hashable (NESet PerasSeatIndex) instance Hashable (MockPerasCert TestBlock) instance (Hashable a, Hashable (WithOrigin a)) => Hashable (WithOrigin a) instance (StandardHash b, Hashable (HeaderHash b)) => Hashable (ChainHash b) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs index e64d3de4fb..cebb55a8c4 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -21,7 +21,7 @@ import Ouroboros.Consensus.HardFork.History.EraParams (eraEpochSize) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import Ouroboros.Consensus.Ledger.SupportsProtocol -import Ouroboros.Consensus.Peras.Params (mkPerasParams) +import Ouroboros.Consensus.Peras.Context (extractPerasEpochContextResolverHandleFromExtLedgerState) import Ouroboros.Consensus.Storage.ChainDB hiding ( TraceFollowerEvent (..) ) @@ -141,7 +141,8 @@ fromMinimalChainDbArgs MinimalChainDbArgs{..} = , cdbPerasVoteDbArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer - , pvdbaPerasParams = mkPerasParams + , pvdbaPerasEpochContextResolverHandle = + extractPerasEpochContextResolverHandleFromExtLedgerState mcdbInitLedger } , cdbsArgs = ChainDbSpecificArgs diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index d191a0caad..ede361053d 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -12,6 +12,7 @@ module Test.Util.Orphans.ToExpr () where import qualified Control.Monad.Class.MonadTime.SI as SI +import Data.Set.NonEmpty (NESet) import Data.TreeDiff import GHC.Generics (Generic) import Ouroboros.Consensus.Block @@ -132,6 +133,8 @@ deriving anyclass instance ToExpr (PerasVoteId blk) deriving anyclass instance ToExpr a => ToExpr (WithArrivalTime a) +deriving anyclass instance ToExpr a => ToExpr (NESet a) + instance ToExpr PerasSeatIndex where toExpr = defaultExprViaShow instance ToExpr (HeaderHash blk) => ToExpr (MockPerasVote blk) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index 581c747aaa..08ee8efeaa 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -144,13 +144,12 @@ import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) - , forgeMockPerasCert - , validateMockPerasCert ) +import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCommittee, MockPerasCrypto) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) import Ouroboros.Consensus.Peras.SelectView (weightedSelectView) import Ouroboros.Consensus.Peras.Vote.Mock ( MockPerasVote (..) - , validateMockPerasVote ) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Protocol.Abstract @@ -713,13 +712,11 @@ instance Typeable ptype => BlockSupportsPeras (TestBlockWith ptype) where + type PerasCrypto (TestBlockWith ptype) = MockPerasCrypto (TestBlockWith ptype) + type PerasVotingCommitteeScheme (TestBlockWith ptype) = MockPerasCommittee (TestBlockWith ptype) type PerasVote (TestBlockWith ptype) = MockPerasVote (TestBlockWith ptype) type PerasCert (TestBlockWith ptype) = MockPerasCert (TestBlockWith ptype) - type PerasError (TestBlockWith ptype) = VoidPerasError (TestBlockWith ptype) - - verifyPerasVote = validateMockPerasVote - verifyPerasCert = validateMockPerasCert - forgePerasCert = forgeMockPerasCert + type PerasError (TestBlockWith ptype) = MockPerasError (TestBlockWith ptype) -- TODO: extract actual Peras certificates from blocks getPerasCertInBlock _ = Nothing diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index 15cc9a5d92..9ed902d64f 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} @@ -9,8 +8,6 @@ module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke ( tests - , genPerasCert - , genValidatedPerasCert ) where import Control.Monad (join) @@ -25,7 +22,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert -import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) +import Ouroboros.Consensus.Peras.Context (constPerasEpochContextResolverHandle) import Ouroboros.Consensus.Storage.PerasCertDB.API ( AddPerasCertResult (..) , PerasCertDB @@ -41,14 +38,15 @@ import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundPeer) import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke ( ListWithUniqueIds (..) - , WithId - , genListWithUniqueIds - , genPointTestBlock , genProtocolConstants + , prop_smoke_object_diffusion + ) +import Test.Consensus.Peras.Util + ( genListWithUniqueIds + , genMockPerasEpochContext + , genMockValidatedPerasCert , genWithArrivalTime - , getId , mockSystemTime - , prop_smoke_object_diffusion ) import Test.QuickCheck import Test.Tasty @@ -62,36 +60,12 @@ tests = [ testProperty "PerasCertDiffusion smoke test" prop_smoke ] -genPerasCert :: Gen (PerasCert TestBlock) -genPerasCert = do - mockCertRound <- PerasRoundNo <$> arbitrary - mockCertBlock <- genPointTestBlock - pure $ - MockPerasCert - { mockCertRound - , mockCertBlock - } - -instance WithId (MockPerasCert blk) PerasRoundNo where - getId = getPerasCertRound - -instance - IsPerasCert (PerasCert blk) blk => - WithId (WithArrivalTime (ValidatedPerasCert blk)) PerasRoundNo - where - getId = getPerasCertRound . vpcCert . forgetArrivalTime - -genValidatedPerasCert :: Gen (ValidatedPerasCert TestBlock) -genValidatedPerasCert = - ValidatedPerasCert - <$> genPerasCert - <*> pure (perasWeight mkPerasParams) - newCertDB :: ( IOLike m , BlockSupportsPeras blk ) => - [WithArrivalTime (ValidatedPerasCert blk)] -> m (PerasCertDB m blk) + [WithArrivalTime (ValidatedPerasCert blk)] -> + m (PerasCertDB m blk) newCertDB certs = do db <- PerasCertDB.createDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) mapM_ @@ -107,38 +81,42 @@ newCertDB certs = do prop_smoke :: Property prop_smoke = forAll genProtocolConstants $ \protocolConstants -> - forAll (genListWithUniqueIds (genWithArrivalTime genValidatedPerasCert)) $ - \(ListWithUniqueIds watValidatedCerts) -> - let - mkPoolInterfaces :: - forall m. - IOLike m => - m - ( ObjectPoolReader PerasRoundNo (PerasCert TestBlock) PerasCertTicketNo m - , ObjectPoolWriter PerasRoundNo (PerasCert TestBlock) m - , m [PerasCert TestBlock] - ) - mkPoolInterfaces = do - outboundPool <- newCertDB watValidatedCerts - inboundPool <- newCertDB [] + forAll genMockPerasEpochContext $ \epochContext -> + forAll + (genListWithUniqueIds getPerasCertRound (genWithArrivalTime (genMockValidatedPerasCert epochContext))) $ + \(ListWithUniqueIds watValidatedCerts) -> + let + mkPoolInterfaces :: + forall m. + IOLike m => + m + ( ObjectPoolReader PerasRoundNo (PerasCert TestBlock) PerasCertTicketNo m + , ObjectPoolWriter PerasRoundNo (PerasCert TestBlock) m + , m [PerasCert TestBlock] + ) + mkPoolInterfaces = do + epochContextResolverHandle <- constPerasEpochContextResolverHandle epochContext + + outboundPool <- newCertDB watValidatedCerts + inboundPool <- newCertDB [] - let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool - inboundPoolWriter = makePerasCertPoolWriterFromCertDB mockSystemTime inboundPool - getAllInboundPoolContent = do - certsMap <- - atomically $ - PerasCertDB.getCertsAfter inboundPool (PerasCertDB.zeroPerasCertTicketNo) - certs' <- sequence (Map.elems certsMap) - pure $ vpcCert . forgetArrivalTime <$> certs' + let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool + inboundPoolWriter = makePerasCertPoolWriterFromCertDB mockSystemTime inboundPool epochContextResolverHandle + getAllInboundPoolContent = do + certsMap <- + atomically $ + PerasCertDB.getCertsAfter inboundPool (PerasCertDB.zeroPerasCertTicketNo) + certs' <- sequence (Map.elems certsMap) + pure $ vpcCert . forgetArrivalTime <$> certs' - return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) - in - prop_smoke_object_diffusion - protocolConstants - (map (vpcCert . forgetArrivalTime) watValidatedCerts) - runOutboundPeer - runInboundPeer - mkPoolInterfaces + return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) + in + prop_smoke_object_diffusion + protocolConstants + (map (vpcCert . forgetArrivalTime) watValidatedCerts) + runOutboundPeer + runInboundPeer + mkPoolInterfaces where runOutboundPeer outbound outboundChannel tracer = runPeer diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs index 8caa7058fa..8ae4bddfc4 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs @@ -1,22 +1,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke ( tests - , genPerasSeatIndex - , genVoteWeight - , genPerasVote - , genValidatedPerasVote ) where import Control.Monad (join) import Control.Tracer (contramap, nullTracer) import qualified Data.Map as Map -import Data.Ratio ((%)) import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) import Ouroboros.Consensus.Block.SupportsPeras import Ouroboros.Consensus.BlockchainTime.WallClock.Types @@ -25,7 +19,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote -import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) +import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle, constPerasEpochContextResolverHandle) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB @@ -41,15 +35,16 @@ import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundPeer) import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke ( ListWithUniqueIds (..) - , WithId - , genListWithUniqueIds - , genPointTestBlock , genProtocolConstants + , prop_smoke_object_diffusion + ) +import Test.Consensus.Peras.Util + ( genListWithUniqueIds + , genMockPerasEpochContext , genWithArrivalTime - , getId , mockSystemTime - , prop_smoke_object_diffusion ) +import Test.Consensus.Peras.Util.Mock (genMockValidatedPerasVote) import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck (testProperty) @@ -62,53 +57,15 @@ tests = [ testProperty "PerasVoteDiffusion smoke test" prop_smoke ] -genPerasSeatIndex :: Gen PerasSeatIndex -genPerasSeatIndex = PerasSeatIndex <$> arbitrary - -genVoteWeight :: Gen VoteWeight -genVoteWeight = do - weight <- (1 %) <$> choose (2, 10) - pure (VoteWeight weight) - -genPerasVote :: Gen (PerasVote TestBlock) -genPerasVote = do - mockVoteRound <- PerasRoundNo <$> arbitrary - mockVoteBlock <- genPointTestBlock - mockVoteSeatIndex <- genPerasSeatIndex - mockVoteWeight <- genVoteWeight - pure $ - MockPerasVote - { mockVoteRound - , mockVoteBlock - , mockVoteSeatIndex - , mockVoteWeight - } - -instance WithId (MockPerasVote blk) (PerasVoteId blk) where - getId = getPerasVoteId - -instance - IsPerasVote (PerasVote blk) blk => - WithId (WithArrivalTime (ValidatedPerasVote blk)) (PerasVoteId blk) - where - getId = getPerasVoteId . vpvVote . forgetArrivalTime - -genValidatedPerasVote :: Gen (ValidatedPerasVote TestBlock) -genValidatedPerasVote = do - mockVote <- genPerasVote - pure - ValidatedPerasVote - { vpvVote = mockVote - , vpvVoteWeight = mockVoteWeight mockVote - } - newVoteDB :: ( IOLike m , BlockSupportsPeras blk ) => - [WithArrivalTime (ValidatedPerasVote blk)] -> m (PerasVoteDB m blk) -newVoteDB votes = do - db <- PerasVoteDB.createDB (PerasVoteDB.PerasVoteDbArgs nullTracer mkPerasParams) + PerasEpochContextResolverHandle m blk -> + [WithArrivalTime (ValidatedPerasVote blk)] -> + m (PerasVoteDB m blk) +newVoteDB resolverHandle votes = do + db <- PerasVoteDB.createDB (PerasVoteDB.PerasVoteDbArgs nullTracer resolverHandle) mapM_ ( \vote -> do result <- join $ atomically $ PerasVoteDB.addVote db vote @@ -123,40 +80,40 @@ newVoteDB votes = do prop_smoke :: Property prop_smoke = forAll genProtocolConstants $ \protocolConstants -> - forAll (genListWithUniqueIds (genWithArrivalTime genValidatedPerasVote)) $ - \(ListWithUniqueIds watValidatedVotes) -> - let - mkPoolInterfaces :: - IOLike m => - m - ( ObjectPoolReader (PerasVoteId TestBlock) (PerasVote TestBlock) PerasVoteTicketNo m - , ObjectPoolWriter (PerasVoteId TestBlock) (PerasVote TestBlock) m - , m [PerasVote TestBlock] - ) - mkPoolInterfaces = do - outboundPool <- newVoteDB watValidatedVotes - inboundPool <- newVoteDB [] + forAll genMockPerasEpochContext $ \epochContext -> + forAll + (genListWithUniqueIds getPerasVoteRound (genWithArrivalTime (genMockValidatedPerasVote epochContext))) $ + \(ListWithUniqueIds watValidatedVotes) -> + let + mkPoolInterfaces :: + IOLike m => + m + ( ObjectPoolReader (PerasVoteId TestBlock) (PerasVote TestBlock) PerasVoteTicketNo m + , ObjectPoolWriter (PerasVoteId TestBlock) (PerasVote TestBlock) m + , m [PerasVote TestBlock] + ) + mkPoolInterfaces = do + epochContextResolverHandle <- constPerasEpochContextResolverHandle epochContext + + outboundPool <- newVoteDB epochContextResolverHandle watValidatedVotes + inboundPool <- newVoteDB epochContextResolverHandle [] - let outboundPoolReader = makePerasVotePoolReaderFromVoteDB outboundPool - inboundPoolWriter = - makePerasVotePoolWriterFromVoteDB - mockSystemTime - (pure (VoteWeightDistr mempty)) -- mocked votes are self-validating - inboundPool - getAllInboundPoolContent = do - votesMap <- - atomically $ - PerasVoteDB.getVotesAfter inboundPool zeroPerasVoteTicketNo - pure $ vpvVote . forgetArrivalTime <$> Map.elems votesMap + let outboundPoolReader = makePerasVotePoolReaderFromVoteDB outboundPool + inboundPoolWriter = makePerasVotePoolWriterFromVoteDB mockSystemTime inboundPool epochContextResolverHandle + getAllInboundPoolContent = do + votesMap <- + atomically $ + PerasVoteDB.getVotesAfter inboundPool zeroPerasVoteTicketNo + pure $ vpvVote . forgetArrivalTime <$> Map.elems votesMap - return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) - in - prop_smoke_object_diffusion - protocolConstants - (map (vpvVote . forgetArrivalTime) watValidatedVotes) - runOutboundPeer - runInboundPeer - mkPoolInterfaces + return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) + in + prop_smoke_object_diffusion + protocolConstants + (map (vpvVote . forgetArrivalTime) watValidatedVotes) + runOutboundPeer + runInboundPeer + mkPoolInterfaces where runOutboundPeer outbound outboundChannel tracer = runPeer diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs index b4e860c01f..5acc8f6305 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -1,46 +1,30 @@ -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -- | Smoke tests for the object diffusion protocol. This uses a trivial object -- pool and checks that a few objects can indeed be transferred from the -- outbound to the inbound peer. module Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke ( tests - , WithId (..) , ListWithUniqueIds (..) , ProtocolConstants - , mockSystemTime , prop_smoke_object_diffusion , genSmokeObjectId , genSmokeObject - , genListWithUniqueIds , genProtocolConstants - , genRelativeTime - , genWithArrivalTime - , genPointTestBlock ) where import Cardano.Network.NodeToNode.Version (NodeToNodeVersion (..)) import Control.Monad.IOSim (runSimStrictShutdown) import Control.ResourceRegistry (forkLinkedThread, waitAnyThread, withRegistry) import Control.Tracer (Tracer, nullTracer, traceWith) -import Data.Containers.ListUtils (nubOrdOn) import Data.Data (Typeable) import Data.Functor.Contravariant (contramap) -import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map -import Data.Word (Word64) import Network.TypedProtocol.Channel (Channel, createConnectedChannels) import Network.TypedProtocol.Codec (AnyMessage) import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) import NoThunks.Class (NoThunks) -import Ouroboros.Consensus.BlockchainTime.WallClock.Types - ( RelativeTime (..) - , SystemTime (..) - , WithArrivalTime (..) - ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound ( objectDiffusionInbound ) @@ -59,9 +43,7 @@ import Ouroboros.Consensus.Util.IOLike , uncheckedNewTVarM , writeTVar ) -import Ouroboros.Network.Block (Point (..), SlotNo (SlotNo)) import Ouroboros.Network.ControlMessage (ControlMessage (..)) -import Ouroboros.Network.Point (Block (Block), WithOrigin (..)) import Ouroboros.Network.Protocol.ObjectDiffusion.Codec (codecObjectDiffusionId) import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound ( ObjectDiffusionInboundPipelined @@ -77,12 +59,12 @@ import Ouroboros.Network.Protocol.ObjectDiffusion.Type , NumObjectsUnacknowledged (..) , ObjectDiffusion ) +import Test.Consensus.Peras.Util (ListWithUniqueIds (..), genListWithUniqueIds) import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.IOLike () -import Test.Util.TestBlock tests :: TestTree tests = @@ -93,22 +75,6 @@ tests = prop_smoke ] -{------------------------------------------------------------------------------- - Provides a way to generate lists composed of objects with no duplicate ids, - with an Arbitrary instance --------------------------------------------------------------------------------} - -class WithId a idTy | a -> idTy where - getId :: a -> idTy - -newtype ListWithUniqueIds a idTy = ListWithUniqueIds [a] - deriving (Eq, Show, Ord) - -genListWithUniqueIds :: (Ord idTy, WithId a idTy) => Gen a -> Gen (ListWithUniqueIds a idTy) -genListWithUniqueIds genObject = ListWithUniqueIds . nubOrdOn getId <$> listOf genObject - -instance WithId SmokeObject SmokeObjectId where getId = getSmokeObjectId - {------------------------------------------------------------------------------- Mock objectPools -------------------------------------------------------------------------------} @@ -202,46 +168,10 @@ genProtocolConstants = do nodeToNodeVersion :: NodeToNodeVersion nodeToNodeVersion = NodeToNodeV_14 -{------------------------------------------------------------------------------- - Shared generators for Peras smoke tests --------------------------------------------------------------------------------} - -genRelativeTime :: Gen RelativeTime -genRelativeTime = RelativeTime . fromIntegral <$> arbitrary @Word64 - -genWithArrivalTime :: Gen a -> Gen (WithArrivalTime a) -genWithArrivalTime genA = WithArrivalTime <$> genRelativeTime <*> genA - -genPointTestBlock :: Gen (Point TestBlock) -genPointTestBlock = - -- Sometimes pick the genesis point - frequency - [ (1, pure $ Point Origin) - , - ( 50 - , do - slotNo <- SlotNo <$> arbitrary - hash <- TestHash . NE.fromList . getNonEmpty <$> arbitrary - pure $ Point (At (Block slotNo hash)) - ) - ] - --- | A static 'SystemTime' returning a constant time. The canonical mock --- system time lives in 'Test.Util.LogicalClock.mockSystemTime', but it --- is a field of 'LogicalClock' which requires a 'ResourceRegistry' and --- a background tick thread — too heavyweight for simple property tests --- that don't need time progression. -mockSystemTime :: Applicative m => SystemTime m -mockSystemTime = - SystemTime - { systemTimeCurrent = pure (RelativeTime 0) - , systemTimeWait = pure () - } - prop_smoke :: Property prop_smoke = forAll genProtocolConstants $ \protocolConstants -> - forAll (genListWithUniqueIds genSmokeObject) $ \(ListWithUniqueIds objects) -> + forAll (genListWithUniqueIds getSmokeObjectId genSmokeObject) $ \(ListWithUniqueIds objects) -> prop_smoke_object_diffusion protocolConstants objects diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs index 8b925b9d58..8077e92bb6 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs @@ -205,7 +205,7 @@ certInclusionDecisionTag = \case -- - 25% chance of being 2 -- - 12.5% chance of being 3 -- ... and so on -genPerasParams :: Gen PerasParams +genPerasParams :: Gen (PerasParams blk) genPerasParams = do _A <- fromIntegral . (+ 1) <$> geometric 0.5 pure diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs index cabea97e26..b52e3080ec 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs @@ -1,273 +1,5 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +module Test.Consensus.Peras.Util (module X) where --- | Common utilities for writing tests for Peras types. -module Test.Consensus.Peras.Util - ( -- * Predicates - perasVoteIsPersistent - , perasCertContainsOnlyPersistentVotes - - -- * Generators - , genPerasVote - , genPerasCert - - -- * Tabulators - , mkBucket - , tabulatePerasCert - , tabulatePerasVote - ) where - -import Cardano.Crypto.Hash (ByteString) -import Cardano.Ledger.BaseTypes (SlotNo (..)) -import Control.Monad (forM) -import qualified Data.ByteString as ByteString -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as ShortByteString -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map.NonEmpty as NEMap -import Data.Maybe (catMaybes, fromMaybe) -import Data.Proxy (Proxy (..)) -import Data.String (IsString (..)) -import Data.Traversable (mapAccumM) -import Data.Word (Word8) -import GHC.Word (Word16) -import Ouroboros.Consensus.Block (HeaderHash) -import Ouroboros.Consensus.Block.Abstract (WithOrigin (..)) -import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), toBytes32RealPoint) -import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS -import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 -import Ouroboros.Consensus.Peras.Crypto.BLS - ( PerasBLSCryptoAggregateVoteSignature (..) - , VRFOutput (..) - , VoteSignature (..) - ) -import Ouroboros.Consensus.Peras.Types - ( PerasBoostedBlock (..) - , PerasRoundNo (..) - , PerasSeatIndex (..) - ) -import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 -import Test.QuickCheck - ( Arbitrary (..) - , Gen - , Property - , choose - , frequency - , sized - , tabulate - , vectorOf - ) - --- * Predicates - --- | Whether a Peras vote is a persistent one -perasVoteIsPersistent :: V1.PerasVote tag -> Bool -perasVoteIsPersistent vote - | V1.PersistentPerasVoteEligibilityProof{} <- V1.pvEligibilityProof vote = True - | otherwise = False - --- | Whether a Peras certifcate only contains persistent votes -perasCertContainsOnlyPersistentVotes :: V1.PerasCert tag -> Bool -perasCertContainsOnlyPersistentVotes cert = - all - ( \case - V1.PersistentPerasVoteEligibilityProof -> True - V1.NonPersistentPerasVoteEligibilityProof{} -> False - ) - ( NEMap.elems - . V1.unPerasCertVoters - . V1.pcVoters - $ cert - ) - --- * Generators - -genRoundNo :: Gen PerasRoundNo -genRoundNo = PerasRoundNo <$> arbitrary - -data BlockWith32BytesHeaderHash -type instance HeaderHash BlockWith32BytesHeaderHash = ShortByteString - -genBoostedBlock :: Gen PerasBoostedBlock -genBoostedBlock = PerasBoostedBlock <$> genWithOrigin genBytes32RealPoint - where - genWithOrigin gen = - frequency - [ (1, pure Origin) - , (9, NotOrigin <$> gen) - ] - genBytes32RealPoint = do - slotNo <- SlotNo <$> arbitrary - hash <- ShortByteString.pack <$> vectorOf 32 arbitrary - pure $ - toBytes32RealPoint @BlockWith32BytesHeaderHash $ - RealPoint slotNo hash - -genSeatIndex :: Gen PerasSeatIndex -genSeatIndex = PerasSeatIndex <$> arbitrary - -genPrivateKey :: Proxy r -> Gen (BLS.PrivateKey r) -genPrivateKey _ = - fromMaybe (error "genPrivateKey: invalid key bytes") - . BLS.rawDeserialisePrivateKey "ROUNDTRIP" - . ByteString.pack - <$> vectorOf 32 (arbitrary @Word8) - -genSignature :: - forall r. - BLS.HasBLSContext r => - Proxy r -> - Gen (BLS.Signature r) -genSignature _ = do - key <- genPrivateKey (Proxy @r) - msg <- fromString @ByteString <$> arbitrary - pure $ BLS.signWithRole key msg - -genVoteEligibilityProof :: Bool -> Gen V1.PerasVoteEligibilityProof -genVoteEligibilityProof shouldGenNonPersistent = do - frequency - [ - ( 4 - , pure V1.PersistentPerasVoteEligibilityProof - ) - , - ( if shouldGenNonPersistent then 1 else 0 - , V1.NonPersistentPerasVoteEligibilityProof - . PerasBLSCryptoVRFOutput - <$> genSignature (Proxy @BLS.VRF) - ) - ] - -genVoters :: Bool -> Gen V1.PerasCertVoters -genVoters shouldGenNonPersistent = do - numVoters <- - sized $ \size -> - fmap (+ 1) $ - choose @Word16 (0, fromIntegral size * 10) - numPersistentVoters <- - case shouldGenNonPersistent of - True -> choose (0, numVoters) - False -> pure numVoters - persistentVoters <- - if numPersistentVoters == 0 - then pure [] - else forM [0 .. numPersistentVoters - 1] $ \i -> do - let proof = V1.PersistentPerasVoteEligibilityProof - pure (PerasSeatIndex i, proof) - nonPersistentVoters <- - if numPersistentVoters == numVoters - then pure [] - else forM [numPersistentVoters .. numVoters - 1] $ \i -> do - proof <- - V1.NonPersistentPerasVoteEligibilityProof - . PerasBLSCryptoVRFOutput - <$> genSignature (Proxy @BLS.VRF) - pure (PerasSeatIndex i, proof) - voters <- - fmap (snd . fmap catMaybes) - . mapAccumM - ( \canDrop (i, proof) -> do - voter <- - frequency - [ (75, pure (Just (i, proof))) - , (if canDrop then 25 else 0, pure Nothing) - ] - pure - ( canDrop || voter == Nothing - , voter - ) - ) - False - $ persistentVoters <> nonPersistentVoters - pure $ - V1.PerasCertVoters (NEMap.fromList (NonEmpty.fromList voters)) - -genPerasVote :: Bool -> Gen (V1.PerasVote tag) -genPerasVote shouldGenNonPersistent = do - pvRoundNo <- genRoundNo - pvBoostedBlock <- genBoostedBlock - pvSeatIndex <- genSeatIndex - pvEligibilityProof <- genVoteEligibilityProof shouldGenNonPersistent - pvSignature <- - PerasBLSCryptoVoteSignature - <$> genSignature (Proxy @BLS.SIGN) - pure - V1.PerasVote - { V1.pvRoundNo - , V1.pvBoostedBlock - , V1.pvSeatIndex - , V1.pvEligibilityProof - , V1.pvSignature - } - -genPerasCert :: Bool -> Gen (V1.PerasCert tag) -genPerasCert shouldGenNonPersistent = do - pcRoundNo <- genRoundNo - pcBoostedBlock <- genBoostedBlock - pcVoters <- genVoters shouldGenNonPersistent - pcSignature <- - PerasBLSCryptoAggregateVoteSignature - <$> genSignature (Proxy @BLS.SIGN) - pure - V1.PerasCert - { V1.pcRoundNo - , V1.pcBoostedBlock - , V1.pcVoters - , V1.pcSignature - } - --- * Tabulators - -mkBucket :: Int -> Int -> String -> String -mkBucket bucketSize x suffix - | lower == upper = show lower <> suffix - | otherwise = show lower <> "-" <> show upper <> suffix - where - lower = (x `div` bucketSize) * bucketSize - upper = lower + bucketSize - -tabulatePerasCert :: V1.PerasCert tag -> Property -> Property -tabulatePerasCert cert = - foldr (flip (.)) id $ - [ tabulate - "Number of voters" - [mkBucket 100 numVoters " voters"] - , tabulate - "Proportion of persistent voters" - [mkBucket 10 persistentVotersRatio "%"] - ] - where - numVoters = - length - . V1.unPerasCertVoters - . V1.pcVoters - $ cert - numPersistentVoters = - length - . filter (== V1.PersistentPerasVoteEligibilityProof) - . NonEmpty.toList - . NEMap.elems - . V1.unPerasCertVoters - . V1.pcVoters - $ cert - - persistentVotersRatio - | numVoters == 0 = 0 - | otherwise = numPersistentVoters * 100 `div` numVoters - -tabulatePerasVote :: V1.PerasVote tag -> Property -> Property -tabulatePerasVote vote = - foldr (flip (.)) id $ - [ tabulate - "Voter type" - [voterType] - ] - where - voterType = - case V1.pvEligibilityProof vote of - V1.PersistentPerasVoteEligibilityProof -> "persistent" - V1.NonPersistentPerasVoteEligibilityProof _ -> "non-persistent" +import Test.Consensus.Peras.Util.Internal as X +import Test.Consensus.Peras.Util.Mock as X +import Test.Consensus.Peras.Util.V1 as X diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Internal.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Internal.hs new file mode 100644 index 0000000000..0af5eec8ea --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Internal.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Consensus.Peras.Util.Internal where + +import Data.Containers.ListUtils (nubOrdOn) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Word (Word64) +import Ouroboros.Consensus.Block.SupportsPeras (PerasRoundNo (..)) +import Ouroboros.Consensus.BlockchainTime (RelativeTime (..), SystemTime (..), WithArrivalTime (..)) +import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId) +import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) +import Ouroboros.Network.Block (Point (..), SlotNo (..)) +import Ouroboros.Network.Point (Block (..), WithOrigin (..)) +import Test.Consensus.Committee.Utils (mkPoolId) +import Test.QuickCheck (Arbitrary (arbitrary), Gen, NonEmptyList (getNonEmpty)) +import Test.QuickCheck.Gen (frequency, listOf, listOf1) +import Test.Util.TestBlock (TestBlock, TestHash (..)) + +genRoundNo :: Gen PerasRoundNo +genRoundNo = PerasRoundNo <$> arbitrary + +genSeatIndex :: Gen PerasSeatIndex +genSeatIndex = PerasSeatIndex <$> arbitrary + +genPoolId :: Gen PoolId +genPoolId = mkPoolId <$> arbitrary + +genLedgerStake :: Gen LedgerStake +genLedgerStake = LedgerStake <$> arbitrary + +newtype ListWithUniqueIds a = ListWithUniqueIds [a] + deriving (Eq, Show, Ord) + +newtype NonEmptyListWithUniqueIds a = NonEmptyListWithUniqueIds (NonEmpty a) + deriving (Eq, Show, Ord) + +genListWithUniqueIds :: Ord idTy => (a -> idTy) -> Gen a -> Gen (ListWithUniqueIds a) +genListWithUniqueIds getId genObject = ListWithUniqueIds . nubOrdOn getId <$> listOf genObject + +genNonEmptyListWithUniqueIds :: + Ord idTy => (a -> idTy) -> Gen a -> Gen (NonEmptyListWithUniqueIds a) +genNonEmptyListWithUniqueIds getId genObject = NonEmptyListWithUniqueIds . NonEmpty.fromList . nubOrdOn getId <$> listOf1 genObject + +nonEmptyListOf :: Gen a -> Gen (NonEmpty a) +nonEmptyListOf genObject = NonEmpty.fromList <$> listOf1 genObject + +{------------------------------------------------------------------------------- + Shared generators for Peras smoke tests +-------------------------------------------------------------------------------} + +genRelativeTime :: Gen RelativeTime +genRelativeTime = RelativeTime . fromIntegral <$> arbitrary @Word64 + +genWithArrivalTime :: Gen a -> Gen (WithArrivalTime a) +genWithArrivalTime genA = WithArrivalTime <$> genRelativeTime <*> genA + +genPointTestBlock :: Gen (Point TestBlock) +genPointTestBlock = + -- Sometimes pick the genesis point + frequency + [ (1, pure $ Point Origin) + , + ( 50 + , do + slotNo <- SlotNo <$> arbitrary + hash <- TestHash . NonEmpty.fromList . getNonEmpty <$> arbitrary + pure $ Point (At (Block slotNo hash)) + ) + ] + +-- | A static 'SystemTime' returning a constant time. The canonical mock +-- system time lives in 'Test.Util.LogicalClock.mockSystemTime', but it +-- is a field of 'LogicalClock' which requires a 'ResourceRegistry' and +-- a background tick thread — too heavyweight for simple property tests +-- that don't need time progression. +mockSystemTime :: Applicative m => SystemTime m +mockSystemTime = + SystemTime + { systemTimeCurrent = pure (RelativeTime 0) + , systemTimeWait = pure () + } + +-- * Tabulators + +mkBucket :: Int -> Int -> String -> String +mkBucket bucketSize x suffix + | lower == upper = show lower <> suffix + | otherwise = show lower <> "-" <> show upper <> suffix + where + lower = (x `div` bucketSize) * bucketSize + upper = lower + bucketSize diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Mock.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Mock.hs new file mode 100644 index 0000000000..e12446a4ae --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Mock.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Test.Consensus.Peras.Util.Mock where + +import Data.Containers.NonEmpty (NE) +import Data.Either (fromRight) +import Data.Set (Set) +import qualified Data.Set.NonEmpty as NESet +import Ouroboros.Consensus.Block (BlockSupportsPeras (PerasEpochContext), PerasParams (perasWeight)) +import Ouroboros.Consensus.Block.SupportsPeras (PerasParams, ValidatedPerasCert (..), ValidatedPerasVote (..), mkPerasParams) +import Ouroboros.Consensus.Committee.Class +import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) +import Ouroboros.Consensus.Peras.Crypto.Mock + ( MockPerasCommittee + , MockPerasCrypto + , VotingCommittee (MockPerasVotingCommittee) + , VotingCommitteeInput (MockPerasVotingCommitteeInput) + , getEligibility + , unsafeIntToSeatIndex + ) +import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) +import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) +import Test.Consensus.Peras.Util.Internal +import Test.QuickCheck (Gen, choose) +import Test.Util.TestBlock (TestBlock) + +genMockPerasVotingCommitteeInput :: + Gen (VotingCommitteeInput (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock)) +genMockPerasVotingCommitteeInput = do + NonEmptyListWithUniqueIds poolIds <- genNonEmptyListWithUniqueIds id genPoolId + poolIdsWithStakes <- traverse (\poolId -> (poolId,) <$> genLedgerStake) poolIds + pure $ MockPerasVotingCommitteeInput poolIdsWithStakes + +genMockPerasVotingCommittee :: + Gen (VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock)) +genMockPerasVotingCommittee = + fromRight (error "mkVotingCommittee of O.C.Peras.Crypto.Mock can't fail") . mkVotingCommittee + <$> genMockPerasVotingCommitteeInput + +genPerasParams :: Gen (PerasParams TestBlock) +genPerasParams = pure mkPerasParams + +genMockPerasEpochContext :: Gen (PerasEpochContext TestBlock) +genMockPerasEpochContext = (,) <$> genMockPerasVotingCommittee <*> genPerasParams + +pickSeatIndexFromCommittee :: + VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> Gen PerasSeatIndex +pickSeatIndexFromCommittee (MockPerasVotingCommittee weightDistr) = do + let maxIndex = length weightDistr - 1 + unsafeIntToSeatIndex <$> choose (0, maxIndex) + +genVotersSubset :: + VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> + Gen (NE (Set PerasSeatIndex)) +genVotersSubset committee = do + NonEmptyListWithUniqueIds seatIndices <- + genNonEmptyListWithUniqueIds id (pickSeatIndexFromCommittee committee) + pure $ NESet.fromList seatIndices + +genMockPerasVote :: + VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> + Gen (MockPerasVote TestBlock) +genMockPerasVote committee = do + seatIndex <- pickSeatIndexFromCommittee committee + roundNo <- genRoundNo + block <- genPointTestBlock + pure + MockPerasVote + { mockVoteSeatIndex = seatIndex + , mockVoteRound = roundNo + , mockVoteBlock = block + } + +genMockValidatedPerasVote :: PerasEpochContext TestBlock -> Gen (ValidatedPerasVote TestBlock) +genMockValidatedPerasVote (committee, _params) = do + vote <- genMockPerasVote committee + let eligibilityWitness = + maybe + ( error + "genValidatedPerasVote: seatIndex of vote generated from the committee should be part of the committee" + ) + id + (getEligibility committee (mockVoteSeatIndex vote)) + pure + ValidatedPerasVote + { vpvVote = vote + , vpvVoteWeight = eligiblePartyVoteWeight committee eligibilityWitness + } + +genMockPerasCert :: + VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> + Gen (MockPerasCert TestBlock) +genMockPerasCert committee = do + votersSubset <- genVotersSubset committee + roundNo <- genRoundNo + block <- genPointTestBlock + pure + MockPerasCert + { mockCertVoters = votersSubset + , mockCertRound = roundNo + , mockCertBlock = block + } + +genMockValidatedPerasCert :: PerasEpochContext TestBlock -> Gen (ValidatedPerasCert TestBlock) +genMockValidatedPerasCert (committee, params) = do + cert <- genMockPerasCert committee + pure $ + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasWeight params + } diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/V1.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/V1.hs new file mode 100644 index 0000000000..ab54c1c5e2 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/V1.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Common utilities for writing tests for Peras types. +module Test.Consensus.Peras.Util.V1 + ( -- * Predicates + perasVoteIsPersistent + , perasCertContainsOnlyPersistentVotes + + -- * Generators + , genPerasVote + , genPerasCert + + -- * Tabulators + , tabulatePerasCert + , tabulatePerasVote + ) where + +import Cardano.Crypto.Hash (ByteString) +import Cardano.Ledger.BaseTypes (SlotNo (..)) +import Control.Monad (forM) +import qualified Data.ByteString as ByteString +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as ShortByteString +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.NonEmpty as NEMap +import Data.Maybe (catMaybes, fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.String (IsString (..)) +import Data.Traversable (mapAccumM) +import Data.Word (Word8) +import GHC.Word (Word16) +import Ouroboros.Consensus.Block (HeaderHash) +import Ouroboros.Consensus.Block.Abstract (WithOrigin (..)) +import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), toBytes32RealPoint) +import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import Ouroboros.Consensus.Peras.Crypto.BLS + ( PerasBLSCryptoAggregateVoteSignature (..) + , VRFOutput (..) + , VoteSignature (..) + ) +import Ouroboros.Consensus.Peras.Types + ( PerasBoostedBlock (..) + , PerasSeatIndex (..) + ) +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import Test.Consensus.Peras.Util.Internal (genRoundNo, genSeatIndex, mkBucket) +import Test.QuickCheck + ( Arbitrary (..) + , Gen + , Property + , choose + , frequency + , sized + , tabulate + , vectorOf + ) + +-- * Predicates + +-- | Whether a Peras vote is a persistent one +perasVoteIsPersistent :: V1.PerasVote tag -> Bool +perasVoteIsPersistent vote + | V1.PersistentPerasVoteEligibilityProof{} <- V1.pvEligibilityProof vote = True + | otherwise = False + +-- | Whether a Peras certifcate only contains persistent votes +perasCertContainsOnlyPersistentVotes :: V1.PerasCert tag -> Bool +perasCertContainsOnlyPersistentVotes cert = + all + ( \case + V1.PersistentPerasVoteEligibilityProof -> True + V1.NonPersistentPerasVoteEligibilityProof{} -> False + ) + ( NEMap.elems + . V1.unPerasCertVoters + . V1.pcVoters + $ cert + ) + +-- * Generators + +data BlockWith32BytesHeaderHash +type instance HeaderHash BlockWith32BytesHeaderHash = ShortByteString + +genBoostedBlock :: Gen PerasBoostedBlock +genBoostedBlock = PerasBoostedBlock <$> genWithOrigin genBytes32RealPoint + where + genWithOrigin gen = + frequency + [ (1, pure Origin) + , (9, NotOrigin <$> gen) + ] + genBytes32RealPoint = do + slotNo <- SlotNo <$> arbitrary + hash <- ShortByteString.pack <$> vectorOf 32 arbitrary + pure $ + toBytes32RealPoint @BlockWith32BytesHeaderHash $ + RealPoint slotNo hash + +genPrivateKey :: Proxy r -> Gen (BLS.PrivateKey r) +genPrivateKey _ = + fromMaybe (error "genPrivateKey: invalid key bytes") + . BLS.rawDeserialisePrivateKey "ROUNDTRIP" + . ByteString.pack + <$> vectorOf 32 (arbitrary @Word8) + +genSignature :: + forall r. + BLS.HasBLSContext r => + Proxy r -> + Gen (BLS.Signature r) +genSignature _ = do + key <- genPrivateKey (Proxy @r) + msg <- fromString @ByteString <$> arbitrary + pure $ BLS.signWithRole key msg + +genVoteEligibilityProof :: Bool -> Gen V1.PerasVoteEligibilityProof +genVoteEligibilityProof shouldGenNonPersistent = do + frequency + [ + ( 4 + , pure V1.PersistentPerasVoteEligibilityProof + ) + , + ( if shouldGenNonPersistent then 1 else 0 + , V1.NonPersistentPerasVoteEligibilityProof + . PerasBLSCryptoVRFOutput + <$> genSignature (Proxy @BLS.VRF) + ) + ] + +genVoters :: Bool -> Gen V1.PerasCertVoters +genVoters shouldGenNonPersistent = do + numVoters <- + sized $ \size -> + fmap (+ 1) $ + choose @Word16 (0, fromIntegral size * 10) + numPersistentVoters <- + case shouldGenNonPersistent of + True -> choose (0, numVoters) + False -> pure numVoters + persistentVoters <- + if numPersistentVoters == 0 + then pure [] + else forM [0 .. numPersistentVoters - 1] $ \i -> do + let proof = V1.PersistentPerasVoteEligibilityProof + pure (PerasSeatIndex i, proof) + nonPersistentVoters <- + if numPersistentVoters == numVoters + then pure [] + else forM [numPersistentVoters .. numVoters - 1] $ \i -> do + proof <- + V1.NonPersistentPerasVoteEligibilityProof + . PerasBLSCryptoVRFOutput + <$> genSignature (Proxy @BLS.VRF) + pure (PerasSeatIndex i, proof) + voters <- + fmap (snd . fmap catMaybes) + . mapAccumM + ( \canDrop (i, proof) -> do + voter <- + frequency + [ (75, pure (Just (i, proof))) + , (if canDrop then 25 else 0, pure Nothing) + ] + pure + ( canDrop || voter == Nothing + , voter + ) + ) + False + $ persistentVoters <> nonPersistentVoters + pure $ + V1.PerasCertVoters (NEMap.fromList (NonEmpty.fromList voters)) + +genPerasVote :: Bool -> Gen (V1.PerasVote tag) +genPerasVote shouldGenNonPersistent = do + pvRoundNo <- genRoundNo + pvBoostedBlock <- genBoostedBlock + pvSeatIndex <- genSeatIndex + pvEligibilityProof <- genVoteEligibilityProof shouldGenNonPersistent + pvSignature <- + PerasBLSCryptoVoteSignature + <$> genSignature (Proxy @BLS.SIGN) + pure + V1.PerasVote + { V1.pvRoundNo + , V1.pvBoostedBlock + , V1.pvSeatIndex + , V1.pvEligibilityProof + , V1.pvSignature + } + +genPerasCert :: Bool -> Gen (V1.PerasCert tag) +genPerasCert shouldGenNonPersistent = do + pcRoundNo <- genRoundNo + pcBoostedBlock <- genBoostedBlock + pcVoters <- genVoters shouldGenNonPersistent + pcSignature <- + PerasBLSCryptoAggregateVoteSignature + <$> genSignature (Proxy @BLS.SIGN) + pure + V1.PerasCert + { V1.pcRoundNo + , V1.pcBoostedBlock + , V1.pcVoters + , V1.pcSignature + } + +-- * Tabulators + +tabulatePerasCert :: V1.PerasCert tag -> Property -> Property +tabulatePerasCert cert = + foldr (flip (.)) id $ + [ tabulate + "Number of voters" + [mkBucket 100 numVoters " voters"] + , tabulate + "Proportion of persistent voters" + [mkBucket 10 persistentVotersRatio "%"] + ] + where + numVoters = + length + . V1.unPerasCertVoters + . V1.pcVoters + $ cert + numPersistentVoters = + length + . filter (== V1.PersistentPerasVoteEligibilityProof) + . NonEmpty.toList + . NEMap.elems + . V1.unPerasCertVoters + . V1.pcVoters + $ cert + + persistentVotersRatio + | numVoters == 0 = 0 + | otherwise = numPersistentVoters * 100 `div` numVoters + +tabulatePerasVote :: V1.PerasVote tag -> Property -> Property +tabulatePerasVote vote = + foldr (flip (.)) id $ + [ tabulate + "Voter type" + [voterType] + ] + where + voterType = + case V1.pvEligibilityProof vote of + V1.PersistentPerasVoteEligibilityProof -> "persistent" + V1.NonPersistentPerasVoteEligibilityProof _ -> "non-persistent" diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs index 029b8667a6..40d6781f80 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs @@ -96,7 +96,7 @@ data PerasVotingRulesDecisionModel -- -- NOTE: this predicate could be lifted directly from the agda specification. isPerasVotingAllowedModel :: - PerasVotingView TestCert -> + PerasVotingView TestCert TestBlock -> PerasVotingRulesDecisionModel isPerasVotingAllowedModel PerasVotingView @@ -219,7 +219,7 @@ prop_isPerasVotingAllowed = forAll genPerasVotingView $ \pvv -> do -- - 25% chance of being 2 -- - 12.5% chance of being 3 -- ... and so on -genPerasParams :: Gen PerasParams +genPerasParams :: Gen (PerasParams blk) genPerasParams = do _L <- fromIntegral . (+ 1) <$> geometric 0.5 _X <- fromIntegral . (+ 1) <$> geometric 0.5 @@ -309,7 +309,7 @@ genLatestCertOnChain roundNo = do { lcocCert = cert } -genPerasVotingView :: Gen (PerasVotingView TestCert) +genPerasVotingView :: Gen (PerasVotingView TestCert TestBlock) genPerasVotingView = do perasParams <- genPerasParams currRoundNo <- genPerasRoundNo diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index d4643231a8..7c5d1f4790 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -19,9 +19,12 @@ module Test.Ouroboros.Storage.PerasCertDB.StateMachine (tests) where import Control.Monad (join) import Control.Monad.State import Control.Tracer (nullTracer) +import Data.Containers.NonEmpty (NE) import Data.Function ((&)) import qualified Data.List.NonEmpty as NE +import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Set.NonEmpty as NESet import Data.Word (Word64) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types @@ -52,7 +55,7 @@ tests = [ adjustQuickCheckTests (* 100) $ testProperty "q-d" $ prop_qd ] -perasTestParams :: PerasParams +perasTestParams :: PerasParams blk perasTestParams = mkPerasParams prop_qd :: Actions Model -> Property @@ -87,6 +90,7 @@ instance StateModel Model where genAddCert = do roundNo <- genRoundNo boostedBlock <- genPoint + voters <- genVoters now <- genRelativeTime let certWithTime = WithArrivalTime now $ @@ -95,6 +99,7 @@ instance StateModel Model where MockPerasCert { mockCertRound = roundNo , mockCertBlock = boostedBlock + , mockCertVoters = voters } , vpcCertBoost = perasWeight perasTestParams } @@ -115,6 +120,13 @@ instance StateModel Model where , (1, pure $ PerasRoundNo 2) , (8, PerasRoundNo <$> arbitrary) ] + + genVoters :: Gen (NE (Set PerasSeatIndex)) + genVoters = + NESet.fromList <$> (liftA2 (NE.:|) genSeatIndex (listOf genSeatIndex)) + + genSeatIndex = PerasSeatIndex <$> arbitrary + genHash = TestHash . NE.fromList . getNonEmpty <$> arbitrary initialState = Model Model.initModel diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs index 92cb0469df..10cd02c932 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs @@ -69,7 +69,7 @@ data PerasVoteDbModelError = MultipleWinnersInRound PerasRoundNo data Model blk = Model { open :: Bool -- ^ Is the database open? - , params :: PerasParams + , params :: PerasParams blk -- ^ Configuration parameters , lastTicketNo :: PerasVoteTicketNo -- ^ The last issued ticket number @@ -98,7 +98,7 @@ instance where toExpr = defaultExprViaShow -initModel :: PerasParams -> Model blk +initModel :: PerasParams blk -> Model blk initModel cfg = Model { open = False diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index 3569a5d3ed..f7a8aee701 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -100,7 +100,7 @@ tests = prop_qd ] -perasTestParams :: PerasParams +perasTestParams :: PerasParams blk perasTestParams = mkPerasParams prop_qd :: Actions Model -> Property @@ -186,7 +186,6 @@ instance StateModel Model where { mockVoteRound = roundNo , mockVoteBlock = point , mockVoteSeatIndex = seatIndex - , mockVoteWeight = weight } , vpvVoteWeight = weight } From 0c79a132d476c46cfecd71ce0aa49c7950fc7c3d Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 1 Jun 2026 11:18:27 +0200 Subject: [PATCH 45/62] Move Peras test utils and make tests compile --- ouroboros-consensus.cabal | 12 +- .../Test/Util/Committee.hs} | 2 +- .../Test/Util/Peras.hs | 5 + .../Test/Util/Peras/Cert/Inclusion.hs | 314 ++++++++++++++++++ .../Test/Util/Peras}/Internal.hs | 4 +- .../Test/Util/Peras}/Mock.hs | 10 +- .../Test/Util/Peras/Serialisation.hs | 85 +++++ .../Test/Util/Peras}/V1.hs | 4 +- .../Test/Consensus/Committee/Class.hs | 2 +- .../Committee/EveryoneVotes/Tests.hs | 20 +- .../Test/Consensus/Committee/TestCrypto.hs | 2 +- .../Test/Consensus/Committee/WFALS.hs | 2 +- .../Consensus/Committee/WFALS/Model/Utils.hs | 2 +- .../Test/Consensus/Committee/WFALS/Tests.hs | 20 +- .../ObjectDiffusion/PerasCert/Smoke.hs | 2 +- .../ObjectDiffusion/PerasVote/Smoke.hs | 19 +- .../MiniProtocol/ObjectDiffusion/Smoke.hs | 2 +- .../Test/Consensus/Peras/Serialisation.hs | 2 +- .../Test/Consensus/Peras/Util.hs | 5 - .../Test/Consensus/Peras/Voting/Adapter.hs | 16 +- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 9 +- .../Storage/PerasVoteDB/StateMachine.hs | 17 +- 22 files changed, 489 insertions(+), 67 deletions(-) rename ouroboros-consensus/{test/consensus-test/Test/Consensus/Committee/Utils.hs => src/unstable-consensus-testlib/Test/Util/Committee.hs} (99%) create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras.hs create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Cert/Inclusion.hs rename ouroboros-consensus/{test/consensus-test/Test/Consensus/Peras/Util => src/unstable-consensus-testlib/Test/Util/Peras}/Internal.hs (97%) rename ouroboros-consensus/{test/consensus-test/Test/Consensus/Peras/Util => src/unstable-consensus-testlib/Test/Util/Peras}/Mock.hs (94%) create mode 100644 ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Serialisation.hs rename ouroboros-consensus/{test/consensus-test/Test/Consensus/Peras/Util => src/unstable-consensus-testlib/Test/Util/Peras}/V1.hs (98%) delete mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 318b744379..e77b042c9f 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -469,6 +469,7 @@ library unstable-consensus-testlib Test.Util.ChainDB Test.Util.ChainUpdates Test.Util.ChunkInfo + Test.Util.Committee Test.Util.Corruption Test.Util.FileLock Test.Util.HardFork.Future @@ -485,6 +486,12 @@ library unstable-consensus-testlib Test.Util.Orphans.SignableRepresentation Test.Util.Orphans.ToExpr Test.Util.Paths + Test.Util.Peras + Test.Util.Peras.Cert.Inclusion + Test.Util.Peras.Internal + Test.Util.Peras.Mock + Test.Util.Peras.Serialisation + Test.Util.Peras.V1 Test.Util.QSM Test.Util.QuickCheck Test.Util.Range @@ -662,7 +669,6 @@ test-suite consensus-test Test.Consensus.Committee.EveryoneVotes Test.Consensus.Committee.EveryoneVotes.Tests Test.Consensus.Committee.TestCrypto - Test.Consensus.Committee.Utils Test.Consensus.Committee.WFALS Test.Consensus.Committee.WFALS.Conformance Test.Consensus.Committee.WFALS.Model @@ -689,10 +695,6 @@ test-suite consensus-test Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke Test.Consensus.Peras.Cert.Inclusion Test.Consensus.Peras.Serialisation - Test.Consensus.Peras.Util - Test.Consensus.Peras.Util.V1 - Test.Consensus.Peras.Util.Mock - Test.Consensus.Peras.Util.Internal Test.Consensus.Peras.Voting.Adapter Test.Consensus.Peras.Voting.Rules Test.Consensus.Peras.WeightSnapshot diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/Utils.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Committee.hs similarity index 99% rename from ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/Utils.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Committee.hs index d8f2e1e71c..89b559761c 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/Utils.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Committee.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} -- | Utility functions for the voting committee tests. -module Test.Consensus.Committee.Utils +module Test.Util.Committee ( -- * General utilities mkPoolId , unfairWFATiebreaker diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras.hs new file mode 100644 index 0000000000..3364882a8c --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras.hs @@ -0,0 +1,5 @@ +module Test.Util.Peras (module X) where + +import Test.Util.Peras.Internal as X +import Test.Util.Peras.Mock as X +import Test.Util.Peras.V1 as X diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Cert/Inclusion.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Cert/Inclusion.hs new file mode 100644 index 0000000000..0c3aac5c94 --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Cert/Inclusion.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Test that the Peras certificate inclusion rules can correctly decide when +-- to include a certificate +-- +-- NOTE: in this file, we use uncommon variable names such as `_A` because that +-- is their name in the CIP-0140, and we can't have variable names starting +-- with capital letters. Contrary to typical Haskell conventions, those do not +-- denote ignored variables. +module Test.Util.Peras.Cert.Inclusion (tests) where + +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics (Generic) +import Ouroboros.Consensus.Block (Point (..), WithOrigin (..)) +import Ouroboros.Consensus.Block.SupportsPeras + ( BoostedBlock + , IsPerasCert (..) + , PerasCertMaxRounds (..) + , PerasParams (..) + , PerasRoundNo (..) + , mkPerasParams + ) +import Ouroboros.Consensus.Peras.Cert.Inclusion + ( LatestCertOnChainView (..) + , LatestCertSeenView (..) + , PerasCertInclusionRulesDecision (..) + , PerasCertInclusionView (..) + , needCert + ) +import Ouroboros.Consensus.Util.Pred (Evidence (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck + ( Arbitrary (..) + , Gen + , Property + , Testable (..) + , choose + , counterexample + , forAll + , frequency + , tabulate + , testProperty + ) +import Test.Util.QuickCheck (geometric) +import Test.Util.TestBlock (TestBlock) +import Test.Util.TestEnv (adjustQuickCheckTests) + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = + adjustQuickCheckTests (* 1000) $ + testGroup + "Peras certificate inclusion rules" + [ testProperty "needCert" prop_needCert + ] + +{------------------------------------------------------------------------------- + Model conformance test property +-------------------------------------------------------------------------------} + +data PerasCertInclusionRulesDecisionModel + = PerasCertInclusionDecisionModel + { shouldIncludeCert :: Bool + , noCertsFromTwoRoundsAgo :: Bool + , latestCertSeenIsNotExpired :: Bool + , latestCertSeenIsNewerThanLatestCertOnChain :: Bool + } + +-- | A simplified model of the Peras certificate inclusion rules, used to compare +-- against the real implementation. The main difference is that this model computes +-- the result of the predicate directly over the inputs, rather than using the +-- 'Pred' combinators to produce evidence in either direction. +-- +-- NOTE: this predicate could be lifted directly from the agda specification. +needCertModel :: + PerasCertInclusionView TestCert TestBlock -> + PerasCertInclusionRulesDecisionModel +needCertModel + PerasCertInclusionView + { perasParams + , currRoundNo + , latestCertSeen + , latestCertOnChain + , certIds + } = + PerasCertInclusionDecisionModel + { shouldIncludeCert = + noCertsFromTwoRoundsAgo + && latestCertSeenIsNotExpired + && latestCertSeenIsNewerThanLatestCertOnChain + , noCertsFromTwoRoundsAgo = + noCertsFromTwoRoundsAgo + , latestCertSeenIsNotExpired = + latestCertSeenIsNotExpired + , latestCertSeenIsNewerThanLatestCertOnChain = + latestCertSeenIsNewerThanLatestCertOnChain + } + where + noCertsFromTwoRoundsAgo = + if currRoundNo < 2 + then False + else not ((currRoundNo - 2) `Set.member` certIds) + + latestCertSeenIsNotExpired = + currRoundNo + <= _A + getPerasCertRound (lcsCert latestCertSeen) + + latestCertSeenIsNewerThanLatestCertOnChain = + case latestCertOnChain of + Origin -> True + NotOrigin lcoc -> + getPerasCertRound (lcsCert latestCertSeen) > lcocRoundNo lcoc + + _A = + PerasRoundNo $ + unPerasCertMaxRounds $ + perasCertMaxRounds $ + perasParams + +-- | Test that the Peras certificate inclusion rules can correctly decide when +-- to include a certificate based on a simplified model that doesn't use anything +-- fancy to evaluate the rules. +prop_needCert :: Property +prop_needCert = forAll genPerasCertInclusionView $ \pciv -> do + -- Determine whether we should include a cert according to the model + let PerasCertInclusionDecisionModel + { shouldIncludeCert + , noCertsFromTwoRoundsAgo + , latestCertSeenIsNotExpired + , latestCertSeenIsNewerThanLatestCertOnChain + } = + needCertModel pciv + -- Some helper functions to report success/failure + let chain = flip (foldr ($)) . reverse + let ok desc = + chain + [ tabulate "NoCertsFromTwoRoundsAgo" [show noCertsFromTwoRoundsAgo] + , tabulate "LatestCertSeenIsNotExpired" [show latestCertSeenIsNotExpired] + , tabulate + "LatestCertSeenIsNewerThanLatestCertOnChain" + [show latestCertSeenIsNewerThanLatestCertOnChain] + , tabulate + "NoCertsFromTwoRoundsAgo|LatestCertSeenIsNotExpired|LatestCertSeenIsNewerThanLatestCertOnChain" + [ show + ( noCertsFromTwoRoundsAgo + , latestCertSeenIsNotExpired + , latestCertSeenIsNewerThanLatestCertOnChain + ) + ] + , tabulate "Should include cert according to model" [show shouldIncludeCert] + , tabulate "Actual result" [desc] + ] + $ property True + let failure desc = + counterexample desc $ + property False + -- Now check that the real implementation agrees with the model + let certInclusionDecision = needCert pciv + case certInclusionDecision of + IncludeCert (ETrue _includeCertReason) _cert + | shouldIncludeCert -> + ok $ certInclusionDecisionTag certInclusionDecision + | otherwise -> + failure $ "Expected not to include cert, but got: " <> show certInclusionDecision + DoNotIncludeCert (EFalse _doNotIncludeCertReason) + | not shouldIncludeCert -> + ok $ certInclusionDecisionTag certInclusionDecision + | otherwise -> + failure $ "Expected to include cert, but got: " <> show certInclusionDecision + +-- | Tag for the certificate inclusion decision result, used for tabulation. +-- +-- We use this instead of 'explainShallow' to avoid creating too many unique +-- strings for tabulation (explainShallow includes round numbers which would +-- create millions of distinct cases, making the tabulation output useless). +certInclusionDecisionTag :: PerasCertInclusionRulesDecision cert -> String +certInclusionDecisionTag = \case + IncludeCert{} -> "IncludeCert" + DoNotIncludeCert{} -> "DoNotIncludeCert" + +{------------------------------------------------------------------------------- + Arbitrary helpers +-------------------------------------------------------------------------------} + +-- * Peras parameters + +-- NOTE: we use a geometric distribution to bias towards smaller values. +-- This increases the chance of covering all the inclusion rules more evenly, +-- while still allowing for larger values to be generated occasionally. +-- +-- Moreover, geometric(0.5) + 1 means that: +-- - 50% chance of being 1 +-- - 25% chance of being 2 +-- - 12.5% chance of being 3 +-- ... and so on +genPerasParams :: Gen (PerasParams blk) +genPerasParams = do + _A <- fromIntegral . (+ 1) <$> geometric 0.5 + pure + mkPerasParams + { perasCertMaxRounds = PerasCertMaxRounds _A + } + +-- * Peras round numbers + +-- | Generate a Peras round number. +-- +-- We skew the distribution towards the first two rounds to cover the edge cases +-- in the certificate inclusion rules a bit more often. +genPerasRoundNo :: Gen PerasRoundNo +genPerasRoundNo = + frequency + [ (1, pure (PerasRoundNo 0)) + , (1, pure (PerasRoundNo 1)) + , (8, PerasRoundNo <$> arbitrary) + ] + +-- * Mocked certificate type + +-- | A mocked certificate type for testing, so we don't have to deal with +-- development changes in the real certificate type. +data TestCert + = TestCert + { tcRoundNo :: PerasRoundNo + } + deriving (Show, Eq, Generic) + +type instance BoostedBlock (TestCert) = Point TestBlock +instance IsPerasCert TestCert TestBlock where + getPerasCertRound = tcRoundNo + + -- We don't really care about the block being boosted for the inclusion rules + getPerasCertBlock = const GenesisPoint + +-- | Generate a test certificate +-- +-- NOTE: to improve the probabilities of covering all the paths in the code, +-- we generate certificates relative to a given Peras round (the current one). +genTestCert :: PerasRoundNo -> Gen TestCert +genTestCert roundNo = do + offset <- choose @Integer (-10, 3) + -- NOTE: here we need to be careful not to underflow the round number + let roundNo' = + PerasRoundNo $ + fromIntegral $ + max 0 $ + toInteger (unPerasRoundNo roundNo) + offset + pure $ + TestCert + { tcRoundNo = roundNo' + } + +-- * Certificate and inclusion views + +genLatestCertSeen :: PerasRoundNo -> Gen (LatestCertSeenView TestCert) +genLatestCertSeen roundNo = do + cert <- genTestCert roundNo + pure + LatestCertSeenView + { lcsCert = cert + , lcsCertRound = getPerasCertRound cert + } + +genLatestCertOnChain :: PerasRoundNo -> Gen (LatestCertOnChainView TestCert) +genLatestCertOnChain roundNo = do + cert <- genTestCert roundNo + let certRoundNo = getPerasCertRound cert + pure $ + LatestCertOnChainView + { lcocRoundNo = certRoundNo + } + +genPerasCertIds :: PerasRoundNo -> Gen (Set PerasRoundNo) +genPerasCertIds currRoundNo = do + -- Decide whether to include a cert from two rounds ago + containsCertFromTwoRoundsAgo <- arbitrary + pure $ + if containsCertFromTwoRoundsAgo && currRoundNo >= 2 + then Set.singleton (currRoundNo - 2) + else Set.empty + +genPerasCertInclusionView :: Gen (PerasCertInclusionView TestCert TestBlock) +genPerasCertInclusionView = do + perasParams <- genPerasParams + currRoundNo <- genPerasRoundNo + latestCertSeen <- genLatestCertSeen currRoundNo + latestCertOnChain <- genWithOrigin (genLatestCertOnChain currRoundNo) + certIds <- genPerasCertIds currRoundNo + pure + PerasCertInclusionView + { perasParams + , currRoundNo + , latestCertSeen = latestCertSeen + , latestCertOnChain = latestCertOnChain + , certIds = certIds + } + where + genWithOrigin gen = + frequency + [ (1, pure Origin) + , (9, NotOrigin <$> gen) + ] diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Internal.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs similarity index 97% rename from ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Internal.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs index 0af5eec8ea..bee331a874 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Internal.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeApplications #-} -module Test.Consensus.Peras.Util.Internal where +module Test.Util.Peras.Internal where import Data.Containers.ListUtils (nubOrdOn) import Data.List.NonEmpty (NonEmpty) @@ -12,10 +12,10 @@ import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId) import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) import Ouroboros.Network.Block (Point (..), SlotNo (..)) import Ouroboros.Network.Point (Block (..), WithOrigin (..)) -import Test.Consensus.Committee.Utils (mkPoolId) import Test.QuickCheck (Arbitrary (arbitrary), Gen, NonEmptyList (getNonEmpty)) import Test.QuickCheck.Gen (frequency, listOf, listOf1) import Test.Util.TestBlock (TestBlock, TestHash (..)) +import Test.Util.Committee (mkPoolId) genRoundNo :: Gen PerasRoundNo genRoundNo = PerasRoundNo <$> arbitrary diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Mock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs similarity index 94% rename from ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Mock.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs index e12446a4ae..10f0d0763d 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/Mock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs @@ -1,14 +1,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -module Test.Consensus.Peras.Util.Mock where +module Test.Util.Peras.Mock where import Data.Containers.NonEmpty (NE) import Data.Either (fromRight) import Data.Set (Set) import qualified Data.Set.NonEmpty as NESet import Ouroboros.Consensus.Block (BlockSupportsPeras (PerasEpochContext), PerasParams (perasWeight)) -import Ouroboros.Consensus.Block.SupportsPeras (PerasParams, ValidatedPerasCert (..), ValidatedPerasVote (..), mkPerasParams) +import Ouroboros.Consensus.Block.SupportsPeras + ( ValidatedPerasCert (..) + , ValidatedPerasVote (..) + , mkPerasParams + ) import Ouroboros.Consensus.Committee.Class import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Peras.Crypto.Mock @@ -21,8 +25,8 @@ import Ouroboros.Consensus.Peras.Crypto.Mock ) import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) -import Test.Consensus.Peras.Util.Internal import Test.QuickCheck (Gen, choose) +import Test.Util.Peras.Internal import Test.Util.TestBlock (TestBlock) genMockPerasVotingCommitteeInput :: diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Serialisation.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Serialisation.hs new file mode 100644 index 0000000000..35e965ccf3 --- /dev/null +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Serialisation.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Serialisation roundtrip tests for Peras types +module Test.Util.Peras.Serialisation + ( tests + ) where + +import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeFull, serialize) +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import Test.QuickCheck + ( Gen + , Property + , counterexample + , forAll + , tabulate + , (===) + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.Peras + ( genPerasCert + , genPerasVote + , mkBucket + , tabulatePerasCert + , tabulatePerasVote + ) +import Test.Util.TestEnv (adjustQuickCheckTests) + +tests :: TestTree +tests = + testGroup + "Serialization roundtrip for Peras types" + [ adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasVote" $ + prop_roundtrip @(V1.PerasVote ()) + -- Generate both persistent and non-persistent votes + (genPerasVote True) + tabulatePerasVote + , adjustQuickCheckTests (* 10) $ + testProperty "Roundtrip for PerasCert" $ + prop_roundtrip @(V1.PerasCert ()) + -- Generate certs with both persistent and non-persistent votes + (genPerasCert True) + tabulatePerasCert + ] + +-- * Properties + +prop_roundtrip :: + forall a. + ( Eq a + , Show a + , ToCBOR a + , FromCBOR a + ) => + Gen a -> + (a -> Property -> Property) -> + Property +prop_roundtrip gen tabulateValue = + forAll gen $ \a -> do + let encoded = serialize a + let decoded = decodeFull encoded + tabulateValue a + . tabulateEncodedSize encoded + . counterexample + ( unlines + [ "Original value:" + , show a + , "Decoded value:" + , show decoded + ] + ) + $ Right a === decoded + +-- * Tabulators + +tabulateEncodedSize :: LazyByteString.ByteString -> Property -> Property +tabulateEncodedSize bytes = + tabulate + "Encoded size" + [mkBucket 1000 (fromIntegral (LazyByteString.length bytes)) " bytes"] diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/V1.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/V1.hs similarity index 98% rename from ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/V1.hs rename to ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/V1.hs index ab54c1c5e2..cb5a05aea6 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util/V1.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/V1.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeFamilies #-} -- | Common utilities for writing tests for Peras types. -module Test.Consensus.Peras.Util.V1 +module Test.Util.Peras.V1 ( -- * Predicates perasVoteIsPersistent , perasCertContainsOnlyPersistentVotes @@ -49,7 +49,7 @@ import Ouroboros.Consensus.Peras.Types , PerasSeatIndex (..) ) import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 -import Test.Consensus.Peras.Util.Internal (genRoundNo, genSeatIndex, mkBucket) +import Test.Util.Peras.Internal (genRoundNo, genSeatIndex, mkBucket) import Test.QuickCheck ( Arbitrary (..) , Gen diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/Class.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/Class.hs index 5e650171ee..6c88ae91e8 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/Class.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/Class.hs @@ -25,7 +25,6 @@ import Ouroboros.Consensus.Committee.Crypto ) import Test.Consensus.Committee.TestCrypto (TestCrypto) import qualified Test.Consensus.Committee.TestCrypto as TestCrypto -import Test.Consensus.Committee.Utils (mkBucket) import Test.QuickCheck ( Arbitrary (..) , Gen @@ -42,6 +41,7 @@ import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (Testable (..), testProperty) import Test.Util.TestEnv (adjustQuickCheckTests) +import Test.Util.Committee (mkBucket) tests :: TestTree tests = diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/EveryoneVotes/Tests.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/EveryoneVotes/Tests.hs index 60eedb3bf5..19e572517f 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/EveryoneVotes/Tests.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/EveryoneVotes/Tests.hs @@ -40,16 +40,6 @@ import Ouroboros.Consensus.Committee.WFA ) import Test.Consensus.Committee.TestCrypto (TestCrypto) import qualified Test.Consensus.Committee.TestCrypto as TestCrypto -import Test.Consensus.Committee.Utils - ( eqWithShowCmp - , genPools - , genPositiveStake - , mkBucket - , onError - , tabulateNumPools - , tabulatePoolStake - , unfairWFATiebreaker - ) import Test.QuickCheck ( Gen , Property @@ -65,6 +55,16 @@ import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.TestEnv (adjustQuickCheckTests) +import Test.Util.Committee + ( eqWithShowCmp + , genPools + , genPositiveStake + , mkBucket + , onError + , tabulateNumPools + , tabulatePoolStake + , unfairWFATiebreaker + ) tests :: TestTree tests = diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs index 3136c8b673..8cfd5050a3 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs @@ -63,7 +63,6 @@ import Ouroboros.Consensus.Committee.Crypto ) import Ouroboros.Consensus.Committee.Crypto.BLS (KeyRole (..)) import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS -import Test.Consensus.Committee.Utils (genEpochNonce) import Test.QuickCheck ( Arbitrary (..) , Gen @@ -81,6 +80,7 @@ import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.TestEnv (adjustQuickCheckTests) +import Test.Util.Committee (genEpochNonce) -- * Test crypto based on BLS signatures diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS.hs index 02b957682e..5503ed2594 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS.hs @@ -16,7 +16,6 @@ import Data.String (IsString (..)) import qualified Ouroboros.Consensus.Committee.Types as WFA import Ouroboros.Consensus.Committee.WFA (WFATiebreaker (..)) import qualified Ouroboros.Consensus.Committee.WFA as WFA -import Test.Consensus.Committee.Utils (mkPoolId) import Test.Consensus.Committee.WFALS.Conformance (conformsToRustImplementation) import Test.Consensus.Committee.WFALS.Model ( NumSeats @@ -38,6 +37,7 @@ import Test.QuickCheck ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) +import Test.Util.Committee (mkPoolId) import Test.Util.TestEnv (adjustQuickCheckTests) tests :: TestTree diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Model/Utils.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Model/Utils.hs index dfbac767ca..f71e6d9a84 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Model/Utils.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Model/Utils.hs @@ -17,7 +17,6 @@ import qualified Data.Map.Strict as Map import Data.Ratio ((%)) import qualified Data.Set as Set import Data.Word (Word64) -import Test.Consensus.Committee.Utils (mkBucket) import Test.Consensus.Committee.WFALS.Model ( IsStake (..) , NumSeats @@ -38,6 +37,7 @@ import Test.QuickCheck , tabulate , vectorOf ) +import Test.Util.Committee (mkBucket) -- * Generators diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Tests.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Tests.hs index e9eac340ec..bac3d3ae2d 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Tests.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Tests.hs @@ -51,16 +51,6 @@ import Ouroboros.Consensus.Committee.WFALS ) import Test.Consensus.Committee.TestCrypto (TestCrypto) import qualified Test.Consensus.Committee.TestCrypto as TestCrypto -import Test.Consensus.Committee.Utils - ( eqWithShowCmp - , genEpochNonce - , genPools - , mkBucket - , onError - , tabulateNumPools - , tabulatePoolStake - , unfairWFATiebreaker - ) import Test.QuickCheck ( Gen , Property @@ -76,6 +66,16 @@ import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.TestEnv (adjustQuickCheckTests) +import Test.Util.Committee + ( eqWithShowCmp + , genEpochNonce + , genPools + , mkBucket + , onError + , tabulateNumPools + , tabulatePoolStake + , unfairWFATiebreaker + ) tests :: TestTree tests = diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index 9ed902d64f..1b89a5d9a9 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -41,7 +41,7 @@ import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke , genProtocolConstants , prop_smoke_object_diffusion ) -import Test.Consensus.Peras.Util +import Test.Util.Peras ( genListWithUniqueIds , genMockPerasEpochContext , genMockValidatedPerasCert diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs index 8ae4bddfc4..9c9c6ccc15 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs @@ -19,7 +19,10 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote -import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle, constPerasEpochContextResolverHandle) +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextResolverHandle + , constPerasEpochContextResolverHandle + ) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB @@ -38,16 +41,16 @@ import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke , genProtocolConstants , prop_smoke_object_diffusion ) -import Test.Consensus.Peras.Util +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.Peras ( genListWithUniqueIds , genMockPerasEpochContext + , genMockValidatedPerasVote , genWithArrivalTime , mockSystemTime ) -import Test.Consensus.Peras.Util.Mock (genMockValidatedPerasVote) -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.QuickCheck (testProperty) import Test.Util.TestBlock tests :: TestTree @@ -82,8 +85,8 @@ prop_smoke = forAll genProtocolConstants $ \protocolConstants -> forAll genMockPerasEpochContext $ \epochContext -> forAll - (genListWithUniqueIds getPerasVoteRound (genWithArrivalTime (genMockValidatedPerasVote epochContext))) $ - \(ListWithUniqueIds watValidatedVotes) -> + (genListWithUniqueIds getPerasVoteRound (genWithArrivalTime (genMockValidatedPerasVote epochContext))) + $ \(ListWithUniqueIds watValidatedVotes) -> let mkPoolInterfaces :: IOLike m => diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs index 5acc8f6305..9e64765fb8 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -59,12 +59,12 @@ import Ouroboros.Network.Protocol.ObjectDiffusion.Type , NumObjectsUnacknowledged (..) , ObjectDiffusion ) -import Test.Consensus.Peras.Util (ListWithUniqueIds (..), genListWithUniqueIds) import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.IOLike () +import Test.Util.Peras (ListWithUniqueIds (..), genListWithUniqueIds) tests :: TestTree tests = diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs index 02a9c8b0b9..f1920cb5d8 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs @@ -11,7 +11,7 @@ import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeFull, serialize) import qualified Data.ByteString.Lazy as LazyByteString import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 -import Test.Consensus.Peras.Util +import Test.Util.Peras ( genPerasCert , genPerasVote , mkBucket diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs deleted file mode 100644 index b52e3080ec..0000000000 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Util.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Test.Consensus.Peras.Util (module X) where - -import Test.Consensus.Peras.Util.Internal as X -import Test.Consensus.Peras.Util.Mock as X -import Test.Consensus.Peras.Util.V1 as X diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs index ef095eec99..c77cc31a49 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Adapter.hs @@ -15,14 +15,6 @@ import Ouroboros.Consensus.Committee.EveryoneVotes (EveryoneVotes) import Ouroboros.Consensus.Committee.WFALS (WFALS) import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 -import Test.Consensus.Peras.Util - ( genPerasCert - , genPerasVote - , perasCertContainsOnlyPersistentVotes - , perasVoteIsPersistent - , tabulatePerasCert - , tabulatePerasVote - ) import Test.QuickCheck ( Gen , Property @@ -35,6 +27,14 @@ import Test.QuickCheck ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) +import Test.Util.Peras + ( genPerasCert + , genPerasVote + , perasCertContainsOnlyPersistentVotes + , perasVoteIsPersistent + , tabulatePerasCert + , tabulatePerasVote + ) import Test.Util.TestEnv (adjustQuickCheckTests) tests :: TestTree 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 ce6e3328af..190ed5f2d1 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 @@ -182,6 +182,7 @@ import Test.Util.ChunkInfo import Test.Util.Header (attachSlotTimeToFragment) import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.ToExpr () +import Test.Util.Peras (genMockPerasVotingCommittee, genVotersSubset) import Test.Util.QuickCheck import Test.Util.RefEnv (RefEnv) import qualified Test.Util.RefEnv as RE @@ -1290,6 +1291,8 @@ generator loe genBlock genPerasBlock m@Model{..} = ] -- Include the boosted block itself in the persisted seenBlocks let seenBlks = fmap (blk :) gapBlks + -- Generate some voters to populate the certificate + voters <- genMockPerasVotingCommittee >>= genVotersSubset -- Build the certificate now <- genRelativeTime let certWithTime = @@ -1299,6 +1302,7 @@ generator loe genBlock genPerasBlock m@Model{..} = MockPerasCert { mockCertRound = roundNo , mockCertBlock = blockPoint blk + , mockCertVoters = voters } , vpcCertBoost = boost } @@ -1334,7 +1338,6 @@ generator loe genBlock genPerasBlock m@Model{..} = { mockVoteRound = roundNo , mockVoteBlock = blockPoint blk , mockVoteSeatIndex = seatIndex - , mockVoteWeight = weight } , vpvVoteWeight = weight } @@ -2146,10 +2149,14 @@ genBlkPair chunkInfo loe Model{..} = boostedBlock <- -- NOTE: we don't care about this boosted block, it could be @Genesis@ blockPoint <$> genSuccOfCurrentChainTip + voters <- + genMockPerasVotingCommittee >>= genVotersSubset + pure MockPerasCert { mockCertRound = roundNo , mockCertBlock = boostedBlock + , mockCertVoters = voters } -- | Generate a random security parameter (k) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index f7a8aee701..b09bf0f4fc 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -37,6 +37,7 @@ import GHC.Generics (Generic) import Ouroboros.Consensus.Block.Abstract (Point (..), SlotNo (..)) import Ouroboros.Consensus.Block.SupportsPeras ( IsPerasVote (..) + , PerasEpochContext , PerasParams , PerasRoundNo (..) , PerasSeatIndex (..) @@ -51,6 +52,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , WithArrivalTime (..) ) +import Ouroboros.Consensus.Peras.Context (constPerasEpochContextResolverHandle) import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) @@ -84,6 +86,7 @@ import Test.QuickCheck.StateModel ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) +import Test.Util.Peras (genMockPerasVotingCommittee) import Test.Util.TestBlock ( TestBlock , TestHash (..) @@ -131,6 +134,7 @@ newtype Model = Model (Model.Model TestBlock) instance StateModel Model where data Action Model a where CreateDB :: + PerasEpochContext TestBlock -> Action Model () AddVote :: WithArrivalTime (ValidatedPerasVote TestBlock) -> @@ -170,7 +174,9 @@ instance StateModel Model where ] where genCreateDB = do - pure CreateDB + committee <- genMockPerasVotingCommittee + let params = perasTestParams + pure $ CreateDB (committee, params) genAddVote = do roundNo <- genRoundNo @@ -234,7 +240,7 @@ instance StateModel Model where nextState (Model m) action _ = case action of - CreateDB -> Model $ Model.openDB m + CreateDB _context -> Model $ Model.openDB m AddVote vote -> Model $ snd $ Model.addVote vote m GetVoteIds -> Model $ m GetVotesAfter _ -> Model $ m @@ -243,7 +249,7 @@ instance StateModel Model where precondition (Model m) action = case action of - CreateDB -> not (Model.open m) + CreateDB _context -> not (Model.open m) AddVote _ -> Model.open m GetVoteIds -> Model.open m GetVotesAfter _ -> Model.open m @@ -259,8 +265,9 @@ instance HasVariables (Action Model a) where instance RunModel Model (StateT (PerasVoteDB IO TestBlock) IO) where perform _ action _ = case action of - CreateDB -> do - let args = PerasVoteDB.PerasVoteDbArgs nullTracer perasTestParams + CreateDB context -> do + resolverHandle <- lift $ constPerasEpochContextResolverHandle context + let args = PerasVoteDB.PerasVoteDbArgs nullTracer resolverHandle voteDB <- lift $ PerasVoteDB.createDB args put voteDB AddVote vote -> do From 8fbfce088cc49a1b427adc9c60ef54f1782be3f2 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 1 Jun 2026 13:37:04 +0200 Subject: [PATCH 46/62] Fix broken tests and warnings --- ouroboros-consensus.cabal | 2 +- .../Consensus/Block/SupportsPeras.hs | 7 +-- .../Consensus/Committee/EveryoneVotes.hs | 1 - .../Ouroboros/Consensus/Peras/Context.hs | 3 +- .../Ouroboros/Consensus/Peras/Crypto/Mock.hs | 13 ++-- .../Ouroboros/Consensus/Peras/Error/Mock.hs | 2 - .../Ouroboros/Consensus/Peras/Error/V1.hs | 2 - .../Test/Util/Peras/Internal.hs | 29 +++++++-- .../Test/Util/Peras/Mock.hs | 63 +++++++++++++++---- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 6 +- .../Ouroboros/Storage/PerasVoteDB/Model.hs | 8 +++ .../Storage/VolatileDB/StateMachine.hs | 3 + 12 files changed, 100 insertions(+), 39 deletions(-) diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index e77b042c9f..a0fe7888b0 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -829,7 +829,6 @@ test-suite storage-test Test.Ouroboros.Storage.VolatileDB.StateMachine build-depends: - nonempty-containers, aeson, base, bifunctors, @@ -854,6 +853,7 @@ test-suite storage-test io-sim, mempack, mtl, + nonempty-containers, nothunks, ouroboros-consensus:{lsm, ouroboros-consensus}, ouroboros-network:{api, api-tests-lib, protocols-tests-lib}, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 8e988ade3a..789edd8a07 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -14,6 +14,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Block.SupportsPeras ( PerasVotingCommittee @@ -382,7 +383,7 @@ newtype VoidPerasError blk = VoidPerasError { unVoidPerasError :: Void } - deriving newtype (Show, Eq, NoThunks, Generic, Typeable, ShowProxy, Exception) + deriving newtype (Show, Eq, NoThunks, Generic, ShowProxy, Exception) instance IsPerasError (VoidPerasError blk) blk where injectVotingCommitteeError _ = @@ -406,11 +407,7 @@ type instance PublicKey (VoidPerasCrypto blk) = Void instance CryptoSupportsVoteSigning (VoidPerasCrypto blk) where type VoteSigningKey (VoidPerasCrypto blk) = Void - - -- \| Key used for verifying votes type VoteVerificationKey (VoidPerasCrypto blk) = Void - - -- \| Cryptographic signature of a vote data VoteSignature (VoidPerasCrypto blk) = VoidVoteSignature {unVoidVoteSignature :: Void} getVoteSigningKey _proxy privateKey = absurd privateKey getVoteVerificationKey _proxy publicKey = absurd publicKey diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index 17425713fd..f4a3c02d44 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs index 3784aa1ab3..f44d145fb3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs @@ -17,7 +17,6 @@ where import Control.Exception (Exception) import Control.Monad.Class.MonadSTM (STM) -import Data.Typeable (Typeable) import GHC.Generics (Generic) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) @@ -46,7 +45,7 @@ type PerasEpochContextResolver blk = PerasRoundNo -> Either PerasEpochContextNotFoundForRound (PerasEpochContext blk) data PerasEpochContextNotFoundForRound = PerasEpochContextNotFoundForRound PerasRoundNo - deriving (Show, Eq, Generic, NoThunks, Typeable, Exception) + deriving (Show, Eq, Generic, NoThunks, Exception) newtype PerasEpochContextResolverHandle m blk = PerasEpochContextResolverHandle (StrictTVar m (PerasEpochContextResolver blk)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs index 3b574d72b3..380d0219ef 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs @@ -36,7 +36,6 @@ import Data.List.Extra ((!?)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set.NonEmpty as NESet -import Data.Typeable (Typeable) import Data.Word (Word16) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -167,35 +166,35 @@ instance { -- Stake distribution weightDistr :: NonEmpty (PoolId, VoteWeight) } - deriving stock (Show, Eq, Generic, Typeable) + deriving stock (Show, Eq, Generic) deriving anyclass NoThunks newtype VotingCommitteeInput crypto (MockPerasCommittee blk) = MockPerasVotingCommitteeInput (NonEmpty (PoolId, LedgerStake)) - deriving stock (Show, Eq, Generic, Typeable) + deriving stock (Show, Eq, Generic) deriving anyclass NoThunks newtype VotingCommitteeError crypto (MockPerasCommittee blk) = -- Seat index is out of bounds for the voting committee MissingSeatIndex PerasSeatIndex - deriving stock (Show, Eq, Generic, Typeable) + deriving stock (Show, Eq, Generic) deriving anyclass (NoThunks, Exception) data EligibilityWitness crypto (MockPerasCommittee blk) = MockPerasCommitteeMember !PerasSeatIndex !VoteWeight - deriving stock (Show, Eq, Generic, Typeable) + deriving stock (Show, Eq, Generic) deriving anyclass NoThunks newtype Vote crypto (MockPerasCommittee blk) = MockPerasCommitteeVote (MockPerasVote blk) - deriving stock (Show, Eq, Generic, Typeable) + deriving stock (Show, Eq, Generic) deriving anyclass NoThunks newtype Cert crypto (MockPerasCommittee blk) = MockPerasCommitteeCert (MockPerasCert blk) - deriving stock (Show, Eq, Generic, Typeable) + deriving stock (Show, Eq, Generic) deriving anyclass NoThunks mkVotingCommittee (MockPerasVotingCommitteeInput stakeDistr) = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs index 6c408ef7fe..5641a1ac40 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs @@ -44,8 +44,6 @@ deriving instance NoThunks (MockPerasError blk) deriving instance Generic (MockPerasError blk) -deriving instance - Typeable (MockPerasError blk) deriving instance (Show (PerasVotingCommitteeError blk), Typeable blk) => Exception (MockPerasError blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs index affd71ee47..8c53ec5e3e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/V1.hs @@ -49,8 +49,6 @@ deriving instance NoThunks (PerasError blk) deriving instance Generic (PerasError blk) -deriving instance - Typeable (PerasError blk) deriving instance (Show (PerasVotingCommitteeError blk), Typeable blk) => Exception (PerasError blk) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs index bee331a874..bb4fc52872 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs @@ -1,21 +1,40 @@ {-# LANGUAGE TypeApplications #-} -module Test.Util.Peras.Internal where +module Test.Util.Peras.Internal + ( genPerasParams + , genRoundNo + , genSeatIndex + , genPoolId + , genLedgerStake + , ListWithUniqueIds (..) + , NonEmptyListWithUniqueIds (..) + , genListWithUniqueIds + , genNonEmptyListWithUniqueIds + , nonEmptyListOf + , genRelativeTime + , genWithArrivalTime + , genPointTestBlock + , mockSystemTime + , mkBucket + ) where import Data.Containers.ListUtils (nubOrdOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Word (Word64) -import Ouroboros.Consensus.Block.SupportsPeras (PerasRoundNo (..)) +import Ouroboros.Consensus.Block.SupportsPeras (PerasRoundNo (..), PerasParams, mkPerasParams) import Ouroboros.Consensus.BlockchainTime (RelativeTime (..), SystemTime (..), WithArrivalTime (..)) import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId) import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) import Ouroboros.Network.Block (Point (..), SlotNo (..)) import Ouroboros.Network.Point (Block (..), WithOrigin (..)) -import Test.QuickCheck (Arbitrary (arbitrary), Gen, NonEmptyList (getNonEmpty)) +import Test.QuickCheck (Arbitrary (arbitrary), Gen, NonEmptyList (getNonEmpty), choose) import Test.QuickCheck.Gen (frequency, listOf, listOf1) -import Test.Util.TestBlock (TestBlock, TestHash (..)) import Test.Util.Committee (mkPoolId) +import Test.Util.TestBlock (TestBlock, TestHash (..)) + +genPerasParams :: Gen (PerasParams blk) +genPerasParams = pure mkPerasParams genRoundNo :: Gen PerasRoundNo genRoundNo = PerasRoundNo <$> arbitrary @@ -27,7 +46,7 @@ genPoolId :: Gen PoolId genPoolId = mkPoolId <$> arbitrary genLedgerStake :: Gen LedgerStake -genLedgerStake = LedgerStake <$> arbitrary +genLedgerStake = LedgerStake . toRational <$> choose @Int (1, 100) newtype ListWithUniqueIds a = ListWithUniqueIds [a] deriving (Eq, Show, Ord) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs index 10f0d0763d..58cc756b2b 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs @@ -1,25 +1,40 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -module Test.Util.Peras.Mock where +module Test.Util.Peras.Mock + ( genMockPerasVotingCommitteeInput + , genMockPerasVotingCommittee + , genMockPerasEpochContext + , genMockPerasVote + , genMockValidatedPerasVote + , genMockPerasCert + , genMockPerasCertFullCommittee + , genMockValidatedPerasCert + , genMockPerasVoterIndices + , pickSeatIndexFromCommittee + , genVotersSubset + ) where import Data.Containers.NonEmpty (NE) import Data.Either (fromRight) +import qualified Data.List.NonEmpty as NonEmpty import Data.Set (Set) import qualified Data.Set.NonEmpty as NESet -import Ouroboros.Consensus.Block (BlockSupportsPeras (PerasEpochContext), PerasParams (perasWeight)) +import Ouroboros.Consensus.Block + ( BlockSupportsPeras (..) + , PerasParams (..) + ) import Ouroboros.Consensus.Block.SupportsPeras ( ValidatedPerasCert (..) , ValidatedPerasVote (..) - , mkPerasParams ) import Ouroboros.Consensus.Committee.Class import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Peras.Crypto.Mock ( MockPerasCommittee , MockPerasCrypto - , VotingCommittee (MockPerasVotingCommittee) - , VotingCommitteeInput (MockPerasVotingCommitteeInput) + , VotingCommittee (..) + , VotingCommitteeInput (..) , getEligibility , unsafeIntToSeatIndex ) @@ -27,6 +42,14 @@ import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) import Test.QuickCheck (Gen, choose) import Test.Util.Peras.Internal + ( NonEmptyListWithUniqueIds (..) + , genLedgerStake + , genNonEmptyListWithUniqueIds + , genPerasParams + , genPointTestBlock + , genPoolId + , genRoundNo + ) import Test.Util.TestBlock (TestBlock) genMockPerasVotingCommitteeInput :: @@ -42,16 +65,13 @@ genMockPerasVotingCommittee = fromRight (error "mkVotingCommittee of O.C.Peras.Crypto.Mock can't fail") . mkVotingCommittee <$> genMockPerasVotingCommitteeInput -genPerasParams :: Gen (PerasParams TestBlock) -genPerasParams = pure mkPerasParams - genMockPerasEpochContext :: Gen (PerasEpochContext TestBlock) genMockPerasEpochContext = (,) <$> genMockPerasVotingCommittee <*> genPerasParams pickSeatIndexFromCommittee :: VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> Gen PerasSeatIndex -pickSeatIndexFromCommittee (MockPerasVotingCommittee weightDistr) = do - let maxIndex = length weightDistr - 1 +pickSeatIndexFromCommittee committee = do + let maxIndex = length (weightDistr committee) - 1 unsafeIntToSeatIndex <$> choose (0, maxIndex) genVotersSubset :: @@ -62,6 +82,12 @@ genVotersSubset committee = do genNonEmptyListWithUniqueIds id (pickSeatIndexFromCommittee committee) pure $ NESet.fromList seatIndices +genMockPerasVoterIndices :: Gen (NE (Set PerasSeatIndex)) +genMockPerasVoterIndices = do + NonEmptyListWithUniqueIds seatIndices <- + genNonEmptyListWithUniqueIds id (unsafeIntToSeatIndex <$> choose (0, 100)) + pure $ NESet.fromList seatIndices + genMockPerasVote :: VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> Gen (MockPerasVote TestBlock) @@ -106,9 +132,24 @@ genMockPerasCert committee = do , mockCertBlock = block } +genMockPerasCertFullCommittee :: + VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> + Gen (MockPerasCert TestBlock) +genMockPerasCertFullCommittee committee = do + let maxIndex = length (weightDistr committee) - 1 + let voters = NESet.fromList (NonEmpty.fromList (unsafeIntToSeatIndex <$> [0 .. maxIndex])) + roundNo <- genRoundNo + block <- genPointTestBlock + pure + MockPerasCert + { mockCertVoters = voters + , mockCertRound = roundNo + , mockCertBlock = block + } + genMockValidatedPerasCert :: PerasEpochContext TestBlock -> Gen (ValidatedPerasCert TestBlock) genMockValidatedPerasCert (committee, params) = do - cert <- genMockPerasCert committee + cert <- genMockPerasCertFullCommittee committee pure $ ValidatedPerasCert { vpcCert = cert 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 190ed5f2d1..b1ab1d0091 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 @@ -182,7 +182,7 @@ import Test.Util.ChunkInfo import Test.Util.Header (attachSlotTimeToFragment) import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.ToExpr () -import Test.Util.Peras (genMockPerasVotingCommittee, genVotersSubset) +import Test.Util.Peras (genMockPerasVoterIndices) import Test.Util.QuickCheck import Test.Util.RefEnv (RefEnv) import qualified Test.Util.RefEnv as RE @@ -1292,7 +1292,7 @@ generator loe genBlock genPerasBlock m@Model{..} = -- Include the boosted block itself in the persisted seenBlocks let seenBlks = fmap (blk :) gapBlks -- Generate some voters to populate the certificate - voters <- genMockPerasVotingCommittee >>= genVotersSubset + voters <- genMockPerasVoterIndices -- Build the certificate now <- genRelativeTime let certWithTime = @@ -2150,7 +2150,7 @@ genBlkPair chunkInfo loe Model{..} = -- NOTE: we don't care about this boosted block, it could be @Genesis@ blockPoint <$> genSuccOfCurrentChainTip voters <- - genMockPerasVotingCommittee >>= genVotersSubset + genMockPerasVoterIndices pure MockPerasCert diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs index 10cd02c932..f94551dad9 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/Model.hs @@ -22,6 +22,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Set.NonEmpty as NESet import Data.TreeDiff (ToExpr (..), defaultExprViaShow) import GHC.Generics (Generic) import Ouroboros.Consensus.Block (SlotNo, WithOrigin (..), pointSlot) @@ -245,6 +246,12 @@ addVote vote model -- The extended set of votes including the new one extendedVotes = Set.insert voteEntry existingVotes + -- The extended set of voters including the new one + extendedVoters = + NESet.unsafeFromSet -- Safe due to insert below + . Set.insert voter + . Set.map veVoter + $ existingVotes -- Get the total weight of a set of votes getTotalWeight = VoteWeight @@ -278,6 +285,7 @@ addVote vote model MockPerasCert { mockCertRound = roundNo , mockCertBlock = votedBlock + , mockCertVoters = extendedVoters } , vpcCertBoost = perasWeight (params model) } diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs index 5884ee08a1..61b600e15a 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs @@ -84,6 +84,7 @@ import Test.Util.ToExpr () import Test.Util.Tracer (recordingTracerIORef) import Text.Show.Pretty (ppShow) import Prelude hiding (elem) +import Test.Util.Peras.Mock (genMockPerasVoterIndices) type Block = TestBlock @@ -412,10 +413,12 @@ generatorCmdImpl Model{..} = genPerasCert = do mockCertRound <- PerasRoundNo <$> arbitrary mockCertBlock <- blockPoint <$> genRandomBlock + mockCertVoters <- genMockPerasVoterIndices pure $ MockPerasCert { mockCertRound , mockCertBlock + , mockCertVoters } genHash :: Gen (HeaderHash Block) From 0bd1a2dd9a9006dd627e370e3eba7d183d9f1fa0 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 1 Jun 2026 15:28:30 +0200 Subject: [PATCH 47/62] Change BlockSupportsPeras instance for ShelleyBlock p DijkstraEra + HardForkBlock to use concrete V1.Peras{Cert,Vote} --- .../Ouroboros/Consensus/Shelley/Node/Peras.hs | 36 ++++---- .../Consensus/Protocol/Praos/Peras.hs | 91 +++++++++---------- .../Ouroboros/Consensus/Block/RealPoint.hs | 11 ++- .../Consensus/Block/SupportsPeras.hs | 2 +- .../Consensus/HardFork/Combinator/Basics.hs | 50 +++++----- .../Consensus/HardFork/Combinator/Block.hs | 16 ---- .../Ouroboros/Consensus/Peras/Cert/V1.hs | 24 ++++- .../Ouroboros/Consensus/Peras/Types.hs | 7 +- .../Ouroboros/Consensus/Peras/Vote/V1.hs | 22 ++++- .../Test/Util/Peras/Internal.hs | 2 +- .../Test/Util/Peras/V1.hs | 9 +- .../Test/Consensus/Committee/Class.hs | 2 +- .../Committee/EveryoneVotes/Tests.hs | 2 +- .../Test/Consensus/Committee/TestCrypto.hs | 2 +- .../Test/Consensus/Committee/WFALS/Tests.hs | 2 +- .../ObjectDiffusion/PerasCert/Smoke.hs | 10 +- .../Test/Consensus/Peras/Serialisation.hs | 14 +-- .../Storage/VolatileDB/StateMachine.hs | 2 +- 18 files changed, 162 insertions(+), 142 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs index b76e3ddcfa..8641a37b90 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -17,13 +17,14 @@ import Cardano.Ledger.Api import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) ) -import Ouroboros.Consensus.Peras.Cert.Mock - ( MockPerasCert (..) - ) -import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCommittee, MockPerasCrypto) -import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) -import Ouroboros.Consensus.Peras.Vote.Mock - ( MockPerasVote (..) +import Ouroboros.Consensus.Committee.WFALS (WFALS) +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS +import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import Ouroboros.Consensus.Protocol.Praos.Peras + ( PraosStateSupportsPerasVoting (..) + , praosStatePerasVotingCommitteeInputV1 ) import Ouroboros.Consensus.Shelley.Ledger.Block ( ShelleyBlock @@ -44,20 +45,21 @@ instance ShelleyCompatible proto AlonzoEra => BlockSupportsPeras (ShelleyBlock p instance ShelleyCompatible proto BabbageEra => BlockSupportsPeras (ShelleyBlock proto BabbageEra) instance ShelleyCompatible proto ConwayEra => BlockSupportsPeras (ShelleyBlock proto ConwayEra) --- NOTE: this is a mocked up implementation without crypto! --- TODO: replace this with a concrete implementation using 'Peras.Vote.V1' and --- 'Peras.Cert.V1' for era >= DijkstraEra. instance ShelleyCompatible proto DijkstraEra => BlockSupportsPeras (ShelleyBlock proto DijkstraEra) where - type PerasCrypto (ShelleyBlock proto DijkstraEra) = MockPerasCrypto (ShelleyBlock proto DijkstraEra) - type - PerasVotingCommitteeScheme (ShelleyBlock proto DijkstraEra) = - MockPerasCommittee (ShelleyBlock proto DijkstraEra) - type PerasVote (ShelleyBlock proto DijkstraEra) = MockPerasVote (ShelleyBlock proto DijkstraEra) - type PerasCert (ShelleyBlock proto DijkstraEra) = MockPerasCert (ShelleyBlock proto DijkstraEra) - type PerasError (ShelleyBlock proto DijkstraEra) = MockPerasError (ShelleyBlock proto DijkstraEra) + type PerasVote (ShelleyBlock proto DijkstraEra) = V1.PerasVote (ShelleyBlock proto DijkstraEra) + type PerasCert (ShelleyBlock proto DijkstraEra) = V1.PerasCert (ShelleyBlock proto DijkstraEra) + type PerasError (ShelleyBlock proto DijkstraEra) = V1.PerasError (ShelleyBlock proto DijkstraEra) + type PerasCrypto (ShelleyBlock proto DijkstraEra) = BLS.PerasBLSCrypto + type PerasVotingCommitteeScheme (ShelleyBlock proto DijkstraEra) = WFALS -- TODO: extract actual Peras certificates from blocks getPerasCertInBlock _ = Nothing + +instance + ShelleyCompatible proto DijkstraEra => + PraosStateSupportsPerasVoting (ShelleyBlock proto DijkstraEra) + where + praosStatePerasVotingCommitteeInput = praosStatePerasVotingCommitteeInputV1 diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs index 2abdedf64f..292ebafbb1 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -3,16 +3,17 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Voting interface for Peras derived from the Praos ledger view. module Ouroboros.Consensus.Protocol.Praos.Peras ( PraosStateSupportsPerasVoting (..) + , praosStatePerasVotingCommitteeInputV1 ) where import Data.Bifunctor (Bifunctor (..)) -import Data.ByteString.Short (ShortByteString) -import Ouroboros.Consensus.Block.Abstract (HeaderHash, StandardHash) +import Ouroboros.Consensus.Block.Abstract (StandardHash) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) , IsPerasError (..) @@ -24,6 +25,7 @@ import Ouroboros.Consensus.Block.SupportsPeras ) import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee) import qualified Ouroboros.Consensus.Committee.Class as Committee +import Ouroboros.Consensus.Committee.Crypto (PublicKey) import Ouroboros.Consensus.Committee.WFA ( mkExtWFAStakeDistr , wFATiebreakerWithEpochNonce @@ -32,64 +34,20 @@ import Ouroboros.Consensus.Committee.WFALS ( VotingCommitteeInput (..) , WFALS ) -import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import Ouroboros.Consensus.HardFork.Combinator.Abstract (CanHardFork) +import Ouroboros.Consensus.HardFork.Combinator.Basics (HardForkBlock) import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS import Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe ( unsafeExtendPerasStakeDistrWithPublicKeysFromEnv ) import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 import Ouroboros.Consensus.Peras.Params (PerasParams (..)) -import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 import Ouroboros.Consensus.Protocol.Praos ( PraosState (..) , Ticked (..) ) import Ouroboros.Consensus.Protocol.Praos.Views (LedgerView (..)) --------------------------------------------------------------------------------- --- This is a mocked up instance - -data RealBlock - -type instance HeaderHash RealBlock = ShortByteString -instance StandardHash RealBlock - -instance BlockSupportsPeras RealBlock where - type PerasVote RealBlock = V1.PerasVote RealBlock - type PerasCert RealBlock = V1.PerasCert RealBlock - type PerasError RealBlock = V1.PerasError RealBlock - type PerasCrypto RealBlock = BLS.PerasBLSCrypto - type PerasVotingCommitteeScheme RealBlock = WFALS - - -- TODO: extract actual Peras certificates from blocks - getPerasCertInBlock _ = Nothing - -instance PraosStateSupportsPerasVoting RealBlock where - praosStatePerasVotingCommitteeInput _ perasParams tickedPraosState = do - let epochNonce = - praosStateEpochNonce - . tickedPraosStateChainDepState - $ tickedPraosState - -- TODO: replace the following hack with proper on-chain key registration. - stakeDistrWithPublicKeys <- - bimap V1.PerasTemporaryPublicKeyHackError id - . unsafeExtendPerasStakeDistrWithPublicKeysFromEnv - . lvPoolDistr - . tickedPraosStateLedgerView - $ tickedPraosState - extWFAStakeDistr <- - bimap V1.PerasVotingWFAError id $ - mkExtWFAStakeDistr - (wFATiebreakerWithEpochNonce epochNonce) - stakeDistrWithPublicKeys - pure $ - WFALSVotingCommitteeInput - epochNonce - (perasTargetCommitteeSize perasParams) - extWFAStakeDistr - --------------------------------------------------------------------------------- - class ( BlockSupportsPeras blk , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) -- TODO remove this constraint when it becomes a superclass constraint of 'BlockSupportsPeras' @@ -119,3 +77,40 @@ class praosStatePerasVotingCommitteeInput p perasParams tickedPraosState bimap injectVotingCommitteeError id $ Committee.mkVotingCommittee committeeInput + +praosStatePerasVotingCommitteeInputV1 :: + PublicKey crypto ~ BLS.PerasPublicKey => + proxy blk -> + PerasParams blk -> + Ticked PraosState -> + Either (V1.PerasError blk) (VotingCommitteeInput crypto WFALS) +praosStatePerasVotingCommitteeInputV1 _ perasParams tickedPraosState = do + let epochNonce = + praosStateEpochNonce + . tickedPraosStateChainDepState + $ tickedPraosState + -- TODO: replace the following hack with proper on-chain key registration. + stakeDistrWithPublicKeys <- + bimap V1.PerasTemporaryPublicKeyHackError id + . unsafeExtendPerasStakeDistrWithPublicKeysFromEnv + . lvPoolDistr + . tickedPraosStateLedgerView + $ tickedPraosState + extWFAStakeDistr <- + bimap V1.PerasVotingWFAError id $ + mkExtWFAStakeDistr + (wFATiebreakerWithEpochNonce epochNonce) + stakeDistrWithPublicKeys + pure $ + WFALSVotingCommitteeInput + epochNonce + (perasTargetCommitteeSize perasParams) + extWFAStakeDistr + +instance + ( StandardHash (HardForkBlock xs) + , CanHardFork xs + ) => + PraosStateSupportsPerasVoting (HardForkBlock xs) + where + praosStatePerasVotingCommitteeInput = praosStatePerasVotingCommitteeInputV1 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs index 966cec0f81..f2ac2bef0a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/RealPoint.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -169,17 +170,17 @@ decodeBytes32RealPoint = do fromBytes32RealPoint :: forall blk. - Coercible (HeaderHash blk) ShortByteString => + ConvertRawHash blk => Bytes32RealPoint -> RealPoint blk fromBytes32RealPoint (Bytes32RealPoint s h) = - RealPoint s (coerce h) + RealPoint s (fromShortRawHash (Proxy @blk) h) toBytes32RealPoint :: forall blk. - Coercible (HeaderHash blk) ShortByteString => + ConvertRawHash blk => RealPoint blk -> Bytes32RealPoint toBytes32RealPoint (RealPoint s h) = - assert (ByteString.length (coerce h) == 32) $ - Bytes32RealPoint s (coerce h) + assert (ByteString.length (toShortRawHash (Proxy @blk) h) == 32) $ + Bytes32RealPoint s (toShortRawHash (Proxy @blk) h) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 789edd8a07..97d3eb3c90 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -13,8 +13,8 @@ {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} module Ouroboros.Consensus.Block.SupportsPeras ( PerasVotingCommittee diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index 625051fb16..97dec58470 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -44,12 +44,14 @@ import Data.SOP.Constraint import Data.SOP.Functors import Data.SOP.Strict import Data.Typeable +import Data.Word (Word32) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) ) +import Ouroboros.Consensus.Committee.WFALS (WFALS) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.AcrossEras @@ -60,14 +62,10 @@ import Ouroboros.Consensus.HardFork.Combinator.State.Types import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) -import Ouroboros.Consensus.Peras.Cert.Mock - ( MockPerasCert (..) - ) -import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCommittee, MockPerasCrypto) -import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) -import Ouroboros.Consensus.Peras.Vote.Mock - ( MockPerasVote (..) - ) +import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS +import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (ShowProxy) @@ -274,26 +272,34 @@ instance CanHardFork xs => LedgerSupportsPeras (HardForkBlock xs) where BlockSupportsPeras -------------------------------------------------------------------------------} --- NOTE: this is a mocked up implementation without crypto! - --- TODO: when replacing this with a real votes and certificates, we need to make --- sure that their binary representation would be compatible with the one the --- HFC would produce if it were in charge of dispatching them. Concretely, this --- means adding an envelope around the actual votes and certificates indicating --- which era they belong to. This is to allow for the possibility of having the --- HFC dispatch different types of votes and certificates in the future. - +-- TODO: we need to change the binary representation of votes and certs to carry +-- era-specific/versionning information, to allow future evolutions instance ( StandardHash (HardForkBlock xs) , CanHardFork xs ) => BlockSupportsPeras (HardForkBlock xs) where - type PerasCrypto (HardForkBlock xs) = MockPerasCrypto (HardForkBlock xs) - type PerasVotingCommitteeScheme (HardForkBlock xs) = (MockPerasCommittee (HardForkBlock xs)) - type PerasVote (HardForkBlock xs) = MockPerasVote (HardForkBlock xs) - type PerasCert (HardForkBlock xs) = MockPerasCert (HardForkBlock xs) - type PerasError (HardForkBlock xs) = MockPerasError (HardForkBlock xs) + type PerasVote (HardForkBlock xs) = V1.PerasVote (HardForkBlock xs) + type PerasCert (HardForkBlock xs) = V1.PerasCert (HardForkBlock xs) + type PerasError (HardForkBlock xs) = V1.PerasError (HardForkBlock xs) + type PerasCrypto (HardForkBlock xs) = BLS.PerasBLSCrypto + type PerasVotingCommitteeScheme (HardForkBlock xs) = WFALS -- TODO: extract actual Peras certificates from blocks getPerasCertInBlock _ = Nothing + +{------------------------------------------------------------------------------- + ConvertRawHash +-------------------------------------------------------------------------------} + +instance CanHardFork xs => ConvertRawHash (HardForkBlock xs) where + toShortRawHash _ = getOneEraHash + fromShortRawHash _ = OneEraHash + hashSize _ = getSameValue hashSizes + where + hashSizes :: NP (K Word32) xs + hashSizes = hcpure proxySingle hashSizeOne + + hashSizeOne :: forall blk. SingleEraBlock blk => K Word32 blk + hashSizeOne = K $ hashSize (Proxy @blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Block.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Block.hs index 7c0c9c4807..7554db3cd3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Block.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Block.hs @@ -35,7 +35,6 @@ import Data.SOP.Index import qualified Data.SOP.Match as Match import Data.SOP.Strict import Data.Typeable (Typeable) -import Data.Word import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -168,21 +167,6 @@ instance CanHardFork xs => HasNestedContent Header (HardForkBlock xs) where go (NestedCtxt (NCZ ctxt)) x = Z (nest (DepPair (NestedCtxt ctxt) x)) go (NestedCtxt (NCS ctxt)) x = S (go (NestedCtxt ctxt) x) -{------------------------------------------------------------------------------- - ConvertRawHash --------------------------------------------------------------------------------} - -instance CanHardFork xs => ConvertRawHash (HardForkBlock xs) where - toShortRawHash _ = getOneEraHash - fromShortRawHash _ = OneEraHash - hashSize _ = getSameValue hashSizes - where - hashSizes :: NP (K Word32) xs - hashSizes = hcpure proxySingle hashSizeOne - - hashSizeOne :: forall blk. SingleEraBlock blk => K Word32 blk - hashSizeOne = K $ hashSize (Proxy @blk) - {------------------------------------------------------------------------------- HasAnnTip -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs index 763c41360c..2dbb9aea63 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Cert/V1.hs @@ -9,6 +9,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -30,21 +31,20 @@ import Cardano.Binary , decodeListLenOf , encodeListLen ) +import Codec.Serialise (Serialise (..)) import Control.Monad (when) import Control.Monad.Error.Class (MonadError (..)) -import Data.ByteString.Short (ShortByteString) -import Data.Coerce (Coercible) import Data.Containers.NonEmpty (HasNonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.NonEmpty as NEMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, isJust) -import Data.Typeable (Typeable) +import Data.Typeable (Proxy (..), Typeable) import Data.Word (Word16) import GHC.Generics (Generic) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) -import Ouroboros.Consensus.Block.Abstract (HeaderHash) +import Ouroboros.Consensus.Block.Abstract (ConvertRawHash) import Ouroboros.Consensus.Block.SupportsPeras ( BoostedBlock , IsPerasCert (..) @@ -66,12 +66,14 @@ import Ouroboros.Consensus.Committee.EveryoneVotes ) import Ouroboros.Consensus.Committee.WFA (SeatIndex (..)) import Ouroboros.Consensus.Committee.WFALS (Cert (..), WFALS) +import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..)) import Ouroboros.Consensus.Peras.Crypto.BLS ( PerasBLSCrypto ) import Ouroboros.Consensus.Peras.Vote.V1 (PerasVoteEligibilityProof (..)) import Ouroboros.Consensus.Util.Bitmap (Bitmap) import qualified Ouroboros.Consensus.Util.Bitmap as Bitmap +import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) -- | Concrete Peras certificates using BLS signatures -- @@ -94,7 +96,7 @@ data PerasCert tag deriving anyclass NoThunks instance - Coercible (HeaderHash blk) ShortByteString => + ConvertRawHash blk => IsPerasCert (PerasCert blk) blk where getPerasCertRound = @@ -126,6 +128,18 @@ instance Typeable tag => ToCBOR (PerasCert tag) where <> toCBOR (pcVoters cert) <> toCBOR (pcSignature cert) +instance Typeable tag => SerialiseNodeToNode blk (PerasCert tag) where + encodeNodeToNode _ccfg _version = toCBOR + + decodeNodeToNode _ccfg _version = fromCBOR + +instance Typeable tag => Serialise (PerasCert tag) where + encode = toCBOR + decode = fromCBOR + +instance ShowProxy tag => ShowProxy (PerasCert tag) where + showProxy _ = "PerasCert " <> showProxy (Proxy @tag) + -- | Voters contained in a certificate with their appropriate eligibility proof newtype PerasCertVoters = PerasCertVoters diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs index 6d58d3b529..338f0e12f9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Types.hs @@ -38,8 +38,7 @@ import Cardano.Binary ) import Codec.Serialise.Class (Serialise (..)) import Control.DeepSeq (NFData) -import Data.ByteString.Short (ShortByteString) -import Data.Coerce (Coercible, coerce) +import Data.Coerce (coerce) import Data.Containers.NonEmpty (HasNonEmpty (..)) import Data.Kind (Type) import Data.Map.Strict (Map) @@ -48,7 +47,7 @@ import Data.Proxy (Proxy (..)) import Data.Word (Word16, Word64) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) -import Ouroboros.Consensus.Block.Abstract (HeaderHash, Point, WithOrigin) +import Ouroboros.Consensus.Block.Abstract (ConvertRawHash, Point, WithOrigin) import Ouroboros.Consensus.Block.RealPoint ( Bytes32RealPoint , decodeBytes32RealPoint @@ -124,7 +123,7 @@ instance ToCBOR PerasBoostedBlock where toCBOR = encodeWithOrigin encodeBytes32RealPoint . unPerasBoostedBlock instance - Coercible (HeaderHash blk) ShortByteString => + ConvertRawHash blk => BoostedBlockCompatibleWithPoint PerasBoostedBlock blk where boostedBlockToPoint = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs index 1b1cbf751e..3c8749e6e8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/V1.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -25,13 +26,12 @@ import Cardano.Binary , decodeListLenOf , encodeListLen ) -import Data.ByteString.Short (ShortByteString) -import Data.Coerce (Coercible) +import Codec.Serialise (Serialise (..)) import Data.Typeable (Typeable) import Data.Word (Word8) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) -import Ouroboros.Consensus.Block.Abstract (HeaderHash) +import Ouroboros.Consensus.Block.Abstract (ConvertRawHash) import Ouroboros.Consensus.Block.SupportsPeras ( BoostedBlock , IsPerasVote (..) @@ -49,10 +49,12 @@ import Ouroboros.Consensus.Committee.EveryoneVotes , Vote (..) ) import Ouroboros.Consensus.Committee.WFALS (Vote (..), WFALS) +import Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToNode (..)) import Ouroboros.Consensus.Peras.Crypto.BLS ( PerasBLSCrypto , VRFOutput ) +import Ouroboros.Network.Util.ShowProxy -- | Concrete Peras votes using BLS signatures -- @@ -78,7 +80,7 @@ data PerasVote tag type instance BoostedBlock (PerasVote tag) = PerasBoostedBlock instance - Coercible (HeaderHash blk) ShortByteString => + ConvertRawHash blk => IsPerasVote (PerasVote blk) blk where getPerasVoteSeatIndex = pvSeatIndex @@ -142,6 +144,18 @@ instance ToCBOR PerasVoteEligibilityProof where <> toCBOR (1 :: Word8) <> toCBOR vrfOutput +instance Typeable tag => SerialiseNodeToNode blk (PerasVote tag) where + encodeNodeToNode _ccfg _version = toCBOR + + decodeNodeToNode _ccfg _version = fromCBOR + +instance Typeable tag => Serialise (PerasVote tag) where + encode = toCBOR + decode = fromCBOR + +instance ShowProxy tag => ShowProxy (PerasVote tag) where + showProxy _ = "PerasVote " <> showProxy (Proxy @tag) + -- * Compatibility with voting committee implementations -- 'PerasVote's are compatible with 'WFALS' as long as we make sure to avoid diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs index bb4fc52872..3047a295a7 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs @@ -22,7 +22,7 @@ import Data.Containers.ListUtils (nubOrdOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Word (Word64) -import Ouroboros.Consensus.Block.SupportsPeras (PerasRoundNo (..), PerasParams, mkPerasParams) +import Ouroboros.Consensus.Block.SupportsPeras (PerasParams, PerasRoundNo (..), mkPerasParams) import Ouroboros.Consensus.BlockchainTime (RelativeTime (..), SystemTime (..), WithArrivalTime (..)) import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId) import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/V1.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/V1.hs index cb5a05aea6..8861fa2f18 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/V1.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/V1.hs @@ -26,6 +26,7 @@ import Control.Monad (forM) import qualified Data.ByteString as ByteString import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as ShortByteString +import Data.Coerce (coerce) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.NonEmpty as NEMap import Data.Maybe (catMaybes, fromMaybe) @@ -35,7 +36,7 @@ import Data.Traversable (mapAccumM) import Data.Word (Word8) import GHC.Word (Word16) import Ouroboros.Consensus.Block (HeaderHash) -import Ouroboros.Consensus.Block.Abstract (WithOrigin (..)) +import Ouroboros.Consensus.Block.Abstract (ConvertRawHash (..), WithOrigin (..)) import Ouroboros.Consensus.Block.RealPoint (RealPoint (..), toBytes32RealPoint) import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 @@ -49,7 +50,6 @@ import Ouroboros.Consensus.Peras.Types , PerasSeatIndex (..) ) import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 -import Test.Util.Peras.Internal (genRoundNo, genSeatIndex, mkBucket) import Test.QuickCheck ( Arbitrary (..) , Gen @@ -60,6 +60,7 @@ import Test.QuickCheck , tabulate , vectorOf ) +import Test.Util.Peras.Internal (genRoundNo, genSeatIndex, mkBucket) -- * Predicates @@ -87,6 +88,10 @@ perasCertContainsOnlyPersistentVotes cert = data BlockWith32BytesHeaderHash type instance HeaderHash BlockWith32BytesHeaderHash = ShortByteString +instance ConvertRawHash (BlockWith32BytesHeaderHash) where + toShortRawHash _ = coerce + fromShortRawHash _ = coerce + hashSize _ = 32 genBoostedBlock :: Gen PerasBoostedBlock genBoostedBlock = PerasBoostedBlock <$> genWithOrigin genBytes32RealPoint diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/Class.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/Class.hs index 6c88ae91e8..6bf4c0f771 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/Class.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/Class.hs @@ -40,8 +40,8 @@ import Test.QuickCheck ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (Testable (..), testProperty) -import Test.Util.TestEnv (adjustQuickCheckTests) import Test.Util.Committee (mkBucket) +import Test.Util.TestEnv (adjustQuickCheckTests) tests :: TestTree tests = diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/EveryoneVotes/Tests.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/EveryoneVotes/Tests.hs index 19e572517f..8e7d05be9a 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/EveryoneVotes/Tests.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/EveryoneVotes/Tests.hs @@ -54,7 +54,6 @@ import Test.QuickCheck ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Test.Util.TestEnv (adjustQuickCheckTests) import Test.Util.Committee ( eqWithShowCmp , genPools @@ -65,6 +64,7 @@ import Test.Util.Committee , tabulatePoolStake , unfairWFATiebreaker ) +import Test.Util.TestEnv (adjustQuickCheckTests) tests :: TestTree tests = diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs index 8cfd5050a3..8b5c53fed3 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs @@ -79,8 +79,8 @@ import Test.QuickCheck ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Test.Util.TestEnv (adjustQuickCheckTests) import Test.Util.Committee (genEpochNonce) +import Test.Util.TestEnv (adjustQuickCheckTests) -- * Test crypto based on BLS signatures diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Tests.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Tests.hs index bac3d3ae2d..ba3aa623e8 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Tests.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/WFALS/Tests.hs @@ -65,7 +65,6 @@ import Test.QuickCheck ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Test.Util.TestEnv (adjustQuickCheckTests) import Test.Util.Committee ( eqWithShowCmp , genEpochNonce @@ -76,6 +75,7 @@ import Test.Util.Committee , tabulatePoolStake , unfairWFATiebreaker ) +import Test.Util.TestEnv (adjustQuickCheckTests) tests :: TestTree tests = diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index 1b89a5d9a9..4a5f04190b 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -41,6 +41,9 @@ import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke , genProtocolConstants , prop_smoke_object_diffusion ) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) import Test.Util.Peras ( genListWithUniqueIds , genMockPerasEpochContext @@ -48,9 +51,6 @@ import Test.Util.Peras , genWithArrivalTime , mockSystemTime ) -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.QuickCheck (testProperty) import Test.Util.TestBlock tests :: TestTree @@ -83,8 +83,8 @@ prop_smoke = forAll genProtocolConstants $ \protocolConstants -> forAll genMockPerasEpochContext $ \epochContext -> forAll - (genListWithUniqueIds getPerasCertRound (genWithArrivalTime (genMockValidatedPerasCert epochContext))) $ - \(ListWithUniqueIds watValidatedCerts) -> + (genListWithUniqueIds getPerasCertRound (genWithArrivalTime (genMockValidatedPerasCert epochContext))) + $ \(ListWithUniqueIds watValidatedCerts) -> let mkPoolInterfaces :: forall m. diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs index f1920cb5d8..7a103099c5 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Serialisation.hs @@ -11,13 +11,6 @@ import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeFull, serialize) import qualified Data.ByteString.Lazy as LazyByteString import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 -import Test.Util.Peras - ( genPerasCert - , genPerasVote - , mkBucket - , tabulatePerasCert - , tabulatePerasVote - ) import Test.QuickCheck ( Gen , Property @@ -28,6 +21,13 @@ import Test.QuickCheck ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) +import Test.Util.Peras + ( genPerasCert + , genPerasVote + , mkBucket + , tabulatePerasCert + , tabulatePerasVote + ) import Test.Util.TestEnv (adjustQuickCheckTests) tests :: TestTree diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs index 61b600e15a..3cbf41ae8f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs @@ -78,13 +78,13 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.ToExpr () +import Test.Util.Peras.Mock (genMockPerasVoterIndices) import Test.Util.QuickCheck import Test.Util.SOP import Test.Util.ToExpr () import Test.Util.Tracer (recordingTracerIORef) import Text.Show.Pretty (ppShow) import Prelude hiding (elem) -import Test.Util.Peras.Mock (genMockPerasVoterIndices) type Block = TestBlock From a219e48a9663482f05aef129d26cbe140232a7f9 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 1 Jun 2026 16:41:06 +0200 Subject: [PATCH 48/62] Further refine PerasEpochContext access/plumbing --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 8 -- .../Consensus/Protocol/Praos/Peras.hs | 2 + ouroboros-consensus.cabal | 1 - .../Consensus/Committee/AcrossEpochs.hs | 74 ------------------- .../Ouroboros/Consensus/Ledger/Extended.hs | 17 +++++ .../ObjectDiffusion/ObjectPool/PerasCert.hs | 40 +++++----- .../ObjectDiffusion/ObjectPool/PerasVote.hs | 39 +++++----- .../Ouroboros/Consensus/Peras/Context.hs | 18 ++--- .../Consensus/Storage/ChainDB/API.hs | 12 +++ .../Consensus/Storage/ChainDB/Impl.hs | 12 ++- .../Consensus/Storage/ChainDB/Impl/Args.hs | 6 +- .../Test/Util/ChainDB.hs | 4 +- 12 files changed, 89 insertions(+), 144 deletions(-) delete mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/AcrossEpochs.hs diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 2010e9f579..49ad07e2ed 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -383,10 +383,6 @@ mkHandlers ( makePerasCertPoolWriterFromChainDB systemTime getChainDB - -- [TODO EPOCH CONTEXT PLUMBING]: when actual plumbing for Peras is ready, we will have to - -- extract the 'PerasEpochContextResolverHandle' from the 'ExtLedgerState' to pass - -- it here - undefined ) version controlMessageSTM @@ -406,10 +402,6 @@ mkHandlers ( makePerasVotePoolWriterFromChainDB systemTime getChainDB - -- [TODO EPOCH CONTEXT PLUMBING]: when actual plumbing for Peras is ready, we will have to - -- extract the 'PerasEpochContextResolverHandle' from the 'ExtLedgerState' to pass - -- it here - undefined ) version controlMessageSTM diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs index 292ebafbb1..384260e9eb 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -7,6 +7,8 @@ {-# LANGUAGE UndecidableInstances #-} -- | Voting interface for Peras derived from the Praos ledger view. +-- +-- [TODO EPOCH CONTEXT PLUMBING] module Ouroboros.Consensus.Protocol.Praos.Peras ( PraosStateSupportsPerasVoting (..) , praosStatePerasVotingCommitteeInputV1 diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index a0fe7888b0..4f78ae42b7 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -117,7 +117,6 @@ library Ouroboros.Consensus.BlockchainTime.WallClock.Simple Ouroboros.Consensus.BlockchainTime.WallClock.Types Ouroboros.Consensus.BlockchainTime.WallClock.Util - Ouroboros.Consensus.Committee.AcrossEpochs Ouroboros.Consensus.Committee.Class Ouroboros.Consensus.Committee.Crypto Ouroboros.Consensus.Committee.Crypto.BLS diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/AcrossEpochs.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/AcrossEpochs.hs deleted file mode 100644 index b969f5e69e..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/AcrossEpochs.hs +++ /dev/null @@ -1,74 +0,0 @@ --- | This module extends a given voting committee to work across epochs. --- --- This is needed to support the case of validating an old vote or certificate --- from a previous epoch arriving too late. In the general case, this means we --- would need to store an arbitrary number of past voting committee selections. --- However, since: --- 1. the length of an epoch is much larger than the immutability window, and --- 2. we don't care about validating votes older than the immutability window, --- it follows that we only need to store the voting committee selection for --- the current and previous epochs. --- NOTE: this rationale might need to be revisited if we ever want to support --- validating votes and certificates older than the immutability window, e.g., --- for historical queries. -module Ouroboros.Consensus.Committee.AcrossEpochs - ( InterEpochVotingCommittee (..) - , mkInterEpochVotingCommittee - , newEpoch - , getVotingCommitteeForElection - ) where - -import Data.Maybe.Strict (StrictMaybe (..)) -import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) -import Ouroboros.Consensus.Committee.Crypto (ElectionId) - -data InterEpochVotingCommittee crypto committee - = InterEpochVotingCommittee - { currEpochVotingCommittee :: !(VotingCommittee crypto committee) - , prevEpochVotingCommittee :: !(StrictMaybe (VotingCommittee crypto committee)) - } - --- | Construct an inter-epoch committee selection for the first epoch -mkInterEpochVotingCommittee :: - CryptoSupportsVotingCommittee crypto committee => - VotingCommitteeInput crypto committee -> - Either - (VotingCommitteeError crypto committee) - (InterEpochVotingCommittee crypto committee) -mkInterEpochVotingCommittee votingCommitteeInput = do - votingCommittee <- - mkVotingCommittee votingCommitteeInput - pure $ - InterEpochVotingCommittee - { currEpochVotingCommittee = - votingCommittee - , prevEpochVotingCommittee = - SNothing - } - --- | Update an inter-epoch committee selection at the beginning of a new epoch -newEpoch :: - CryptoSupportsVotingCommittee crypto committee => - VotingCommitteeInput crypto committee -> - InterEpochVotingCommittee crypto committee -> - Either - (VotingCommitteeError crypto committee) - (InterEpochVotingCommittee crypto committee) -newEpoch newEpochVotingCommitteeInput interEpochVotingCommittee = do - newEpochVotingCommittee <- - mkVotingCommittee newEpochVotingCommitteeInput - pure $ - InterEpochVotingCommittee - { currEpochVotingCommittee = - newEpochVotingCommittee - , prevEpochVotingCommittee = - SJust (currEpochVotingCommittee interEpochVotingCommittee) - } - --- | Get the voting committee corresponding to an election, if any -getVotingCommitteeForElection :: - ElectionId crypto -> - InterEpochVotingCommittee crypto committee -> - Maybe (VotingCommittee crypto committee) -getVotingCommitteeForElection _electionId _interEpochVotingCommittee = do - error "TODO: implement getVotingCommitteeForElection" diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs index 0f8b55290d..1c39ed9c4b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -26,6 +26,7 @@ module Ouroboros.Consensus.Ledger.Extended , decodeExtLedgerState , encodeDiskExtLedgerState , encodeExtLedgerState + , getPerasEpochContextResolverHandle -- * Type family instances , LedgerTables (..) @@ -47,8 +48,13 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Context + ( PerasEpochContextResolver + , PerasEpochContextResolverHandle (..) + ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.Serialisation +import Ouroboros.Consensus.Util.IOLike (MonadSTM (STM)) import Ouroboros.Consensus.Util.IndexedMemPack {------------------------------------------------------------------------------- @@ -70,9 +76,19 @@ deriving instance LedgerSupportsProtocol blk => Show (ExtValidationError blk) data ExtLedgerState blk mk = ExtLedgerState { ledgerState :: !(LedgerState blk mk) , headerState :: !(HeaderState blk) + -- , perasEpochContextResolver :: !(PerasEpochContextResolver blk) [TODO EPOCH CONTEXT PLUMBING] } deriving Generic +-- In the future we will have a ledgerPerasEpochContextResolver field in ExtLedgerState +-- [TODO EPOCH CONTEXT PLUMBING] +ledgerPerasEpochContextResolver :: ExtLedgerState blk mk -> PerasEpochContextResolver blk +ledgerPerasEpochContextResolver = undefined + +getPerasEpochContextResolverHandle :: + MonadSTM m => STM m (ExtLedgerState blk mk) -> PerasEpochContextResolverHandle m blk +getPerasEpochContextResolverHandle getLedgerStateSTM = PerasEpochContextResolverHandle $ ledgerPerasEpochContextResolver <$> getLedgerStateSTM + deriving instance (EqMK mk, LedgerSupportsProtocol blk) => Eq (ExtLedgerState blk mk) @@ -137,6 +153,7 @@ data instance Ticked ExtLedgerState blk mk = TickedExtLedgerState { tickedLedgerState :: Ticked LedgerState blk mk , ledgerView :: LedgerView (BlockProtocol blk) , tickedHeaderState :: Ticked (HeaderState blk) + -- , tickedPerasEpochContextResolver :: PerasEpochContextResolver blk [TODO EPOCH CONTEXT PLUMBING] } instance IsLedger LedgerState blk => GetTip (Ticked ExtLedgerState blk) where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index 0f3c63a391..44d78bd8ad 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -29,7 +29,7 @@ import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API , ObjectPoolWriter (..) ) import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle, verifyPerasCertInContext) -import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) +import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB, getPerasEpochContextResolverHandle) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.PerasCertDB.API ( PerasCertDB @@ -136,23 +136,23 @@ makePerasCertPoolWriterFromChainDB :: ) => SystemTime m -> ChainDB m blk -> - PerasEpochContextResolverHandle m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m -makePerasCertPoolWriterFromChainDB systemTime chainDB resolverHandle = - ObjectPoolWriter - { opwObjectId = getPerasCertRound - , opwAddObjects = \certs -> do - now <- systemTimeCurrent systemTime - validatedCerts <- atomically $ do - alreadyInDb <- ChainDB.getPerasCertIds chainDB - let certsNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasCertRound) certs - traverse (verifyPerasCertInContext resolverHandle) certsNotAlreadyInDb - -- Some certs are invalid => reject the whole batch - -- We could combine the two 'traverse' operations into one in which case - -- any validated cert would be immediately added no matter what is the - -- validity of the other certs in the batch. - traverse_ (ChainDB.addPerasCertAsync chainDB . WithArrivalTime now) validatedCerts - , opwHasObject = do - certIds <- ChainDB.getPerasCertIds chainDB - pure $ \roundNo -> Set.member roundNo certIds - } +makePerasCertPoolWriterFromChainDB systemTime chainDB = + let resolverHandle = getPerasEpochContextResolverHandle chainDB + in ObjectPoolWriter + { opwObjectId = getPerasCertRound + , opwAddObjects = \certs -> do + now <- systemTimeCurrent systemTime + validatedCerts <- atomically $ do + alreadyInDb <- ChainDB.getPerasCertIds chainDB + let certsNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasCertRound) certs + traverse (verifyPerasCertInContext resolverHandle) certsNotAlreadyInDb + -- Some certs are invalid => reject the whole batch + -- We could combine the two 'traverse' operations into one in which case + -- any validated cert would be immediately added no matter what is the + -- validity of the other certs in the batch. + traverse_ (ChainDB.addPerasCertAsync chainDB . WithArrivalTime now) validatedCerts + , opwHasObject = do + certIds <- ChainDB.getPerasCertIds chainDB + pure $ \roundNo -> Set.member roundNo certIds + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs index 55153be652..4e1425e74b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs @@ -30,6 +30,7 @@ import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API , ObjectPoolWriter (..) ) import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle, verifyPerasVoteInContext) +import Ouroboros.Consensus.Storage.ChainDB (getPerasEpochContextResolverHandle) import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.PerasVoteDB.API @@ -139,23 +140,23 @@ makePerasVotePoolWriterFromChainDB :: ) => SystemTime m -> ChainDB m blk -> - PerasEpochContextResolverHandle m blk -> ObjectPoolWriter (PerasVoteId blk) (PerasVote blk) m -makePerasVotePoolWriterFromChainDB systemTime chainDB resolverHandle = - ObjectPoolWriter - { opwObjectId = getPerasVoteId - , opwAddObjects = \votes -> do - now <- systemTimeCurrent systemTime - validatedVotes <- atomically $ do - alreadyInDb <- ChainDB.getPerasVoteIds chainDB - let votesNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasVoteId) votes - traverse (verifyPerasVoteInContext resolverHandle) votesNotAlreadyInDb - -- Some votes are invalid => reject the whole batch - -- We could combine the two 'traverse' operations into one in which case - -- any validated vote would be immediately added no matter what is the - -- validity of the other votes in the batch. - traverse_ (ChainDB.addPerasVoteWithAsyncCertHandling chainDB . WithArrivalTime now) validatedVotes - , opwHasObject = do - voteIds <- ChainDB.getPerasVoteIds chainDB - pure $ \voteId -> Set.member voteId voteIds - } +makePerasVotePoolWriterFromChainDB systemTime chainDB = + let resolverHandle = getPerasEpochContextResolverHandle chainDB + in ObjectPoolWriter + { opwObjectId = getPerasVoteId + , opwAddObjects = \votes -> do + now <- systemTimeCurrent systemTime + validatedVotes <- atomically $ do + alreadyInDb <- ChainDB.getPerasVoteIds chainDB + let votesNotAlreadyInDb = filter ((`Set.notMember` alreadyInDb) . getPerasVoteId) votes + traverse (verifyPerasVoteInContext resolverHandle) votesNotAlreadyInDb + -- Some votes are invalid => reject the whole batch + -- We could combine the two 'traverse' operations into one in which case + -- any validated vote would be immediately added no matter what is the + -- validity of the other votes in the batch. + traverse_ (ChainDB.addPerasVoteWithAsyncCertHandling chainDB . WithArrivalTime now) validatedVotes + , opwHasObject = do + voteIds <- ChainDB.getPerasVoteIds chainDB + pure $ \voteId -> Set.member voteId voteIds + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs index f44d145fb3..23feb0a636 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs @@ -6,12 +6,11 @@ module Ouroboros.Consensus.Peras.Context ( PerasEpochContextResolver , PerasEpochContextNotFoundForRound (..) - , PerasEpochContextResolverHandle + , PerasEpochContextResolverHandle (..) , verifyPerasVoteInContext , verifyPerasCertInContext , resolveRoundNoWithHandle , constPerasEpochContextResolverHandle - , extractPerasEpochContextResolverHandleFromExtLedgerState ) where @@ -28,13 +27,11 @@ import Ouroboros.Consensus.Block.SupportsPeras , ValidatedPerasVote , getPerasVoteRound ) -import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import Ouroboros.Consensus.Util.IOLike ( IOLike , MonadSTM , MonadThrow , NoThunks - , StrictTVar , newTVarIO , readTVar , throwSTM @@ -48,7 +45,7 @@ data PerasEpochContextNotFoundForRound = PerasEpochContextNotFoundForRound Peras deriving (Show, Eq, Generic, NoThunks, Exception) newtype PerasEpochContextResolverHandle m blk - = PerasEpochContextResolverHandle (StrictTVar m (PerasEpochContextResolver blk)) + = PerasEpochContextResolverHandle (STM m (PerasEpochContextResolver blk)) resolveRoundNoWithHandle :: MonadSTM m => @@ -56,7 +53,7 @@ resolveRoundNoWithHandle :: PerasRoundNo -> STM m (Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)) resolveRoundNoWithHandle (PerasEpochContextResolverHandle resolverHandle) roundNo = do - resolver <- readTVar resolverHandle + resolver <- resolverHandle pure $ resolver roundNo verifyPerasVoteInContext :: @@ -95,10 +92,7 @@ verifyPerasCertInContext handle cert = do constPerasEpochContextResolverHandle :: IOLike m => PerasEpochContext blk -> m (PerasEpochContextResolverHandle m blk) -constPerasEpochContextResolverHandle epochContext = +constPerasEpochContextResolverHandle epochContext = do let resolver = \_ -> Right epochContext - in PerasEpochContextResolverHandle <$> newTVarIO resolver - -extractPerasEpochContextResolverHandleFromExtLedgerState :: - ExtLedgerState blk mk -> PerasEpochContextResolverHandle m blk -extractPerasEpochContextResolverHandleFromExtLedgerState = undefined -- TODO: implement as part of future effort + resolverVar <- newTVarIO resolver + pure $ PerasEpochContextResolverHandle (readTVar resolverVar) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index d40c802949..981b55d63d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -13,6 +13,7 @@ module Ouroboros.Consensus.Storage.ChainDB.API ChainDB (..) , getCurrentTip , getTipBlockNo + , getPerasEpochContextResolverHandle -- * Adding a block , AddBlockPromise (..) @@ -90,6 +91,11 @@ import Ouroboros.Consensus.HeaderStateHistory import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended + ( ExtLedgerState + , ExtValidationError + ) +import qualified Ouroboros.Consensus.Ledger.Extended as ExtLedger +import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment import Ouroboros.Consensus.Storage.Common @@ -492,6 +498,12 @@ getTipBlockNo :: ChainDB m blk -> STM m (WithOrigin BlockNo) getTipBlockNo = fmap Network.getTipBlockNo . getCurrentTip +getPerasEpochContextResolverHandle :: + MonadSTM m => + ChainDB m blk -> + PerasEpochContextResolverHandle m blk +getPerasEpochContextResolverHandle = ExtLedger.getPerasEpochContextResolverHandle . getCurrentLedger + {------------------------------------------------------------------------------- Adding a block -------------------------------------------------------------------------------} 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 0b04e7a088..269f0eeb50 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 @@ -57,7 +57,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HeaderValidation (mkHeaderWithTime) -import Ouroboros.Consensus.Ledger.Extended (ledgerState) +import Ouroboros.Consensus.Ledger.Extended (getPerasEpochContextResolverHandle, ledgerState) import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol @@ -195,7 +195,13 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do traceWith tracer $ TraceOpenEvent OpenedLgrDB perasCertDB <- PerasCertDB.createDB argsPerasCertDB - perasVoteDB <- PerasVoteDB.createDB argsPerasVoteDB + perasVoteDB <- + PerasVoteDB.createDB + PerasVoteDB.PerasVoteDbArgs + { PerasVoteDB.pvdbaTracer = PerasVoteDB.pvdbaTracer incompleteArgsPerasVoteDB + , PerasVoteDB.pvdbaPerasEpochContextResolverHandle = + getPerasEpochContextResolverHandle (LedgerDB.getVolatileTip lgrDB) + } varInvalid <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0)) @@ -351,7 +357,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do argsVolatileDb argsLgrDb argsPerasCertDB - argsPerasVoteDB + incompleteArgsPerasVoteDB cdbSpecificArgs = args -- The LedgerDB requires a criterion ('LedgerDB.GetVolatileSuffix') diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index 3cfbdd4832..1285889d52 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -26,7 +26,6 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol -import Ouroboros.Consensus.Peras.Context (extractPerasEpochContextResolverHandleFromExtLedgerState) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( GetLoEFragment @@ -58,7 +57,7 @@ data ChainDbArgs f m blk = ChainDbArgs , cdbVolDbArgs :: VolatileDB.VolatileDbArgs f m blk , cdbLgrDbArgs :: LedgerDB.LedgerDbArgs f m blk , cdbPerasCertDbArgs :: PerasCertDB.PerasCertDbArgs f m blk - , cdbPerasVoteDbArgs :: PerasVoteDB.PerasVoteDbArgs f m blk + , cdbPerasVoteDbArgs :: Incomplete PerasVoteDB.PerasVoteDbArgs m blk , cdbsArgs :: ChainDbSpecificArgs f m blk } @@ -230,8 +229,7 @@ completeChainDbArgs , cdbPerasVoteDbArgs = PerasVoteDB.PerasVoteDbArgs { PerasVoteDB.pvdbaTracer = PerasVoteDB.pvdbaTracer (cdbPerasVoteDbArgs defArgs) - , PerasVoteDB.pvdbaPerasEpochContextResolverHandle = - extractPerasEpochContextResolverHandleFromExtLedgerState initLedger + , PerasVoteDB.pvdbaPerasEpochContextResolverHandle = NoDefault } , cdbsArgs = (cdbsArgs defArgs) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs index cebb55a8c4..4ca2fa2bc7 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -21,7 +21,6 @@ import Ouroboros.Consensus.HardFork.History.EraParams (eraEpochSize) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import Ouroboros.Consensus.Ledger.SupportsProtocol -import Ouroboros.Consensus.Peras.Context (extractPerasEpochContextResolverHandleFromExtLedgerState) import Ouroboros.Consensus.Storage.ChainDB hiding ( TraceFollowerEvent (..) ) @@ -141,8 +140,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs{..} = , cdbPerasVoteDbArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer - , pvdbaPerasEpochContextResolverHandle = - extractPerasEpochContextResolverHandleFromExtLedgerState mcdbInitLedger + , pvdbaPerasEpochContextResolverHandle = NoDefault } , cdbsArgs = ChainDbSpecificArgs From 6c6d0a148c81871a6d681bc7f2ccda112d08961a Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 2 Jun 2026 15:10:06 +0200 Subject: [PATCH 49/62] WIP adding perasEpochContextResolver to ExtLedgerState --- .../Consensus/Byron/Ledger/Ledger.hs | 2 + .../Ouroboros/Consensus/Byron/Ledger/PBFT.hs | 1 + .../byron/Ouroboros/Consensus/Byron/Node.hs | 2 + .../Ouroboros/Consensus/Cardano/Node.hs | 4 +- .../Consensus/Shelley/Ledger/Block.hs | 2 + .../Consensus/Shelley/Node/TPraos.hs | 2 + .../Ouroboros/Consensus/ByronDual/Ledger.hs | 8 ++ .../Ouroboros/Consensus/ByronDual/Node.hs | 3 +- .../Consensus/ByronDual/Node/Peras.hs | 19 --- .../Consensus/ByronDual/Node/Serialisation.hs | 1 - .../Test/Consensus/Byron/Examples.hs | 2 + .../Cardano/Tools/DBAnalyser/Analysis.hs | 7 +- .../Test/Consensus/Shelley/Examples.hs | 4 + .../Test/Consensus/HardFork/Combinator.hs | 3 + ouroboros-consensus.cabal | 1 - .../bench/ChainSync-client-bench/Main.hs | 3 + .../Consensus/Block/SupportsPeras.hs | 62 ++++++++-- .../Consensus/Block/SupportsProtocol.hs | 5 + .../Consensus/Committee/Crypto/BLS.hs | 12 +- .../Consensus/Committee/EveryoneVotes.hs | 22 +++- .../Ouroboros/Consensus/Committee/Types.hs | 24 +++- .../Ouroboros/Consensus/Committee/WFA.hs | 42 +++++-- .../Ouroboros/Consensus/Committee/WFALS.hs | 23 +++- .../HardFork/Combinator/Embed/Binary.hs | 3 + .../HardFork/Combinator/Embed/Nary.hs | 11 ++ .../HardFork/Combinator/Embed/Unary.hs | 8 ++ .../HardFork/Combinator/Ledger/Query.hs | 9 +- .../Ouroboros/Consensus/HeaderStateHistory.hs | 2 +- .../Ouroboros/Consensus/Ledger/Dual.hs | 5 + .../Ouroboros/Consensus/Ledger/Extended.hs | 108 ++++++++++++------ .../Ouroboros/Consensus/Peras/Context.hs | 95 ++++++++++++--- .../Ouroboros/Consensus/Peras/Crypto/BLS.hs | 57 ++++++--- .../Consensus/Peras/Crypto/BLS/Unsafe.hs | 6 +- .../Ouroboros/Consensus/Peras/Crypto/Mock.hs | 62 +++++++--- .../Ouroboros/Consensus/Peras/Params.hs | 21 ++-- .../Consensus/Storage/LedgerDB/API.hs | 2 + .../Ouroboros/Consensus/Util/Orphans.hs | 11 ++ .../Test/Ouroboros/Storage/TestBlock.hs | 2 + .../Test/Util/Orphans/ToExpr.hs | 5 + .../Test/Util/Peras/Mock.hs | 12 +- .../Test/Util/TestBlock.hs | 6 +- .../Consensus/Mock/Ledger/Block/BFT.hs | 12 ++ .../Consensus/Mock/Ledger/Block/PBFT.hs | 1 + .../Consensus/Mock/Ledger/Block/Praos.hs | 1 + .../Consensus/Mock/Ledger/Block/PraosRule.hs | 1 + .../Ouroboros/Consensus/Mock/Node/BFT.hs | 2 + .../Ouroboros/Consensus/Mock/Node/PBFT.hs | 2 + .../Ouroboros/Consensus/Mock/Node/Praos.hs | 2 + .../Consensus/Mock/Node/PraosRule.hs | 2 + .../Ouroboros/Consensus/Tutorial/Simple.lhs | 5 +- .../Consensus/Tutorial/WithEpoch.lhs | 6 + .../Ouroboros/Storage/ChainDB/StateMachine.hs | 1 + .../Storage/PerasVoteDB/StateMachine.hs | 10 +- 53 files changed, 552 insertions(+), 172 deletions(-) delete mode 100644 ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Peras.hs diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index 7cca08c3f5..0e0ceb38ef 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -472,6 +472,8 @@ encodeByronExtLedgerState = encodeByronLedgerState encodeByronChainDepState encodeByronAnnTip + -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + undefined encodeByronHeaderState :: HeaderState ByronBlock -> Encoding encodeByronHeaderState = diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs index 203d39eaf4..c452c790c0 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/PBFT.hs @@ -23,6 +23,7 @@ import Ouroboros.Consensus.Byron.Crypto.DSIGN import Ouroboros.Consensus.Byron.Ledger.Block import Ouroboros.Consensus.Byron.Ledger.Config import Ouroboros.Consensus.Byron.Ledger.Serialisation () +import Ouroboros.Consensus.Byron.Node.Peras () import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.PBFT diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs index 782bd8fd4d..9f3bbb652a 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -215,6 +215,8 @@ protocolInfoByron -- balances. ledgerState = initByronLedgerState genesisConfig Nothing , headerState = genesisHeaderState S.empty + , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + perasEpochContextResolver = undefined } } where diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index a964daa928..c879cec2f2 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -935,6 +935,8 @@ protocolInfoCardano paramsCardano ExtLedgerState { headerState = initHeaderState , ledgerState = overShelleyBasedLedgerState initLedgerState + , -- [TODO EPOCH CONTEX PLUMBING] we need to fix this + perasEpochContextResolver = undefined } where overShelleyBasedLedgerState (HardForkLedgerState st) = @@ -942,7 +944,7 @@ protocolInfoCardano paramsCardano initHeaderState :: HeaderState (CardanoBlock c) initLedgerState :: LedgerState (CardanoBlock c) ValuesMK - ExtLedgerState initLedgerState initHeaderState = + ExtLedgerState initLedgerState initHeaderState _ = injectInitialExtLedgerState cfg $ initExtLedgerStateByron diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs index 13c73e14c8..3a6fe8fe40 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -57,6 +57,7 @@ import Cardano.Ledger.Hashes (HASH) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (Crypto) import qualified Cardano.Protocol.TPraos.BHeader as SL +import Codec.Serialise (Serialise) import qualified Data.ByteString.Lazy as Lazy import Data.Coerce (coerce) import Data.Typeable (Typeable) @@ -125,6 +126,7 @@ class , Crypto (ProtoCrypto proto) , -- Peras constraints BlockSupportsPeras (ShelleyBlock proto era) + , Serialise (PerasEpochContext (ShelleyBlock proto era)) , -- Backwards compatibility Plain.FromCBOR (LegacyPParams era) , Plain.ToCBOR (LegacyPParams era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs index 65fc57fa7a..c20b1f6937 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs @@ -295,4 +295,6 @@ protocolInfoTPraosShelleyBased ExtLedgerState { ledgerState = initLedgerState , headerState = genesisHeaderState initChainDepState + , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + perasEpochContextResolver = undefined } diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Ledger.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Ledger.hs index 730720a045..8c78d37f9c 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Ledger.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Ledger.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} @@ -258,3 +259,10 @@ forgeDualByronBlock cfg curBlockNo curSlotNo tickedLedger vtxs isLeader = (tickedDualLedgerStateBridge tickedLedger) (hashVerKey . deriveVerKeyDSIGN . pbftIsLeaderSignKey $ isLeader) ) + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: DualByron does not support Peras, so we can use the empty instance here. +instance BlockSupportsPeras DualByronBlock diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs index 183dce4f95..20891b3877 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs @@ -27,7 +27,6 @@ import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Node import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.ByronDual.Ledger -import Ouroboros.Consensus.ByronDual.Node.Peras () import Ouroboros.Consensus.ByronDual.Node.Serialisation () import Ouroboros.Consensus.ByronSpec.Ledger import qualified Ouroboros.Consensus.ByronSpec.Ledger.Genesis as Genesis @@ -127,6 +126,8 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss = , dualLedgerStateBridge = initBridge } , headerState = genesisHeaderState S.empty + , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + perasEpochContextResolver = undefined } } , return $ dualByronBlockForging . byronLeaderCredentials <$> credss diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Peras.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Peras.hs deleted file mode 100644 index 5cf7407010..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Peras.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Empty Peras support for DualByron. --- --- NOTE: this module exists solely because the orphan module --- 'Ouroboros.Consensus.ByronDual.Node.Serialisation' needs this instance, but --- defining it there would be too confusing. -module Ouroboros.Consensus.ByronDual.Node.Peras () where - -import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras) -import Ouroboros.Consensus.ByronDual.Ledger (DualByronBlock) - -{------------------------------------------------------------------------------- - BlockSupportsPeras --------------------------------------------------------------------------------} - --- NOTE: DualByron does not support Peras, so we can use the empty instance here. -instance BlockSupportsPeras DualByronBlock diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs index 787cf7e4ab..946ec235bb 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs @@ -16,7 +16,6 @@ import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Node.Serialisation () import Ouroboros.Consensus.Byron.Protocol import Ouroboros.Consensus.ByronDual.Ledger -import Ouroboros.Consensus.ByronDual.Node.Peras () import Ouroboros.Consensus.ByronSpec.Ledger import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Dual diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs index 9fd2804588..ffe6cc401f 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs @@ -223,6 +223,8 @@ exampleExtLedgerState = ExtLedgerState { ledgerState = exampleLedgerState , headerState = exampleHeaderState + , -- [TODO EPOCH CONTEXT PLUMBING] we need t ofix this + perasEpochContextResolver = undefined } exampleHeaderHash :: ByronHash diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs index 69a008d1f8..0339cead4c 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs @@ -706,7 +706,12 @@ benchmarkLedgerOps mOutfile ledgerAppMode AnalysisEnv{db, registry, startFrom, c F.writeDataPoint outFileHandle outFormat slotDataPoint - LedgerDB.push intLedgerDB $ ExtLedgerState (prependDiffs tkLdgrSt newLedger) newHeader + LedgerDB.push intLedgerDB $ + ExtLedgerState + (prependDiffs tkLdgrSt newLedger) + newHeader + -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + undefined where rp = blockRealPoint blk diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs index 6705b96832..a9fca86cec 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs @@ -228,6 +228,8 @@ fromShelleyLedgerExamples ExtLedgerState ledgerState (genesisHeaderState chainDepState) + -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + undefined ledgerConfig = exampleShelleyLedgerConfig leTranslationContext @@ -367,6 +369,8 @@ fromShelleyLedgerExamplesPraos ExtLedgerState ledgerState (genesisHeaderState chainDepState) + -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + undefined ledgerConfig = exampleShelleyLedgerConfig leTranslationContext diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index 2ffcd3ff8f..62371f4d6b 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -253,6 +253,9 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = genesisHeaderState $ initHardForkState (WrapChainDepState initChainDepState) + , perasEpochContextResolver = + -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + undefined } } diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 4f78ae42b7..453eecb795 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1462,7 +1462,6 @@ library unstable-byron-testlib exposed-modules: Ouroboros.Consensus.ByronDual.Ledger Ouroboros.Consensus.ByronDual.Node - Ouroboros.Consensus.ByronDual.Node.Peras Ouroboros.Consensus.ByronDual.Node.Serialisation Test.Consensus.Byron.Examples Test.Consensus.Byron.Generators diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index 70854581a8..3790d50566 100644 --- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs +++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs @@ -221,6 +221,9 @@ oracularLedgerDB p = { TB.lastAppliedPoint = p , TB.payloadDependentState = TB.EmptyPLDS } + , Extended.perasEpochContextResolver = + -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + undefined } -- | A convenient fact about 'TB.TestBlock' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 97d3eb3c90..90ae3f8dcc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -20,6 +20,7 @@ module Ouroboros.Consensus.Block.SupportsPeras ( PerasVotingCommittee , PerasVotingCommitteeError , PerasVotingCommitteeInput + , DefaultPerasEpochContext (..) , BlockSupportsPeras (..) , PerasVoteCompatibleWithVotingCommittee (..) , PerasCertCompatibleWithVotingCommittee (..) @@ -51,6 +52,7 @@ module Ouroboros.Consensus.Block.SupportsPeras , module Ouroboros.Consensus.Peras.Types ) where +import Codec.Serialise (Serialise) import Control.Exception (assert) import Control.Exception.Base (Exception) import Data.Bifunctor (bimap) @@ -104,6 +106,19 @@ type PerasVotingCommitteeInput blk = (PerasCrypto blk) (PerasVotingCommitteeScheme blk) +-- | Default epoch context for Peras +data DefaultPerasEpochContext blk + = DefaultPerasEpochContext + { dpecCommittee :: PerasVotingCommittee blk + , dpecParams :: PerasParams blk + } + +deriving instance Show (PerasVotingCommittee blk) => Show (DefaultPerasEpochContext blk) +deriving instance Eq (PerasVotingCommittee blk) => Eq (DefaultPerasEpochContext blk) +deriving instance NoThunks (PerasVotingCommittee blk) => NoThunks (DefaultPerasEpochContext blk) +deriving instance Serialise (PerasVotingCommittee blk) => Serialise (DefaultPerasEpochContext blk) +deriving instance Generic (DefaultPerasEpochContext blk) + -- * BlockSupportsPeras class -- TODO: Add CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) as a superclass constraint of 'BlockSupportsPeras' @@ -139,8 +154,20 @@ class , NoThunks (PerasError blk) , IsPerasError (PerasError blk) blk , Exception (PerasError blk) + , -- PerasVotingCommittee constraints + Typeable (PerasVotingCommittee blk) + , Show (PerasVotingCommittee blk) + , Eq (PerasVotingCommittee blk) + , NoThunks (PerasVotingCommittee blk) + , -- PerasEpochContext constraints + Typeable (PerasEpochContext blk) + , Show (PerasEpochContext blk) + , Eq (PerasEpochContext blk) + , NoThunks (PerasEpochContext blk) , -- Compatiblity with committee/crypto - CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) + Typeable (PerasCrypto blk) + , Typeable (PerasVotingCommitteeScheme blk) + , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) , ElectionId (PerasCrypto blk) ~ PerasRoundNo , VoteCandidate (PerasCrypto blk) ~ BoostedBlock (PerasVote blk) , VoteCandidate (PerasCrypto blk) ~ BoostedBlock (PerasCert blk) @@ -179,14 +206,14 @@ class type PerasVotingCommitteeScheme blk = VoidPerasVotingCommitteeScheme type PerasEpochContext blk = (context :: Type) | context -> blk - type PerasEpochContext blk = (PerasVotingCommittee blk, PerasParams blk) + type PerasEpochContext blk = DefaultPerasEpochContext blk pecPerasParams :: PerasEpochContext blk -> PerasParams blk default pecPerasParams :: - PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams blk) => + PerasEpochContext blk ~ DefaultPerasEpochContext blk => PerasEpochContext blk -> PerasParams blk - pecPerasParams (_committee, params) = params + pecPerasParams = dpecParams forgePerasVoteIfEligible :: PerasEpochContext blk -> @@ -196,14 +223,15 @@ class Point blk -> Either (PerasError blk) (Maybe (ValidatedPerasVote blk)) default forgePerasVoteIfEligible :: - PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams blk) => + PerasEpochContext blk ~ DefaultPerasEpochContext blk => PerasEpochContext blk -> PoolId -> PrivateKey (PerasCrypto blk) -> PerasRoundNo -> Point blk -> Either (PerasError blk) (Maybe (ValidatedPerasVote blk)) - forgePerasVoteIfEligible (committee, _params) ourId ourPrivateKey roundNo point = do + forgePerasVoteIfEligible context ourId ourPrivateKey roundNo point = do + let committee = dpecCommittee context mWitness <- bimap injectVotingCommitteeError id $ Committee.checkShouldVote committee ourId ourPrivateKey roundNo @@ -224,11 +252,12 @@ class PerasVote blk -> Either (PerasError blk) (ValidatedPerasVote blk) default verifyPerasVote :: - PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams blk) => + PerasEpochContext blk ~ DefaultPerasEpochContext blk => PerasEpochContext blk -> PerasVote blk -> Either (PerasError blk) (ValidatedPerasVote blk) - verifyPerasVote (committee, _params) vote = do + verifyPerasVote context vote = do + let committee = dpecCommittee context -- NOTE: checking that the voted point is not from the future w.r.t. the -- starting slot of the 'PerasRoundNo' will have to be done at the HFC level -- since here we don't have 'PerasRoundNo' -> 'SlotNo' resolution device. @@ -250,11 +279,12 @@ class PerasVoteCollectionWithQuorum blk -> Either (PerasError blk) (ValidatedPerasCert blk) default forgePerasCert :: - PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams blk) => + PerasEpochContext blk ~ DefaultPerasEpochContext blk => PerasEpochContext blk -> PerasVoteCollectionWithQuorum blk -> Either (PerasError blk) (ValidatedPerasCert blk) - forgePerasCert (_committee, params) voteCollection = do + forgePerasCert context voteCollection = do + let params = dpecParams context abstractVoteCollection <- bimap injectConversionError id $ toUniqueVotesWithSameTarget voteCollection @@ -275,11 +305,13 @@ class PerasCert blk -> Either (PerasError blk) (ValidatedPerasCert blk) default verifyPerasCert :: - PerasEpochContext blk ~ (PerasVotingCommittee blk, PerasParams blk) => + PerasEpochContext blk ~ DefaultPerasEpochContext blk => PerasEpochContext blk -> PerasCert blk -> Either (PerasError blk) (ValidatedPerasCert blk) - verifyPerasCert (committee, params) cert = do + verifyPerasCert context cert = do + let committee = dpecCommittee context + let params = dpecParams context -- NOTE: checking that the voted point is not from the future w.r.t. the -- starting slot of the 'PerasRoundNo' will have to be done at the HFC level -- since here we don't have 'PerasRoundNo' -> 'SlotNo' resolution device. @@ -432,6 +464,12 @@ instance CryptoSupportsVotingCommittee (VoidPerasCrypto blk) VoidPerasVotingComm voteTarget (Vote (VoidPerasVote void)) = absurd void compareVotesById (Vote (VoidPerasVote void)) _ = absurd void +deriving instance Show (VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme) +deriving instance Eq (VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme) +deriving instance NoThunks (VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme) +deriving instance Serialise (VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme) +deriving instance Generic (VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme) + instance PerasVoteCompatibleWithVotingCommittee (VoidPerasVote blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsProtocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsProtocol.hs index 5ff7d6f2fb..9595180939 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsProtocol.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsProtocol.hs @@ -6,6 +6,7 @@ module Ouroboros.Consensus.Block.SupportsProtocol (BlockSupportsProtocol (..), s import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras (..)) import Ouroboros.Consensus.Protocol.Abstract {------------------------------------------------------------------------------- @@ -21,6 +22,10 @@ class , NoThunks (BlockConfig blk) , NoThunks (CodecConfig blk) , NoThunks (StorageConfig blk) + , -- Peras context requirements + Show (PerasEpochContext blk) + , Eq (PerasEpochContext blk) + , NoThunks (PerasEpochContext blk) ) => BlockSupportsProtocol blk where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs index 6494443209..9f80bb39b8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs @@ -17,12 +17,12 @@ module Ouroboros.Consensus.Committee.Crypto.BLS ( -- * BLS crypto helpers to instantiate voting committees KeyRole (..) , KeyScope - , PrivateKey + , PrivateKey (privateKeyScope) , rawDeserialisePrivateKey , rawSerialisePrivateKey , coercePrivateKey , derivePublicKey - , PublicKey + , PublicKey (publicKeyScope) , rawDeserialisePublicKey , rawSerialisePublicKey , coercePublicKey @@ -93,7 +93,8 @@ data PrivateKey r = PrivateKey { unPrivateKey :: !(SignKeyDSIGN BLS12381MinSigDSIGN) , privateKeyScope :: !KeyScope } - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving anyclass NoThunks rawDeserialisePrivateKey :: KeyScope -> @@ -132,9 +133,10 @@ derivePublicKey sk = type PublicKey :: KeyRole -> Type data PublicKey r = PublicKey { unPublicKey :: !(VerKeyDSIGN BLS12381MinSigDSIGN) - , publicKeyScope :: !(KeyScope) + , publicKeyScope :: !KeyScope } - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving anyclass NoThunks rawDeserialisePublicKey :: KeyScope -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index f4a3c02d44..01d0378616 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -28,6 +29,7 @@ module Ouroboros.Consensus.Committee.EveryoneVotes import Cardano.Ledger.BaseTypes (NonZero) import Cardano.Ledger.BaseTypes.NonZero (NonZero (..), nonZero) +import Control.Exception (Exception) import Control.Monad.Zip (MonadZip (..)) import qualified Data.Array as Array import Data.Bifunctor (Bifunctor (..)) @@ -38,6 +40,7 @@ import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (..)) import Data.Set (Set) import qualified Data.Set.NonEmpty as NESet +import Data.Typeable (Typeable) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Committee.Class @@ -110,8 +113,6 @@ instance InvalidCertSignature String | -- We triggered an unexpected cryptographic error CryptoError String - deriving stock (Show, Eq, Generic) - deriving anyclass NoThunks data EligibilityWitness crypto EveryoneVotes = EveryoneVotesMember @@ -147,6 +148,23 @@ instance (EveryoneVotesVote seatIndex2 electionId2 _ _) = compare (electionId1, seatIndex1) (electionId2, seatIndex2) +deriving instance Show (PublicKey crypto) => Show (VotingCommittee crypto EveryoneVotes) +deriving instance Eq (PublicKey crypto) => Eq (VotingCommittee crypto EveryoneVotes) +deriving instance NoThunks (PublicKey crypto) => NoThunks (VotingCommittee crypto EveryoneVotes) +deriving instance Generic (VotingCommittee crypto EveryoneVotes) + +deriving instance Show (PublicKey crypto) => Show (VotingCommitteeInput crypto EveryoneVotes) +deriving instance Eq (PublicKey crypto) => Eq (VotingCommitteeInput crypto EveryoneVotes) +deriving instance + NoThunks (PublicKey crypto) => NoThunks (VotingCommitteeInput crypto EveryoneVotes) +deriving instance Generic (VotingCommitteeInput crypto EveryoneVotes) + +deriving instance Show (VotingCommitteeError crypto EveryoneVotes) +deriving instance Eq (VotingCommitteeError crypto EveryoneVotes) +deriving instance NoThunks (VotingCommitteeError crypto EveryoneVotes) +deriving instance Generic (VotingCommitteeError crypto EveryoneVotes) +deriving instance Typeable crypto => Exception (VotingCommitteeError crypto EveryoneVotes) + -- | Construct a 'EveryoneVotesVotingCommittee' for a given epoch mkEveryoneVotesVotingCommittee :: VotingCommitteeInput crypto EveryoneVotes -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs index 38c859d9ec..bef302150d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs @@ -12,10 +12,11 @@ module Ouroboros.Consensus.Committee.Types , Cumulative (..) ) where +import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.BaseTypes (HasZero) -import Cardano.Ledger.Core (KeyHash, KeyRole (..)) +import Cardano.Ledger.Core (KeyHash (..), KeyRole (..)) import Cardano.Prelude (Generic) -import Codec.Serialise (Serialise) +import Codec.Serialise (Serialise (..)) import Control.DeepSeq (NFData) import Data.Semigroup (Sum (..)) import Data.Word (Word64) @@ -28,12 +29,23 @@ newtype PoolId = PoolId deriving stock (Show, Eq, Ord, Generic) deriving anyclass NoThunks +instance Serialise PoolId where + encode (PoolId hash) = + encode (Hash.hashToBytes (unKeyHash hash)) + decode = do + bytes <- decode + case Hash.hashFromBytes bytes of + Just hash -> + return (PoolId (KeyHash hash)) + Nothing -> + fail ("failed to decode PoolId, invalid hash bytes: " <> show bytes) + -- | Stake of a voter as reflected by the ledger state newtype LedgerStake = LedgerStake { unLedgerStake :: Rational } deriving stock (Show, Eq, Ord, Generic) - deriving newtype (Num, HasZero) + deriving newtype (Num, HasZero, Serialise) deriving anyclass NoThunks -- | Relative voting power of a voter in the committee selection scheme @@ -50,12 +62,14 @@ newtype VoteWeight = VoteWeight newtype TargetCommitteeSize = TargetCommitteeSize { unTargetCommitteeSize :: Word64 } - deriving (Show, Eq, Generic) + deriving stock (Show, Eq, Generic) + deriving newtype Serialise deriving anyclass NoThunks -- | Wrapper to tag accumulated resources newtype Cumulative a = Cumulative { unCumulative :: a } - deriving (Show, Eq, Generic) + deriving stock (Show, Eq, Generic) + deriving newtype Serialise deriving anyclass NoThunks diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs index 018c1a4518..e13ff82c23 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Deterministic portion of the Weighted Fait-Accompli committee selection scheme @@ -34,7 +35,8 @@ import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.BaseTypes (Nonce (NeutralNonce, Nonce)) import Cardano.Ledger.Binary (runByteBuilder) import Cardano.Ledger.Core (HASH, Hash, KeyHash (unKeyHash)) -import Control.Exception (assert) +import Codec.Serialise (Serialise (..)) +import Control.Exception (Exception, assert) import Data.Array (Array, Ix, listArray) import qualified Data.Array as Array import qualified Data.ByteString.Builder.Extra as BS @@ -52,6 +54,7 @@ import Ouroboros.Consensus.Committee.Types , TargetCommitteeSize (..) , unPoolId ) +import Ouroboros.Consensus.Util.Orphans () -- * Weighted Fait-Accompli committee selection scheme @@ -60,28 +63,36 @@ newtype PersistentCommitteeSize = PersistentCommitteeSize { unPersistentCommitteeSize :: Word64 } - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving newtype Serialise + deriving anyclass NoThunks -- | Non-persistent committee size newtype NonPersistentCommitteeSize = NonPersistentCommitteeSize { unNonPersistentCommitteeSize :: Word64 } - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving newtype Serialise + deriving anyclass NoThunks -- | Total persistent stake newtype TotalPersistentStake = TotalPersistentStake { unTotalPersistentStake :: Cumulative LedgerStake } - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving newtype Serialise + deriving anyclass NoThunks -- | Total non-persistent stake newtype TotalNonPersistentStake = TotalNonPersistentStake { unTotalNonPersistentStake :: Cumulative LedgerStake } - deriving (Show, Eq) + deriving stock (Show, Eq, Generic) + deriving newtype Serialise + deriving anyclass NoThunks -- | Errors that can occur when trying to split the stake distribution into -- persistent and seats via weighted Fait-Accompli. @@ -94,7 +105,8 @@ data WFAError NotEnoughPoolsWithPositiveStake TargetCommitteeSize NumPoolsWithPositiveStake - deriving (Show, Eq, NoThunks, Generic) + deriving stock (Show, Eq, Generic) + deriving anyclass (NoThunks, Exception, Serialise) -- | Split a stake distrubution into persistent and non-persistent committee -- seats according to the weighted Fait-Accompli scheme. @@ -238,7 +250,7 @@ newtype SeatIndex { unSeatIndex :: Word64 } deriving stock (Show, Eq, Ord, Ix, Generic) - deriving newtype Enum + deriving newtype (Enum, Serialise) deriving anyclass NoThunks -- | Number of pools with positive stake in the underlying stake distribution @@ -247,6 +259,7 @@ newtype NumPoolsWithPositiveStake { unNumPoolsWithPositiveStake :: Word64 } deriving stock (Show, Eq, Generic) + deriving newtype Serialise deriving anyclass NoThunks -- | Total stake in the underlying stake distribution @@ -254,7 +267,8 @@ newtype TotalStake = TotalStake { unTotalStake :: Cumulative LedgerStake } - deriving (Show, Eq, Generic) + deriving stock (Show, Eq, Generic) + deriving newtype Serialise deriving anyclass NoThunks -- | Tiebreaker for voters with the same stake in the cumulative stake. @@ -378,7 +392,17 @@ data ExtWFAStakeDistr a -- precomputed at the beginning of each epoch to allow for quick -- transformations between absolute and relative stakes. } - deriving Show + deriving stock (Show, Eq, Generic) + deriving anyclass (NoThunks, Serialise) + +instance Serialise a => Serialise (Array SeatIndex a) where + encode arr = do + let xs = Array.elems arr + encode xs + decode = do + xs <- decode + let bounds = (SeatIndex 0, SeatIndex (fromIntegral (length xs - 1))) + pure $ Array.listArray bounds xs -- | Construct an extended cumulative stake distribution. -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index 942bc1f045..bf0405802e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -46,6 +47,8 @@ module Ouroboros.Consensus.Committee.WFALS ) where import Cardano.Ledger.BaseTypes (NonZero (..), Nonce, nonZero) +import Codec.Serialise (Serialise) +import Control.Exception (Exception) import Control.Monad (void) import Control.Monad.Zip (MonadZip (..)) import qualified Data.Array as Array @@ -58,6 +61,7 @@ import qualified Data.Map.NonEmpty as NEMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Committee.Class @@ -169,8 +173,6 @@ instance InvalidCertSignature String | -- We triggered an unexpected cryptographic error CryptoError String - deriving stock (Show, Eq, Generic) - deriving anyclass NoThunks data EligibilityWitness crypto WFALS = -- A persistent member of the voting committee @@ -225,6 +227,23 @@ instance WFALSNonPersistentVote seatIndex electionId _ _ _ -> (seatIndex, electionId) +deriving instance Show (PublicKey crypto) => Show (VotingCommittee crypto WFALS) +deriving instance Eq (PublicKey crypto) => Eq (VotingCommittee crypto WFALS) +deriving instance NoThunks (PublicKey crypto) => NoThunks (VotingCommittee crypto WFALS) +deriving instance Serialise (PublicKey crypto) => Serialise (VotingCommittee crypto WFALS) +deriving instance Generic (VotingCommittee crypto WFALS) + +deriving instance Show (PublicKey crypto) => Show (VotingCommitteeInput crypto WFALS) +deriving instance Eq (PublicKey crypto) => Eq (VotingCommitteeInput crypto WFALS) +deriving instance NoThunks (PublicKey crypto) => NoThunks (VotingCommitteeInput crypto WFALS) +deriving instance Generic (VotingCommitteeInput crypto WFALS) + +deriving instance Show (VotingCommitteeError crypto WFALS) +deriving instance Eq (VotingCommitteeError crypto WFALS) +deriving instance NoThunks (VotingCommitteeError crypto WFALS) +deriving instance Generic (VotingCommitteeError crypto WFALS) +deriving instance Typeable crypto => Exception (VotingCommitteeError crypto WFALS) + -- | Construct a 'WFALSVotingCommittee' for a given epoch mkWFALSVotingCommittee :: VotingCommitteeInput crypto WFALS -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs index 7005e301b9..9f55fe43d4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs @@ -108,6 +108,9 @@ protocolInfoBinary initHardForkState $ WrapChainDepState $ headerStateChainDep initHeaderState1 + , perasEpochContextResolver = + -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + undefined } } , \tr -> alignWith alignBlockForging <$> blockForging1 tr <*> blockForging2 tr diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs index 033c189278..fca11cf25f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs @@ -53,6 +53,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..)) import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolver) import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.TypeFamilyWrappers @@ -244,12 +245,17 @@ instance Inject HeaderState where WrapChainDepState headerStateChainDep } +-- [TODO EPOCH CONTEXT PLUMBING] we need to fix this +instance Inject PerasEpochContextResolver where + inject = undefined + instance Inject (Flip ExtLedgerState mk) where inject iidx (Flip ExtLedgerState{..}) = Flip $ ExtLedgerState { ledgerState = unFlip $ inject iidx (Flip ledgerState) , headerState = inject iidx headerState + , perasEpochContextResolver = inject iidx perasEpochContextResolver } {------------------------------------------------------------------------------- @@ -279,6 +285,7 @@ injectInitialExtLedgerState cfg extLedgerState0 = ExtLedgerState { ledgerState = targetEraLedgerState , headerState = targetEraHeaderState + , perasEpochContextResolver = targetEraPerasEpochContextResolver } where cfgs :: NP TopLevelConfig (x ': xs) @@ -326,3 +333,7 @@ injectInitialExtLedgerState cfg extLedgerState0 = targetEraHeaderState :: HeaderState (HardForkBlock (x ': xs)) targetEraHeaderState = genesisHeaderState targetEraChainDepState + + -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + targetEraPerasEpochContextResolver :: PerasEpochContextResolver (HardForkBlock (x ': xs)) + targetEraPerasEpochContextResolver = undefined diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs index 29674a997b..e0f5cb455f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs @@ -68,6 +68,7 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolver) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB @@ -356,6 +357,7 @@ instance Isomorphic (Flip ExtLedgerState mk) where ExtLedgerState { ledgerState = unFlip $ project $ Flip ledgerState , headerState = project headerState + , perasEpochContextResolver = project perasEpochContextResolver } inject (Flip ExtLedgerState{..}) = @@ -363,6 +365,7 @@ instance Isomorphic (Flip ExtLedgerState mk) where ExtLedgerState { ledgerState = unFlip $ inject $ Flip ledgerState , headerState = inject headerState + , perasEpochContextResolver = inject perasEpochContextResolver } instance Isomorphic AnnTip where @@ -547,6 +550,11 @@ instance Isomorphic ProtocolInfo where , pInfoInitLedger = unFlip $ inject $ Flip pInfoInitLedger } +-- [TODO EPOCH CONTEXT PLUMBING] we need to fix this +instance Isomorphic PerasEpochContextResolver where + project = undefined + inject = undefined + {------------------------------------------------------------------------------- Types that require take advantage of the fact that we have a single era -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs index a5ec083d1b..de58b11edf 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs @@ -217,7 +217,7 @@ instance answerPureBlockQuery (ExtLedgerCfg cfg) query - ext@(ExtLedgerState st@(HardForkLedgerState hardForkState) _) = + ext@(ExtLedgerState st@(HardForkLedgerState hardForkState) _ _) = case query of QueryIfCurrent queryIfCurrent -> interpretQueryIfCurrent @@ -294,12 +294,15 @@ answerBlockQueryHelper distribExtLedgerState :: All SingleEraBlock xs => ExtLedgerState (HardForkBlock xs) mk -> NS (Flip ExtLedgerState mk) xs -distribExtLedgerState (ExtLedgerState ledgerState headerState) = - hmap (\(Pair hst lst) -> Flip $ ExtLedgerState (unFlip lst) hst) $ +distribExtLedgerState (ExtLedgerState ledgerState headerState perasResolver) = + hmap (\(Pair hst lst) -> Flip $ ExtLedgerState (unFlip lst) hst perasResolver') $ mustMatchNS "HeaderState" (distribHeaderState headerState) (State.tip (hardForkLedgerStatePerEra ledgerState)) + where + -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + perasResolver' = undefined -- | Precondition: the 'headerStateTip' and 'headerStateChainDep' should be from -- the same era. In practice, this is _always_ the case, unless the diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs index 4a450c78a4..1f7c52343a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs @@ -207,7 +207,7 @@ mkHeaderStateWithTime :: LedgerConfig blk -> ExtLedgerState blk mk -> HeaderStateWithTime blk -mkHeaderStateWithTime lcfg (ExtLedgerState lst hst) = +mkHeaderStateWithTime lcfg (ExtLedgerState lst hst _) = mkHeaderStateWithTimeFromSummary summary hst where -- A summary can always translate the tip slot of the ledger state it was diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs index 7755ab9662..e37413f305 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -265,6 +265,11 @@ class , Serialise (BridgeLedger m a) , Serialise (BridgeBlock m a) , Serialise (BridgeTx m a) + , -- Requirements for Peras epoch context + Show (PerasEpochContext (DualBlock m a)) + , Eq (PerasEpochContext (DualBlock m a)) + , NoThunks (PerasEpochContext (DualBlock m a)) + , Serialise (PerasEpochContext (DualBlock m a)) , Show (BridgeTx m a) ) => Bridge m a diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs index 1c39ed9c4b..3300b7df1b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -76,24 +76,26 @@ deriving instance LedgerSupportsProtocol blk => Show (ExtValidationError blk) data ExtLedgerState blk mk = ExtLedgerState { ledgerState :: !(LedgerState blk mk) , headerState :: !(HeaderState blk) - -- , perasEpochContextResolver :: !(PerasEpochContextResolver blk) [TODO EPOCH CONTEXT PLUMBING] + , perasEpochContextResolver :: !(PerasEpochContextResolver blk) } deriving Generic --- In the future we will have a ledgerPerasEpochContextResolver field in ExtLedgerState --- [TODO EPOCH CONTEXT PLUMBING] -ledgerPerasEpochContextResolver :: ExtLedgerState blk mk -> PerasEpochContextResolver blk -ledgerPerasEpochContextResolver = undefined - getPerasEpochContextResolverHandle :: MonadSTM m => STM m (ExtLedgerState blk mk) -> PerasEpochContextResolverHandle m blk -getPerasEpochContextResolverHandle getLedgerStateSTM = PerasEpochContextResolverHandle $ ledgerPerasEpochContextResolver <$> getLedgerStateSTM +getPerasEpochContextResolverHandle getLedgerStateSTM = + PerasEpochContextResolverHandle $ perasEpochContextResolver <$> getLedgerStateSTM deriving instance - (EqMK mk, LedgerSupportsProtocol blk) => + ( EqMK mk + , LedgerSupportsProtocol blk + , Eq (PerasEpochContext blk) + ) => Eq (ExtLedgerState blk mk) deriving instance - (ShowMK mk, LedgerSupportsProtocol blk) => + ( ShowMK mk + , LedgerSupportsProtocol blk + , Show (PerasEpochContext blk) + ) => Show (ExtLedgerState blk mk) -- | We override 'showTypeOf' to show the type of the block @@ -101,7 +103,10 @@ deriving instance -- This makes debugging a bit easier, as the block gets used to resolve all -- kinds of type families. instance - (NoThunksMK mk, LedgerSupportsProtocol blk) => + ( NoThunksMK mk + , LedgerSupportsProtocol blk + , NoThunks (PerasEpochContext blk) + ) => NoThunks (ExtLedgerState blk mk) where showTypeOf _ = show $ typeRep (Proxy @(ExtLedgerState blk)) @@ -153,19 +158,23 @@ data instance Ticked ExtLedgerState blk mk = TickedExtLedgerState { tickedLedgerState :: Ticked LedgerState blk mk , ledgerView :: LedgerView (BlockProtocol blk) , tickedHeaderState :: Ticked (HeaderState blk) - -- , tickedPerasEpochContextResolver :: PerasEpochContextResolver blk [TODO EPOCH CONTEXT PLUMBING] + , tickedPerasEpochContextResolver :: PerasEpochContextResolver blk } instance IsLedger LedgerState blk => GetTip (Ticked ExtLedgerState blk) where getTip = castPoint . getTip . tickedLedgerState instance - LedgerSupportsProtocol blk => + ( LedgerSupportsProtocol blk + , Show (PerasEpochContext blk) + , Eq (PerasEpochContext blk) + , NoThunks (PerasEpochContext blk) + ) => IsLedger ExtLedgerState blk where type LedgerErr ExtLedgerState blk = ExtValidationError blk - applyChainTickLedgerResult evs cfg slot (ExtLedgerState ledger header) = + applyChainTickLedgerResult evs cfg slot (ExtLedgerState ledger header perasResolver) = castLedgerResult ledgerResult <&> \tickedLedgerState -> let ledgerView :: LedgerView (BlockProtocol blk) ledgerView = protocolLedgerView lcfg tickedLedgerState @@ -184,6 +193,10 @@ instance ledgerResult = applyChainTickLedgerResult evs lcfg slot ledger + -- [TODO EPOCH CONTEXT PLUMBING] We need to understand if this needs extra + -- care or not. + tickedPerasEpochContextResolver = perasResolver + applyHelper :: forall blk. (HasCallStack, LedgerSupportsProtocol blk) => @@ -218,9 +231,19 @@ applyHelper f opts cfg blk TickedExtLedgerState{..} = do ledgerView (getHeader blk) tickedHeaderState - pure $ (\l -> ExtLedgerState l hdr) <$> castLedgerResult ledgerResult + -- [TODO EPOCH CONTEXT PLUMBING] We need to understand if this needs extra care or not. + let perasResolver = tickedPerasEpochContextResolver + pure $ (\l -> ExtLedgerState l hdr perasResolver) <$> castLedgerResult ledgerResult -instance (GetBlockKeySets blk, LedgerSupportsProtocol blk) => ApplyBlock ExtLedgerState blk where +instance + ( GetBlockKeySets blk + , LedgerSupportsProtocol blk + , Show (PerasEpochContext blk) + , Eq (PerasEpochContext blk) + , NoThunks (PerasEpochContext blk) + ) => + ApplyBlock ExtLedgerState blk + where applyBlockLedgerResultWithValidation doValidate = applyHelper (applyBlockLedgerResultWithValidation doValidate) @@ -228,7 +251,7 @@ instance (GetBlockKeySets blk, LedgerSupportsProtocol blk) => ApplyBlock ExtLedg applyHelper applyBlockLedgerResult reapplyBlockLedgerResult evs cfg blk TickedExtLedgerState{..} = - (\l -> ExtLedgerState l hdr) <$> castLedgerResult ledgerResult + (\l -> ExtLedgerState l hdr perasResolver) <$> castLedgerResult ledgerResult where ledgerResult = reapplyBlockLedgerResult @@ -243,6 +266,9 @@ instance (GetBlockKeySets blk, LedgerSupportsProtocol blk) => ApplyBlock ExtLedg (getHeader blk) tickedHeaderState + -- [TODO EPOCH CONTEXT PLUMBING] We need to understand if this needs extra care or not. + perasResolver = tickedPerasEpochContextResolver + {------------------------------------------------------------------------------- Serialisation -------------------------------------------------------------------------------} @@ -251,17 +277,20 @@ encodeExtLedgerState :: (LedgerState blk mk -> Encoding) -> (ChainDepState (BlockProtocol blk) -> Encoding) -> (AnnTip blk -> Encoding) -> + (PerasEpochContextResolver blk -> Encoding) -> ExtLedgerState blk mk -> Encoding encodeExtLedgerState encodeLedgerState encodeChainDepState encodeAnnTip - ExtLedgerState{ledgerState, headerState} = + encodePerasEpochContextResolver + ExtLedgerState{ledgerState, headerState, perasEpochContextResolver} = mconcat - [ encodeListLen 2 + [ encodeListLen 3 , encodeLedgerState ledgerState , encodeHeaderState' headerState + , encodePerasEpochContextResolver perasEpochContextResolver ] where encodeHeaderState' = @@ -274,6 +303,7 @@ encodeDiskExtLedgerState :: ( EncodeDisk blk (LedgerState blk EmptyMK) , EncodeDisk blk (ChainDepState (BlockProtocol blk)) , EncodeDisk blk (AnnTip blk) + , EncodeDisk blk (PerasEpochContextResolver blk) ) => (CodecConfig blk -> ExtLedgerState blk EmptyMK -> Encoding) encodeDiskExtLedgerState cfg = @@ -281,20 +311,24 @@ encodeDiskExtLedgerState cfg = (encodeDisk cfg) (encodeDisk cfg) (encodeDisk cfg) + (encodeDisk cfg) decodeExtLedgerState :: (forall s. Decoder s (LedgerState blk EmptyMK)) -> (forall s. Decoder s (ChainDepState (BlockProtocol blk))) -> (forall s. Decoder s (AnnTip blk)) -> + (forall s. Decoder s (PerasEpochContextResolver blk)) -> (forall s. Decoder s (ExtLedgerState blk EmptyMK)) decodeExtLedgerState decodeLedgerState decodeChainDepState - decodeAnnTip = do - decodeListLenOf 2 + decodeAnnTip + decodePerasEpochContextResolver = do + decodeListLenOf 3 ledgerState <- decodeLedgerState headerState <- decodeHeaderState' - return ExtLedgerState{ledgerState, headerState} + perasEpochContextResolver <- decodePerasEpochContextResolver + return ExtLedgerState{ledgerState, headerState, perasEpochContextResolver} where decodeHeaderState' = decodeHeaderState @@ -306,6 +340,7 @@ decodeDiskExtLedgerState :: ( DecodeDisk blk (LedgerState blk EmptyMK) , DecodeDisk blk (ChainDepState (BlockProtocol blk)) , DecodeDisk blk (AnnTip blk) + , DecodeDisk blk (PerasEpochContextResolver blk) ) => (CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk EmptyMK)) decodeDiskExtLedgerState cfg = @@ -313,6 +348,7 @@ decodeDiskExtLedgerState cfg = (decodeDisk cfg) (decodeDisk cfg) (decodeDisk cfg) + (decodeDisk cfg) {------------------------------------------------------------------------------- Ledger Tables @@ -322,55 +358,57 @@ instance (NoThunks (TxIn blk), NoThunks (TxOut blk), HasLedgerTables LedgerState blk) => HasLedgerTables ExtLedgerState blk where - projectLedgerTables (ExtLedgerState lstate _) = + projectLedgerTables (ExtLedgerState lstate _ _) = projectLedgerTables lstate - withLedgerTables (ExtLedgerState lstate hstate) tables = + withLedgerTables (ExtLedgerState lstate hstate perasResolver) tables = ExtLedgerState (lstate `withLedgerTables` tables) hstate + perasResolver instance (NoThunks (TxIn blk), NoThunks (TxOut blk), HasLedgerTables (Ticked LedgerState) blk) => HasLedgerTables (Ticked ExtLedgerState) blk where - projectLedgerTables (TickedExtLedgerState lstate _view _hstate) = + projectLedgerTables (TickedExtLedgerState lstate _view _hstate _perasResolver) = projectLedgerTables lstate withLedgerTables - (TickedExtLedgerState lstate view hstate) + (TickedExtLedgerState lstate view hstate perasResolver) tables = TickedExtLedgerState (lstate `withLedgerTables` tables) view hstate + perasResolver instance CanStowLedgerTables (LedgerState blk) => CanStowLedgerTables (ExtLedgerState blk) where - stowLedgerTables (ExtLedgerState lstate hstate) = - ExtLedgerState (stowLedgerTables lstate) hstate + stowLedgerTables (ExtLedgerState lstate hstate perasResolver) = + ExtLedgerState (stowLedgerTables lstate) hstate perasResolver - unstowLedgerTables (ExtLedgerState lstate hstate) = - ExtLedgerState (unstowLedgerTables lstate) hstate + unstowLedgerTables (ExtLedgerState lstate hstate perasResolver) = + ExtLedgerState (unstowLedgerTables lstate) hstate perasResolver instance CanUpgradeLedgerTables LedgerState blk => CanUpgradeLedgerTables ExtLedgerState blk where - upgradeTables (ExtLedgerState st0 _) (ExtLedgerState st1 _) = + upgradeTables (ExtLedgerState st0 _ _) (ExtLedgerState st1 _ _) = upgradeTables st0 st1 instance (txout ~ TxOut blk, IndexedMemPack LedgerState blk txout) => IndexedMemPack ExtLedgerState blk txout where - indexedTypeName p (ExtLedgerState st _) = indexedTypeName p st - indexedPackedByteCount (ExtLedgerState st _) = indexedPackedByteCount st - indexedPackM (ExtLedgerState st _) = indexedPackM st - indexedUnpackM (ExtLedgerState st _) = indexedUnpackM st + indexedTypeName p (ExtLedgerState st _ _) = indexedTypeName p st + indexedPackedByteCount (ExtLedgerState st _ _) = indexedPackedByteCount st + indexedPackM (ExtLedgerState st _ _) = indexedPackM st + indexedUnpackM (ExtLedgerState st _ _) = indexedUnpackM st instance LedgerTablesAreTrivial LedgerState blk => LedgerTablesAreTrivial ExtLedgerState blk where - convertMapKind (ExtLedgerState st hst) = ExtLedgerState (convertMapKind st) hst + convertMapKind (ExtLedgerState st hst perasResolver) = ExtLedgerState (convertMapKind st) hst perasResolver instance SerializeTablesWithHint LedgerState blk => SerializeTablesWithHint ExtLedgerState blk where decodeTablesWithHint st = decodeTablesWithHint (ledgerState st) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs index 23feb0a636..0601019b42 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs @@ -1,10 +1,16 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Peras.Context ( PerasEpochContextResolver + , BoundedPerasEpochContext (..) + , resolveRoundNo , PerasEpochContextNotFoundForRound (..) , PerasEpochContextResolverHandle (..) , verifyPerasVoteInContext @@ -14,8 +20,11 @@ module Ouroboros.Consensus.Peras.Context ) where +import Codec.Serialise (Serialise) +import Control.Applicative (Alternative (..)) import Control.Exception (Exception) import Control.Monad.Class.MonadSTM (STM) +import Data.Either.Extra (maybeToEither) import GHC.Generics (Generic) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) @@ -27,6 +36,7 @@ import Ouroboros.Consensus.Block.SupportsPeras , ValidatedPerasVote , getPerasVoteRound ) +import Ouroboros.Consensus.Storage.Serialisation (DecodeDisk, EncodeDisk (..)) import Ouroboros.Consensus.Util.IOLike ( IOLike , MonadSTM @@ -37,9 +47,61 @@ import Ouroboros.Consensus.Util.IOLike , throwSTM ) --- stored inside PraosState ? -type PerasEpochContextResolver blk = - PerasRoundNo -> Either PerasEpochContextNotFoundForRound (PerasEpochContext blk) +data PerasEpochContextResolver blk + = ConstPerasEpochContextResolver + (PerasEpochContext blk) + | BoundedPerasEpochContextResolver + (BoundedPerasEpochContext blk) + (Maybe (BoundedPerasEpochContext blk)) + +deriving instance Show (PerasEpochContext blk) => Show (PerasEpochContextResolver blk) +deriving instance Eq (PerasEpochContext blk) => Eq (PerasEpochContextResolver blk) +deriving instance NoThunks (PerasEpochContext blk) => NoThunks (PerasEpochContextResolver blk) +deriving instance Generic (PerasEpochContextResolver blk) + +deriving instance Serialise (PerasEpochContext blk) => Serialise (PerasEpochContextResolver blk) +instance Serialise (PerasEpochContext blk) => EncodeDisk blk (PerasEpochContextResolver blk) +instance Serialise (PerasEpochContext blk) => DecodeDisk blk (PerasEpochContextResolver blk) + +data BoundedPerasEpochContext blk + = BoundedPerasEpochContext + { startPerasRoundNo :: PerasRoundNo -- inclusive + , endPerasRoundNo :: PerasRoundNo -- exclusive + , epochContext :: PerasEpochContext blk + } + +deriving instance Show (PerasEpochContext blk) => Show (BoundedPerasEpochContext blk) +deriving instance Eq (PerasEpochContext blk) => Eq (BoundedPerasEpochContext blk) +deriving instance NoThunks (PerasEpochContext blk) => NoThunks (BoundedPerasEpochContext blk) +deriving instance Generic (BoundedPerasEpochContext blk) + +deriving instance Serialise (PerasEpochContext blk) => Serialise (BoundedPerasEpochContext blk) +instance Serialise (PerasEpochContext blk) => EncodeDisk blk (BoundedPerasEpochContext blk) +instance Serialise (PerasEpochContext blk) => DecodeDisk blk (BoundedPerasEpochContext blk) + +withinEpochContext :: + PerasRoundNo -> + BoundedPerasEpochContext blk -> + Maybe (PerasEpochContext blk) +withinEpochContext roundNo boundedContext + | roundNo >= startPerasRoundNo boundedContext + && roundNo < endPerasRoundNo boundedContext = + Just $ epochContext boundedContext + | otherwise = + Nothing + +resolveRoundNo :: + PerasEpochContextResolver blk -> + PerasRoundNo -> + Either PerasEpochContextNotFoundForRound (PerasEpochContext blk) +resolveRoundNo resolver roundNo = + case resolver of + ConstPerasEpochContextResolver context -> + Right context + BoundedPerasEpochContextResolver currEpochContext mbPrevEpochContext -> + maybeToEither (PerasEpochContextNotFoundForRound roundNo) $ + withinEpochContext roundNo currEpochContext + <|> (withinEpochContext roundNo =<< mbPrevEpochContext) data PerasEpochContextNotFoundForRound = PerasEpochContextNotFoundForRound PerasRoundNo deriving (Show, Eq, Generic, NoThunks, Exception) @@ -47,6 +109,16 @@ data PerasEpochContextNotFoundForRound = PerasEpochContextNotFoundForRound Peras newtype PerasEpochContextResolverHandle m blk = PerasEpochContextResolverHandle (STM m (PerasEpochContextResolver blk)) +constPerasEpochContextResolverHandle :: + ( IOLike m + , NoThunks (PerasEpochContext blk) + ) => + PerasEpochContext blk -> m (PerasEpochContextResolverHandle m blk) +constPerasEpochContextResolverHandle context = do + let resolver = ConstPerasEpochContextResolver context + resolverVar <- newTVarIO resolver + pure $ PerasEpochContextResolverHandle (readTVar resolverVar) + resolveRoundNoWithHandle :: MonadSTM m => PerasEpochContextResolverHandle m blk -> @@ -54,7 +126,7 @@ resolveRoundNoWithHandle :: STM m (Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)) resolveRoundNoWithHandle (PerasEpochContextResolverHandle resolverHandle) roundNo = do resolver <- resolverHandle - pure $ resolver roundNo + pure $ resolveRoundNo resolver roundNo verifyPerasVoteInContext :: ( MonadSTM m @@ -68,8 +140,8 @@ verifyPerasVoteInContext handle vote = do let roundNo = getPerasVoteRound vote resolveRoundNoWithHandle handle roundNo >>= \case Left err -> throwSTM err - Right epochContext -> - case verifyPerasVote epochContext vote of + Right context -> + case verifyPerasVote context vote of Left err -> throwSTM err Right validatedVote -> pure validatedVote @@ -85,14 +157,7 @@ verifyPerasCertInContext handle cert = do let roundNo = getPerasCertRound cert in resolveRoundNoWithHandle handle roundNo >>= \case Left err -> throwSTM err - Right epochContext -> - case verifyPerasCert epochContext cert of + Right context -> + case verifyPerasCert context cert of Left err -> throwSTM err Right validatedCert -> pure validatedCert - -constPerasEpochContextResolverHandle :: - IOLike m => PerasEpochContext blk -> m (PerasEpochContextResolverHandle m blk) -constPerasEpochContextResolverHandle epochContext = do - let resolver = \_ -> Right epochContext - resolverVar <- newTVarIO resolver - pure $ PerasEpochContextResolverHandle (readTVar resolverVar) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs index 34e9c954c8..3b8cf30f06 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs @@ -27,16 +27,18 @@ module Ouroboros.Consensus.Peras.Crypto.BLS , PerasBLSCryptoAggregateVoteSignature (..) ) where -import Cardano.Binary (FromCBOR, ToCBOR (..)) +import Cardano.Binary (FromCBOR, ToCBOR (..), decodeListLenOf, encodeListLen) import Cardano.Crypto.DSIGN (BLS12381MinSigDSIGN, DSIGNAlgorithm (..)) import Cardano.Crypto.Hash (Hash) import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.BaseTypes (Nonce (..), SlotNo (..)) import Cardano.Ledger.Binary (runByteBuilder) import Cardano.Ledger.Hashes (HASH) +import Codec.Serialise (Serialise (..)) import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Builder.Extra as BS import qualified Data.ByteString.Short as BS +import GHC.Base (Any) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract (WithOrigin (..)) @@ -69,23 +71,42 @@ type instance ElectionId PerasBLSCrypto = PerasRoundNo type instance VoteCandidate PerasBLSCrypto = PerasBoostedBlock -- | Private key of a Peras committee member -data PerasPrivateKey - = PerasPrivateKey - { perasVoteSignKey :: BLS.PrivateKey SIGN - , perasVRFSignKey :: BLS.PrivateKey VRF - } +newtype PerasPrivateKey + = PerasPrivateKey (BLS.PrivateKey Any) + deriving stock Generic + deriving anyclass NoThunks type instance PrivateKey PerasBLSCrypto = PerasPrivateKey -- | Public key of a Peras committee member data PerasPublicKey - = PerasPublicKey - { perasVoteVerKey :: BLS.PublicKey SIGN - , perasVRFVerKey :: BLS.PublicKey VRF - } + = PerasPublicKey (BLS.PublicKey Any) + deriving stock (Eq, Show, Generic) + deriving anyclass NoThunks type instance PublicKey PerasBLSCrypto = PerasPublicKey +-- NOTE: we include the key scope in the serialised format of the public key +instance Serialise PerasPublicKey where + encode (PerasPublicKey pk) = do + encodeListLen 2 + <> encode (BLS.publicKeyScope pk) + <> encode (BLS.rawSerialisePublicKey pk) + decode = do + decodeListLenOf 2 + keyScope <- decode + keyBytes <- decode + case BLS.rawDeserialisePublicKey keyScope keyBytes of + Just pk -> + pure (PerasPublicKey pk) + Nothing -> + fail + ( "Failed to decode PerasPublicKey, invalid public key bytes: " + <> show keyBytes + <> " with scope: " + <> show keyScope + ) + -- | Hash the message of a Peras vote -- -- NOTE: this is inspired by the implementation used by the Praos VRF check in @@ -157,10 +178,10 @@ instance CryptoSupportsVoteSigning PerasBLSCrypto where deriving newtype (FromCBOR, ToCBOR) deriving anyclass NoThunks - getVoteSigningKey _ = - perasVoteSignKey - getVoteVerificationKey _ = - perasVoteVerKey + getVoteSigningKey _ (PerasPrivateKey sk) = + BLS.coercePrivateKey @SIGN sk + getVoteVerificationKey _ (PerasPublicKey pk) = + BLS.coercePublicKey @SIGN pk signVote sk roundNo boostedBlock = PerasBLSCryptoVoteSignature @@ -197,11 +218,11 @@ instance CryptoSupportsVRF PerasBLSCrypto where deriving newtype (FromCBOR, ToCBOR) deriving anyclass NoThunks - getVRFSigningKey _ = - perasVRFSignKey + getVRFSigningKey _ (PerasPrivateKey sk) = + BLS.coercePrivateKey @VRF sk - getVRFVerificationKey _ = - perasVRFVerKey + getVRFVerificationKey _ (PerasPublicKey pk) = + BLS.coercePublicKey @VRF pk mkVRFElectionInput epochNonce roundNo = PerasBLSCryptoVRFElectionInput $ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs index af5cb6af43..a29990e611 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs @@ -82,9 +82,5 @@ unsafePerasBLSPublicKeysFromEnv = Nothing -> Left $ "Invalid public key format: " <> key Just pk -> - Right $ - PerasPublicKey - { perasVoteVerKey = BLS.coercePublicKey @BLS.SIGN pk - , perasVRFVerKey = BLS.coercePublicKey @BLS.VRF pk - } + Right $ PerasPublicKey pk {-# NOINLINE unsafePerasBLSPublicKeysFromEnv #-} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs index 380d0219ef..d522a28a0b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -29,6 +30,7 @@ module Ouroboros.Consensus.Peras.Crypto.Mock ) where import Cardano.Prelude (Bifunctor (second)) +import Codec.Serialise (Serialise) import Control.Exception.Base (Exception) import Data.Either.Extra (maybeToEither) import qualified Data.List as List @@ -36,10 +38,11 @@ import Data.List.Extra ((!?)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set.NonEmpty as NESet +import Data.Typeable (Typeable) import Data.Word (Word16) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) -import Ouroboros.Consensus.Block.Abstract (Point) +import Ouroboros.Consensus.Block.Abstract (HeaderHash, Point, StandardHash) import Ouroboros.Consensus.Block.SupportsPeras ( PerasCertCompatibleWithVotingCommittee (..) , PerasRoundNo @@ -78,11 +81,7 @@ type instance PublicKey (MockPerasCrypto blk) = () instance CryptoSupportsVoteSigning (MockPerasCrypto blk) where type VoteSigningKey (MockPerasCrypto blk) = () - - -- \| Key used for verifying votes type VoteVerificationKey (MockPerasCrypto blk) = () - - -- \| Cryptographic signature of a vote data VoteSignature (MockPerasCrypto blk) = MockVoteSignature getVoteSigningKey _proxy privateKey = privateKey getVoteVerificationKey _proxy publicKey = publicKey @@ -166,36 +165,24 @@ instance { -- Stake distribution weightDistr :: NonEmpty (PoolId, VoteWeight) } - deriving stock (Show, Eq, Generic) - deriving anyclass NoThunks newtype VotingCommitteeInput crypto (MockPerasCommittee blk) = MockPerasVotingCommitteeInput (NonEmpty (PoolId, LedgerStake)) - deriving stock (Show, Eq, Generic) - deriving anyclass NoThunks newtype VotingCommitteeError crypto (MockPerasCommittee blk) = -- Seat index is out of bounds for the voting committee MissingSeatIndex PerasSeatIndex - deriving stock (Show, Eq, Generic) - deriving anyclass (NoThunks, Exception) data EligibilityWitness crypto (MockPerasCommittee blk) = MockPerasCommitteeMember !PerasSeatIndex !VoteWeight - deriving stock (Show, Eq, Generic) - deriving anyclass NoThunks newtype Vote crypto (MockPerasCommittee blk) = MockPerasCommitteeVote (MockPerasVote blk) - deriving stock (Show, Eq, Generic) - deriving anyclass NoThunks newtype Cert crypto (MockPerasCommittee blk) = MockPerasCommitteeCert (MockPerasCert blk) - deriving stock (Show, Eq, Generic) - deriving anyclass NoThunks mkVotingCommittee (MockPerasVotingCommitteeInput stakeDistr) = let LedgerStake totalStake = sum (snd <$> stakeDistr) @@ -250,6 +237,47 @@ instance ) = compare (mockVoteRound1, mockVoteSeatIndex1) (mockVoteRound2, mockVoteSeatIndex2) +deriving instance Show (VotingCommittee crypto (MockPerasCommittee blk)) +deriving instance Eq (VotingCommittee crypto (MockPerasCommittee blk)) +deriving instance NoThunks (VotingCommittee crypto (MockPerasCommittee blk)) +deriving instance Serialise (VotingCommittee crypto (MockPerasCommittee blk)) +deriving instance Generic (VotingCommittee crypto (MockPerasCommittee blk)) + +deriving instance Show (VotingCommitteeInput crypto (MockPerasCommittee blk)) +deriving instance Eq (VotingCommitteeInput crypto (MockPerasCommittee blk)) +deriving instance NoThunks (VotingCommitteeInput crypto (MockPerasCommittee blk)) +deriving instance Serialise (VotingCommitteeInput crypto (MockPerasCommittee blk)) +deriving instance Generic (VotingCommitteeInput crypto (MockPerasCommittee blk)) + +deriving instance Show (VotingCommitteeError crypto (MockPerasCommittee blk)) +deriving instance Eq (VotingCommitteeError crypto (MockPerasCommittee blk)) +deriving instance NoThunks (VotingCommitteeError crypto (MockPerasCommittee blk)) +deriving instance Serialise (VotingCommitteeError crypto (MockPerasCommittee blk)) +deriving instance Generic (VotingCommitteeError crypto (MockPerasCommittee blk)) +deriving instance + ( Typeable crypto + , Typeable blk + ) => + Exception (VotingCommitteeError crypto (MockPerasCommittee blk)) + +deriving instance StandardHash blk => Show (Vote crypto (MockPerasCommittee blk)) +deriving instance StandardHash blk => Eq (Vote crypto (MockPerasCommittee blk)) +deriving instance StandardHash blk => NoThunks (Vote crypto (MockPerasCommittee blk)) +deriving instance Serialise (HeaderHash blk) => Serialise (Vote crypto (MockPerasCommittee blk)) +deriving instance Generic (Vote crypto (MockPerasCommittee blk)) + +deriving instance StandardHash blk => Show (Cert crypto (MockPerasCommittee blk)) +deriving instance StandardHash blk => Eq (Cert crypto (MockPerasCommittee blk)) +deriving instance StandardHash blk => NoThunks (Cert crypto (MockPerasCommittee blk)) +deriving instance Serialise (HeaderHash blk) => Serialise (Cert crypto (MockPerasCommittee blk)) +deriving instance Generic (Cert crypto (MockPerasCommittee blk)) + +deriving instance Show (EligibilityWitness crypto (MockPerasCommittee blk)) +deriving instance Eq (EligibilityWitness crypto (MockPerasCommittee blk)) +deriving instance NoThunks (EligibilityWitness crypto (MockPerasCommittee blk)) +deriving instance Serialise (EligibilityWitness crypto (MockPerasCommittee blk)) +deriving instance Generic (EligibilityWitness crypto (MockPerasCommittee blk)) + instance PerasVoteCompatibleWithVotingCommittee (MockPerasVote blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs index 0d53146609..5e5c2538c0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs @@ -26,6 +26,7 @@ module Ouroboros.Consensus.Peras.Params ) where +import Codec.Serialise (Serialise) import Data.Semigroup (Sum (..)) import Data.Word (Word64) import GHC.Generics (Generic) @@ -44,7 +45,7 @@ newtype PerasIgnoranceRounds = PerasIgnoranceRounds {unPerasIgnoranceRounds :: Word64} deriving Show via Quiet PerasIgnoranceRounds deriving stock Generic - deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + deriving newtype (Enum, Eq, Ord, NoThunks, Condense, Serialise) -- | Minimum number of rounds to wait before voting again after a cooldown -- period starts. @@ -52,7 +53,7 @@ newtype PerasCooldownRounds = PerasCooldownRounds {unPerasCooldownRounds :: Word64} deriving Show via Quiet PerasCooldownRounds deriving stock Generic - deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + deriving newtype (Enum, Eq, Ord, NoThunks, Condense, Serialise) -- | Minimum age in slots of a block before it can be voted for in order to get -- a boost. @@ -60,14 +61,14 @@ newtype PerasBlockMinSlots = PerasBlockMinSlots {unPerasBlockMinSlots :: Word64} deriving Show via Quiet PerasBlockMinSlots deriving stock Generic - deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + deriving newtype (Enum, Eq, Ord, NoThunks, Condense, Serialise) -- | Maximum age for a certificate to be included in a block, in rounds. newtype PerasCertMaxRounds = PerasCertMaxRounds {unPerasCertMaxRounds :: Word64} deriving Show via Quiet PerasCertMaxRounds deriving stock Generic - deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + deriving newtype (Enum, Eq, Ord, NoThunks, Condense, Serialise) -- | Maximum number of slots to wait for after the start of a round to consider -- a certificate valid for voting. @@ -75,21 +76,21 @@ newtype PerasCertArrivalThreshold = PerasCertArrivalThreshold {unPerasCertArrivalThreshold :: Word64} deriving Show via Quiet PerasCertArrivalThreshold deriving stock Generic - deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + deriving newtype (Enum, Eq, Ord, NoThunks, Condense, Serialise) -- | Length of a Peras round in slots. newtype PerasRoundLength = PerasRoundLength {unPerasRoundLength :: Word64} deriving Show via Quiet PerasRoundLength deriving stock Generic - deriving newtype (Enum, Eq, Ord, NoThunks) + deriving newtype (Enum, Eq, Ord, NoThunks, Condense, Serialise) -- | Weight assigned to a block when boosted by a Peras certificate. newtype PerasWeight = PerasWeight {unPerasWeight :: Word64} deriving Show via Quiet PerasWeight deriving stock Generic - deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + deriving newtype (Enum, Eq, Ord, NoThunks, Condense, Serialise) deriving via Sum Word64 instance Semigroup PerasWeight deriving via Sum Word64 instance Monoid PerasWeight @@ -99,7 +100,7 @@ newtype PerasQuorumWeightThreshold = PerasQuorumWeightThreshold {unPerasQuorumWeightThreshold :: Rational} deriving Show via Quiet PerasQuorumWeightThreshold deriving stock Generic - deriving newtype (Eq, Ord, NoThunks, Condense) + deriving newtype (Eq, Ord, NoThunks, Condense, Serialise) -- | Safety margin needed on top of the quorum vote weight threshold. -- @@ -110,7 +111,7 @@ newtype PerasQuorumWeightThresholdSafetyMargin = PerasQuorumWeightThresholdSafetyMargin {unPerasQuorumWeightThresholdSafetyMargin :: Rational} deriving Show via Quiet PerasQuorumWeightThresholdSafetyMargin deriving stock Generic - deriving newtype (Eq, Ord, NoThunks, Condense) + deriving newtype (Eq, Ord, NoThunks, Condense, Serialise) {------------------------------------------------------------------------------- Protocol parameters bundle @@ -134,7 +135,7 @@ data PerasParams blk = PerasParams , perasQuorumWeightThresholdSafetyMargin :: !PerasQuorumWeightThresholdSafetyMargin , perasTargetCommitteeSize :: !Committee.TargetCommitteeSize } - deriving (Show, Eq, Generic, NoThunks) + deriving (Show, Eq, Generic, NoThunks, Serialise) -- | Instantiate default Peras protocol parameters. -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs index 767b7a0d45..5f376d8138 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs @@ -267,6 +267,8 @@ import System.FS.CRC -- instantiated with a @blk@. type LedgerDbSerialiseConstraints blk = ( Serialise (HeaderHash blk) + , Serialise (PerasEpochContext blk) + , Serialise (PerasEpochContext blk) , EncodeDisk blk (LedgerState blk EmptyMK) , DecodeDisk blk (LedgerState blk EmptyMK) , EncodeDisk blk (AnnTip blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index 5e17b3cb7f..bad4dfcf5d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -13,10 +13,13 @@ import Cardano.Binary (fromCBOR, toCBOR) import Cardano.Crypto.DSIGN.Class import Cardano.Crypto.DSIGN.Mock (MockDSIGN) import Cardano.Crypto.Hash (Hash, HashAlgorithm) +import Cardano.Ledger.BaseTypes (Nonce) import Cardano.Ledger.Genesis (NoGenesis (..)) import Codec.CBOR.Decoding (Decoder) import Codec.Serialise (Serialise (..)) import Control.Tracer (Tracer) +import Data.Array (Array) +import qualified Data.Array as Array import Data.IntPSQ (IntPSQ) import qualified Data.IntPSQ as PSQ import Data.Map.NonEmpty (NEMap) @@ -55,6 +58,10 @@ instance Serialise (VerKeyDSIGN MockDSIGN) where encode = encodeVerKeyDSIGN decode = decodeVerKeyDSIGN +instance Serialise Nonce where + encode = toCBOR + decode = fromCBOR + {------------------------------------------------------------------------------- NoThunks -------------------------------------------------------------------------------} @@ -102,6 +109,10 @@ instance NoThunks v => NoThunks (NESet v) where showTypeOf _ = "NESet" wNoThunks ctxt = wNoThunks ctxt . NESet.toSet +instance NoThunks a => NoThunks (Array i a) where + showTypeOf _ = "Array" + wNoThunks ctxt = wNoThunks ctxt . Array.elems + instance NoThunks StdGen where showTypeOf _ = "StdGen" wNoThunks ctx = wNoThunks ctx . OnlyCheckWhnf . Random.unStdGen diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index d83b3df9d2..1de05e2d7a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -760,6 +760,8 @@ testInitExtLedger = ExtLedgerState { ledgerState = testInitLedger , headerState = genesisHeaderState () + , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + perasEpochContextResolver = undefined } -- Only for a single node diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index ede361053d..3b882dc7d8 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -24,6 +24,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mempool.API import Ouroboros.Consensus.Mempool.TxSeq import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert) +import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolver) import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..)) @@ -66,6 +67,7 @@ instance ( ToExpr (LedgerState blk EmptyMK) , ToExpr (ChainDepState (BlockProtocol blk)) , ToExpr (TipInfo blk) + , ToExpr (PerasEpochContextResolver blk) ) => ToExpr (ExtLedgerState blk EmptyMK) @@ -140,6 +142,9 @@ instance ToExpr PerasSeatIndex where toExpr = defaultExprViaShow instance ToExpr (HeaderHash blk) => ToExpr (MockPerasVote blk) instance ToExpr (HeaderHash blk) => ToExpr (MockPerasCert blk) +instance Show (PerasEpochContext blk) => ToExpr (PerasEpochContextResolver blk) where + toExpr = defaultExprViaShow + {------------------------------------------------------------------------------- si-timers --------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs index 58cc756b2b..3d8f8906e2 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs @@ -25,7 +25,8 @@ import Ouroboros.Consensus.Block , PerasParams (..) ) import Ouroboros.Consensus.Block.SupportsPeras - ( ValidatedPerasCert (..) + ( DefaultPerasEpochContext (..) + , ValidatedPerasCert (..) , ValidatedPerasVote (..) ) import Ouroboros.Consensus.Committee.Class @@ -66,7 +67,7 @@ genMockPerasVotingCommittee = <$> genMockPerasVotingCommitteeInput genMockPerasEpochContext :: Gen (PerasEpochContext TestBlock) -genMockPerasEpochContext = (,) <$> genMockPerasVotingCommittee <*> genPerasParams +genMockPerasEpochContext = DefaultPerasEpochContext <$> genMockPerasVotingCommittee <*> genPerasParams pickSeatIndexFromCommittee :: VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> Gen PerasSeatIndex @@ -103,7 +104,8 @@ genMockPerasVote committee = do } genMockValidatedPerasVote :: PerasEpochContext TestBlock -> Gen (ValidatedPerasVote TestBlock) -genMockValidatedPerasVote (committee, _params) = do +genMockValidatedPerasVote context = do + let committee = dpecCommittee context vote <- genMockPerasVote committee let eligibilityWitness = maybe @@ -148,7 +150,9 @@ genMockPerasCertFullCommittee committee = do } genMockValidatedPerasCert :: PerasEpochContext TestBlock -> Gen (ValidatedPerasCert TestBlock) -genMockValidatedPerasCert (committee, params) = do +genMockValidatedPerasCert context = do + let committee = dpecCommittee context + let params = dpecParams context cert <- genMockPerasCertFullCommittee committee pure $ ValidatedPerasCert diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index 08ee8efeaa..5053096e3d 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -645,6 +645,8 @@ testInitExtLedgerWithState st = ExtLedgerState { ledgerState = testInitLedgerWithState st , headerState = genesisHeaderState () + , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + perasEpochContextResolver = undefined } data TestBlockLedgerConfig = TestBlockLedgerConfig @@ -1002,8 +1004,8 @@ instance Serialise (AnnTip (TestBlockWith ptype)) where decode = defaultDecodeAnnTip decode instance PayloadSemantics ptype => Serialise (ExtLedgerState (TestBlockWith ptype) EmptyMK) where - encode = encodeExtLedgerState encode encode encode - decode = decodeExtLedgerState decode decode decode + encode = encodeExtLedgerState encode encode encode encode + decode = decodeExtLedgerState decode decode decode decode instance Serialise (RealPoint (TestBlockWith ptype)) where encode = encodeRealPoint encode diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/BFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/BFT.hs index a891660b9f..838adf037b 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/BFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/BFT.hs @@ -149,6 +149,18 @@ forgeBftExt = ForgeExt $ \cfg _ SimpleBlock{..} -> , simpleBody = simpleBody } +{------------------------------------------------------------------------------- + Peras +-------------------------------------------------------------------------------} + +instance + ( Typeable c + , Typeable c' + , SimpleCrypto c + , SimpleCrypto c' + ) => + BlockSupportsPeras (SimpleBftBlock c c') + {------------------------------------------------------------------------------- Serialisation -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs index 5c5d974e70..037fb75083 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PBFT.hs @@ -37,6 +37,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Mock.Ledger.Block import Ouroboros.Consensus.Mock.Ledger.Forge import Ouroboros.Consensus.Mock.Node.Abstract +import Ouroboros.Consensus.Mock.Node.Peras () import Ouroboros.Consensus.Protocol.PBFT import qualified Ouroboros.Consensus.Protocol.PBFT.State as S import Ouroboros.Consensus.Protocol.Signed diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs index cec01d2e1a..b963ccbb8f 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/Praos.hs @@ -36,6 +36,7 @@ import Ouroboros.Consensus.Mock.Ledger.Address import Ouroboros.Consensus.Mock.Ledger.Block import Ouroboros.Consensus.Mock.Ledger.Forge import Ouroboros.Consensus.Mock.Node.Abstract +import Ouroboros.Consensus.Mock.Node.Peras () import Ouroboros.Consensus.Mock.Protocol.Praos import Ouroboros.Consensus.Protocol.Signed import Ouroboros.Consensus.Storage.Serialisation diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs index 4dac7e982b..e181e4475f 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block/PraosRule.hs @@ -31,6 +31,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Mock.Ledger.Block import Ouroboros.Consensus.Mock.Ledger.Forge import Ouroboros.Consensus.Mock.Node.Abstract +import Ouroboros.Consensus.Mock.Node.Peras () import Ouroboros.Consensus.Mock.Protocol.LeaderSchedule import Ouroboros.Consensus.Mock.Protocol.Praos import Ouroboros.Consensus.NodeId (CoreNodeId) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs index 7892c13b75..0b26dc18bf 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs @@ -53,6 +53,8 @@ protocolInfoBft numCoreNodes nid securityParam eraParams = ExtLedgerState (genesisSimpleLedgerState addrDist) (genesisHeaderState ()) + -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + undefined } where signKey :: CoreNodeId -> SignKeyDSIGN MockDSIGN diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs index b2a8b1eaec..132e8b8f7e 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs @@ -47,6 +47,8 @@ protocolInfoMockPBFT params eraParams = ExtLedgerState (genesisSimpleLedgerState addrDist) (genesisHeaderState S.empty) + -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + undefined } where ledgerView :: PBftLedgerView PBftMockCrypto diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs index 5c5e7a869f..9dbdb4dde0 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs @@ -59,6 +59,8 @@ protocolInfoPraos numCoreNodes nid params eraParams eta0 evolvingStakeDist = ExtLedgerState { ledgerState = genesisSimpleLedgerState addrDist , headerState = genesisHeaderState (PraosChainDepState []) + , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + perasEpochContextResolver = undefined } } where diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs index 8a6eb15e34..508e7e45f2 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs @@ -65,6 +65,8 @@ protocolInfoPraosRule ExtLedgerState { ledgerState = genesisSimpleLedgerState addrDist , headerState = genesisHeaderState () + , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + perasEpochContextResolver = undefined } } where diff --git a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs index 20e0978bbb..ea4ec99d4a 100644 --- a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs +++ b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs @@ -54,7 +54,7 @@ First, some imports we'll need: > (SecurityParam(..), ConsensusConfig, ConsensusProtocol(..), NoTiebreaker(..)) > import Ouroboros.Consensus.Ticked ( Ticked, Ticked(TickedTrivial) ) > import Ouroboros.Consensus.Block -> (BlockSupportsProtocol (tiebreakerView, validateView)) +> (BlockSupportsProtocol (tiebreakerView, validateView), BlockSupportsPeras) > import Ouroboros.Consensus.Ledger.Abstract > (AuxLedgerEvent, GetTip(..), IsLedger(..), LedgerCfg, > LedgerResult(LedgerResult, lrEvents, lrResult), @@ -396,7 +396,10 @@ will know nothing about the structure of the data - instead there are other typeclasses needed to build an interface to derive things that are needed from this value. We'll implement those typeclasses next. +We also need to instantiate `BlockSupportsPeras` for `BlockC`. For this, we can +use the default emtpy implementation. +> instance BlockSupportsPeras BlockC Interface to the Block Header ----------------------------- diff --git a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs index cb3646cb69..70ba91d251 100644 --- a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs +++ b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs @@ -71,6 +71,7 @@ And imports, of course: > BlockProtocol, castHeaderFields, BlockConfig, CodecConfig, > StorageConfig, Point, castPoint, WithOrigin (..), EpochNo (EpochNo), > pointSlot, blockPoint, BlockNo (..)) +> import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras) > import Ouroboros.Consensus.Block.SupportsProtocol > (BlockSupportsProtocol (..)) > import Ouroboros.Consensus.Protocol.Abstract @@ -207,6 +208,11 @@ defined earlier: > instance StandardHash BlockD +We also need to instantiate `BlockSupportsPeras` for `BlockC`. For this, we can +use the default emtpy implementation. + +> instance BlockSupportsPeras BlockD + Then we define a function `computeBlockHash` which computes a `Hash` for a `BlockD` - basically aggregating all the data in the block besides the hash itself: 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 b1ab1d0091..3c88d815e1 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 @@ -1629,6 +1629,7 @@ deriving instance , Show blk , Show (PerasVote blk) , Show (PerasCert blk) + , Show (PerasEpochContext blk) ) => ToExpr (Model blk IO Concrete) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index b09bf0f4fc..71ac76651b 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -36,7 +36,8 @@ import Data.Word (Word64) import GHC.Generics (Generic) import Ouroboros.Consensus.Block.Abstract (Point (..), SlotNo (..)) import Ouroboros.Consensus.Block.SupportsPeras - ( IsPerasVote (..) + ( DefaultPerasEpochContext (..) + , IsPerasVote (..) , PerasEpochContext , PerasParams , PerasRoundNo (..) @@ -176,7 +177,12 @@ instance StateModel Model where genCreateDB = do committee <- genMockPerasVotingCommittee let params = perasTestParams - pure $ CreateDB (committee, params) + pure $ + CreateDB $ + DefaultPerasEpochContext + { dpecCommittee = committee + , dpecParams = params + } genAddVote = do roundNo <- genRoundNo From 239bcda5963c0abbce97e1fdf8950c0c6fe01e9f Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 2 Jun 2026 16:30:51 +0200 Subject: [PATCH 50/62] WIP Continue plumbing --- .../Consensus/Byron/Ledger/Ledger.hs | 7 +- .../Consensus/Shelley/Ledger/Ledger.hs | 4 ++ .../Test/Consensus/HardFork/Combinator/A.hs | 2 + .../Test/Consensus/HardFork/Combinator/B.hs | 2 + .../Ouroboros/Consensus/Protocol/Praos.hs | 3 + .../Consensus/Protocol/Praos/Peras.hs | 69 ++++++++++--------- .../Consensus/HardFork/Combinator/Basics.hs | 6 ++ .../Consensus/HardFork/Combinator/Protocol.hs | 11 ++- .../Consensus/Ledger/SupportsPeras.hs | 16 +++++ .../Ouroboros/Consensus/Protocol/Abstract.hs | 12 ++++ 10 files changed, 97 insertions(+), 35 deletions(-) diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index 0e0ceb38ef..b94d729781 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -14,6 +14,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE TypeApplications #-} -- | Instances requires for consensus/ledger integration module Ouroboros.Consensus.Byron.Ledger.Ledger @@ -88,11 +89,13 @@ import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsPeerSelection -import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Util (ShowProxy (..)) import Ouroboros.Consensus.Util.IndexedMemPack +import Cardano.Ledger.State (PoolDistr(..)) +import Cardano.Ledger.Coin (knownNonZeroCompactCoin, knownNonZeroCoin) {------------------------------------------------------------------------------- LedgerState @@ -582,4 +585,4 @@ instance CanUpgradeLedgerTables LedgerState ByronBlock where -------------------------------------------------------------------------------} -- | Default instance with no Peras support -instance LedgerSupportsPeras ByronBlock +instance LedgerSupportsPeras ByronBlock where diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index f3cfcc4eca..6ea32d1432 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -143,6 +143,7 @@ import Ouroboros.Consensus.Util.CBOR ) import Ouroboros.Consensus.Util.IndexedMemPack import Ouroboros.Consensus.Util.Versioned +import Cardano.Ledger.Shelley.LedgerState (NewEpochState(..)) {------------------------------------------------------------------------------- Config @@ -923,3 +924,6 @@ instance LedgerSupportsPeras (ShelleyBlock proto era) where getLatestPerasCertRound = strictMaybeToMaybe . shelleyLedgerLatestPerasCertRound + + getStakeDistr = + nesPd . shelleyLedgerState diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 8a8a37abcf..1422099455 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -135,6 +135,8 @@ instance ConsensusProtocol ProtocolA where updateChainDepState _ _ _ _ = return () reupdateChainDepState _ _ _ _ = () +instance ChainDepStateSupportsPeras ProtocolA + data BlockA = BlkA { blkA_header :: Header BlockA , blkA_body :: [GenTx BlockA] diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index b01cea1f33..165de13464 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -118,6 +118,8 @@ instance ConsensusProtocol ProtocolB where updateChainDepState _ _ _ _ = return () reupdateChainDepState _ _ _ _ = () +instance ChainDepStateSupportsPeras ProtocolB + data BlockB = BlkB { blkB_header :: Header BlockB } diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 1089989945..8259e1fa47 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -386,6 +386,9 @@ deriving instance PraosCrypto c => NoThunks (PraosValidationErr c) deriving instance PraosCrypto c => Show (PraosValidationErr c) +instance ChainDepStateSupportsPeras (Praos c) where + getEpochNonce _ = praosStateEpochNonce + instance PraosCrypto c => ConsensusProtocol (Praos c) where type ChainDepState (Praos c) = PraosState type IsLeader (Praos c) = PraosIsLeader c diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs index 384260e9eb..b74b3bd2d7 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs @@ -10,8 +10,8 @@ -- -- [TODO EPOCH CONTEXT PLUMBING] module Ouroboros.Consensus.Protocol.Praos.Peras - ( PraosStateSupportsPerasVoting (..) - , praosStatePerasVotingCommitteeInputV1 + ( LedgerStateHeaderStateSupportsPerasVoting (..) + , ledgerStateHeaderStateMkPerasVotingCommitteeInputV1 ) where import Data.Bifunctor (Bifunctor (..)) @@ -37,7 +37,7 @@ import Ouroboros.Consensus.Committee.WFALS , WFALS ) import Ouroboros.Consensus.HardFork.Combinator.Abstract (CanHardFork) -import Ouroboros.Consensus.HardFork.Combinator.Basics (HardForkBlock) +import Ouroboros.Consensus.HardFork.Combinator.Basics (HardForkBlock, LedgerState) import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS import Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe ( unsafeExtendPerasStakeDistrWithPublicKeysFromEnv @@ -46,58 +46,58 @@ import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 import Ouroboros.Consensus.Peras.Params (PerasParams (..)) import Ouroboros.Consensus.Protocol.Praos ( PraosState (..) - , Ticked (..) + , Ticked (..), Praos ) import Ouroboros.Consensus.Protocol.Praos.Views (LedgerView (..)) +import Ouroboros.Consensus.HeaderValidation (HeaderState, headerStateChainDep) +import Ouroboros.Consensus.Block.Abstract (BlockProtocol) +import Cardano.Ledger.State (PoolDistr) +import Cardano.Ledger.BaseTypes (Nonce) +import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) +import Ouroboros.Consensus.HardFork.Combinator.Protocol (HardForkChainDepState) class ( BlockSupportsPeras blk , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) -- TODO remove this constraint when it becomes a superclass constraint of 'BlockSupportsPeras' ) => - PraosStateSupportsPerasVoting blk + LedgerStateHeaderStateSupportsPerasVoting blk where - -- | How to extract a 'PerasVotingCommitteeInput' from a 'Ticked PraosState'. - -- This is used to construct the 'PerasVotingCommittee' used for voting at a given ledger/praos state. - praosStatePerasVotingCommitteeInput :: - proxy blk -> + ledgerStateHeaderStateMkPerasVotingCommitteeInput :: PerasParams blk -> - Ticked PraosState -> + LedgerState blk mk -> + HeaderState blk -> Either (PerasError blk) (PerasVotingCommitteeInput blk) - -- | How to build a new 'PerasVotingCommittee' from a 'Ticked PraosState'. The implementation provided here relies on 'praosStatePerasVotingCommitteeInput'. - praosStateGetPerasVotingCommittee :: - proxy blk -> + ledgerStateHeaderStateMkPerasVotingCommittee :: PerasParams blk -> - Ticked PraosState -> + LedgerState blk mk -> + HeaderState blk -> Either (PerasError blk) (PerasVotingCommittee blk) - praosStateGetPerasVotingCommittee p perasParams tickedPraosState = do + ledgerStateHeaderStateMkPerasVotingCommittee perasParams ledgerState headerState = do committeeInput <- - praosStatePerasVotingCommitteeInput p perasParams tickedPraosState + ledgerStateHeaderStateMkPerasVotingCommitteeInput perasParams ledgerState headerState bimap injectVotingCommitteeError id $ Committee.mkVotingCommittee committeeInput -praosStatePerasVotingCommitteeInputV1 :: - PublicKey crypto ~ BLS.PerasPublicKey => - proxy blk -> +ledgerStateHeaderStateMkPerasVotingCommitteeInputV1 :: + (PublicKey crypto ~ BLS.PerasPublicKey) => + (LedgerState blk mk -> PoolDistr) -> + (ChainDepState (BlockProtocol blk) -> Nonce) -> PerasParams blk -> - Ticked PraosState -> + LedgerState blk mk -> + HeaderState blk -> Either (V1.PerasError blk) (VotingCommitteeInput crypto WFALS) -praosStatePerasVotingCommitteeInputV1 _ perasParams tickedPraosState = do - let epochNonce = - praosStateEpochNonce - . tickedPraosStateChainDepState - $ tickedPraosState +ledgerStateHeaderStateMkPerasVotingCommitteeInputV1 extractPoolDistr extractEpochNonce perasParams ledgerState headerState = do + let epochNonce = extractEpochNonce . headerStateChainDep $ headerState + poolDistr = extractPoolDistr ledgerState -- TODO: replace the following hack with proper on-chain key registration. stakeDistrWithPublicKeys <- - bimap V1.PerasTemporaryPublicKeyHackError id - . unsafeExtendPerasStakeDistrWithPublicKeysFromEnv - . lvPoolDistr - . tickedPraosStateLedgerView - $ tickedPraosState + bimap V1.PerasTemporaryPublicKeyHackError id $ + unsafeExtendPerasStakeDistrWithPublicKeysFromEnv poolDistr extWFAStakeDistr <- bimap V1.PerasVotingWFAError id $ mkExtWFAStakeDistr @@ -113,6 +113,11 @@ instance ( StandardHash (HardForkBlock xs) , CanHardFork xs ) => - PraosStateSupportsPerasVoting (HardForkBlock xs) + LedgerStateHeaderStateSupportsPerasVoting (HardForkBlock xs) where - praosStatePerasVotingCommitteeInput = praosStatePerasVotingCommitteeInputV1 + ledgerStateHeaderStateMkPerasVotingCommitteeInput = ledgerStateHeaderStateMkPerasVotingCommitteeInputV1 extractPoolDistr extractEpochNonce where + extractPoolDistr :: LedgerState (HardForkBlock xs) mk -> PoolDistr + extractPoolDistr = undefined + + extractEpochNonce :: HardForkChainDepState xs -> Nonce + extractEpochNonce = undefined diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index 97dec58470..b563420165 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -267,6 +267,12 @@ instance CanHardFork xs => LedgerSupportsPeras (HardForkBlock xs) where . hcmap proxySingle (K . getLatestPerasCertRound . unFlip) . State.tip . hardForkLedgerStatePerEra + + getStakeDistr = + hcollapse + . hcmap proxySingle (K . getStakeDistr . unFlip) + . State.tip + . hardForkLedgerStatePerEra {------------------------------------------------------------------------------- BlockSupportsPeras diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs index 3c9ffcf6a7..549c01a5d6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE InstanceSigs #-} module Ouroboros.Consensus.HardFork.Combinator.Protocol ( HardForkTiebreakerView (..) @@ -55,13 +56,14 @@ import Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView ) import Ouroboros.Consensus.HardFork.Combinator.State ( HardForkState - , Translate (..) + , Translate (..), getHardForkState ) import qualified Ouroboros.Consensus.HardFork.Combinator.State as State import Ouroboros.Consensus.HardFork.Combinator.Translation as HFTranslation import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util ((.:)) +import qualified Data.SOP.Telescope as Tele {------------------------------------------------------------------------------- ChainSelection @@ -128,6 +130,13 @@ instance CanHardFork xs => ConsensusProtocol (HardForkProtocol xs) where -- Security parameter must be equal across /all/ eras protocolSecurityParam = hardForkConsensusConfigK +instance ChainDepStateSupportsPeras (HardForkProtocol xs) where + getEpochNonce _ = hcollapse + -- [TODO EPOCH CONTEXT PLUMBING] STOPPED THERE + . hcmap proxySingle (K . getEpochNonce . unwrapChainDepState . hmap currentState) + . Tele.tip + . getHardForkState + {------------------------------------------------------------------------------- BlockSupportsProtocol -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs index d2655a94a8..603e68554f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} module Ouroboros.Consensus.Ledger.SupportsPeras ( LedgerSupportsPeras (..) @@ -7,6 +9,9 @@ where import Ouroboros.Consensus.Block.SupportsPeras (PerasRoundNo) import Ouroboros.Consensus.Ledger.Abstract (LedgerState) +import Cardano.Ledger.State (PoolDistr (..)) +import Cardano.Ledger.Coin (knownNonZeroCoin) +import qualified Data.Map as Map -- | Extract Peras information stored in the ledger state class LedgerSupportsPeras blk where @@ -16,3 +21,14 @@ class LedgerSupportsPeras blk where getLatestPerasCertRound :: LedgerState blk mk -> Maybe PerasRoundNo default getLatestPerasCertRound :: LedgerState blk mk -> Maybe PerasRoundNo getLatestPerasCertRound _ = Nothing + + -- | Extract the stake distribution from the given ledger state. + -- PRECONDITION: this function will only return a meaningful result if the + -- ledger state is from a block that supports Peras + getStakeDistr :: LedgerState blk mk -> PoolDistr + default getStakeDistr :: LedgerState blk mk -> PoolDistr + -- NOTE: this is a bit of a hack for blocks that do not really support Peras. + getStakeDistr _ = PoolDistr { + unPoolDistr = Map.empty, + pdTotalActiveStake = knownNonZeroCoin @1 + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs index 109b0a5cc4..6488279f6a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs @@ -8,11 +8,13 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DefaultSignatures #-} module Ouroboros.Consensus.Protocol.Abstract ( -- * Abstract definition of the Ouroboros protocol ConsensusConfig , ConsensusProtocol (..) + , ChainDepStateSupportsPeras (..) -- * Chain order , SelectView (..) @@ -46,6 +48,7 @@ import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.Ticked +import Cardano.Ledger.BaseTypes (Nonce (NeutralNonce)) -- | Static configuration required to run the consensus protocol -- @@ -75,6 +78,7 @@ class , NoThunks (ValidationErr p) , NoThunks (TiebreakerView p) , Typeable p -- so that p can appear in exceptions + , ChainDepStateSupportsPeras p ) => ConsensusProtocol p where @@ -357,3 +361,11 @@ instance ChainOrder (TiebreakerView p) => ChainOrder (SelectView p) where ShouldSwitch r -> ShouldSwitch (SelectViewTiebreak r) ShouldNotSwitch e -> ShouldNotSwitch e GT -> ShouldNotSwitch GT + +class ChainDepStateSupportsPeras p where + -- | Extract the epoch nonce from the given 'ChainDepState'. + -- PRECONDITION: this function will only return a meaningful result if the + -- 'ChainDepState' is from a protocol of a block that supports Peras + getEpochNonce :: proxy p -> ChainDepState p -> Nonce + default getEpochNonce :: proxy p -> ChainDepState p -> Nonce + getEpochNonce _ _ = NeutralNonce From 4f27264dd8ec3b1082bad8e72a8dc07b6f1e7245 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 3 Jun 2026 10:00:23 +0200 Subject: [PATCH 51/62] Working on ledger/header Peras-related state API and implem --- .../Consensus/Byron/Ledger/Ledger.hs | 5 +- .../Consensus/Shelley/Ledger/Block.hs | 3 + .../Consensus/Shelley/Ledger/Ledger.hs | 6 +- .../Ouroboros/Consensus/Shelley/Node/Peras.hs | 11 +- .../Test/Consensus/HardFork/Combinator.hs | 2 +- .../Consensus/Protocol/Praos/Peras.hs | 123 ------------------ .../Ouroboros/Consensus/Protocol/TPraos.hs | 2 + ouroboros-consensus.cabal | 3 +- .../bench/ChainSync-client-bench/Main.hs | 22 +++- .../Consensus/HardFork/Combinator/Basics.hs | 6 +- .../HardFork/Combinator/Ledger/Query.hs | 2 +- .../Consensus/HardFork/Combinator/Protocol.hs | 21 +-- .../Ouroboros/Consensus/Ledger/Extended.hs | 95 +++++++++++++- .../Consensus/Ledger/SupportsPeras.hs | 23 ++-- .../Ouroboros/Consensus/Peras/Context.hs | 2 +- .../Ouroboros/Consensus/Peras/Error/Mock.hs | 1 + .../Ouroboros/Consensus/Peras/Params.hs | 6 +- .../Ouroboros/Consensus/Peras/State/Mock.hs | 33 +++++ .../Ouroboros/Consensus/Peras/State/V1.hs | 53 ++++++++ .../Ouroboros/Consensus/Protocol/Abstract.hs | 4 +- .../Ouroboros/Consensus/Protocol/BFT.hs | 2 + .../Consensus/Protocol/ModChainSel.hs | 7 +- .../Ouroboros/Consensus/Protocol/PBFT.hs | 2 + .../Test/Ouroboros/Storage/TestBlock.hs | 2 +- .../Test/Util/Peras/Cert/Inclusion.hs | 4 +- .../Test/Util/Peras/Internal.hs | 4 +- .../Test/Util/TestBlock.hs | 7 + .../Consensus/Mock/Protocol/LeaderSchedule.hs | 2 + .../Consensus/Mock/Protocol/Praos.hs | 2 + .../Ouroboros/Consensus/Tutorial/Simple.lhs | 3 +- .../Consensus/Tutorial/WithEpoch.lhs | 5 +- .../Test/Consensus/Peras/Cert/Inclusion.hs | 4 +- .../Test/Consensus/Peras/Voting/Rules.hs | 4 +- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 4 +- .../Storage/PerasCertDB/StateMachine.hs | 2 +- .../Storage/PerasVoteDB/StateMachine.hs | 4 +- 36 files changed, 288 insertions(+), 193 deletions(-) delete mode 100644 ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/Mock.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/V1.hs diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index b94d729781..a72f688307 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -14,7 +14,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE TypeApplications #-} -- | Instances requires for consensus/ledger integration module Ouroboros.Consensus.Byron.Ledger.Ledger @@ -94,8 +93,6 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Util (ShowProxy (..)) import Ouroboros.Consensus.Util.IndexedMemPack -import Cardano.Ledger.State (PoolDistr(..)) -import Cardano.Ledger.Coin (knownNonZeroCompactCoin, knownNonZeroCoin) {------------------------------------------------------------------------------- LedgerState @@ -585,4 +582,4 @@ instance CanUpgradeLedgerTables LedgerState ByronBlock where -------------------------------------------------------------------------------} -- | Default instance with no Peras support -instance LedgerSupportsPeras ByronBlock where +instance LedgerSupportsPeras ByronBlock diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs index 3a6fe8fe40..2ce6802505 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -126,6 +126,9 @@ class , Crypto (ProtoCrypto proto) , -- Peras constraints BlockSupportsPeras (ShelleyBlock proto era) + , Show (PerasEpochContext (ShelleyBlock proto era)) + , Eq (PerasEpochContext (ShelleyBlock proto era)) + , NoThunks (PerasEpochContext (ShelleyBlock proto era)) , Serialise (PerasEpochContext (ShelleyBlock proto era)) , -- Backwards compatibility Plain.FromCBOR (LegacyPParams era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index 6ea32d1432..e6aed54e74 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -87,6 +87,7 @@ import Cardano.Ledger.Core import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.Governance as SL +import Cardano.Ledger.Shelley.LedgerState (NewEpochState (..)) import qualified Cardano.Ledger.Shelley.LedgerState as SL import qualified Cardano.Ledger.State as SL import Cardano.Slotting.EpochInfo @@ -143,7 +144,6 @@ import Ouroboros.Consensus.Util.CBOR ) import Ouroboros.Consensus.Util.IndexedMemPack import Ouroboros.Consensus.Util.Versioned -import Cardano.Ledger.Shelley.LedgerState (NewEpochState(..)) {------------------------------------------------------------------------------- Config @@ -924,6 +924,6 @@ instance LedgerSupportsPeras (ShelleyBlock proto era) where getLatestPerasCertRound = strictMaybeToMaybe . shelleyLedgerLatestPerasCertRound - - getStakeDistr = + + getPoolDistr = nesPd . shelleyLedgerState diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs index 8641a37b90..ea6644bc5a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -18,18 +18,17 @@ import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) ) import Ouroboros.Consensus.Committee.WFALS (WFALS) +import Ouroboros.Consensus.Ledger.Extended (LedgerStateHeaderStateSupportsPerasVoting (..)) import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 +import qualified Ouroboros.Consensus.Peras.State.V1 as V1 import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 -import Ouroboros.Consensus.Protocol.Praos.Peras - ( PraosStateSupportsPerasVoting (..) - , praosStatePerasVotingCommitteeInputV1 - ) import Ouroboros.Consensus.Shelley.Ledger.Block ( ShelleyBlock , ShelleyCompatible ) +import Ouroboros.Consensus.Shelley.Ledger.Ledger () {------------------------------------------------------------------------------- BlockSupportsPeras @@ -60,6 +59,6 @@ instance instance ShelleyCompatible proto DijkstraEra => - PraosStateSupportsPerasVoting (ShelleyBlock proto DijkstraEra) + LedgerStateHeaderStateSupportsPerasVoting (ShelleyBlock proto DijkstraEra) where - praosStatePerasVotingCommitteeInput = praosStatePerasVotingCommitteeInputV1 + ledgerStateHeaderStateMkPerasVotingCommitteeInput = V1.ledgerStateHeaderStateMkPerasVotingCommitteeInput diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index 62371f4d6b..dc9e9d35f4 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -161,7 +161,7 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = (History.StandardSafeZone (safeFromTipA k)) (safeZoneB k) <*> pure (GenesisWindow ((unNonZero $ maxRollbacks k) * 2)) - <*> pure (History.PerasEnabled (perasRoundLength mkPerasParams)) + <*> pure (History.PerasEnabled (perasRoundLength defaultPerasParams)) shape :: History.Shape '[BlockA, BlockB] shape = History.Shape $ exactlyTwo eraParamsA eraParamsB diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs deleted file mode 100644 index b74b3bd2d7..0000000000 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Peras.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Voting interface for Peras derived from the Praos ledger view. --- --- [TODO EPOCH CONTEXT PLUMBING] -module Ouroboros.Consensus.Protocol.Praos.Peras - ( LedgerStateHeaderStateSupportsPerasVoting (..) - , ledgerStateHeaderStateMkPerasVotingCommitteeInputV1 - ) where - -import Data.Bifunctor (Bifunctor (..)) -import Ouroboros.Consensus.Block.Abstract (StandardHash) -import Ouroboros.Consensus.Block.SupportsPeras - ( BlockSupportsPeras (..) - , IsPerasError (..) - , PerasCrypto - , PerasParams - , PerasVotingCommittee - , PerasVotingCommitteeInput - , PerasVotingCommitteeScheme - ) -import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee) -import qualified Ouroboros.Consensus.Committee.Class as Committee -import Ouroboros.Consensus.Committee.Crypto (PublicKey) -import Ouroboros.Consensus.Committee.WFA - ( mkExtWFAStakeDistr - , wFATiebreakerWithEpochNonce - ) -import Ouroboros.Consensus.Committee.WFALS - ( VotingCommitteeInput (..) - , WFALS - ) -import Ouroboros.Consensus.HardFork.Combinator.Abstract (CanHardFork) -import Ouroboros.Consensus.HardFork.Combinator.Basics (HardForkBlock, LedgerState) -import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS -import Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe - ( unsafeExtendPerasStakeDistrWithPublicKeysFromEnv - ) -import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 -import Ouroboros.Consensus.Peras.Params (PerasParams (..)) -import Ouroboros.Consensus.Protocol.Praos - ( PraosState (..) - , Ticked (..), Praos - ) -import Ouroboros.Consensus.Protocol.Praos.Views (LedgerView (..)) -import Ouroboros.Consensus.HeaderValidation (HeaderState, headerStateChainDep) -import Ouroboros.Consensus.Block.Abstract (BlockProtocol) -import Cardano.Ledger.State (PoolDistr) -import Cardano.Ledger.BaseTypes (Nonce) -import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) -import Ouroboros.Consensus.HardFork.Combinator.Protocol (HardForkChainDepState) - -class - ( BlockSupportsPeras blk - , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) -- TODO remove this constraint when it becomes a superclass constraint of 'BlockSupportsPeras' - ) => - LedgerStateHeaderStateSupportsPerasVoting blk - where - ledgerStateHeaderStateMkPerasVotingCommitteeInput :: - PerasParams blk -> - LedgerState blk mk -> - HeaderState blk -> - Either - (PerasError blk) - (PerasVotingCommitteeInput blk) - - ledgerStateHeaderStateMkPerasVotingCommittee :: - PerasParams blk -> - LedgerState blk mk -> - HeaderState blk -> - Either - (PerasError blk) - (PerasVotingCommittee blk) - ledgerStateHeaderStateMkPerasVotingCommittee perasParams ledgerState headerState = do - committeeInput <- - ledgerStateHeaderStateMkPerasVotingCommitteeInput perasParams ledgerState headerState - bimap injectVotingCommitteeError id $ - Committee.mkVotingCommittee committeeInput - -ledgerStateHeaderStateMkPerasVotingCommitteeInputV1 :: - (PublicKey crypto ~ BLS.PerasPublicKey) => - (LedgerState blk mk -> PoolDistr) -> - (ChainDepState (BlockProtocol blk) -> Nonce) -> - PerasParams blk -> - LedgerState blk mk -> - HeaderState blk -> - Either (V1.PerasError blk) (VotingCommitteeInput crypto WFALS) -ledgerStateHeaderStateMkPerasVotingCommitteeInputV1 extractPoolDistr extractEpochNonce perasParams ledgerState headerState = do - let epochNonce = extractEpochNonce . headerStateChainDep $ headerState - poolDistr = extractPoolDistr ledgerState - -- TODO: replace the following hack with proper on-chain key registration. - stakeDistrWithPublicKeys <- - bimap V1.PerasTemporaryPublicKeyHackError id $ - unsafeExtendPerasStakeDistrWithPublicKeysFromEnv poolDistr - extWFAStakeDistr <- - bimap V1.PerasVotingWFAError id $ - mkExtWFAStakeDistr - (wFATiebreakerWithEpochNonce epochNonce) - stakeDistrWithPublicKeys - pure $ - WFALSVotingCommitteeInput - epochNonce - (perasTargetCommitteeSize perasParams) - extWFAStakeDistr - -instance - ( StandardHash (HardForkBlock xs) - , CanHardFork xs - ) => - LedgerStateHeaderStateSupportsPerasVoting (HardForkBlock xs) - where - ledgerStateHeaderStateMkPerasVotingCommitteeInput = ledgerStateHeaderStateMkPerasVotingCommitteeInputV1 extractPoolDistr extractEpochNonce where - extractPoolDistr :: LedgerState (HardForkBlock xs) mk -> PoolDistr - extractPoolDistr = undefined - - extractEpochNonce :: HardForkChainDepState xs -> Nonce - extractEpochNonce = undefined diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs index d86ff4279c..d3ff161a34 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs @@ -300,6 +300,8 @@ data instance Ticked TPraosState = TickedChainDepState , tickedTPraosStateLedgerView :: SL.LedgerView } +instance ChainDepStateSupportsPeras (TPraos c) + instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where type ChainDepState (TPraos c) = TPraosState type IsLeader (TPraos c) = TPraosIsLeader c diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 453eecb795..b734c9cfb9 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -248,6 +248,8 @@ library Ouroboros.Consensus.Peras.Error.Mock Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView + Ouroboros.Consensus.Peras.State.Mock + Ouroboros.Consensus.Peras.State.V1 Ouroboros.Consensus.Peras.Types Ouroboros.Consensus.Peras.Vote.Aggregation Ouroboros.Consensus.Peras.Vote.Mock @@ -964,7 +966,6 @@ library protocol Ouroboros.Consensus.Protocol.Praos.AgentClient Ouroboros.Consensus.Protocol.Praos.Common Ouroboros.Consensus.Protocol.Praos.Header - Ouroboros.Consensus.Protocol.Praos.Peras Ouroboros.Consensus.Protocol.Praos.Views Ouroboros.Consensus.Protocol.Praos.VRF Ouroboros.Consensus.Protocol.TPraos diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index 3790d50566..809cf597b6 100644 --- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs +++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs @@ -27,6 +27,9 @@ import Ouroboros.Consensus.Config import qualified Ouroboros.Consensus.HardFork.History as HardFork import qualified Ouroboros.Consensus.HeaderStateHistory as HeaderStateHistory import qualified Ouroboros.Consensus.HeaderValidation as HV +import Ouroboros.Consensus.Ledger.Extended + ( ledgerStateHeaderStateMkConstPerasEpochContextResolverForMock + ) import qualified Ouroboros.Consensus.Ledger.Extended as Extended import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck @@ -201,8 +204,7 @@ inTheYearOneBillion = oracularLedgerDB :: Point B -> Extended.ExtLedgerState B mk oracularLedgerDB p = - Extended.ExtLedgerState - { Extended.headerState = + let headerState = HV.HeaderState { HV.headerStateTip = case pointToWithOriginRealPoint p of Origin -> Origin @@ -216,15 +218,21 @@ oracularLedgerDB p = } , HV.headerStateChainDep = () } - , Extended.ledgerState = + ledgerState = TB.TestLedger { TB.lastAppliedPoint = p , TB.payloadDependentState = TB.EmptyPLDS } - , Extended.perasEpochContextResolver = - -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - undefined - } + in Extended.ExtLedgerState + { Extended.headerState = + headerState + , Extended.ledgerState = + ledgerState + , Extended.perasEpochContextResolver = + ledgerStateHeaderStateMkConstPerasEpochContextResolverForMock + ledgerState + headerState + } -- | A convenient fact about 'TB.TestBlock' testBlockHashBlockNo :: TB.TestHash -> BlockNo diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index b563420165..6a654fd87e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -267,10 +267,10 @@ instance CanHardFork xs => LedgerSupportsPeras (HardForkBlock xs) where . hcmap proxySingle (K . getLatestPerasCertRound . unFlip) . State.tip . hardForkLedgerStatePerEra - - getStakeDistr = + + getPoolDistr = hcollapse - . hcmap proxySingle (K . getStakeDistr . unFlip) + . hcmap proxySingle (K . getPoolDistr . unFlip) . State.tip . hardForkLedgerStatePerEra diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs index de58b11edf..1170a1c93b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs @@ -294,7 +294,7 @@ answerBlockQueryHelper distribExtLedgerState :: All SingleEraBlock xs => ExtLedgerState (HardForkBlock xs) mk -> NS (Flip ExtLedgerState mk) xs -distribExtLedgerState (ExtLedgerState ledgerState headerState perasResolver) = +distribExtLedgerState (ExtLedgerState ledgerState headerState _perasResolver) = hmap (\(Pair hst lst) -> Flip $ ExtLedgerState (unFlip lst) hst perasResolver') $ mustMatchNS "HeaderState" diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs index 549c01a5d6..0e95736ea8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -10,7 +11,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE InstanceSigs #-} module Ouroboros.Consensus.HardFork.Combinator.Protocol ( HardForkTiebreakerView (..) @@ -29,6 +29,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Protocol , Ticked (..) ) where +import Cardano.Ledger.BaseTypes (Nonce) import Control.Monad.Except import Data.Functor.Product import Data.SOP.BasicFunctors @@ -56,14 +57,13 @@ import Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView ) import Ouroboros.Consensus.HardFork.Combinator.State ( HardForkState - , Translate (..), getHardForkState + , Translate (..) ) import qualified Ouroboros.Consensus.HardFork.Combinator.State as State import Ouroboros.Consensus.HardFork.Combinator.Translation as HFTranslation import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util ((.:)) -import qualified Data.SOP.Telescope as Tele {------------------------------------------------------------------------------- ChainSelection @@ -130,12 +130,15 @@ instance CanHardFork xs => ConsensusProtocol (HardForkProtocol xs) where -- Security parameter must be equal across /all/ eras protocolSecurityParam = hardForkConsensusConfigK -instance ChainDepStateSupportsPeras (HardForkProtocol xs) where - getEpochNonce _ = hcollapse - -- [TODO EPOCH CONTEXT PLUMBING] STOPPED THERE - . hcmap proxySingle (K . getEpochNonce . unwrapChainDepState . hmap currentState) - . Tele.tip - . getHardForkState +instance CanHardFork xs => ChainDepStateSupportsPeras (HardForkProtocol xs) where + getEpochNonce _ = + hcollapse + . hcmap proxySingle getEpochNonce' + . State.tip + where + getEpochNonce' :: forall blk. SingleEraBlock blk => WrapChainDepState blk -> K Nonce blk + getEpochNonce' (WrapChainDepState st) = + K (getEpochNonce (Proxy @(BlockProtocol blk)) st) {------------------------------------------------------------------------------- BlockSupportsProtocol diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs index 3300b7df1b..1b65b3f47d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DefaultSignatures #-} {- HLINT ignore "Unused LANGUAGE pragma" -} -- False hint on TypeOperators {-# LANGUAGE DeriveAnyClass #-} @@ -31,27 +32,40 @@ module Ouroboros.Consensus.Ledger.Extended -- * Type family instances , LedgerTables (..) , Ticked (..) + + -- * Peras support + , LedgerStateHeaderStateSupportsPerasVoting (..) + + -- * Peras helpers for blocks using mock/void peras committee/crypto + , ledgerStateHeaderStateMkConstPerasEpochContextResolver + , ledgerStateHeaderStateMkConstPerasEpochContextResolverDischargeVoid + , ledgerStateHeaderStateMkConstPerasEpochContextResolverForMock ) where import Codec.CBOR.Decoding (Decoder, decodeListLenOf) import Codec.CBOR.Encoding (Encoding, encodeListLen) import Control.DeepSeq (NFData) import Control.Monad.Except +import Data.Bifunctor (Bifunctor (bimap)) import Data.Functor ((<&>)) import Data.Proxy import Data.Typeable +import Data.Void (absurd) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee) +import qualified Ouroboros.Consensus.Committee.Class as Committee import Ouroboros.Consensus.Config import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Peras.Context - ( PerasEpochContextResolver + ( PerasEpochContextResolver (ConstPerasEpochContextResolver) , PerasEpochContextResolverHandle (..) ) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.IOLike (MonadSTM (STM)) @@ -413,3 +427,82 @@ instance LedgerTablesAreTrivial LedgerState blk => LedgerTablesAreTrivial ExtLed instance SerializeTablesWithHint LedgerState blk => SerializeTablesWithHint ExtLedgerState blk where decodeTablesWithHint st = decodeTablesWithHint (ledgerState st) encodeTablesWithHint st tbs = encodeTablesWithHint (ledgerState st) tbs + +------------------------------------------------------------------------------- +-- Peras support +------------------------------------------------------------------------------- + +class + ( BlockSupportsPeras blk + , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) -- TODO remove this constraint when it becomes a superclass constraint of 'BlockSupportsPeras' + ) => + LedgerStateHeaderStateSupportsPerasVoting blk + where + ledgerStateHeaderStateMkPerasVotingCommitteeInput :: + PerasParams blk -> + LedgerState blk mk -> + HeaderState blk -> + Either + (PerasError blk) + (PerasVotingCommitteeInput blk) + + ledgerStateHeaderStateMkPerasVotingCommittee :: + PerasParams blk -> + LedgerState blk mk -> + HeaderState blk -> + Either + (PerasError blk) + (PerasVotingCommittee blk) + ledgerStateHeaderStateMkPerasVotingCommittee perasParams ledgerState headerState = do + committeeInput <- + ledgerStateHeaderStateMkPerasVotingCommitteeInput perasParams ledgerState headerState + bimap injectVotingCommitteeError id $ + Committee.mkVotingCommittee committeeInput + + ledgerStateHeaderStateMkPerasEpochContext :: + LedgerState blk mk -> + HeaderState blk -> + Either + (PerasError blk) + (PerasEpochContext blk) + default ledgerStateHeaderStateMkPerasEpochContext :: + PerasEpochContext blk ~ DefaultPerasEpochContext blk => + LedgerState blk mk -> + HeaderState blk -> + Either + (PerasError blk) + (PerasEpochContext blk) + ledgerStateHeaderStateMkPerasEpochContext ledgerState headerState = do + let dpecParams = defaultPerasParams + dpecCommittee <- ledgerStateHeaderStateMkPerasVotingCommittee dpecParams ledgerState headerState + pure $ DefaultPerasEpochContext{dpecParams, dpecCommittee} + +ledgerStateHeaderStateMkConstPerasEpochContextResolver :: + LedgerStateHeaderStateSupportsPerasVoting blk => + LedgerState blk mk -> + HeaderState blk -> + Either + (PerasError blk) + (PerasEpochContextResolver blk) +ledgerStateHeaderStateMkConstPerasEpochContextResolver ledgerState headerState = + ConstPerasEpochContextResolver <$> ledgerStateHeaderStateMkPerasEpochContext ledgerState headerState + +ledgerStateHeaderStateMkConstPerasEpochContextResolverForMock :: + (LedgerStateHeaderStateSupportsPerasVoting blk, PerasError blk ~ MockPerasError blk) => + LedgerState blk mk -> + HeaderState blk -> + PerasEpochContextResolver blk +ledgerStateHeaderStateMkConstPerasEpochContextResolverForMock ledgerState headerState = + case ledgerStateHeaderStateMkConstPerasEpochContextResolver ledgerState headerState of + Left mockErr -> error ("mkVotingCommittee for MockPerasCommittee should never fail, but got: " ++ show mockErr) + Right resolver -> resolver + +ledgerStateHeaderStateMkConstPerasEpochContextResolverDischargeVoid :: + (LedgerStateHeaderStateSupportsPerasVoting blk, PerasError blk ~ VoidPerasError blk) => + LedgerState blk mk -> + HeaderState blk -> + PerasEpochContextResolver blk +ledgerStateHeaderStateMkConstPerasEpochContextResolverDischargeVoid ledgerState headerState = + case ledgerStateHeaderStateMkConstPerasEpochContextResolver ledgerState headerState of + Left (VoidPerasError void) -> absurd void + Right resolver -> resolver diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs index 603e68554f..f8874168e7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeras.hs @@ -1,17 +1,17 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} module Ouroboros.Consensus.Ledger.SupportsPeras ( LedgerSupportsPeras (..) ) where -import Ouroboros.Consensus.Block.SupportsPeras (PerasRoundNo) -import Ouroboros.Consensus.Ledger.Abstract (LedgerState) -import Cardano.Ledger.State (PoolDistr (..)) import Cardano.Ledger.Coin (knownNonZeroCoin) +import Cardano.Ledger.State (PoolDistr (..)) import qualified Data.Map as Map +import Ouroboros.Consensus.Block.SupportsPeras (PerasRoundNo) +import Ouroboros.Consensus.Ledger.Abstract (LedgerState) -- | Extract Peras information stored in the ledger state class LedgerSupportsPeras blk where @@ -25,10 +25,11 @@ class LedgerSupportsPeras blk where -- | Extract the stake distribution from the given ledger state. -- PRECONDITION: this function will only return a meaningful result if the -- ledger state is from a block that supports Peras - getStakeDistr :: LedgerState blk mk -> PoolDistr - default getStakeDistr :: LedgerState blk mk -> PoolDistr - -- NOTE: this is a bit of a hack for blocks that do not really support Peras. - getStakeDistr _ = PoolDistr { - unPoolDistr = Map.empty, - pdTotalActiveStake = knownNonZeroCoin @1 - } + getPoolDistr :: LedgerState blk mk -> PoolDistr + default getPoolDistr :: LedgerState blk mk -> PoolDistr + -- NOTE: this is a bit of a hack for blocks that do not really support Peras. + getPoolDistr _ = + PoolDistr + { unPoolDistr = Map.empty + , pdTotalActiveStake = knownNonZeroCoin @1 + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs index 0601019b42..c8f74bd022 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs @@ -8,7 +8,7 @@ {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Peras.Context - ( PerasEpochContextResolver + ( PerasEpochContextResolver (ConstPerasEpochContextResolver) , BoundedPerasEpochContext (..) , resolveRoundNo , PerasEpochContextNotFoundForRound (..) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs index 5641a1ac40..fff9c1537d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Error/Mock.hs @@ -32,6 +32,7 @@ data MockPerasError blk PerasConversionError | PerasQuorumNotReachedError VoteWeight + | InputStakeDistrIsEmpty deriving instance Show (PerasVotingCommitteeError blk) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs index 5e5c2538c0..0886f360c1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs @@ -19,7 +19,7 @@ module Ouroboros.Consensus.Peras.Params -- * Protocol parameters bundle , PerasParams (..) - , mkPerasParams + , defaultPerasParams -- * Convenience re-exports , Committee.TargetCommitteeSize (..) @@ -140,8 +140,8 @@ data PerasParams blk = PerasParams -- | Instantiate default Peras protocol parameters. -- -- NOTE: in the future this will depend on a concrete 'BlockConfig'. -mkPerasParams :: PerasParams blk -mkPerasParams = +defaultPerasParams :: PerasParams blk +defaultPerasParams = -- Many of these parameters are provided with sensible default values for now, -- waiting for a final decision (in a future stage of the project) on the -- exact values to use. See https://github.com/tweag/cardano-peras/issues/97. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/Mock.hs new file mode 100644 index 0000000000..0fb346d416 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/Mock.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.Peras.State.Mock (ledgerStateHeaderStateMkMockPerasVotingCommitteeInput) where + +import Cardano.Ledger.State (IndividualPoolStake (individualPoolStake), PoolDistr (..)) +import Cardano.Prelude (maybeToEither) +import Data.Bifunctor (Bifunctor (..)) +import Data.List.NonEmpty (nonEmpty) +import qualified Data.Map as Map +import Ouroboros.Consensus.Block.SupportsPeras (PerasParams (..)) +import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) +import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId (..)) +import Ouroboros.Consensus.HardFork.Combinator.Basics (LedgerState) +import Ouroboros.Consensus.HeaderValidation (HeaderState (..)) +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) +import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCommittee, VotingCommitteeInput (..)) +import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError (..)) + +-- | NOTE: this function will return an error on an empty stake distr, which is what the default instance of 'LedgerSupportsPeras' returns. +ledgerStateHeaderStateMkMockPerasVotingCommitteeInput :: + forall blk mk crypto. + LedgerSupportsPeras blk => + PerasParams blk -> + LedgerState blk mk -> + HeaderState blk -> + Either (MockPerasError blk) (VotingCommitteeInput crypto (MockPerasCommittee blk)) +ledgerStateHeaderStateMkMockPerasVotingCommitteeInput _perasParams ledgerState _headerState = do + let PoolDistr{unPoolDistr} = getPoolDistr ledgerState + stakeDistr = nonEmpty $ fmap (bimap PoolId (LedgerStake . individualPoolStake)) . Map.toList $ unPoolDistr + MockPerasVotingCommitteeInput <$> maybeToEither InputStakeDistrIsEmpty stakeDistr diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/V1.hs new file mode 100644 index 0000000000..1f0ebd1586 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/V1.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Ouroboros.Consensus.Peras.State.V1 (ledgerStateHeaderStateMkPerasVotingCommitteeInput) where + +import Data.Bifunctor (Bifunctor (..)) +import Data.Proxy (Proxy (..)) +import Ouroboros.Consensus.Block.Abstract (BlockProtocol) +import Ouroboros.Consensus.Block.SupportsPeras (PerasParams (..)) +import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) +import Ouroboros.Consensus.Committee.Crypto (PublicKey) +import Ouroboros.Consensus.Committee.WFA (mkExtWFAStakeDistr, wFATiebreakerWithEpochNonce) +import Ouroboros.Consensus.Committee.WFALS (VotingCommitteeInput (..), WFALS) +import Ouroboros.Consensus.HardFork.Combinator.Basics (LedgerState) +import Ouroboros.Consensus.HeaderValidation (HeaderState (..)) +import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) +import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS +import Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe + ( unsafeExtendPerasStakeDistrWithPublicKeysFromEnv + ) +import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 +import Ouroboros.Consensus.Protocol.Abstract (ChainDepStateSupportsPeras (..)) + +ledgerStateHeaderStateMkPerasVotingCommitteeInput :: + forall blk mk crypto. + ( PublicKey crypto ~ BLS.PerasPublicKey + , LedgerSupportsPeras blk + , ChainDepStateSupportsPeras (BlockProtocol blk) + ) => + PerasParams blk -> + LedgerState blk mk -> + HeaderState blk -> + Either (V1.PerasError blk) (VotingCommitteeInput crypto WFALS) +ledgerStateHeaderStateMkPerasVotingCommitteeInput perasParams ledgerState headerState = do + let epochNonce = getEpochNonce (Proxy @(BlockProtocol blk)) . headerStateChainDep $ headerState + poolDistr = getPoolDistr ledgerState + -- TODO: replace the following hack with proper on-chain key registration. + stakeDistrWithPublicKeys <- + bimap V1.PerasTemporaryPublicKeyHackError id $ + unsafeExtendPerasStakeDistrWithPublicKeysFromEnv poolDistr + extWFAStakeDistr <- + bimap V1.PerasVotingWFAError id $ + mkExtWFAStakeDistr + (wFATiebreakerWithEpochNonce epochNonce) + stakeDistrWithPublicKeys + pure $ + WFALSVotingCommitteeInput + epochNonce + (perasTargetCommitteeSize perasParams) + extWFAStakeDistr diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs index 6488279f6a..c6b79aa498 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} @@ -8,7 +9,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DefaultSignatures #-} module Ouroboros.Consensus.Protocol.Abstract ( -- * Abstract definition of the Ouroboros protocol @@ -36,6 +36,7 @@ module Ouroboros.Consensus.Protocol.Abstract , SecurityParam (..) ) where +import Cardano.Ledger.BaseTypes (Nonce (NeutralNonce)) import Cardano.Slotting.Slot (WithOrigin (At)) import Control.Monad.Except import Data.Function (on) @@ -48,7 +49,6 @@ import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.Ticked -import Cardano.Ledger.BaseTypes (Nonce (NeutralNonce)) -- | Static configuration required to run the consensus protocol -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/BFT.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/BFT.hs index a6bdc94378..76c416262c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/BFT.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/BFT.hs @@ -125,6 +125,8 @@ data instance ConsensusConfig (Bft c) = BftConfig } deriving Generic +instance ChainDepStateSupportsPeras (Bft c) + instance BftCrypto c => ConsensusProtocol (Bft c) where type ValidationErr (Bft c) = BftValidationErr type ValidateView (Bft c) = BftValidateView c diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/ModChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/ModChainSel.hs index 07e0dc3964..ad3cfd3aab 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/ModChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/ModChainSel.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Ouroboros.Consensus.Protocol.ModChainSel @@ -9,7 +11,7 @@ module Ouroboros.Consensus.Protocol.ModChainSel , ConsensusConfig (..) ) where -import Data.Typeable (Typeable) +import Data.Typeable (Proxy (..), Typeable) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Protocol.Abstract @@ -21,6 +23,9 @@ newtype instance ConsensusConfig (ModChainSel p t) = McsConsensusConfig } deriving Generic +instance ChainDepStateSupportsPeras p => ChainDepStateSupportsPeras (ModChainSel p t) where + getEpochNonce (_ :: proxy (ModChainSel p t)) = getEpochNonce (Proxy @p) + instance ( ConsensusProtocol p , ChainOrder t diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs index d2841ef109..53ae9c6101 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs @@ -286,6 +286,8 @@ data instance Ticked (PBftState c) = TickedPBftState , getTickedPBftState :: PBftState c } +instance ChainDepStateSupportsPeras (PBft c) + instance PBftCrypto c => ConsensusProtocol (PBft c) where type ValidationErr (PBft c) = PBftValidationErr c type ValidateView (PBft c) = PBftValidateView c diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index 1de05e2d7a..564e92e455 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -803,7 +803,7 @@ mkTestConfig k ChunkSize{chunkCanContainEBB, numRegularBlocks} = , eraSlotLength = slotLength , eraSafeZone = HardFork.StandardSafeZone (unNonZero (maxRollbacks k) * 2) , eraGenesisWin = GenesisWindow (unNonZero (maxRollbacks k) * 2) - , eraPerasRoundLength = HardFork.PerasEnabled (perasRoundLength mkPerasParams) + , eraPerasRoundLength = HardFork.PerasEnabled (perasRoundLength defaultPerasParams) } instance ImmutableEraParams TestBlock where diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Cert/Inclusion.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Cert/Inclusion.hs index 0c3aac5c94..fa42980fb4 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Cert/Inclusion.hs @@ -27,7 +27,7 @@ import Ouroboros.Consensus.Block.SupportsPeras , PerasCertMaxRounds (..) , PerasParams (..) , PerasRoundNo (..) - , mkPerasParams + , defaultPerasParams ) import Ouroboros.Consensus.Peras.Cert.Inclusion ( LatestCertOnChainView (..) @@ -209,7 +209,7 @@ genPerasParams :: Gen (PerasParams blk) genPerasParams = do _A <- fromIntegral . (+ 1) <$> geometric 0.5 pure - mkPerasParams + defaultPerasParams { perasCertMaxRounds = PerasCertMaxRounds _A } diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs index 3047a295a7..3ffd1e4d24 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Internal.hs @@ -22,7 +22,7 @@ import Data.Containers.ListUtils (nubOrdOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Word (Word64) -import Ouroboros.Consensus.Block.SupportsPeras (PerasParams, PerasRoundNo (..), mkPerasParams) +import Ouroboros.Consensus.Block.SupportsPeras (PerasParams, PerasRoundNo (..), defaultPerasParams) import Ouroboros.Consensus.BlockchainTime (RelativeTime (..), SystemTime (..), WithArrivalTime (..)) import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId) import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) @@ -34,7 +34,7 @@ import Test.Util.Committee (mkPoolId) import Test.Util.TestBlock (TestBlock, TestHash (..)) genPerasParams :: Gen (PerasParams blk) -genPerasParams = pure mkPerasParams +genPerasParams = pure defaultPerasParams genRoundNo :: Gen PerasRoundNo genRoundNo = PerasRoundNo <$> arbitrary diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index 5053096e3d..4da6bd8691 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -148,6 +148,7 @@ import Ouroboros.Consensus.Peras.Cert.Mock import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCommittee, MockPerasCrypto) import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) import Ouroboros.Consensus.Peras.SelectView (weightedSelectView) +import Ouroboros.Consensus.Peras.State.Mock (ledgerStateHeaderStateMkMockPerasVotingCommitteeInput) import Ouroboros.Consensus.Peras.Vote.Mock ( MockPerasVote (..) ) @@ -703,6 +704,12 @@ instance PayloadSemantics ptype => LedgerSupportsProtocol (TestBlockWith ptype) constantForecastInRange (strictMaybeToMaybe (tblcForecastRange cfg)) () (getTipSlot state) instance LedgerSupportsPeras (TestBlockWith ptype) +instance Typeable ptype => LedgerStateHeaderStateSupportsPerasVoting (TestBlockWith ptype) where + -- TODO: this will blow up if we actually try to use it + -- Potential solutions: + -- 1. have an extra type parameter indicating if Peras support is expected for this instance of TestBlock, and choose between mock/void crypto depending on that + -- 2. extend LedgerState for 'TestBlock' to provide a non-default instance of 'LedgerSupportsPeras', i.e. return a non-empty stake distribution + ledgerStateHeaderStateMkPerasVotingCommitteeInput = ledgerStateHeaderStateMkMockPerasVotingCommitteeInput {------------------------------------------------------------------------------- BlockSupportsPeras diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs index 06de6da25b..1144ad2a69 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs @@ -35,6 +35,8 @@ data instance ConsensusConfig (WithLeaderSchedule p) = WLSConfig } deriving Generic +instance ChainDepStateSupportsPeras (WithLeaderSchedule p) + instance ConsensusProtocol p => ConsensusProtocol (WithLeaderSchedule p) where type TiebreakerView (WithLeaderSchedule p) = TiebreakerView p diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs index 849c1dbaa8..0f71f4e15a 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs @@ -568,6 +568,8 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where } in PraosChainDepState $ bi : praosHistory cds +instance ChainDepStateSupportsPeras (Praos c) + -- (Standard) Praos uses the standard chain selection rule, so no need to -- override (though see note regarding clock skew). diff --git a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs index ea4ec99d4a..e82ff54dcb 100644 --- a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs +++ b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs @@ -51,7 +51,7 @@ First, some imports we'll need: > Header, StorageConfig, ChainHash, HasHeader(..), HeaderFields(..), > HeaderHash, Point, StandardHash) > import Ouroboros.Consensus.Protocol.Abstract -> (SecurityParam(..), ConsensusConfig, ConsensusProtocol(..), NoTiebreaker(..)) +> (SecurityParam(..), ConsensusConfig, ConsensusProtocol(..), NoTiebreaker(..), ChainDepStateSupportsPeras) > import Ouroboros.Consensus.Ticked ( Ticked, Ticked(TickedTrivial) ) > import Ouroboros.Consensus.Block > (BlockSupportsProtocol (tiebreakerView, validateView), BlockSupportsPeras) @@ -134,6 +134,7 @@ simple one here: Next, we instantiate the `ConsensusProtocol` for `SP`: +> instance ChainDepStateSupportsPeras SP > instance ConsensusProtocol SP where > type TiebreakerView SP = NoTiebreaker diff --git a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs index 70ba91d251..1bdc6a8d2e 100644 --- a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs +++ b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs @@ -96,7 +96,8 @@ And imports, of course: > import Ouroboros.Consensus.Ledger.Tables.Utils > import Ouroboros.Consensus.Util.IndexedMemPack - +> import Ouroboros.Consensus.Protocol.Abstract (ChainDepStateSupportsPeras) + Epochs ------ @@ -526,6 +527,8 @@ of `ConsensusProtocol PrtclD` we will represent the epoch snapshot using the Now we can instantiate `ConsensusProtocol PrtclD` proper with the types and functions defined above: +> instance ChainDepStateSupportsPeras PrtclD where + > instance ConsensusProtocol PrtclD where > type ChainDepState PrtclD = ChainDepStateD diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs index 8077e92bb6..c4da8cd404 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Cert/Inclusion.hs @@ -27,7 +27,7 @@ import Ouroboros.Consensus.Block.SupportsPeras , PerasCertMaxRounds (..) , PerasParams (..) , PerasRoundNo (..) - , mkPerasParams + , defaultPerasParams ) import Ouroboros.Consensus.Peras.Cert.Inclusion ( LatestCertOnChainView (..) @@ -209,7 +209,7 @@ genPerasParams :: Gen (PerasParams blk) genPerasParams = do _A <- fromIntegral . (+ 1) <$> geometric 0.5 pure - mkPerasParams + defaultPerasParams { perasCertMaxRounds = PerasCertMaxRounds _A } diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs index 40d6781f80..f6bfbe722f 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs @@ -30,7 +30,7 @@ import Ouroboros.Consensus.Block.SupportsPeras , PerasIgnoranceRounds (..) , PerasParams (..) , PerasRoundNo (..) - , mkPerasParams + , defaultPerasParams , onPerasRoundNo ) import Ouroboros.Consensus.BlockchainTime @@ -226,7 +226,7 @@ genPerasParams = do _R <- fromIntegral . (+ 1) <$> geometric 0.5 _K <- fromIntegral . (+ 1) <$> geometric 0.5 pure - mkPerasParams + defaultPerasParams { perasBlockMinSlots = PerasBlockMinSlots _L , perasCertArrivalThreshold = PerasCertArrivalThreshold _X , perasIgnoranceRounds = PerasIgnoranceRounds _R diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 678aa5155f..573d7d2d73 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -447,7 +447,7 @@ empty loe initLedger = { volatileDbBlocks = Map.empty , immutableDbChain = Chain.Genesis , perasCertModel = PerasCertDBModel.openDB PerasCertDBModel.initModel - , perasVoteModel = PerasVoteDBModel.openDB (PerasVoteDBModel.initModel mkPerasParams) + , perasVoteModel = PerasVoteDBModel.openDB (PerasVoteDBModel.initModel defaultPerasParams) , cps = CPS.initChainProducerState Chain.Genesis , currentLedger = initLedger , initLedger = initLedger @@ -1232,7 +1232,7 @@ wipeVolatileDB cfg m = (closeDB m) { volatileDbBlocks = Map.empty , perasCertModel = PerasCertDBModel.openDB PerasCertDBModel.initModel - , perasVoteModel = PerasVoteDBModel.openDB (PerasVoteDBModel.initModel mkPerasParams) + , perasVoteModel = PerasVoteDBModel.openDB (PerasVoteDBModel.initModel defaultPerasParams) , cps = CPS.switchFork newChain (cps m) , currentLedger = newLedger , invalid = Map.empty diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index 7c5d1f4790..51da6bf2a1 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -56,7 +56,7 @@ tests = ] perasTestParams :: PerasParams blk -perasTestParams = mkPerasParams +perasTestParams = defaultPerasParams prop_qd :: Actions Model -> Property prop_qd actions = QC.monadic f $ property () <$ runActions actions diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index 71ac76651b..f54db01e43 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -47,7 +47,7 @@ import Ouroboros.Consensus.Block.SupportsPeras , ValidatedPerasCert , ValidatedPerasVote (..) , VoteWeight (..) - , mkPerasParams + , defaultPerasParams ) import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) @@ -105,7 +105,7 @@ tests = ] perasTestParams :: PerasParams blk -perasTestParams = mkPerasParams +perasTestParams = defaultPerasParams prop_qd :: Actions Model -> Property prop_qd actions = monadic runActualImplemMonad resultAsPropertyM From 7c87cd5da66f46ff4fa16fb50208c114dd160f39 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 3 Jun 2026 13:56:58 +0200 Subject: [PATCH 52/62] Add private key reader from env hack --- .../Consensus/Peras/Crypto/BLS/Unsafe.hs | 44 +++++++++++++++---- 1 file changed, 36 insertions(+), 8 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs index a29990e611..1b2725f384 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS/Unsafe.hs @@ -1,15 +1,22 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} --- | Temporary hack for retrieving BLS public keys from a JSON file specified --- in the environment variable 'PERAS_PUBLIC_KEY_FILE'. +-- | Temporary hack for retrieving BLS keys from the environment. +-- +-- * Our private key can be read directly from the value of the environment +-- variable 'PERAS_PRIVATE_KEY'. +-- +-- * Public keys from all nodes (including oneself) can be read from a JSON file +-- specified in the environment variable 'PERAS_PUBLIC_KEY_FILE'. +-- +-- NOTE: keys read using this module always have the "TESTNET" scope. -- -- WARNING: this is a temporary hack for testing purposes, and should not be -- used under any circumstances in production. This will be replaced with proper -- on-chain key registration in the future. module Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe - ( unsafeExtendPerasStakeDistrWithPublicKeysFromEnv + ( unsafePerasBLSPrivateKeyFromEnv + , unsafeExtendPerasStakeDistrWithPublicKeysFromEnv , unsafePerasBLSPublicKeysFromEnv ) where @@ -20,10 +27,34 @@ import qualified Data.Map.Strict as Map import Data.String (IsString (..)) import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId (..)) -import Ouroboros.Consensus.Peras.Crypto.BLS (PerasPublicKey (..)) +import Ouroboros.Consensus.Peras.Crypto.BLS (PerasPrivateKey (..), PerasPublicKey (..)) import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) +keyScope :: BLS.KeyScope +keyScope = "TESTNET" + +-- | Read a private key from the environment variable 'PERAS_PRIVATE_KEY' +unsafePerasBLSPrivateKeyFromEnv :: Either String PerasPrivateKey +unsafePerasBLSPrivateKeyFromEnv = + unsafePerformIO $ + lookupEnv envVar >>= \case + Nothing -> do + pure $ Left $ "Environment variable " <> envVar <> "not set." + Just rawKey -> do + pure $ decodeKey rawKey + where + envVar = + "PERAS_PRIVATE_KEY" + + decodeKey key = + case BLS.rawDeserialisePrivateKey keyScope (fromString key) of + Nothing -> + Left $ "Invalid private key format: " <> key + Just sk -> + Right $ PerasPrivateKey sk +{-# NOINLINE unsafePerasBLSPrivateKeyFromEnv #-} + -- | Extend a given 'PoolDistr' with the corresponding BLS public keys for each -- pool retrieved from the JSON file specified in the environment variable -- 'PERAS_PUBLIC_KEY_FILE'. @@ -74,9 +105,6 @@ unsafePerasBLSPublicKeysFromEnv = envVar = "PERAS_PUBLIC_KEY_FILE" - keyScope = - "TESTNET" - decodeKey key = case BLS.rawDeserialisePublicKey keyScope (fromString key) of Nothing -> From 145372481a961ee351cfe57c8b8ce59b6ebfc946 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 3 Jun 2026 16:23:14 +0200 Subject: [PATCH 53/62] Improve PerasEpochContextResolver/LedgerStateHeaderStateSupportsPerasVoting design --- .../Consensus/Byron/Ledger/Ledger.hs | 3 +- .../byron/Ouroboros/Consensus/Byron/Node.hs | 23 +- .../Ouroboros/Consensus/Byron/Node/Peras.hs | 3 + .../Ouroboros/Consensus/Cardano/Node.hs | 17 +- .../Consensus/Shelley/Ledger/Block.hs | 2 + .../Ouroboros/Consensus/Shelley/Node/Peras.hs | 49 ++- .../Consensus/Shelley/Node/TPraos.hs | 17 +- .../Ouroboros/Consensus/ByronDual/Ledger.hs | 7 - .../Ouroboros/Consensus/ByronDual/Node.hs | 15 +- .../Test/Consensus/Byron/Examples.hs | 16 +- .../Cardano/Tools/DBAnalyser/Analysis.hs | 20 +- .../Cardano/Tools/DBAnalyser/Run.hs | 2 + .../Test/Consensus/Shelley/Examples.hs | 26 +- .../Ouroboros/Consensus/Network/NodeToNode.hs | 2 + .../Test/Consensus/Genesis/Setup.hs | 3 + .../Test/Consensus/Genesis/TestSuite.hs | 2 + .../Test/Consensus/HardFork/Combinator.hs | 17 +- .../Test/Consensus/HardFork/Combinator/A.hs | 3 + .../Test/Consensus/HardFork/Combinator/B.hs | 3 + .../Consensus/PeerSimulator/NodeLifecycle.hs | 4 + .../Test/Consensus/PeerSimulator/Run.hs | 3 + ouroboros-consensus.cabal | 1 + .../bench/ChainSync-client-bench/Main.hs | 8 +- .../Consensus/Block/SupportsPeras.hs | 1 + .../Consensus/HardFork/Combinator/Basics.hs | 14 +- .../HardFork/Combinator/Embed/Binary.hs | 22 +- .../HardFork/Combinator/Embed/Nary.hs | 20 +- .../HardFork/Combinator/Embed/Unary.hs | 14 +- .../HardFork/Combinator/Ledger/Query.hs | 2 +- .../Consensus/HardFork/Combinator/Protocol.hs | 30 ++ .../Ouroboros/Consensus/Ledger/Dual.hs | 11 + .../Ouroboros/Consensus/Ledger/Extended.hs | 119 +------ .../ObjectDiffusion/ObjectPool/PerasCert.hs | 8 +- .../ObjectDiffusion/ObjectPool/PerasVote.hs | 8 +- .../Ouroboros/Consensus/Node/Run.hs | 2 + .../Ouroboros/Consensus/Peras/Context.hs | 337 +++++++++++++++--- .../Ouroboros/Consensus/Peras/Crypto/Mock.hs | 133 +++---- .../Ouroboros/Consensus/Peras/State/Mock.hs | 7 +- .../Ouroboros/Consensus/Peras/State/V1.hs | 2 +- .../Ouroboros/Consensus/Peras/Voting/V1.hs | 5 + .../Consensus/Storage/ChainDB/Impl.hs | 4 + .../Ouroboros/Consensus/Storage/LedgerDB.hs | 2 + .../Consensus/Storage/LedgerDB/API.hs | 6 +- .../Consensus/Storage/LedgerDB/V2.hs | 2 + .../Consensus/Storage/PerasVoteDB/Impl.hs | 4 +- .../Ouroboros/Consensus/Util/Orphans.hs | 5 + .../Test/Ouroboros/Storage/TestBlock.hs | 31 +- .../Test/Util/Orphans/ToExpr.hs | 13 +- .../Test/Util/Peras/Mock.hs | 19 +- .../Test/Util/Serialisation/Roundtrip.hs | 11 +- .../Test/Util/TestBlock.hs | 38 +- .../Ouroboros/Consensus/Mock/Node/BFT.hs | 18 +- .../Ouroboros/Consensus/Mock/Node/PBFT.hs | 14 +- .../Ouroboros/Consensus/Mock/Node/Peras.hs | 5 + .../Ouroboros/Consensus/Mock/Node/Praos.hs | 18 +- .../Consensus/Mock/Node/PraosRule.hs | 17 +- .../ObjectDiffusion/PerasCert/Smoke.hs | 4 +- .../ObjectDiffusion/PerasVote/Smoke.hs | 8 +- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 18 +- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 5 + .../Storage/PerasVoteDB/StateMachine.hs | 4 +- 61 files changed, 835 insertions(+), 392 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/V1.hs diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index a72f688307..5b92818daa 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -472,8 +472,7 @@ encodeByronExtLedgerState = encodeByronLedgerState encodeByronChainDepState encodeByronAnnTip - -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - undefined + encode encodeByronHeaderState :: HeaderState ByronBlock -> Encoding encodeByronHeaderState = diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs index 9f3bbb652a..42d76ecee9 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -54,6 +54,7 @@ import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.NodeId (CoreNodeId) +import Ouroboros.Consensus.Peras.Context (ledgerStateHeaderStateMkPerasEpochContextResolver) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.PBFT import qualified Ouroboros.Consensus.Protocol.PBFT.State as S @@ -209,15 +210,19 @@ protocolInfoByron , topLevelConfigCheckpoints = emptyCheckpointsMap } , pInfoInitLedger = - ExtLedgerState - { -- Important: don't pass the compacted genesis config to - -- 'initByronLedgerState', it needs the full one, including the AVVM - -- balances. - ledgerState = initByronLedgerState genesisConfig Nothing - , headerState = genesisHeaderState S.empty - , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - perasEpochContextResolver = undefined - } + let + -- Important: don't pass the compacted genesis config to + -- 'initByronLedgerState', it needs the full one, including the AVVM + -- balances. + ledgerState = initByronLedgerState genesisConfig Nothing + headerState = genesisHeaderState S.empty + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in + ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } } where compactedGenesisConfig = compactGenesisConfig genesisConfig diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs index 7509b4f185..4e1c666034 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node/Peras.hs @@ -10,6 +10,7 @@ module Ouroboros.Consensus.Byron.Node.Peras () where import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras) import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting (..)) {------------------------------------------------------------------------------- BlockSupportsPeras @@ -17,3 +18,5 @@ import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) -- NOTE: Byron does not support Peras, so we can use the empty instance here. instance BlockSupportsPeras ByronBlock + +instance LedgerStateHeaderStateSupportsPerasVoting ByronBlock diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index c879cec2f2..8e14eb0397 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -91,6 +91,9 @@ import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (ledgerStateHeaderStateMkPerasEpochContextResolver) + ) import Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..)) import Ouroboros.Consensus.Protocol.Praos.AgentClient import Ouroboros.Consensus.Protocol.Praos.Common @@ -932,12 +935,14 @@ protocolInfoCardano paramsCardano -- testing/benchmarking). initExtLedgerStateCardano :: ExtLedgerState (CardanoBlock c) ValuesMK initExtLedgerStateCardano = - ExtLedgerState - { headerState = initHeaderState - , ledgerState = overShelleyBasedLedgerState initLedgerState - , -- [TODO EPOCH CONTEX PLUMBING] we need to fix this - perasEpochContextResolver = undefined - } + let ledgerState = overShelleyBasedLedgerState initLedgerState + headerState = initHeaderState + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } where overShelleyBasedLedgerState (HardForkLedgerState st) = HardForkLedgerState $ hap (fn id :* registerAny) st diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs index 2ce6802505..e36c566c40 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -68,6 +68,7 @@ import Ouroboros.Consensus.HardFork.Combinator ( HasPartialConsensusConfig ) import Ouroboros.Consensus.HeaderValidation +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Praos.Common ( PraosTiebreakerView @@ -126,6 +127,7 @@ class , Crypto (ProtoCrypto proto) , -- Peras constraints BlockSupportsPeras (ShelleyBlock proto era) + , LedgerStateHeaderStateSupportsPerasVoting (ShelleyBlock proto era) , Show (PerasEpochContext (ShelleyBlock proto era)) , Eq (PerasEpochContext (ShelleyBlock proto era)) , NoThunks (PerasEpochContext (ShelleyBlock proto era)) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs index ea6644bc5a..180acaf2cb 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -17,13 +17,20 @@ import Cardano.Ledger.Api import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) ) -import Ouroboros.Consensus.Committee.WFALS (WFALS) -import Ouroboros.Consensus.Ledger.Extended (LedgerStateHeaderStateSupportsPerasVoting (..)) import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (..) + , V1PerasEpochContextResolver + , unsafeBoundedPerasEpochContextWithMinMaxBounds + , v1AbsorbErrorInResolver + , v1InitPerasEpochContextResolver + , v1ResolveRoundNo + ) import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 import qualified Ouroboros.Consensus.Peras.State.V1 as V1 import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Voting.V1 as V1 import Ouroboros.Consensus.Shelley.Ledger.Block ( ShelleyBlock , ShelleyCompatible @@ -52,13 +59,47 @@ instance type PerasCert (ShelleyBlock proto DijkstraEra) = V1.PerasCert (ShelleyBlock proto DijkstraEra) type PerasError (ShelleyBlock proto DijkstraEra) = V1.PerasError (ShelleyBlock proto DijkstraEra) type PerasCrypto (ShelleyBlock proto DijkstraEra) = BLS.PerasBLSCrypto - type PerasVotingCommitteeScheme (ShelleyBlock proto DijkstraEra) = WFALS + type PerasVotingCommitteeScheme (ShelleyBlock proto DijkstraEra) = V1.PerasVotingCommitteeScheme - -- TODO: extract actual Peras certificates from blocks + -- [TODO EPOCH CONTEXT PLUMBING/EXTRACT CERT] extract actual Peras certificates from blocks getPerasCertInBlock _ = Nothing +instance + ShelleyCompatible proto ShelleyEra => + LedgerStateHeaderStateSupportsPerasVoting (ShelleyBlock proto ShelleyEra) +instance + ShelleyCompatible proto AllegraEra => + LedgerStateHeaderStateSupportsPerasVoting (ShelleyBlock proto AllegraEra) +instance + ShelleyCompatible proto MaryEra => + LedgerStateHeaderStateSupportsPerasVoting + ( ShelleyBlock + proto + MaryEra + ) +instance + ShelleyCompatible proto AlonzoEra => + LedgerStateHeaderStateSupportsPerasVoting (ShelleyBlock proto AlonzoEra) +instance + ShelleyCompatible proto BabbageEra => + LedgerStateHeaderStateSupportsPerasVoting (ShelleyBlock proto BabbageEra) +instance + ShelleyCompatible proto ConwayEra => + LedgerStateHeaderStateSupportsPerasVoting (ShelleyBlock proto ConwayEra) + instance ShelleyCompatible proto DijkstraEra => LedgerStateHeaderStateSupportsPerasVoting (ShelleyBlock proto DijkstraEra) where + type + PerasEpochContextResolver (ShelleyBlock proto DijkstraEra) = + V1PerasEpochContextResolver (ShelleyBlock proto DijkstraEra) + ledgerStateHeaderStateMkPerasVotingCommitteeInput = V1.ledgerStateHeaderStateMkPerasVotingCommitteeInput + + ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState = + v1AbsorbErrorInResolver $ + v1InitPerasEpochContextResolver . unsafeBoundedPerasEpochContextWithMinMaxBounds + <$> (ledgerStateHeaderStateMkPerasEpochContext ledgerState headerState) + + resolveRoundNo = v1ResolveRoundNo diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs index c20b1f6937..a2ecce17e7 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs @@ -48,6 +48,9 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (ledgerStateHeaderStateMkPerasEpochContextResolver) + ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey @@ -292,9 +295,11 @@ protocolInfoTPraosShelleyBased initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era) ValuesMK initExtLedgerState = - ExtLedgerState - { ledgerState = initLedgerState - , headerState = genesisHeaderState initChainDepState - , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - perasEpochContextResolver = undefined - } + let ledgerState = initLedgerState + headerState = genesisHeaderState initChainDepState + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Ledger.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Ledger.hs index 8c78d37f9c..cebd996e15 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Ledger.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Ledger.hs @@ -259,10 +259,3 @@ forgeDualByronBlock cfg curBlockNo curSlotNo tickedLedger vtxs isLeader = (tickedDualLedgerStateBridge tickedLedger) (hashVerKey . deriveVerKeyDSIGN . pbftIsLeaderSignKey $ isLeader) ) - -{------------------------------------------------------------------------------- - BlockSupportsPeras --------------------------------------------------------------------------------} - --- NOTE: DualByron does not support Peras, so we can use the empty instance here. -instance BlockSupportsPeras DualByronBlock diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs index 20891b3877..594872f00b 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs @@ -40,6 +40,7 @@ import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Context (ledgerStateHeaderStateMkPerasEpochContextResolver) import Ouroboros.Consensus.Protocol.PBFT import qualified Ouroboros.Consensus.Protocol.PBFT.State as S import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..)) @@ -118,17 +119,19 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss = , topLevelConfigCheckpoints = emptyCheckpointsMap } , pInfoInitLedger = - ExtLedgerState - { ledgerState = + let ledgerState = DualLedgerState { dualLedgerStateMain = initConcreteState , dualLedgerStateAux = initAbstractState , dualLedgerStateBridge = initBridge } - , headerState = genesisHeaderState S.empty - , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - perasEpochContextResolver = undefined - } + headerState = genesisHeaderState S.empty + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } } , return $ dualByronBlockForging . byronLeaderCredentials <$> credss ) diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs index ffe6cc401f..d63886a9ee 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -44,6 +45,7 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Context (ledgerStateHeaderStateMkPerasEpochContextResolver) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.PBFT import qualified Ouroboros.Consensus.Protocol.PBFT.State as S @@ -220,12 +222,14 @@ exampleHeaderState = HeaderState (NotOrigin exampleAnnTip) exampleChainDepState exampleExtLedgerState :: ExtLedgerState ByronBlock ValuesMK exampleExtLedgerState = - ExtLedgerState - { ledgerState = exampleLedgerState - , headerState = exampleHeaderState - , -- [TODO EPOCH CONTEXT PLUMBING] we need t ofix this - perasEpochContextResolver = undefined - } + let ledgerState = exampleLedgerState + headerState = exampleHeaderState + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } exampleHeaderHash :: ByronHash exampleHeaderHash = blockHash exampleBlock diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs index 0339cead4c..89a57b3c6e 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs @@ -69,6 +69,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import qualified Ouroboros.Consensus.Mempool as Mempool import Ouroboros.Consensus.Mempool.Impl.Common +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting, ledgerStateHeaderStateMkPerasEpochContextResolver) import Ouroboros.Consensus.Protocol.Abstract (LedgerView) import Ouroboros.Consensus.Storage.Common (BlockComponent (..)) import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) @@ -90,6 +91,7 @@ runAnalysis :: , LedgerSupportsMempool.HasTxs blk , LedgerSupportsMempool blk , LedgerSupportsProtocol blk + , LedgerStateHeaderStateSupportsPerasVoting blk , CanStowLedgerTables (LedgerState blk) , Show (TxIn blk) , Show (TxOut blk) @@ -416,6 +418,7 @@ showEBBs AnalysisEnv{db, registry, startFrom, limit, tracer} = do storeLedgerStateAt :: forall blk. ( LedgerSupportsProtocol blk + , LedgerStateHeaderStateSupportsPerasVoting blk , HasAnalysis blk ) => SlotNo -> @@ -499,6 +502,7 @@ checkNoThunksEvery :: forall blk. ( HasAnalysis blk , LedgerSupportsProtocol blk + , LedgerStateHeaderStateSupportsPerasVoting blk , CanStowLedgerTables (LedgerState blk) ) => Word64 -> @@ -556,6 +560,7 @@ traceLedgerProcessing :: forall blk. ( HasAnalysis blk , LedgerSupportsProtocol blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => Analysis blk StartFromLedgerState traceLedgerProcessing @@ -613,6 +618,7 @@ benchmarkLedgerOps :: forall blk. ( LedgerSupportsProtocol blk , HasAnalysis blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => Maybe FilePath -> LedgerApplicationMode -> @@ -707,11 +713,14 @@ benchmarkLedgerOps mOutfile ledgerAppMode AnalysisEnv{db, registry, startFrom, c F.writeDataPoint outFileHandle outFormat slotDataPoint LedgerDB.push intLedgerDB $ - ExtLedgerState - (prependDiffs tkLdgrSt newLedger) - newHeader - -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - undefined + let ledgerState = (prependDiffs tkLdgrSt newLedger) + headerState = newHeader + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } where rp = blockRealPoint blk @@ -781,6 +790,7 @@ getBlockApplicationMetrics :: forall blk. ( HasAnalysis blk , LedgerSupportsProtocol blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => NumberOfBlocks -> Maybe FilePath -> Analysis blk StartFromLedgerState getBlockApplicationMetrics (NumberOfBlocks nrBlocks) mOutFile env = do diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs index 2a238a0f8d..48ef1801b4 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs @@ -32,6 +32,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import qualified Ouroboros.Consensus.Node as Node import qualified Ouroboros.Consensus.Node.InitStorage as Node import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Protocol.Abstract import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB @@ -59,6 +60,7 @@ import Text.Printf (printf) openLedgerDB :: forall blk. ( LedgerSupportsProtocol blk + , LedgerStateHeaderStateSupportsPerasVoting blk , InspectLedger blk , HasHardForkHistory blk ) => diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs index a9fca86cec..6da6748ced 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -43,6 +44,7 @@ import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.Tables hiding (TxIn) import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Peras.Context (ledgerStateHeaderStateMkPerasEpochContextResolver) import Ouroboros.Consensus.Protocol.Abstract (translateChainDepState) import Ouroboros.Consensus.Protocol.Praos (Praos) import Ouroboros.Consensus.Protocol.Praos.Common @@ -225,11 +227,13 @@ fromShelleyLedgerExamples } chainDepState = TPraosState (NotOrigin 1) pleChainDepState extLedgerState = - ExtLedgerState - ledgerState - (genesisHeaderState chainDepState) - -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - undefined + let headerState = genesisHeaderState chainDepState + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } ledgerConfig = exampleShelleyLedgerConfig leTranslationContext @@ -366,11 +370,13 @@ fromShelleyLedgerExamplesPraos translateChainDepState (Proxy @(TPraos StandardCrypto, Praos StandardCrypto)) $ TPraosState (NotOrigin 1) pleChainDepState extLedgerState = - ExtLedgerState - ledgerState - (genesisHeaderState chainDepState) - -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - undefined + let headerState = genesisHeaderState chainDepState + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } ledgerConfig = exampleShelleyLedgerConfig leTranslationContext diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 49ad07e2ed..7254773377 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -85,6 +85,7 @@ import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation import qualified Ouroboros.Consensus.Node.Tracers as Node import Ouroboros.Consensus.NodeKernel +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.Serialisation (SerialisedHeader) import Ouroboros.Consensus.Util (ShowProxy) @@ -278,6 +279,7 @@ mkHandlers :: , MonadTimer m , HasTxId (GenTx blk) , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , LedgerSupportsMempool blk , LedgerSupportsProtocol blk , Ord addrNTN diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs index 7c0771d947..df6e527077 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs @@ -43,6 +43,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.MiniProtocol.ChainSync.Client ( ChainSyncClientException (..) ) +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB import Ouroboros.Consensus.Storage.LedgerDB.API ( CanUpgradeLedgerTables @@ -161,6 +162,7 @@ runGenesisTest :: , ConfigSupportsNode blk , LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk @@ -224,6 +226,7 @@ runConformanceTest :: , ConfigSupportsNode blk , LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs index 17fafb54ae..0050a46ccb 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/TestSuite.hs @@ -47,6 +47,7 @@ import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Storage.ChainDB (SerialiseDiskConstraints) import Ouroboros.Consensus.Storage.LedgerDB.API ( CanUpgradeLedgerTables @@ -185,6 +186,7 @@ toTestTree :: , ConfigSupportsNode blk , LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index dc9e9d35f4..e5c1009098 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -7,6 +7,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} @@ -48,6 +49,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Context (ledgerStateHeaderStateMkPerasEpochContextResolver) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.LeaderSchedule ( LeaderSchedule (..) @@ -244,19 +246,20 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = { pInfoConfig = topLevelConfig nid , pInfoInitLedger = - ExtLedgerState - { ledgerState = + let ledgerState = HardForkLedgerState $ initHardForkState (Flip initLedgerState) - , headerState = + headerState = genesisHeaderState $ initHardForkState (WrapChainDepState initChainDepState) - , perasEpochContextResolver = - -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - undefined - } + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } } blockForging :: Monad m => [MkBlockForging m TestBlock] diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 1422099455..34234c4c0a 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -88,6 +88,7 @@ import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) import Ouroboros.Consensus.Storage.Serialisation @@ -620,6 +621,8 @@ instance SerialiseNodeToClient BlockA (EpochInfo Identity, PartialLedgerConfigA) encodeNodeToClient = error "BlockA being used as a SingleEraBlock" decodeNodeToClient = error "BlockA being used as a SingleEraBlock" +instance LedgerStateHeaderStateSupportsPerasVoting BlockA + instance SerialiseConstraintsHFC BlockA instance SerialiseDiskConstraints BlockA instance SerialiseNodeToClientConstraints BlockA diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index 165de13464..1a2d3a5f27 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -72,6 +72,7 @@ import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) import Ouroboros.Consensus.Storage.Serialisation @@ -462,6 +463,8 @@ instance HasBinaryBlockInfo BlockB where , headerSize = fromIntegral $ Lazy.length (serialise blkB_header) } +instance LedgerStateHeaderStateSupportsPerasVoting BlockB + instance SerialiseConstraintsHFC BlockB instance SerialiseDiskConstraints BlockB instance SerialiseNodeToClientConstraints BlockB diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs index 8d91c0fe3e..db559b43b2 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs @@ -35,6 +35,7 @@ import Ouroboros.Consensus.Ledger.Tables.MapKind (ValuesMK) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client ( ChainSyncClientHandleCollection (..) ) +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Storage.ChainDB.API import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB @@ -135,6 +136,7 @@ mkChainDb :: IOLike m => ( LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk @@ -189,6 +191,7 @@ restoreNode :: ( IOLike m , LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk @@ -220,6 +223,7 @@ lifecycleStart :: ( IOLike m , LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index 439e5993d8..2d8233d4b2 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -47,6 +47,7 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.Node.GsmState as GSM import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Storage.ChainDB.API import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB @@ -559,6 +560,7 @@ nodeLifecycle :: , ConfigSupportsNode blk , LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk @@ -619,6 +621,7 @@ runPointSchedule :: , ConfigSupportsNode blk , LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , ChainDB.SerialiseDiskConstraints blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index b734c9cfb9..165ce40898 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -256,6 +256,7 @@ library Ouroboros.Consensus.Peras.Vote.V1 Ouroboros.Consensus.Peras.Voting.Rules Ouroboros.Consensus.Peras.Voting.View + Ouroboros.Consensus.Peras.Voting.V1 Ouroboros.Consensus.Peras.Weight Ouroboros.Consensus.Protocol.Abstract Ouroboros.Consensus.Protocol.BFT diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index 809cf597b6..7bab81b296 100644 --- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs +++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs @@ -27,9 +27,6 @@ import Ouroboros.Consensus.Config import qualified Ouroboros.Consensus.HardFork.History as HardFork import qualified Ouroboros.Consensus.HeaderStateHistory as HeaderStateHistory import qualified Ouroboros.Consensus.HeaderValidation as HV -import Ouroboros.Consensus.Ledger.Extended - ( ledgerStateHeaderStateMkConstPerasEpochContextResolverForMock - ) import qualified Ouroboros.Consensus.Ledger.Extended as Extended import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck @@ -45,6 +42,9 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion ) import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (ledgerStateHeaderStateMkPerasEpochContextResolver) + ) import Ouroboros.Consensus.Protocol.BFT import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Util.IOLike @@ -229,7 +229,7 @@ oracularLedgerDB p = , Extended.ledgerState = ledgerState , Extended.perasEpochContextResolver = - ledgerStateHeaderStateMkConstPerasEpochContextResolverForMock + ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 90ae3f8dcc..9721259491 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -24,6 +24,7 @@ module Ouroboros.Consensus.Block.SupportsPeras , BlockSupportsPeras (..) , PerasVoteCompatibleWithVotingCommittee (..) , PerasCertCompatibleWithVotingCommittee (..) + , VoidPerasVotingCommitteeScheme , VoidPerasVote (..) , VoidPerasCert (..) , VoidPerasError (..) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index 6a654fd87e..15d5997742 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -51,9 +51,14 @@ import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) ) -import Ouroboros.Consensus.Committee.WFALS (WFALS) import Ouroboros.Consensus.Config -import Ouroboros.Consensus.HardFork.Combinator.Abstract +import Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork + ( CanHardFork + ) +import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock + ( SingleEraBlock + , proxySingle + ) import Ouroboros.Consensus.HardFork.Combinator.AcrossEras import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import qualified Ouroboros.Consensus.HardFork.Combinator.State.Infra as State @@ -66,6 +71,7 @@ import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1 import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS import qualified Ouroboros.Consensus.Peras.Error.V1 as V1 import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 +import qualified Ouroboros.Consensus.Peras.Voting.V1 as V1 import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (ShowProxy) @@ -290,9 +296,9 @@ instance type PerasCert (HardForkBlock xs) = V1.PerasCert (HardForkBlock xs) type PerasError (HardForkBlock xs) = V1.PerasError (HardForkBlock xs) type PerasCrypto (HardForkBlock xs) = BLS.PerasBLSCrypto - type PerasVotingCommitteeScheme (HardForkBlock xs) = WFALS + type PerasVotingCommitteeScheme (HardForkBlock xs) = V1.PerasVotingCommitteeScheme - -- TODO: extract actual Peras certificates from blocks + -- [TODO EPOCH CONTEXT PLUMBING/EXTRACT CERT] extract actual Peras certificates from blocks getPerasCertInBlock _ = Nothing {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs index 9f55fe43d4..ec5a3ecacc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,6 +25,9 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Basics (LedgerConfig) import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (ledgerStateHeaderStateMkPerasEpochContextResolver) + ) import Ouroboros.Consensus.Protocol.Abstract (protocolSecurityParam) import Ouroboros.Consensus.TypeFamilyWrappers @@ -99,19 +103,23 @@ protocolInfoBinary , topLevelConfigCheckpoints = emptyCheckpointsMap } , pInfoInitLedger = - ExtLedgerState - { ledgerState = + let ledgerState = HardForkLedgerState $ initHardForkState (Flip initLedgerState1) - , headerState = + headerState = genesisHeaderState $ initHardForkState $ WrapChainDepState $ headerStateChainDep initHeaderState1 - , perasEpochContextResolver = - -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - undefined - } + perasEpochContextResolver = + ledgerStateHeaderStateMkPerasEpochContextResolver + ledgerState + headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } } , \tr -> alignWith alignBlockForging <$> blockForging1 tr <*> blockForging2 tr ) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs index fca11cf25f..ed00b6dc4f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs @@ -50,10 +50,15 @@ import Ouroboros.Consensus.HeaderValidation , genesisHeaderState ) import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..)) +import Ouroboros.Consensus.Ledger.Extended + ( ExtLedgerState (..) + ) import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.Tables.Utils -import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolver) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (ledgerStateHeaderStateMkPerasEpochContextResolver) + , PerasEpochContextResolver (..) + ) import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.TypeFamilyWrappers @@ -245,17 +250,15 @@ instance Inject HeaderState where WrapChainDepState headerStateChainDep } --- [TODO EPOCH CONTEXT PLUMBING] we need to fix this -instance Inject PerasEpochContextResolver where - inject = undefined - instance Inject (Flip ExtLedgerState mk) where inject iidx (Flip ExtLedgerState{..}) = Flip $ ExtLedgerState { ledgerState = unFlip $ inject iidx (Flip ledgerState) , headerState = inject iidx headerState - , perasEpochContextResolver = inject iidx perasEpochContextResolver + , perasEpochContextResolver -- [TODO EPOCH CONTEXT PLUMBING/CONVERSION] we need to fix this + = + undefined } {------------------------------------------------------------------------------- @@ -334,6 +337,5 @@ injectInitialExtLedgerState cfg extLedgerState0 = targetEraHeaderState :: HeaderState (HardForkBlock (x ': xs)) targetEraHeaderState = genesisHeaderState targetEraChainDepState - -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this targetEraPerasEpochContextResolver :: PerasEpochContextResolver (HardForkBlock (x ': xs)) - targetEraPerasEpochContextResolver = undefined + targetEraPerasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver targetEraLedgerState targetEraHeaderState diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs index e0f5cb455f..be690133de 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs @@ -68,7 +68,6 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Node.ProtocolInfo -import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolver) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB @@ -357,7 +356,9 @@ instance Isomorphic (Flip ExtLedgerState mk) where ExtLedgerState { ledgerState = unFlip $ project $ Flip ledgerState , headerState = project headerState - , perasEpochContextResolver = project perasEpochContextResolver + , perasEpochContextResolver -- [TODO EPOCH CONTEXT PLUMBING/CONVERSION] we need to fix this + = + undefined } inject (Flip ExtLedgerState{..}) = @@ -365,7 +366,9 @@ instance Isomorphic (Flip ExtLedgerState mk) where ExtLedgerState { ledgerState = unFlip $ inject $ Flip ledgerState , headerState = inject headerState - , perasEpochContextResolver = inject perasEpochContextResolver + , perasEpochContextResolver -- [TODO EPOCH CONTEXT PLUMBING/CONVERSION] we need to fix this + = + undefined } instance Isomorphic AnnTip where @@ -550,11 +553,6 @@ instance Isomorphic ProtocolInfo where , pInfoInitLedger = unFlip $ inject $ Flip pInfoInitLedger } --- [TODO EPOCH CONTEXT PLUMBING] we need to fix this -instance Isomorphic PerasEpochContextResolver where - project = undefined - inject = undefined - {------------------------------------------------------------------------------- Types that require take advantage of the fact that we have a single era -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs index 1170a1c93b..96ba57da5c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs @@ -301,7 +301,7 @@ distribExtLedgerState (ExtLedgerState ledgerState headerState _perasResolver) = (distribHeaderState headerState) (State.tip (hardForkLedgerStatePerEra ledgerState)) where - -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this + -- [TODO EPOCH CONTEXT PLUMBING/CONVERSION] we need to fix this perasResolver' = undefined -- | Precondition: the 'headerStateTip' and 'headerStateChainDep' should be from diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs index 0e95736ea8..0d490dd122 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.HardFork.Combinator.Protocol @@ -61,6 +62,15 @@ import Ouroboros.Consensus.HardFork.Combinator.State ) import qualified Ouroboros.Consensus.HardFork.Combinator.State as State import Ouroboros.Consensus.HardFork.Combinator.Translation as HFTranslation +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (..) + , V1PerasEpochContextResolver + , unsafeBoundedPerasEpochContextWithMinMaxBounds + , v1AbsorbErrorInResolver + , v1InitPerasEpochContextResolver + , v1ResolveRoundNo + ) +import qualified Ouroboros.Consensus.Peras.State.V1 as V1 import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util ((.:)) @@ -140,6 +150,26 @@ instance CanHardFork xs => ChainDepStateSupportsPeras (HardForkProtocol xs) wher getEpochNonce' (WrapChainDepState st) = K (getEpochNonce (Proxy @(BlockProtocol blk)) st) +{------------------------------------------------------------------------------- + LedgerStateHeaderStateSupportsPerasVoting +-------------------------------------------------------------------------------} + +instance + ( StandardHash (HardForkBlock xs) + , CanHardFork xs + ) => + LedgerStateHeaderStateSupportsPerasVoting (HardForkBlock xs) + where + type PerasEpochContextResolver (HardForkBlock xs) = V1PerasEpochContextResolver (HardForkBlock xs) + + ledgerStateHeaderStateMkPerasVotingCommitteeInput = V1.ledgerStateHeaderStateMkPerasVotingCommitteeInput + ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState = + v1AbsorbErrorInResolver $ + v1InitPerasEpochContextResolver . unsafeBoundedPerasEpochContextWithMinMaxBounds + <$> (ledgerStateHeaderStateMkPerasEpochContext ledgerState headerState) + + resolveRoundNo = v1ResolveRoundNo + {------------------------------------------------------------------------------- BlockSupportsProtocol -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs index e37413f305..eb027b3b3c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} @@ -92,6 +93,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util (ShowProxy (..)) import Ouroboros.Consensus.Util.Condense @@ -1189,3 +1191,12 @@ instance , dualLedgerStateAux , dualLedgerStateBridge } = dls + +{------------------------------------------------------------------------------- + BlockSupportsPeras +-------------------------------------------------------------------------------} + +-- NOTE: DualByron does not support Peras, so we can use the empty instance here. +instance (StandardHash m, Typeable m, Typeable a) => BlockSupportsPeras (DualBlock m a) + +instance LedgerStateHeaderStateSupportsPerasVoting (DualBlock m a) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs index 1b65b3f47d..32c0fca362 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -32,40 +33,27 @@ module Ouroboros.Consensus.Ledger.Extended -- * Type family instances , LedgerTables (..) , Ticked (..) - - -- * Peras support - , LedgerStateHeaderStateSupportsPerasVoting (..) - - -- * Peras helpers for blocks using mock/void peras committee/crypto - , ledgerStateHeaderStateMkConstPerasEpochContextResolver - , ledgerStateHeaderStateMkConstPerasEpochContextResolverDischargeVoid - , ledgerStateHeaderStateMkConstPerasEpochContextResolverForMock ) where import Codec.CBOR.Decoding (Decoder, decodeListLenOf) import Codec.CBOR.Encoding (Encoding, encodeListLen) import Control.DeepSeq (NFData) import Control.Monad.Except -import Data.Bifunctor (Bifunctor (bimap)) import Data.Functor ((<&>)) import Data.Proxy import Data.Typeable -import Data.Void (absurd) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee) -import qualified Ouroboros.Consensus.Committee.Class as Committee import Ouroboros.Consensus.Config import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Peras.Context - ( PerasEpochContextResolver (ConstPerasEpochContextResolver) + ( PerasEpochContextResolver , PerasEpochContextResolverHandle (..) ) -import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.IOLike (MonadSTM (STM)) @@ -102,13 +90,13 @@ getPerasEpochContextResolverHandle getLedgerStateSTM = deriving instance ( EqMK mk , LedgerSupportsProtocol blk - , Eq (PerasEpochContext blk) + , Eq (PerasEpochContextResolver blk) ) => Eq (ExtLedgerState blk mk) deriving instance ( ShowMK mk , LedgerSupportsProtocol blk - , Show (PerasEpochContext blk) + , Show (PerasEpochContextResolver blk) ) => Show (ExtLedgerState blk mk) @@ -119,7 +107,7 @@ deriving instance instance ( NoThunksMK mk , LedgerSupportsProtocol blk - , NoThunks (PerasEpochContext blk) + , NoThunks (PerasEpochContextResolver blk) ) => NoThunks (ExtLedgerState blk mk) where @@ -180,9 +168,9 @@ instance IsLedger LedgerState blk => GetTip (Ticked ExtLedgerState blk) where instance ( LedgerSupportsProtocol blk - , Show (PerasEpochContext blk) - , Eq (PerasEpochContext blk) - , NoThunks (PerasEpochContext blk) + , Show (PerasEpochContextResolver blk) + , Eq (PerasEpochContextResolver blk) + , NoThunks (PerasEpochContextResolver blk) ) => IsLedger ExtLedgerState blk where @@ -207,7 +195,7 @@ instance ledgerResult = applyChainTickLedgerResult evs lcfg slot ledger - -- [TODO EPOCH CONTEXT PLUMBING] We need to understand if this needs extra + -- [TODO EPOCH CONTEXT PLUMBING/UPDATING] We need to understand if this needs extra -- care or not. tickedPerasEpochContextResolver = perasResolver @@ -245,16 +233,16 @@ applyHelper f opts cfg blk TickedExtLedgerState{..} = do ledgerView (getHeader blk) tickedHeaderState - -- [TODO EPOCH CONTEXT PLUMBING] We need to understand if this needs extra care or not. + -- [TODO EPOCH CONTEXT PLUMBING/UPDATING] We need to understand if this needs extra care or not. let perasResolver = tickedPerasEpochContextResolver pure $ (\l -> ExtLedgerState l hdr perasResolver) <$> castLedgerResult ledgerResult instance ( GetBlockKeySets blk , LedgerSupportsProtocol blk - , Show (PerasEpochContext blk) - , Eq (PerasEpochContext blk) - , NoThunks (PerasEpochContext blk) + , Show (PerasEpochContextResolver blk) + , Eq (PerasEpochContextResolver blk) + , NoThunks (PerasEpochContextResolver blk) ) => ApplyBlock ExtLedgerState blk where @@ -280,7 +268,7 @@ instance (getHeader blk) tickedHeaderState - -- [TODO EPOCH CONTEXT PLUMBING] We need to understand if this needs extra care or not. + -- [TODO EPOCH CONTEXT PLUMBING/UPDATING] We need to understand if this needs extra care or not. perasResolver = tickedPerasEpochContextResolver {------------------------------------------------------------------------------- @@ -427,82 +415,3 @@ instance LedgerTablesAreTrivial LedgerState blk => LedgerTablesAreTrivial ExtLed instance SerializeTablesWithHint LedgerState blk => SerializeTablesWithHint ExtLedgerState blk where decodeTablesWithHint st = decodeTablesWithHint (ledgerState st) encodeTablesWithHint st tbs = encodeTablesWithHint (ledgerState st) tbs - -------------------------------------------------------------------------------- --- Peras support -------------------------------------------------------------------------------- - -class - ( BlockSupportsPeras blk - , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) -- TODO remove this constraint when it becomes a superclass constraint of 'BlockSupportsPeras' - ) => - LedgerStateHeaderStateSupportsPerasVoting blk - where - ledgerStateHeaderStateMkPerasVotingCommitteeInput :: - PerasParams blk -> - LedgerState blk mk -> - HeaderState blk -> - Either - (PerasError blk) - (PerasVotingCommitteeInput blk) - - ledgerStateHeaderStateMkPerasVotingCommittee :: - PerasParams blk -> - LedgerState blk mk -> - HeaderState blk -> - Either - (PerasError blk) - (PerasVotingCommittee blk) - ledgerStateHeaderStateMkPerasVotingCommittee perasParams ledgerState headerState = do - committeeInput <- - ledgerStateHeaderStateMkPerasVotingCommitteeInput perasParams ledgerState headerState - bimap injectVotingCommitteeError id $ - Committee.mkVotingCommittee committeeInput - - ledgerStateHeaderStateMkPerasEpochContext :: - LedgerState blk mk -> - HeaderState blk -> - Either - (PerasError blk) - (PerasEpochContext blk) - default ledgerStateHeaderStateMkPerasEpochContext :: - PerasEpochContext blk ~ DefaultPerasEpochContext blk => - LedgerState blk mk -> - HeaderState blk -> - Either - (PerasError blk) - (PerasEpochContext blk) - ledgerStateHeaderStateMkPerasEpochContext ledgerState headerState = do - let dpecParams = defaultPerasParams - dpecCommittee <- ledgerStateHeaderStateMkPerasVotingCommittee dpecParams ledgerState headerState - pure $ DefaultPerasEpochContext{dpecParams, dpecCommittee} - -ledgerStateHeaderStateMkConstPerasEpochContextResolver :: - LedgerStateHeaderStateSupportsPerasVoting blk => - LedgerState blk mk -> - HeaderState blk -> - Either - (PerasError blk) - (PerasEpochContextResolver blk) -ledgerStateHeaderStateMkConstPerasEpochContextResolver ledgerState headerState = - ConstPerasEpochContextResolver <$> ledgerStateHeaderStateMkPerasEpochContext ledgerState headerState - -ledgerStateHeaderStateMkConstPerasEpochContextResolverForMock :: - (LedgerStateHeaderStateSupportsPerasVoting blk, PerasError blk ~ MockPerasError blk) => - LedgerState blk mk -> - HeaderState blk -> - PerasEpochContextResolver blk -ledgerStateHeaderStateMkConstPerasEpochContextResolverForMock ledgerState headerState = - case ledgerStateHeaderStateMkConstPerasEpochContextResolver ledgerState headerState of - Left mockErr -> error ("mkVotingCommittee for MockPerasCommittee should never fail, but got: " ++ show mockErr) - Right resolver -> resolver - -ledgerStateHeaderStateMkConstPerasEpochContextResolverDischargeVoid :: - (LedgerStateHeaderStateSupportsPerasVoting blk, PerasError blk ~ VoidPerasError blk) => - LedgerState blk mk -> - HeaderState blk -> - PerasEpochContextResolver blk -ledgerStateHeaderStateMkConstPerasEpochContextResolverDischargeVoid ledgerState headerState = - case ledgerStateHeaderStateMkConstPerasEpochContextResolver ledgerState headerState of - Left (VoidPerasError void) -> absurd void - Right resolver -> resolver diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index 44d78bd8ad..700d616de2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -28,7 +28,11 @@ import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API ( ObjectPoolReader (..) , ObjectPoolWriter (..) ) -import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle, verifyPerasCertInContext) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting + , PerasEpochContextResolverHandle + , verifyPerasCertInContext + ) import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB, getPerasEpochContextResolverHandle) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.PerasCertDB.API @@ -104,6 +108,7 @@ makePerasCertPoolReaderFromChainDB chainDB = makePerasCertPoolWriterFromCertDB :: ( IOLike m , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => SystemTime m -> PerasCertDB m blk -> @@ -133,6 +138,7 @@ makePerasCertPoolWriterFromCertDB systemTime perasCertDB resolverHandle = makePerasCertPoolWriterFromChainDB :: ( IOLike m , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => SystemTime m -> ChainDB m blk -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs index 4e1425e74b..1439e12fc4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs @@ -29,7 +29,11 @@ import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API ( ObjectPoolReader (..) , ObjectPoolWriter (..) ) -import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle, verifyPerasVoteInContext) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting + , PerasEpochContextResolverHandle + , verifyPerasVoteInContext + ) import Ouroboros.Consensus.Storage.ChainDB (getPerasEpochContextResolverHandle) import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB @@ -107,6 +111,7 @@ makePerasVotePoolReaderFromChainDB chainDB = makePerasVotePoolWriterFromVoteDB :: ( IOLike m , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => SystemTime m -> PerasVoteDB m blk -> @@ -137,6 +142,7 @@ makePerasVotePoolWriterFromVoteDB systemTime perasVoteDB resolverHandle = makePerasVotePoolWriterFromChainDB :: ( IOLike m , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => SystemTime m -> ChainDB m blk -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs index d7b7c2f9bb..df676db32a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs @@ -36,6 +36,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Serialisation +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Storage.ChainDB ( ImmutableDbSerialiseConstraints , SerialiseDiskConstraints @@ -112,6 +113,7 @@ class , BlockSupportsMetrics blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , BlockSupportsSanityCheck blk , Show (CannotForge blk) , Show (ForgeStateInfo blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs index c8f74bd022..23f2a7a569 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs @@ -1,67 +1,317 @@ +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Ouroboros.Consensus.Peras.Context - ( PerasEpochContextResolver (ConstPerasEpochContextResolver) - , BoundedPerasEpochContext (..) - , resolveRoundNo - , PerasEpochContextNotFoundForRound (..) + ( LedgerStateHeaderStateSupportsPerasVoting (..) , PerasEpochContextResolverHandle (..) + , PerasEpochContextNotFoundForRound (..) + , EmptyPerasEpochContextResolver + , MockPerasEpochContextResolver (..) + , V1PerasEpochContextResolver (..) + , BoundedPerasEpochContext (..) + , emptyPerasEpochContextResolver + , emptyAbsorbErrorInResolver + , emptyResolveRoundNo + , mockPerasEpochContextResolver + , mockResolveRoundNo + , mockAbsorbErrorInResolver + , v1InitPerasEpochContextResolver + , v1AdvancePerasEpochContextResolver + , v1ResolveRoundNo + , v1AbsorbErrorInResolver + , resolveRoundNoWithHandle , verifyPerasVoteInContext , verifyPerasCertInContext - , resolveRoundNoWithHandle - , constPerasEpochContextResolverHandle + , unsafeBoundedPerasEpochContextWithMinMaxBounds + , mockPerasEpochContextResolverHandle ) where -import Codec.Serialise (Serialise) +import Cardano.Ledger.BaseTypes (strictMaybeToMaybe) +import Codec.Serialise.Class (Serialise) import Control.Applicative (Alternative (..)) import Control.Exception (Exception) import Control.Monad.Class.MonadSTM (STM) +import Data.Bifunctor (Bifunctor (..)) import Data.Either.Extra (maybeToEither) +import Data.Kind (Type) +import Data.Maybe.Strict (StrictMaybe (..)) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) + , DefaultPerasEpochContext (..) , IsPerasCert (getPerasCertRound) + , IsPerasError (injectVotingCommitteeError) , PerasCert , PerasRoundNo , PerasVote + , PerasVotingCommittee + , PerasVotingCommitteeInput , ValidatedPerasCert , ValidatedPerasVote + , VoidPerasVotingCommitteeScheme + , defaultPerasParams , getPerasVoteRound ) -import Ouroboros.Consensus.Storage.Serialisation (DecodeDisk, EncodeDisk (..)) +import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee) +import qualified Ouroboros.Consensus.Committee.Class as Committee +import Ouroboros.Consensus.HeaderValidation (HeaderState) +import Ouroboros.Consensus.Ledger.Abstract (LedgerState) +import Ouroboros.Consensus.Peras.Params (PerasParams) +import qualified Ouroboros.Consensus.Peras.Voting.V1 as V1 +import Ouroboros.Consensus.Storage.Serialisation (DecodeDisk, EncodeDisk) import Ouroboros.Consensus.Util.IOLike ( IOLike , MonadSTM , MonadThrow - , NoThunks + , NoThunks (..) , newTVarIO , readTVar , throwSTM ) -data PerasEpochContextResolver blk - = ConstPerasEpochContextResolver +------------------------------------------------------------------------------- +-- Peras support +------------------------------------------------------------------------------- + +data EmptyPerasEpochContextResolver = EmptyPerasEpochContextResolver + deriving (Show, Eq, Generic, NoThunks, Serialise) +deriving instance (EncodeDisk blk EmptyPerasEpochContextResolver) +deriving instance (DecodeDisk blk EmptyPerasEpochContextResolver) + +data MockPerasEpochContextResolver blk + = MockPerasEpochContextResolverError !String + | MockPerasEpochContextResolver !(PerasEpochContext blk) +deriving instance Show (PerasEpochContext blk) => Show (MockPerasEpochContextResolver blk) +deriving instance Eq (PerasEpochContext blk) => Eq (MockPerasEpochContextResolver blk) +deriving instance Generic (MockPerasEpochContextResolver blk) +deriving instance NoThunks (PerasEpochContext blk) => NoThunks (MockPerasEpochContextResolver blk) +deriving instance Serialise (PerasEpochContext blk) => Serialise (MockPerasEpochContextResolver blk) +deriving instance + Serialise (PerasEpochContext blk) => EncodeDisk blk (MockPerasEpochContextResolver blk) +deriving instance + Serialise (PerasEpochContext blk) => DecodeDisk blk (MockPerasEpochContextResolver blk) + +data V1PerasEpochContextResolver blk + = V1PerasEpochContextResolverError String + | V1PerasEpochContextResolver + !(BoundedPerasEpochContext blk) + !(StrictMaybe (BoundedPerasEpochContext blk)) +deriving instance Show (PerasEpochContext blk) => Show (V1PerasEpochContextResolver blk) +deriving instance Eq (PerasEpochContext blk) => Eq (V1PerasEpochContextResolver blk) +deriving instance Generic (V1PerasEpochContextResolver blk) +deriving instance NoThunks (PerasEpochContext blk) => NoThunks (V1PerasEpochContextResolver blk) +deriving instance Serialise (PerasEpochContext blk) => Serialise (V1PerasEpochContextResolver blk) +deriving instance + Serialise (PerasEpochContext blk) => EncodeDisk blk (V1PerasEpochContextResolver blk) +deriving instance + Serialise (PerasEpochContext blk) => DecodeDisk blk (V1PerasEpochContextResolver blk) + +data PerasEpochContextNotFoundForRound = PerasEpochContextNotFoundForRound !PerasRoundNo + deriving (Eq, Show, Generic, NoThunks, Exception) + +class + ( IsPerasError (PerasError blk) blk + , CryptoSupportsVotingCommittee (PerasCrypto blk) (PerasVotingCommitteeScheme blk) + , Show (PerasEpochContextResolver blk) + , Eq (PerasEpochContextResolver blk) + , NoThunks (PerasEpochContextResolver blk) + , Typeable (PerasEpochContextResolver blk) + , Serialise (PerasEpochContextResolver blk) + , EncodeDisk blk (PerasEpochContextResolver blk) + , DecodeDisk blk (PerasEpochContextResolver blk) + ) => + LedgerStateHeaderStateSupportsPerasVoting blk + where + type PerasEpochContextResolver blk :: Type + type PerasEpochContextResolver blk = EmptyPerasEpochContextResolver + + ledgerStateHeaderStateMkPerasVotingCommitteeInput :: + PerasParams blk -> + LedgerState blk mk -> + HeaderState blk -> + Either + (PerasError blk) + (PerasVotingCommitteeInput blk) + default ledgerStateHeaderStateMkPerasVotingCommitteeInput :: + PerasVotingCommitteeScheme blk ~ VoidPerasVotingCommitteeScheme => + PerasParams blk -> + LedgerState blk mk -> + HeaderState blk -> + Either + (PerasError blk) + (PerasVotingCommitteeInput blk) + ledgerStateHeaderStateMkPerasVotingCommitteeInput _ _ _ = + error "ledgerStateHeaderStateMkPerasVotingCommitteeInput: not supported for this block" + + ledgerStateHeaderStateMkPerasVotingCommittee :: + PerasParams blk -> + LedgerState blk mk -> + HeaderState blk -> + Either + (PerasError blk) + (PerasVotingCommittee blk) + ledgerStateHeaderStateMkPerasVotingCommittee perasParams ledgerState headerState = do + committeeInput <- + ledgerStateHeaderStateMkPerasVotingCommitteeInput perasParams ledgerState headerState + bimap injectVotingCommitteeError id $ + Committee.mkVotingCommittee committeeInput + + ledgerStateHeaderStateMkPerasEpochContext :: + LedgerState blk mk -> + HeaderState blk -> + Either + (PerasError blk) (PerasEpochContext blk) - | BoundedPerasEpochContextResolver - (BoundedPerasEpochContext blk) - (Maybe (BoundedPerasEpochContext blk)) + default ledgerStateHeaderStateMkPerasEpochContext :: + PerasEpochContext blk ~ DefaultPerasEpochContext blk => + LedgerState blk mk -> + HeaderState blk -> + Either + (PerasError blk) + (PerasEpochContext blk) + ledgerStateHeaderStateMkPerasEpochContext ledgerState headerState = do + let dpecParams = defaultPerasParams + dpecCommittee <- ledgerStateHeaderStateMkPerasVotingCommittee dpecParams ledgerState headerState + pure $ DefaultPerasEpochContext{dpecParams, dpecCommittee} + + ledgerStateHeaderStateMkPerasEpochContextResolver :: + LedgerState blk mk -> + HeaderState blk -> + PerasEpochContextResolver blk + default ledgerStateHeaderStateMkPerasEpochContextResolver :: + PerasEpochContextResolver blk ~ EmptyPerasEpochContextResolver => + LedgerState blk mk -> + HeaderState blk -> + PerasEpochContextResolver blk + ledgerStateHeaderStateMkPerasEpochContextResolver _ _ = emptyPerasEpochContextResolver + + resolveRoundNo :: + PerasEpochContextResolver blk -> + PerasRoundNo -> + Either PerasEpochContextNotFoundForRound (PerasEpochContext blk) + default resolveRoundNo :: + PerasEpochContextResolver blk ~ EmptyPerasEpochContextResolver => + PerasEpochContextResolver blk -> + PerasRoundNo -> + Either PerasEpochContextNotFoundForRound (PerasEpochContext blk) + resolveRoundNo = emptyResolveRoundNo + +-- absorbErrorInResolver :: +-- Either (PerasError blk) (PerasEpochContextResolver blk) -> +-- PerasEpochContextResolver blk +-- default absorbErrorInResolver :: +-- PerasEpochContextResolver blk ~ EmptyPerasEpochContextResolver => +-- Either (PerasError blk) (PerasEpochContextResolver blk) -> +-- PerasEpochContextResolver blk +-- absorbErrorInResolver = emptyAbsorbErrorInResolver + +-------------------------------------------------------------------------------- +-- Empty resolver +-------------------------------------------------------------------------------- + +emptyPerasEpochContextResolver :: + EmptyPerasEpochContextResolver +emptyPerasEpochContextResolver = EmptyPerasEpochContextResolver + +emptyResolveRoundNo :: + PerasEpochContextResolver blk ~ EmptyPerasEpochContextResolver => + PerasEpochContextResolver blk -> + PerasRoundNo -> + Either PerasEpochContextNotFoundForRound (PerasEpochContext blk) +emptyResolveRoundNo _ roundNo = Left $ PerasEpochContextNotFoundForRound roundNo + +emptyAbsorbErrorInResolver :: + PerasEpochContextResolver blk ~ EmptyPerasEpochContextResolver => + Either (PerasError blk) (PerasEpochContextResolver blk) -> + PerasEpochContextResolver blk +emptyAbsorbErrorInResolver _ = EmptyPerasEpochContextResolver -deriving instance Show (PerasEpochContext blk) => Show (PerasEpochContextResolver blk) -deriving instance Eq (PerasEpochContext blk) => Eq (PerasEpochContextResolver blk) -deriving instance NoThunks (PerasEpochContext blk) => NoThunks (PerasEpochContextResolver blk) -deriving instance Generic (PerasEpochContextResolver blk) +-------------------------------------------------------------------------------- +-- Mock Resolver +-------------------------------------------------------------------------------- -deriving instance Serialise (PerasEpochContext blk) => Serialise (PerasEpochContextResolver blk) -instance Serialise (PerasEpochContext blk) => EncodeDisk blk (PerasEpochContextResolver blk) -instance Serialise (PerasEpochContext blk) => DecodeDisk blk (PerasEpochContextResolver blk) +mockPerasEpochContextResolver :: + PerasEpochContext blk -> MockPerasEpochContextResolver blk +mockPerasEpochContextResolver = MockPerasEpochContextResolver + +mockResolveRoundNo :: + PerasEpochContextResolver blk ~ MockPerasEpochContextResolver blk => + PerasEpochContextResolver blk -> + PerasRoundNo -> + Either PerasEpochContextNotFoundForRound (PerasEpochContext blk) +mockResolveRoundNo resolver roundNo = case resolver of + MockPerasEpochContextResolverError _err -> Left $ PerasEpochContextNotFoundForRound roundNo + MockPerasEpochContextResolver context -> Right context + +mockAbsorbErrorInResolver :: + (PerasEpochContextResolver blk ~ MockPerasEpochContextResolver blk, Show (PerasError blk)) => + Either (PerasError blk) (PerasEpochContextResolver blk) -> + PerasEpochContextResolver blk +mockAbsorbErrorInResolver = \case + Left err -> MockPerasEpochContextResolverError (show err) + Right resolver -> resolver + +-------------------------------------------------------------------------------- +-- V1 Resolver +-------------------------------------------------------------------------------- + +v1InitPerasEpochContextResolver :: + BoundedPerasEpochContext blk -> + V1PerasEpochContextResolver blk +v1InitPerasEpochContextResolver currEpochContext = + V1PerasEpochContextResolver currEpochContext SNothing + +v1AdvancePerasEpochContextResolver :: + PerasVotingCommitteeScheme blk ~ V1.PerasVotingCommitteeScheme => + V1PerasEpochContextResolver blk -> + BoundedPerasEpochContext blk -> + V1PerasEpochContextResolver blk +v1AdvancePerasEpochContextResolver prev newEpochContext = case prev of + V1PerasEpochContextResolver prevEpochContextResolver _ -> + V1PerasEpochContextResolver + prevEpochContextResolver + (SJust newEpochContext) + _ -> V1PerasEpochContextResolver newEpochContext SNothing + +v1ResolveRoundNo :: + PerasEpochContextResolver blk ~ V1PerasEpochContextResolver blk => + PerasEpochContextResolver blk -> + PerasRoundNo -> + Either PerasEpochContextNotFoundForRound (PerasEpochContext blk) +v1ResolveRoundNo resolver roundNo = case resolver of + V1PerasEpochContextResolverError _err -> Left $ PerasEpochContextNotFoundForRound roundNo + V1PerasEpochContextResolver current mbPrev -> + maybeToEither (PerasEpochContextNotFoundForRound roundNo) $ + withinEpochContext roundNo current + <|> (withinEpochContext roundNo =<< strictMaybeToMaybe mbPrev) + +v1AbsorbErrorInResolver :: + (PerasEpochContextResolver blk ~ V1PerasEpochContextResolver blk, Show (PerasError blk)) => + Either (PerasError blk) (PerasEpochContextResolver blk) -> + PerasEpochContextResolver blk +v1AbsorbErrorInResolver = \case + Left err -> V1PerasEpochContextResolverError (show err) + Right resolver -> resolver + +-------------------------------------------------------------------------------- +-- Bounded context +-------------------------------------------------------------------------------- data BoundedPerasEpochContext blk = BoundedPerasEpochContext @@ -69,15 +319,23 @@ data BoundedPerasEpochContext blk , endPerasRoundNo :: PerasRoundNo -- exclusive , epochContext :: PerasEpochContext blk } - deriving instance Show (PerasEpochContext blk) => Show (BoundedPerasEpochContext blk) deriving instance Eq (PerasEpochContext blk) => Eq (BoundedPerasEpochContext blk) -deriving instance NoThunks (PerasEpochContext blk) => NoThunks (BoundedPerasEpochContext blk) deriving instance Generic (BoundedPerasEpochContext blk) - +deriving instance NoThunks (PerasEpochContext blk) => NoThunks (BoundedPerasEpochContext blk) deriving instance Serialise (PerasEpochContext blk) => Serialise (BoundedPerasEpochContext blk) -instance Serialise (PerasEpochContext blk) => EncodeDisk blk (BoundedPerasEpochContext blk) -instance Serialise (PerasEpochContext blk) => DecodeDisk blk (BoundedPerasEpochContext blk) +deriving instance Serialise (PerasEpochContext blk) => EncodeDisk blk (BoundedPerasEpochContext blk) +deriving instance Serialise (PerasEpochContext blk) => DecodeDisk blk (BoundedPerasEpochContext blk) + +-- [TODO EPOCH CONTEXT PLUMBING] : remove this guy +unsafeBoundedPerasEpochContextWithMinMaxBounds :: + PerasEpochContext blk -> BoundedPerasEpochContext blk +unsafeBoundedPerasEpochContextWithMinMaxBounds context = + BoundedPerasEpochContext + { startPerasRoundNo = minBound + , endPerasRoundNo = maxBound + , epochContext = context + } withinEpochContext :: PerasRoundNo -> @@ -90,37 +348,22 @@ withinEpochContext roundNo boundedContext | otherwise = Nothing -resolveRoundNo :: - PerasEpochContextResolver blk -> - PerasRoundNo -> - Either PerasEpochContextNotFoundForRound (PerasEpochContext blk) -resolveRoundNo resolver roundNo = - case resolver of - ConstPerasEpochContextResolver context -> - Right context - BoundedPerasEpochContextResolver currEpochContext mbPrevEpochContext -> - maybeToEither (PerasEpochContextNotFoundForRound roundNo) $ - withinEpochContext roundNo currEpochContext - <|> (withinEpochContext roundNo =<< mbPrevEpochContext) - -data PerasEpochContextNotFoundForRound = PerasEpochContextNotFoundForRound PerasRoundNo - deriving (Show, Eq, Generic, NoThunks, Exception) - newtype PerasEpochContextResolverHandle m blk = PerasEpochContextResolverHandle (STM m (PerasEpochContextResolver blk)) -constPerasEpochContextResolverHandle :: +mockPerasEpochContextResolverHandle :: ( IOLike m , NoThunks (PerasEpochContext blk) + , PerasEpochContextResolver blk ~ MockPerasEpochContextResolver blk ) => PerasEpochContext blk -> m (PerasEpochContextResolverHandle m blk) -constPerasEpochContextResolverHandle context = do - let resolver = ConstPerasEpochContextResolver context +mockPerasEpochContextResolverHandle context = do + let resolver = MockPerasEpochContextResolver $ context resolverVar <- newTVarIO resolver pure $ PerasEpochContextResolverHandle (readTVar resolverVar) resolveRoundNoWithHandle :: - MonadSTM m => + (MonadSTM m, LedgerStateHeaderStateSupportsPerasVoting blk) => PerasEpochContextResolverHandle m blk -> PerasRoundNo -> STM m (Either PerasEpochContextNotFoundForRound (PerasEpochContext blk)) @@ -132,6 +375,7 @@ verifyPerasVoteInContext :: ( MonadSTM m , MonadThrow (STM m) , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => PerasEpochContextResolverHandle m blk -> PerasVote blk -> @@ -149,6 +393,7 @@ verifyPerasCertInContext :: ( MonadSTM m , MonadThrow (STM m) , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => PerasEpochContextResolverHandle m blk -> PerasCert blk -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs index d522a28a0b..9abbcfb0e9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/Mock.hs @@ -17,7 +17,6 @@ module Ouroboros.Consensus.Peras.Crypto.Mock ( MockPerasVotingCommitteeScheme , MockPerasCrypto - , MockPerasCommittee , VotingCommittee (..) , VotingCommitteeInput (..) , VotingCommitteeError (..) @@ -69,8 +68,6 @@ import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Peras.Types (PerasSeatIndex (..)) import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) -data MockPerasVotingCommitteeScheme - data MockPerasCrypto blk type instance ElectionId (MockPerasCrypto blk) = PerasRoundNo @@ -150,7 +147,7 @@ instance CryptoSupportsAggregateVoteSigning (MockPerasCrypto blk) where -- () -------------------------------------------------------------------------------- -data MockPerasCommittee blk +data MockPerasVotingCommitteeScheme blk instance ( Ord (ElectionId crypto) @@ -158,31 +155,31 @@ instance , VoteCandidate crypto ~ Point blk , CryptoSupportsAggregateVoteSigning crypto ) => - CryptoSupportsVotingCommittee crypto (MockPerasCommittee blk) + CryptoSupportsVotingCommittee crypto (MockPerasVotingCommitteeScheme blk) where - newtype VotingCommittee crypto (MockPerasCommittee blk) + newtype VotingCommittee crypto (MockPerasVotingCommitteeScheme blk) = MockPerasVotingCommittee { -- Stake distribution weightDistr :: NonEmpty (PoolId, VoteWeight) } - newtype VotingCommitteeInput crypto (MockPerasCommittee blk) + newtype VotingCommitteeInput crypto (MockPerasVotingCommitteeScheme blk) = MockPerasVotingCommitteeInput (NonEmpty (PoolId, LedgerStake)) - newtype VotingCommitteeError crypto (MockPerasCommittee blk) + newtype VotingCommitteeError crypto (MockPerasVotingCommitteeScheme blk) = -- Seat index is out of bounds for the voting committee MissingSeatIndex PerasSeatIndex - data EligibilityWitness crypto (MockPerasCommittee blk) - = MockPerasCommitteeMember + data EligibilityWitness crypto (MockPerasVotingCommitteeScheme blk) + = MockPerasVotingCommitteeSchemeMember !PerasSeatIndex !VoteWeight - newtype Vote crypto (MockPerasCommittee blk) - = MockPerasCommitteeVote (MockPerasVote blk) + newtype Vote crypto (MockPerasVotingCommitteeScheme blk) + = MockPerasVotingCommitteeSchemeVote (MockPerasVote blk) - newtype Cert crypto (MockPerasCommittee blk) - = MockPerasCommitteeCert (MockPerasCert blk) + newtype Cert crypto (MockPerasVotingCommitteeScheme blk) + = MockPerasVotingCommitteeSchemeCert (MockPerasCert blk) mkVotingCommittee (MockPerasVotingCommitteeInput stakeDistr) = let LedgerStake totalStake = sum (snd <$> stakeDistr) @@ -190,115 +187,119 @@ instance in Right MockPerasVotingCommittee{weightDistr = second normalize <$> stakeDistr} checkShouldVote MockPerasVotingCommittee{weightDistr} poolId _ _ = case findWithIndex (\(pid, _) -> pid == poolId) weightDistr of - Just (rawIndex, (_pid, voteWeight)) -> Right . Just $ MockPerasCommitteeMember (unsafeIntToSeatIndex rawIndex) voteWeight + Just (rawIndex, (_pid, voteWeight)) -> Right . Just $ MockPerasVotingCommitteeSchemeMember (unsafeIntToSeatIndex rawIndex) voteWeight _ -> Right Nothing where findWithIndex :: (a -> Bool) -> NonEmpty a -> Maybe (Int, a) findWithIndex p xs = List.find (p . snd) (zip [0 ..] (NonEmpty.toList xs)) - forgeVote (MockPerasCommitteeMember seatIndex _) _ roundNo block = - MockPerasCommitteeVote $ + forgeVote (MockPerasVotingCommitteeSchemeMember seatIndex _) _ roundNo block = + MockPerasVotingCommitteeSchemeVote $ MockPerasVote { mockVoteRound = roundNo , mockVoteBlock = block , mockVoteSeatIndex = seatIndex } - verifyVote MockPerasVotingCommittee{weightDistr} (MockPerasCommitteeVote mockVote) = + verifyVote MockPerasVotingCommittee{weightDistr} (MockPerasVotingCommitteeSchemeVote mockVote) = let seatIndex = mockVoteSeatIndex mockVote in case NonEmpty.toList weightDistr !? seatIndexToInt seatIndex of - Just (_pid, voteWeight) -> Right $ MockPerasCommitteeMember seatIndex voteWeight + Just (_pid, voteWeight) -> Right $ MockPerasVotingCommitteeSchemeMember seatIndex voteWeight _ -> Left (MissingSeatIndex seatIndex) - eligiblePartyVoteWeight _ (MockPerasCommitteeMember _seatIndex voteWeight) = voteWeight + eligiblePartyVoteWeight _ (MockPerasVotingCommitteeSchemeMember _seatIndex voteWeight) = voteWeight forgeCert uniqueVoteWithSameTarget = do let roundNo = getElectionIdFromVotes uniqueVoteWithSameTarget block = getVoteCandidateFromVotes uniqueVoteWithSameTarget rawVotes = getRawVotes uniqueVoteWithSameTarget - let voters = NESet.fromList $ (\(MockPerasCommitteeVote mockVote) -> mockVoteSeatIndex mockVote) <$> rawVotes + let voters = + NESet.fromList $ + (\(MockPerasVotingCommitteeSchemeVote mockVote) -> mockVoteSeatIndex mockVote) <$> rawVotes pure $ - MockPerasCommitteeCert $ + MockPerasVotingCommitteeSchemeCert $ MockPerasCert { mockCertRound = roundNo , mockCertBlock = block , mockCertVoters = voters } - verifyCert committee (MockPerasCommitteeCert mockCert) = do + verifyCert committee (MockPerasVotingCommitteeSchemeCert mockCert) = do let voterList = NESet.toList $ mockCertVoters mockCert traverse (\seatIndex -> maybeToEither (MissingSeatIndex seatIndex) (getEligibility committee seatIndex)) voterList - voteTarget (MockPerasCommitteeVote MockPerasVote{mockVoteRound, mockVoteBlock}) = + voteTarget (MockPerasVotingCommitteeSchemeVote MockPerasVote{mockVoteRound, mockVoteBlock}) = (mockVoteRound, mockVoteBlock) compareVotesById - ( MockPerasCommitteeVote + ( MockPerasVotingCommitteeSchemeVote MockPerasVote{mockVoteRound = mockVoteRound1, mockVoteSeatIndex = mockVoteSeatIndex1} ) - ( MockPerasCommitteeVote + ( MockPerasVotingCommitteeSchemeVote MockPerasVote{mockVoteRound = mockVoteRound2, mockVoteSeatIndex = mockVoteSeatIndex2} ) = compare (mockVoteRound1, mockVoteSeatIndex1) (mockVoteRound2, mockVoteSeatIndex2) -deriving instance Show (VotingCommittee crypto (MockPerasCommittee blk)) -deriving instance Eq (VotingCommittee crypto (MockPerasCommittee blk)) -deriving instance NoThunks (VotingCommittee crypto (MockPerasCommittee blk)) -deriving instance Serialise (VotingCommittee crypto (MockPerasCommittee blk)) -deriving instance Generic (VotingCommittee crypto (MockPerasCommittee blk)) +deriving instance Show (VotingCommittee crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Eq (VotingCommittee crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance NoThunks (VotingCommittee crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Serialise (VotingCommittee crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Generic (VotingCommittee crypto (MockPerasVotingCommitteeScheme blk)) -deriving instance Show (VotingCommitteeInput crypto (MockPerasCommittee blk)) -deriving instance Eq (VotingCommitteeInput crypto (MockPerasCommittee blk)) -deriving instance NoThunks (VotingCommitteeInput crypto (MockPerasCommittee blk)) -deriving instance Serialise (VotingCommitteeInput crypto (MockPerasCommittee blk)) -deriving instance Generic (VotingCommitteeInput crypto (MockPerasCommittee blk)) +deriving instance Show (VotingCommitteeInput crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Eq (VotingCommitteeInput crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance NoThunks (VotingCommitteeInput crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Serialise (VotingCommitteeInput crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Generic (VotingCommitteeInput crypto (MockPerasVotingCommitteeScheme blk)) -deriving instance Show (VotingCommitteeError crypto (MockPerasCommittee blk)) -deriving instance Eq (VotingCommitteeError crypto (MockPerasCommittee blk)) -deriving instance NoThunks (VotingCommitteeError crypto (MockPerasCommittee blk)) -deriving instance Serialise (VotingCommitteeError crypto (MockPerasCommittee blk)) -deriving instance Generic (VotingCommitteeError crypto (MockPerasCommittee blk)) +deriving instance Show (VotingCommitteeError crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Eq (VotingCommitteeError crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance NoThunks (VotingCommitteeError crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Serialise (VotingCommitteeError crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Generic (VotingCommitteeError crypto (MockPerasVotingCommitteeScheme blk)) deriving instance ( Typeable crypto , Typeable blk ) => - Exception (VotingCommitteeError crypto (MockPerasCommittee blk)) + Exception (VotingCommitteeError crypto (MockPerasVotingCommitteeScheme blk)) -deriving instance StandardHash blk => Show (Vote crypto (MockPerasCommittee blk)) -deriving instance StandardHash blk => Eq (Vote crypto (MockPerasCommittee blk)) -deriving instance StandardHash blk => NoThunks (Vote crypto (MockPerasCommittee blk)) -deriving instance Serialise (HeaderHash blk) => Serialise (Vote crypto (MockPerasCommittee blk)) -deriving instance Generic (Vote crypto (MockPerasCommittee blk)) +deriving instance StandardHash blk => Show (Vote crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance StandardHash blk => Eq (Vote crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance StandardHash blk => NoThunks (Vote crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance + Serialise (HeaderHash blk) => Serialise (Vote crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Generic (Vote crypto (MockPerasVotingCommitteeScheme blk)) -deriving instance StandardHash blk => Show (Cert crypto (MockPerasCommittee blk)) -deriving instance StandardHash blk => Eq (Cert crypto (MockPerasCommittee blk)) -deriving instance StandardHash blk => NoThunks (Cert crypto (MockPerasCommittee blk)) -deriving instance Serialise (HeaderHash blk) => Serialise (Cert crypto (MockPerasCommittee blk)) -deriving instance Generic (Cert crypto (MockPerasCommittee blk)) +deriving instance StandardHash blk => Show (Cert crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance StandardHash blk => Eq (Cert crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance StandardHash blk => NoThunks (Cert crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance + Serialise (HeaderHash blk) => Serialise (Cert crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Generic (Cert crypto (MockPerasVotingCommitteeScheme blk)) -deriving instance Show (EligibilityWitness crypto (MockPerasCommittee blk)) -deriving instance Eq (EligibilityWitness crypto (MockPerasCommittee blk)) -deriving instance NoThunks (EligibilityWitness crypto (MockPerasCommittee blk)) -deriving instance Serialise (EligibilityWitness crypto (MockPerasCommittee blk)) -deriving instance Generic (EligibilityWitness crypto (MockPerasCommittee blk)) +deriving instance Show (EligibilityWitness crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Eq (EligibilityWitness crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance NoThunks (EligibilityWitness crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Serialise (EligibilityWitness crypto (MockPerasVotingCommitteeScheme blk)) +deriving instance Generic (EligibilityWitness crypto (MockPerasVotingCommitteeScheme blk)) instance PerasVoteCompatibleWithVotingCommittee (MockPerasVote blk) (MockPerasCrypto blk) -- We can theoretically use an arbitrary crypto scheme, but we must abide by 'vote -> crypto' fun dep - (MockPerasCommittee blk) + (MockPerasVotingCommitteeScheme blk) where - toPerasVote (MockPerasCommitteeVote mockVote) = + toPerasVote (MockPerasVotingCommitteeSchemeVote mockVote) = Right $ mockVote fromPerasVote mockVote = - Right $ MockPerasCommitteeVote mockVote + Right $ MockPerasVotingCommitteeSchemeVote mockVote instance PerasCertCompatibleWithVotingCommittee (MockPerasCert blk) (MockPerasCrypto blk) -- We can theoretically use an arbitrary crypto scheme, but we must abide by 'vote -> crypto' fun dep - (MockPerasCommittee blk) + (MockPerasVotingCommitteeScheme blk) where - toPerasCert (MockPerasCommitteeCert mockCert) = + toPerasCert (MockPerasVotingCommitteeSchemeCert mockCert) = Right $ mockCert fromPerasCert mockCert = - Right $ MockPerasCommitteeCert mockCert + Right $ MockPerasVotingCommitteeSchemeCert mockCert seatIndexToInt :: PerasSeatIndex -> Int seatIndexToInt (PerasSeatIndex seatIndex) = fromIntegral @Word16 @Int seatIndex @@ -310,9 +311,9 @@ unsafeIntToSeatIndex int | otherwise = error $ "unsafeIntToSeatIndex: Int out of bounds for PerasSeatIndex: " <> show int getEligibility :: - VotingCommittee crypto (MockPerasCommittee blk) -> + VotingCommittee crypto (MockPerasVotingCommitteeScheme blk) -> PerasSeatIndex -> - Maybe (EligibilityWitness crypto (MockPerasCommittee blk)) + Maybe (EligibilityWitness crypto (MockPerasVotingCommitteeScheme blk)) getEligibility MockPerasVotingCommittee{weightDistr} seatIndex = do (_poolId, voteWeight) <- NonEmpty.toList weightDistr !? seatIndexToInt seatIndex - pure $ MockPerasCommitteeMember seatIndex voteWeight + pure $ MockPerasVotingCommitteeSchemeMember seatIndex voteWeight diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/Mock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/Mock.hs index 0fb346d416..051219f500 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/Mock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/Mock.hs @@ -16,7 +16,10 @@ import Ouroboros.Consensus.Committee.Types (LedgerStake (..), PoolId (..)) import Ouroboros.Consensus.HardFork.Combinator.Basics (LedgerState) import Ouroboros.Consensus.HeaderValidation (HeaderState (..)) import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) -import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCommittee, VotingCommitteeInput (..)) +import Ouroboros.Consensus.Peras.Crypto.Mock + ( MockPerasVotingCommitteeScheme + , VotingCommitteeInput (..) + ) import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError (..)) -- | NOTE: this function will return an error on an empty stake distr, which is what the default instance of 'LedgerSupportsPeras' returns. @@ -26,7 +29,7 @@ ledgerStateHeaderStateMkMockPerasVotingCommitteeInput :: PerasParams blk -> LedgerState blk mk -> HeaderState blk -> - Either (MockPerasError blk) (VotingCommitteeInput crypto (MockPerasCommittee blk)) + Either (MockPerasError blk) (VotingCommitteeInput crypto (MockPerasVotingCommitteeScheme blk)) ledgerStateHeaderStateMkMockPerasVotingCommitteeInput _perasParams ledgerState _headerState = do let PoolDistr{unPoolDistr} = getPoolDistr ledgerState stakeDistr = nonEmpty $ fmap (bimap PoolId (LedgerStake . individualPoolStake)) . Map.toList $ unPoolDistr diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/V1.hs index 1f0ebd1586..41868ee328 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/V1.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/State/V1.hs @@ -14,8 +14,8 @@ import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee (..)) import Ouroboros.Consensus.Committee.Crypto (PublicKey) import Ouroboros.Consensus.Committee.WFA (mkExtWFAStakeDistr, wFATiebreakerWithEpochNonce) import Ouroboros.Consensus.Committee.WFALS (VotingCommitteeInput (..), WFALS) -import Ouroboros.Consensus.HardFork.Combinator.Basics (LedgerState) import Ouroboros.Consensus.HeaderValidation (HeaderState (..)) +import Ouroboros.Consensus.Ledger.Abstract (LedgerState) import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS import Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/V1.hs new file mode 100644 index 0000000000..98f3a6a7ac --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/V1.hs @@ -0,0 +1,5 @@ +module Ouroboros.Consensus.Peras.Voting.V1 (PerasVotingCommitteeScheme) where + +import Ouroboros.Consensus.Committee.WFALS (WFALS) + +type PerasVotingCommitteeScheme = WFALS 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 269f0eeb50..6242ec6657 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 @@ -61,6 +61,7 @@ import Ouroboros.Consensus.Ledger.Extended (getPerasEpochContextResolverHandle, import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as API import Ouroboros.Consensus.Storage.ChainDB.Impl.Args @@ -102,6 +103,7 @@ withDB :: ( IOLike m , LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk , InspectLedger blk @@ -119,6 +121,7 @@ openDB :: ( IOLike m , LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk , InspectLedger blk @@ -135,6 +138,7 @@ openDBInternal :: ( IOLike m , LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , BlockSupportsDiffusionPipelining blk , BlockSupportsPeras blk , InspectLedger blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs index cf3f52bfe2..40587045be 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -24,6 +24,7 @@ import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Storage.ImmutableDB.Stream import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Args @@ -48,6 +49,7 @@ openDB :: forall m blk st. ( IOLike m , LedgerSupportsProtocol blk + , LedgerStateHeaderStateSupportsPerasVoting blk , InspectLedger blk , HasCallStack , HasHardForkHistory blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs index 5f376d8138..3ebd5b6724 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs @@ -243,6 +243,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache import Ouroboros.Consensus.Storage.ImmutableDB.Stream @@ -267,8 +268,9 @@ import System.FS.CRC -- instantiated with a @blk@. type LedgerDbSerialiseConstraints blk = ( Serialise (HeaderHash blk) - , Serialise (PerasEpochContext blk) - , Serialise (PerasEpochContext blk) + , Serialise (PerasEpochContextResolver blk) + , EncodeDisk blk (PerasEpochContextResolver blk) + , DecodeDisk blk (PerasEpochContextResolver blk) , EncodeDisk blk (LedgerState blk EmptyMK) , DecodeDisk blk (LedgerState blk EmptyMK) , EncodeDisk blk (AnnTip blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs index 20aca78c5c..3f28c7c73e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs @@ -46,6 +46,7 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Args @@ -73,6 +74,7 @@ mkInitDb :: forall m blk backend. ( LedgerSupportsProtocol blk , HasHardForkHistory blk + , LedgerStateHeaderStateSupportsPerasVoting blk , Backend m backend blk , IOLike m ) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index b8f85208a4..38b8b9e00c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -35,7 +35,7 @@ import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (WithArrivalTime (..)) -import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle, resolveRoundNoWithHandle) +import Ouroboros.Consensus.Peras.Context import Ouroboros.Consensus.Peras.Vote.Aggregation import Ouroboros.Consensus.Storage.PerasVoteDB.API import Ouroboros.Consensus.Util.Args @@ -184,6 +184,7 @@ createDB :: forall m blk. ( IOLike m , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => Complete PerasVoteDbArgs m blk -> m (PerasVoteDB m blk) @@ -219,6 +220,7 @@ createDB args@PerasVoteDbArgs{pvdbaPerasEpochContextResolverHandle} = do implAddVote :: ( IOLike m , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => PerasEpochContextResolverHandle m blk -> PerasVoteDbEnv m blk -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index bad4dfcf5d..8d735be5a6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -24,6 +24,7 @@ import Data.IntPSQ (IntPSQ) import qualified Data.IntPSQ as PSQ import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap +import Data.Maybe.Strict (StrictMaybe, maybeToStrictMaybe, strictMaybeToMaybe) import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MultiSet import Data.SOP.BasicFunctors @@ -62,6 +63,10 @@ instance Serialise Nonce where encode = toCBOR decode = fromCBOR +instance Serialise a => Serialise (StrictMaybe a) where + encode = encode . strictMaybeToMaybe + decode = maybeToStrictMaybe <$> decode + {------------------------------------------------------------------------------- NoThunks -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index 564e92e455..3a98cbfc9a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -118,8 +118,10 @@ import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) ) -import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCommittee, MockPerasCrypto) +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting (..), MockPerasEpochContextResolver, mockAbsorbErrorInResolver, mockPerasEpochContextResolver, mockResolveRoundNo) +import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCrypto, MockPerasVotingCommitteeScheme) import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) +import Ouroboros.Consensus.Peras.State.Mock (ledgerStateHeaderStateMkMockPerasVotingCommitteeInput) import Ouroboros.Consensus.Peras.Vote.Mock ( MockPerasVote (..) ) @@ -730,6 +732,17 @@ instance LedgerSupportsProtocol TestBlock where instance LedgerSupportsPeras TestBlock where getLatestPerasCertRound = latestPerasCertRound +instance LedgerStateHeaderStateSupportsPerasVoting TestBlock where + type PerasEpochContextResolver TestBlock = MockPerasEpochContextResolver TestBlock + + ledgerStateHeaderStateMkPerasVotingCommitteeInput = ledgerStateHeaderStateMkMockPerasVotingCommitteeInput + + ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState = + mockAbsorbErrorInResolver $ + mockPerasEpochContextResolver <$> ledgerStateHeaderStateMkPerasEpochContext ledgerState headerState + + resolveRoundNo = mockResolveRoundNo + {------------------------------------------------------------------------------- BlockSupportsPeras -------------------------------------------------------------------------------} @@ -738,7 +751,7 @@ instance LedgerSupportsPeras TestBlock where instance BlockSupportsPeras TestBlock where type PerasCrypto TestBlock = MockPerasCrypto TestBlock - type PerasVotingCommitteeScheme TestBlock = MockPerasCommittee TestBlock + type PerasVotingCommitteeScheme TestBlock = MockPerasVotingCommitteeScheme TestBlock type PerasVote TestBlock = MockPerasVote TestBlock type PerasCert TestBlock = MockPerasCert TestBlock type PerasError TestBlock = MockPerasError TestBlock @@ -757,12 +770,14 @@ testInitLedger = TestLedger GenesisPoint GenesisHash Nothing testInitExtLedger :: ExtLedgerState TestBlock EmptyMK testInitExtLedger = - ExtLedgerState - { ledgerState = testInitLedger - , headerState = genesisHeaderState () - , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - perasEpochContextResolver = undefined - } + let ledgerState = testInitLedger + headerState = genesisHeaderState () + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } -- Only for a single node mkTestConfig :: SecurityParam -> ChunkSize -> TopLevelConfig TestBlock diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index 3b882dc7d8..7145242cfd 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -24,7 +24,12 @@ import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mempool.API import Ouroboros.Consensus.Mempool.TxSeq import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert) -import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolver) +import Ouroboros.Consensus.Peras.Context + ( EmptyPerasEpochContextResolver + , MockPerasEpochContextResolver + , PerasEpochContextResolver + , V1PerasEpochContextResolver + ) import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..)) @@ -142,7 +147,11 @@ instance ToExpr PerasSeatIndex where toExpr = defaultExprViaShow instance ToExpr (HeaderHash blk) => ToExpr (MockPerasVote blk) instance ToExpr (HeaderHash blk) => ToExpr (MockPerasCert blk) -instance Show (PerasEpochContext blk) => ToExpr (PerasEpochContextResolver blk) where +instance ToExpr EmptyPerasEpochContextResolver where + toExpr = defaultExprViaShow +instance Show (PerasEpochContext blk) => ToExpr (MockPerasEpochContextResolver blk) where + toExpr = defaultExprViaShow +instance Show (PerasEpochContext blk) => ToExpr (V1PerasEpochContextResolver blk) where toExpr = defaultExprViaShow {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs index 3d8f8906e2..517038ae10 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Peras/Mock.hs @@ -32,8 +32,8 @@ import Ouroboros.Consensus.Block.SupportsPeras import Ouroboros.Consensus.Committee.Class import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Peras.Crypto.Mock - ( MockPerasCommittee - , MockPerasCrypto + ( MockPerasCrypto + , MockPerasVotingCommitteeScheme , VotingCommittee (..) , VotingCommitteeInput (..) , getEligibility @@ -54,14 +54,14 @@ import Test.Util.Peras.Internal import Test.Util.TestBlock (TestBlock) genMockPerasVotingCommitteeInput :: - Gen (VotingCommitteeInput (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock)) + Gen (VotingCommitteeInput (MockPerasCrypto TestBlock) (MockPerasVotingCommitteeScheme TestBlock)) genMockPerasVotingCommitteeInput = do NonEmptyListWithUniqueIds poolIds <- genNonEmptyListWithUniqueIds id genPoolId poolIdsWithStakes <- traverse (\poolId -> (poolId,) <$> genLedgerStake) poolIds pure $ MockPerasVotingCommitteeInput poolIdsWithStakes genMockPerasVotingCommittee :: - Gen (VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock)) + Gen (VotingCommittee (MockPerasCrypto TestBlock) (MockPerasVotingCommitteeScheme TestBlock)) genMockPerasVotingCommittee = fromRight (error "mkVotingCommittee of O.C.Peras.Crypto.Mock can't fail") . mkVotingCommittee <$> genMockPerasVotingCommitteeInput @@ -70,13 +70,14 @@ genMockPerasEpochContext :: Gen (PerasEpochContext TestBlock) genMockPerasEpochContext = DefaultPerasEpochContext <$> genMockPerasVotingCommittee <*> genPerasParams pickSeatIndexFromCommittee :: - VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> Gen PerasSeatIndex + VotingCommittee (MockPerasCrypto TestBlock) (MockPerasVotingCommitteeScheme TestBlock) -> + Gen PerasSeatIndex pickSeatIndexFromCommittee committee = do let maxIndex = length (weightDistr committee) - 1 unsafeIntToSeatIndex <$> choose (0, maxIndex) genVotersSubset :: - VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> + VotingCommittee (MockPerasCrypto TestBlock) (MockPerasVotingCommitteeScheme TestBlock) -> Gen (NE (Set PerasSeatIndex)) genVotersSubset committee = do NonEmptyListWithUniqueIds seatIndices <- @@ -90,7 +91,7 @@ genMockPerasVoterIndices = do pure $ NESet.fromList seatIndices genMockPerasVote :: - VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> + VotingCommittee (MockPerasCrypto TestBlock) (MockPerasVotingCommitteeScheme TestBlock) -> Gen (MockPerasVote TestBlock) genMockPerasVote committee = do seatIndex <- pickSeatIndexFromCommittee committee @@ -121,7 +122,7 @@ genMockValidatedPerasVote context = do } genMockPerasCert :: - VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> + VotingCommittee (MockPerasCrypto TestBlock) (MockPerasVotingCommitteeScheme TestBlock) -> Gen (MockPerasCert TestBlock) genMockPerasCert committee = do votersSubset <- genVotersSubset committee @@ -135,7 +136,7 @@ genMockPerasCert committee = do } genMockPerasCertFullCommittee :: - VotingCommittee (MockPerasCrypto TestBlock) (MockPerasCommittee TestBlock) -> + VotingCommittee (MockPerasCrypto TestBlock) (MockPerasVotingCommitteeScheme TestBlock) -> Gen (MockPerasCert TestBlock) genMockPerasCertFullCommittee committee = do let maxIndex = length (weightDistr committee) - 1 diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs index b7a66ecd8c..faab38ddbc 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Roundtrip.hs @@ -87,6 +87,9 @@ import Ouroboros.Consensus.Node.Run , SerialiseNodeToNodeConstraints (..) ) import Ouroboros.Consensus.Node.Serialisation +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (PerasEpochContextResolver) + ) import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) import Ouroboros.Consensus.Storage.ChainDB (SerialiseDiskConstraints) import Ouroboros.Consensus.Storage.Serialisation @@ -905,7 +908,13 @@ $( do ) examplesRoundtrip :: forall blk. - (SerialiseDiskConstraints blk, Eq blk, Show blk, LedgerSupportsProtocol blk) => + ( SerialiseDiskConstraints blk + , Eq blk + , Show blk + , LedgerSupportsProtocol blk + , Eq (PerasEpochContextResolver blk) + , Show (PerasEpochContextResolver blk) + ) => CodecConfig blk -> Examples blk -> [TestTree] diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index 4da6bd8691..c458391b54 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -145,7 +145,8 @@ import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) ) -import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCommittee, MockPerasCrypto) +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting (..), MockPerasEpochContextResolver, mockAbsorbErrorInResolver, mockPerasEpochContextResolver, mockResolveRoundNo) +import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCrypto, MockPerasVotingCommitteeScheme) import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) import Ouroboros.Consensus.Peras.SelectView (weightedSelectView) import Ouroboros.Consensus.Peras.State.Mock (ledgerStateHeaderStateMkMockPerasVotingCommitteeInput) @@ -641,14 +642,17 @@ deriving anyclass instance NoThunks (Ticked LedgerState (TestBlockWith ptype) mk) testInitExtLedgerWithState :: + Typeable ptype => PayloadDependentState ptype mk -> ExtLedgerState (TestBlockWith ptype) mk testInitExtLedgerWithState st = - ExtLedgerState - { ledgerState = testInitLedgerWithState st - , headerState = genesisHeaderState () - , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - perasEpochContextResolver = undefined - } + let ledgerState = testInitLedgerWithState st + headerState = genesisHeaderState () + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } data TestBlockLedgerConfig = TestBlockLedgerConfig { tblcHardForkParams :: !HardFork.EraParams @@ -705,12 +709,18 @@ instance PayloadSemantics ptype => LedgerSupportsProtocol (TestBlockWith ptype) instance LedgerSupportsPeras (TestBlockWith ptype) instance Typeable ptype => LedgerStateHeaderStateSupportsPerasVoting (TestBlockWith ptype) where - -- TODO: this will blow up if we actually try to use it - -- Potential solutions: - -- 1. have an extra type parameter indicating if Peras support is expected for this instance of TestBlock, and choose between mock/void crypto depending on that - -- 2. extend LedgerState for 'TestBlock' to provide a non-default instance of 'LedgerSupportsPeras', i.e. return a non-empty stake distribution + type + PerasEpochContextResolver (TestBlockWith ptype) = + MockPerasEpochContextResolver (TestBlockWith ptype) + ledgerStateHeaderStateMkPerasVotingCommitteeInput = ledgerStateHeaderStateMkMockPerasVotingCommitteeInput + ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState = + mockAbsorbErrorInResolver $ + mockPerasEpochContextResolver <$> ledgerStateHeaderStateMkPerasEpochContext ledgerState headerState + + resolveRoundNo = mockResolveRoundNo + {------------------------------------------------------------------------------- BlockSupportsPeras -------------------------------------------------------------------------------} @@ -722,12 +732,14 @@ instance BlockSupportsPeras (TestBlockWith ptype) where type PerasCrypto (TestBlockWith ptype) = MockPerasCrypto (TestBlockWith ptype) - type PerasVotingCommitteeScheme (TestBlockWith ptype) = MockPerasCommittee (TestBlockWith ptype) + type + PerasVotingCommitteeScheme (TestBlockWith ptype) = + MockPerasVotingCommitteeScheme (TestBlockWith ptype) type PerasVote (TestBlockWith ptype) = MockPerasVote (TestBlockWith ptype) type PerasCert (TestBlockWith ptype) = MockPerasCert (TestBlockWith ptype) type PerasError (TestBlockWith ptype) = MockPerasError (TestBlockWith ptype) - -- TODO: extract actual Peras certificates from blocks + -- No certs are stored in 'TestBlockWith' getPerasCertInBlock _ = Nothing {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs index 0b26dc18bf..fdd58bcdc7 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/BFT.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NamedFieldPuns #-} + module Ouroboros.Consensus.Mock.Node.BFT ( MockBftBlock , blockForgingBft @@ -10,11 +12,12 @@ import Ouroboros.Consensus.Block.Forging (BlockForging) import Ouroboros.Consensus.Config import qualified Ouroboros.Consensus.HardFork.History as HardFork import Ouroboros.Consensus.HeaderValidation -import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..)) import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Mock.Node import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId (CoreNodeId (..), NodeId (..)) +import Ouroboros.Consensus.Peras.Context import Ouroboros.Consensus.Protocol.BFT type MockBftBlock = SimpleBftBlock SimpleMockCrypto BftMockCrypto @@ -50,11 +53,14 @@ protocolInfoBft numCoreNodes nid securityParam eraParams = , topLevelConfigCheckpoints = emptyCheckpointsMap } , pInfoInitLedger = - ExtLedgerState - (genesisSimpleLedgerState addrDist) - (genesisHeaderState ()) - -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - undefined + let ledgerState = genesisSimpleLedgerState addrDist + headerState = genesisHeaderState () + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } } where signKey :: CoreNodeId -> SignKeyDSIGN MockDSIGN diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs index 132e8b8f7e..9d687da959 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs @@ -20,6 +20,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool (txForgetValidated) import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId (CoreNodeId (..)) +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting (..)) import Ouroboros.Consensus.Protocol.PBFT import qualified Ouroboros.Consensus.Protocol.PBFT.State as S @@ -44,11 +45,14 @@ protocolInfoMockPBFT params eraParams = , topLevelConfigCheckpoints = emptyCheckpointsMap } , pInfoInitLedger = - ExtLedgerState - (genesisSimpleLedgerState addrDist) - (genesisHeaderState S.empty) - -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - undefined + let ledgerState = genesisSimpleLedgerState addrDist + headerState = genesisHeaderState S.empty + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } } where ledgerView :: PBftLedgerView PBftMockCrypto diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs index 1452104da8..2347d46d8e 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Peras.hs @@ -14,6 +14,7 @@ module Ouroboros.Consensus.Mock.Node.Peras () where import Data.Typeable (Typeable) import Ouroboros.Consensus.Block.SupportsPeras (BlockSupportsPeras (..)) import Ouroboros.Consensus.Mock.Ledger.Block (SimpleBlock, SimpleCrypto) +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting (..)) {------------------------------------------------------------------------------- BlockSupportsPeras @@ -23,3 +24,7 @@ import Ouroboros.Consensus.Mock.Ledger.Block (SimpleBlock, SimpleCrypto) instance (SimpleCrypto c, Typeable ext) => BlockSupportsPeras (SimpleBlock c ext) + +instance + (SimpleCrypto c, Typeable ext) => + LedgerStateHeaderStateSupportsPerasVoting (SimpleBlock c ext) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs index 9dbdb4dde0..6a9a54ac15 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -24,6 +25,9 @@ import Ouroboros.Consensus.Mock.Ledger import Ouroboros.Consensus.Mock.Protocol.Praos import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId (CoreNodeId (..)) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (ledgerStateHeaderStateMkPerasEpochContextResolver) + ) import Ouroboros.Consensus.Util.IOLike type MockPraosBlock = SimplePraosBlock SimpleMockCrypto PraosMockCrypto @@ -56,12 +60,14 @@ protocolInfoPraos numCoreNodes nid params eraParams eta0 evolvingStakeDist = , topLevelConfigCheckpoints = emptyCheckpointsMap } , pInfoInitLedger = - ExtLedgerState - { ledgerState = genesisSimpleLedgerState addrDist - , headerState = genesisHeaderState (PraosChainDepState []) - , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - perasEpochContextResolver = undefined - } + let ledgerState = genesisSimpleLedgerState addrDist + headerState = genesisHeaderState (PraosChainDepState []) + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } } where signKeyVRF :: CoreNodeId -> SignKeyVRF MockVRF diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs index 508e7e45f2..2834347dca 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PraosRule.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NamedFieldPuns #-} + -- | Test the Praos chain selection rule but with explicit leader schedule module Ouroboros.Consensus.Mock.Node.PraosRule ( MockPraosRuleBlock @@ -20,6 +22,7 @@ import Ouroboros.Consensus.Mock.Protocol.LeaderSchedule import Ouroboros.Consensus.Mock.Protocol.Praos import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId (CoreNodeId (..)) +import Ouroboros.Consensus.Peras.Context (ledgerStateHeaderStateMkPerasEpochContextResolver) type MockPraosRuleBlock = SimplePraosRuleBlock SimpleMockCrypto @@ -62,12 +65,14 @@ protocolInfoPraosRule , topLevelConfigCheckpoints = emptyCheckpointsMap } , pInfoInitLedger = - ExtLedgerState - { ledgerState = genesisSimpleLedgerState addrDist - , headerState = genesisHeaderState () - , -- [TODO EPOCH CONTEXT PLUMBING] we need to fix this - perasEpochContextResolver = undefined - } + let ledgerState = genesisSimpleLedgerState addrDist + headerState = genesisHeaderState () + perasEpochContextResolver = ledgerStateHeaderStateMkPerasEpochContextResolver ledgerState headerState + in ExtLedgerState + { ledgerState + , headerState + , perasEpochContextResolver + } } where addrDist :: AddrDist diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index 4a5f04190b..710603f785 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -22,7 +22,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert -import Ouroboros.Consensus.Peras.Context (constPerasEpochContextResolverHandle) +import Ouroboros.Consensus.Peras.Context (mockPerasEpochContextResolverHandle) import Ouroboros.Consensus.Storage.PerasCertDB.API ( AddPerasCertResult (..) , PerasCertDB @@ -95,7 +95,7 @@ prop_smoke = , m [PerasCert TestBlock] ) mkPoolInterfaces = do - epochContextResolverHandle <- constPerasEpochContextResolverHandle epochContext + epochContextResolverHandle <- mockPerasEpochContextResolverHandle epochContext outboundPool <- newCertDB watValidatedCerts inboundPool <- newCertDB [] diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs index 9c9c6ccc15..466d74a079 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs @@ -19,10 +19,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote -import Ouroboros.Consensus.Peras.Context - ( PerasEpochContextResolverHandle - , constPerasEpochContextResolverHandle - ) +import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting, PerasEpochContextResolverHandle, mockPerasEpochContextResolverHandle) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB @@ -63,6 +60,7 @@ tests = newVoteDB :: ( IOLike m , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => PerasEpochContextResolverHandle m blk -> [WithArrivalTime (ValidatedPerasVote blk)] -> @@ -96,7 +94,7 @@ prop_smoke = , m [PerasVote TestBlock] ) mkPoolInterfaces = do - epochContextResolverHandle <- constPerasEpochContextResolverHandle epochContext + epochContextResolverHandle <- mockPerasEpochContextResolverHandle epochContext outboundPool <- newVoteDB epochContextResolverHandle watValidatedVotes inboundPool <- newVoteDB epochContextResolverHandle [] diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 573d7d2d73..d1e016cc0d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -115,6 +115,9 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (PerasEpochContextResolver) + ) import Ouroboros.Consensus.Peras.SelectView import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract @@ -193,6 +196,7 @@ deriving instance deriving instance ( LedgerSupportsProtocol blk + , Show (PerasEpochContextResolver blk) , Show (PerasVote blk) , Show (PerasCert blk) , Show blk @@ -461,6 +465,7 @@ empty loe initLedger = addBlock :: forall blk. ( LedgerSupportsProtocol blk + , LedgerStateHeaderStateSupportsPerasVoting blk , LedgerTablesAreTrivial ExtLedgerState blk , IsPerasCert (PerasCert blk) blk ) => @@ -496,6 +501,7 @@ addPerasCert :: , LedgerTablesAreTrivial ExtLedgerState blk , Ord (PerasCert blk) , IsPerasCert (PerasCert blk) blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => TopLevelConfig blk -> WithArrivalTime (ValidatedPerasCert blk) -> @@ -508,6 +514,7 @@ addPerasVote :: forall blk. ( LedgerSupportsProtocol blk , LedgerTablesAreTrivial ExtLedgerState blk + , LedgerStateHeaderStateSupportsPerasVoting blk , Ord (PerasVote blk) , Ord (PerasCert blk) , PerasCert blk ~ MockPerasCert blk @@ -532,6 +539,7 @@ chainSelection :: ( LedgerTablesAreTrivial ExtLedgerState blk , LedgerSupportsProtocol blk , IsPerasCert (PerasCert blk) blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => TopLevelConfig blk -> Model blk -> @@ -661,6 +669,7 @@ chainSelection cfg m = addBlocks :: ( LedgerSupportsProtocol blk , LedgerTablesAreTrivial ExtLedgerState blk + , LedgerStateHeaderStateSupportsPerasVoting blk , IsPerasCert (PerasCert blk) blk ) => TopLevelConfig blk -> @@ -675,6 +684,7 @@ addBlockPromise :: ( LedgerSupportsProtocol blk , MonadSTM m , LedgerTablesAreTrivial ExtLedgerState blk + , LedgerStateHeaderStateSupportsPerasVoting blk , IsPerasCert (PerasCert blk) blk ) => TopLevelConfig blk -> @@ -699,6 +709,7 @@ updateLoE :: forall blk. ( LedgerTablesAreTrivial ExtLedgerState blk , LedgerSupportsProtocol blk + , LedgerStateHeaderStateSupportsPerasVoting blk , IsPerasCert (PerasCert blk) blk ) => TopLevelConfig blk -> @@ -899,7 +910,10 @@ data ValidatedChain blk -- 'invalid' of the given 'Model'. validate :: forall blk. - (LedgerSupportsProtocol blk, LedgerTablesAreTrivial ExtLedgerState blk) => + ( LedgerSupportsProtocol blk + , LedgerTablesAreTrivial ExtLedgerState blk + , LedgerStateHeaderStateSupportsPerasVoting blk + ) => TopLevelConfig blk -> Model blk -> Chain blk -> @@ -962,6 +976,7 @@ validChains :: forall blk. ( LedgerSupportsProtocol blk , LedgerTablesAreTrivial ExtLedgerState blk + , LedgerStateHeaderStateSupportsPerasVoting blk , IsPerasCert (PerasCert blk) blk ) => TopLevelConfig blk -> @@ -1221,6 +1236,7 @@ wipeVolatileDB :: ( LedgerSupportsProtocol blk , LedgerTablesAreTrivial ExtLedgerState blk , IsPerasCert (PerasCert blk) blk + , LedgerStateHeaderStateSupportsPerasVoting blk ) => TopLevelConfig blk -> Model blk -> 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 3c88d815e1..cd704c85fd 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 @@ -128,6 +128,9 @@ import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (PerasEpochContextResolver) + ) import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB hiding @@ -369,6 +372,7 @@ type TestConstraints blk = ( ConsensusProtocol (BlockProtocol blk) , LedgerSupportsProtocol blk , LedgerSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk , BlockSupportsDiffusionPipelining blk , InspectLedger blk , Eq (ChainDepState (BlockProtocol blk)) @@ -1625,6 +1629,7 @@ deriving instance , ToExpr (TipInfo blk) , ToExpr (LedgerState blk EmptyMK) , ToExpr (ExtValidationError blk) + , ToExpr (PerasEpochContextResolver blk) , StandardHash blk , Show blk , Show (PerasVote blk) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs index f54db01e43..7b24c2359f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB/StateMachine.hs @@ -53,7 +53,7 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , WithArrivalTime (..) ) -import Ouroboros.Consensus.Peras.Context (constPerasEpochContextResolverHandle) +import Ouroboros.Consensus.Peras.Context (mockPerasEpochContextResolverHandle) import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote (..)) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) @@ -272,7 +272,7 @@ instance RunModel Model (StateT (PerasVoteDB IO TestBlock) IO) where perform _ action _ = case action of CreateDB context -> do - resolverHandle <- lift $ constPerasEpochContextResolverHandle context + resolverHandle <- lift $ mockPerasEpochContextResolverHandle context let args = PerasVoteDB.PerasVoteDbArgs nullTracer resolverHandle voteDB <- lift $ PerasVoteDB.createDB args put voteDB From da417bab24070acfa46ba072857bd10878bd3e34 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Fri, 5 Jun 2026 13:57:30 +0200 Subject: [PATCH 54/62] Add getPerasVotingViewHandle to the ChainDB --- .../Cardano/Tools/DBAnalyser/Analysis.hs | 5 +- .../Ouroboros/Consensus/Peras/Context.hs | 24 +++++++ .../Ouroboros/Consensus/Peras/Voting/Rules.hs | 5 +- .../Ouroboros/Consensus/Peras/Voting/View.hs | 25 +++++--- .../Consensus/Storage/ChainDB/API.hs | 20 +++--- .../Consensus/Storage/ChainDB/Impl.hs | 12 +++- .../Consensus/Storage/ChainDB/Impl/Query.hs | 62 +++++++++++++++++++ .../Test/Ouroboros/Storage/TestBlock.hs | 8 ++- .../Test/Util/TestBlock.hs | 8 ++- .../ObjectDiffusion/PerasVote/Smoke.hs | 6 +- .../Test/Consensus/Peras/Voting/Rules.hs | 18 +++--- 11 files changed, 160 insertions(+), 33 deletions(-) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs index 89a57b3c6e..99f1e4edcd 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs @@ -69,7 +69,10 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import qualified Ouroboros.Consensus.Mempool as Mempool import Ouroboros.Consensus.Mempool.Impl.Common -import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting, ledgerStateHeaderStateMkPerasEpochContextResolver) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting + , ledgerStateHeaderStateMkPerasEpochContextResolver + ) import Ouroboros.Consensus.Protocol.Abstract (LedgerView) import Ouroboros.Consensus.Storage.Common (BlockComponent (..)) import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs index 23f2a7a569..75db2be3cb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs @@ -38,6 +38,7 @@ module Ouroboros.Consensus.Peras.Context , verifyPerasCertInContext , unsafeBoundedPerasEpochContextWithMinMaxBounds , mockPerasEpochContextResolverHandle + , forgePerasVoteIfEligibleInContext ) where @@ -52,6 +53,7 @@ import Data.Kind (Type) import Data.Maybe.Strict (StrictMaybe (..)) import Data.Typeable (Typeable) import GHC.Generics (Generic) +import Ouroboros.Consensus.Block.Abstract (Point) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) , DefaultPerasEpochContext (..) @@ -70,6 +72,8 @@ import Ouroboros.Consensus.Block.SupportsPeras ) import Ouroboros.Consensus.Committee.Class (CryptoSupportsVotingCommittee) import qualified Ouroboros.Consensus.Committee.Class as Committee +import Ouroboros.Consensus.Committee.Crypto (PrivateKey) +import Ouroboros.Consensus.Committee.Types (PoolId) import Ouroboros.Consensus.HeaderValidation (HeaderState) import Ouroboros.Consensus.Ledger.Abstract (LedgerState) import Ouroboros.Consensus.Peras.Params (PerasParams) @@ -406,3 +410,23 @@ verifyPerasCertInContext handle cert = do case verifyPerasCert context cert of Left err -> throwSTM err Right validatedCert -> pure validatedCert + +forgePerasVoteIfEligibleInContext :: + ( MonadSTM m + , MonadThrow (STM m) + , BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk + ) => + PerasEpochContextResolverHandle m blk -> + PoolId -> + PrivateKey (PerasCrypto blk) -> + PerasRoundNo -> + Point blk -> + STM m (Maybe (ValidatedPerasVote blk)) +forgePerasVoteIfEligibleInContext handle poolId privateKey roundNo point = do + resolveRoundNoWithHandle handle roundNo >>= \case + Left err -> throwSTM err + Right context -> + case forgePerasVoteIfEligible context poolId privateKey roundNo point of + Left err -> throwSTM err + Right maybeValidatedVote -> pure maybeValidatedVote diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs index 44b2750ebf..ecb24db397 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs @@ -220,7 +220,6 @@ perasVR2A -- This enforces chain quality and common prefix before leaving a cooldown -- period. perasVR2B :: - IsPerasCert cert blk => PerasVotingView cert blk -> Pred PerasVotingRule perasVR2B @@ -236,10 +235,10 @@ perasVR2B -- There is a certificate on chain ==> we must check its round number NotOrigin cert -> -- The certificate comes from a round older than the current one - (currRoundNo :>: getPerasCertRound (lcocCert cert)) + (currRoundNo :>: lcocCertRoundNo cert) -- The certificate round is câ‹…K rounds away from the current one :/\: ( (currRoundNo `rmod` _K) - :==: (getPerasCertRound (lcocCert cert) `rmod` _K) + :==: (lcocCertRoundNo cert `rmod` _K) ) -- There is no certificate on chain ==> check if we are recovering -- from an initial cooldown after having initially failed to diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs index 5fa101619d..9d56102502 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs @@ -28,6 +28,8 @@ module Ouroboros.Consensus.Peras.Voting.View , LatestCertSeenView (..) , LatestCertOnChainView (..) , PerasVotingView (..) + , PerasVotingViewHandle (..) + , WithBoostedBlockStatus (..) , mkPerasVotingView ) where @@ -61,6 +63,7 @@ import Ouroboros.Consensus.Peras.Params , PerasParams (..) ) import Ouroboros.Consensus.Peras.Types (PerasRoundNo) +import Ouroboros.Consensus.Util.IOLike (MonadSTM (..)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -177,8 +180,9 @@ data LatestCertSeenView cert -- strictness annotations as needed. newtype LatestCertOnChainView cert = LatestCertOnChainView - { lcocCert :: cert - -- ^ Latest certificate present in our preferred chain + { lcocCertRoundNo :: PerasRoundNo + -- ^ 'PerasRoundNo' of the latest certificate present in our preferred chain + -- (we don't actually need the whole cert here) } deriving Show @@ -231,8 +235,9 @@ mkPerasVotingView :: PerasRoundNo -> -- | Most recent certificate seen by the voter WithOrigin (WithBoostedBlockStatus cert) -> - -- | Most recent certificate included in some block in our preferred chain - WithOrigin cert -> + -- | 'PerasRoundNo' of the most recent certificate included in some block in + -- our preferred chain + WithOrigin PerasRoundNo -> -- | Prefix leading to the candidate block in the volatile suffix of our -- preferred chain AnchoredFragment (Header blk) -> @@ -242,10 +247,10 @@ mkPerasVotingView perasParams currRoundNo latestCertSeen - latestCertOnChain + latestCertOnChainRoundNo chainAtCandidateBlock = do latestCertSeenView <- traverse mkLatestCertSeenView latestCertSeen - latestCertOnChainView <- traverse mkLatestCertOnChainView latestCertOnChain + latestCertOnChainView <- traverse mkLatestCertOnChainView latestCertOnChainRoundNo pure $ PerasVotingView { perasParams = perasParams @@ -267,10 +272,10 @@ mkPerasVotingView , lcsCandidateBlockExtendsCert } - mkLatestCertOnChainView lcocCert = + mkLatestCertOnChainView lcocCertRoundNo = pure $ LatestCertOnChainView - { lcocCert + { lcocCertRoundNo } -- Does the candidate block extend the one boosted by a certificate? @@ -294,3 +299,7 @@ mkPerasVotingView AF.withinFragmentBounds (castPoint (getPerasCertPoint cert)) chainAtCandidateBlock + +newtype PerasVotingViewHandle m blk + = PerasVotingViewHandle + (PerasRoundNo -> STM m (PerasVotingView (WithArrivalTime (ValidatedPerasCert blk)) blk)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 981b55d63d..2dc4ea34ee 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -13,7 +13,6 @@ module Ouroboros.Consensus.Storage.ChainDB.API ChainDB (..) , getCurrentTip , getTipBlockNo - , getPerasEpochContextResolverHandle -- * Adding a block , AddBlockPromise (..) @@ -94,8 +93,8 @@ import Ouroboros.Consensus.Ledger.Extended ( ExtLedgerState , ExtValidationError ) -import qualified Ouroboros.Consensus.Ledger.Extended as ExtLedger import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle) +import Ouroboros.Consensus.Peras.Voting.View (PerasVotingViewHandle (..)) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment import Ouroboros.Consensus.Storage.Common @@ -463,6 +462,17 @@ data ChainDB m blk = ChainDB -- given one, in ascending order. , getPerasVoteIds :: STM m (Set (PerasVoteId blk)) -- ^ Get the set of all Peras vote IDs currently in the database. + , getPerasVotingViewHandle :: + PerasVotingViewHandle m blk + -- ^ Returns a handle to obtain a 'PerasVotingView' that is used to decide + -- when to vote with respects to the voting rules. + -- + -- NOTE: This needs to be part of the API because the implementation of the ChainDB + -- has access, during initialization, to the 'TopLevelConfig', but it isn't + -- stored/exposed by the API itself. + , getPerasEpochContextResolverHandle :: + PerasEpochContextResolverHandle m blk + -- ^ Returns a handle to obtain the 'PerasEpochContext' for a given 'PerasRoundNo' , waitForImmutableBlock :: RealPoint blk -> m (Either SeekBlockError (RealPoint blk)) -- ^ Wait until the immutable tip's slot is equal or greater than the given slot: -- - returns the block when it becomes the immutable tip, @@ -498,12 +508,6 @@ getTipBlockNo :: ChainDB m blk -> STM m (WithOrigin BlockNo) getTipBlockNo = fmap Network.getTipBlockNo . getCurrentTip -getPerasEpochContextResolverHandle :: - MonadSTM m => - ChainDB m blk -> - PerasEpochContextResolverHandle m blk -getPerasEpochContextResolverHandle = ExtLedger.getPerasEpochContextResolverHandle . getCurrentLedger - {------------------------------------------------------------------------------- Adding a block -------------------------------------------------------------------------------} 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 6242ec6657..35a7cf5740 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 @@ -61,7 +61,11 @@ import Ouroboros.Consensus.Ledger.Extended (getPerasEpochContextResolverHandle, import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol -import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting + , PerasEpochContextResolverHandle (PerasEpochContextResolverHandle) + ) +import Ouroboros.Consensus.Peras.Voting.View (PerasVotingViewHandle (PerasVotingViewHandle)) import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as API import Ouroboros.Consensus.Storage.ChainDB.Impl.Args @@ -320,6 +324,12 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , addPerasVoteWithAsyncCertHandling = getEnv1 h ChainSel.addPerasVoteWithAsyncCertHandling , getPerasVotesAfter = getEnvSTM1 h Query.getPerasVotesAfter , getPerasVoteIds = getEnvSTM h Query.getPerasVoteIds + , getPerasVotingViewHandle = + PerasVotingViewHandle $ \roundNo -> + getEnvSTM h (Query.getPerasVotingView (Args.cdbsTopLevelConfig cdbSpecificArgs) roundNo) + , getPerasEpochContextResolverHandle = + PerasEpochContextResolverHandle $ + getEnvSTM h Query.getPerasEpochContextResolver , waitForImmutableBlock = getEnv1 h Query.waitForImmutableBlock , getLatestPerasCertOnChainRound = getEnvSTM h Query.getLatestPerasCertOnChainRound } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index 6b33ef4ec4..c3565872c9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -27,6 +27,8 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query , getPerasCertIds , getPerasVotesAfter , getPerasVoteIds + , getPerasVotingView + , getPerasEpochContextResolver , getLatestPerasCertOnChainRound , getStatistics , getTipBlock @@ -62,6 +64,17 @@ import Ouroboros.Consensus.HeaderValidation (HeaderWithTime) import Ouroboros.Consensus.Ledger.Abstract (EmptyMK) import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (resolveRoundNo) + , PerasEpochContextResolver + ) +import Ouroboros.Consensus.Peras.Voting.View + ( PerasVotingView + , WithBoostedBlockStatus + , mkPerasVotingView + , perasChainAtCandidateBlock + , runPerasQry + ) import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot , takeVolatileSuffix @@ -369,6 +382,55 @@ getPerasVoteIds :: ChainDbEnv m blk -> STM m (Set (PerasVoteId blk)) getPerasVoteIds CDB{..} = PerasVoteDB.getVoteIds cdbPerasVoteDB +getPerasEpochContextResolver :: + MonadSTM m => + ChainDbEnv m blk -> + STM m (PerasEpochContextResolver blk) +getPerasEpochContextResolver = + fmap perasEpochContextResolver . getCurrentLedger + +fixWithBoostedBlockStatusInDbAPI :: + WithArrivalTime (ValidatedPerasCert blk) -> + WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)) +fixWithBoostedBlockStatusInDbAPI _cert = undefined + +-- [TODO EPOCH CONTEXT PLUMBING/CHAIN DB LATEST CERT SEEN] + +getPerasVotingView :: + ( BlockSupportsPeras blk + , LedgerStateHeaderStateSupportsPerasVoting blk + , IOLike m + , LedgerSupportsPeras blk + , ConsensusProtocol (BlockProtocol blk) + , GetHeader blk + ) => + TopLevelConfig blk -> + PerasRoundNo -> + ChainDbEnv m blk -> + STM m (PerasVotingView (WithArrivalTime (ValidatedPerasCert blk)) blk) +getPerasVotingView _topLevelConfig roundNo env = do + resolver <- getPerasEpochContextResolver env + perasParams <- case resolveRoundNo resolver roundNo of + Left err -> throwSTM err + Right perasContext -> pure $ pecPerasParams perasContext + latestCertSeen <- + withOriginFromMaybe . fmap fixWithBoostedBlockStatusInDbAPI <$> getLatestPerasCertSeen env + latestCertOnChainRoundNo <- withOriginFromMaybe <$> getLatestPerasCertOnChainRound env + let blockMinSlots = perasBlockMinSlots perasParams + currentChain <- getCurrentChain env + let qry = + perasChainAtCandidateBlock blockMinSlots roundNo currentChain >>= \chainAtCandidateBlock -> + mkPerasVotingView + perasParams + roundNo + latestCertSeen + latestCertOnChainRoundNo + chainAtCandidateBlock + summary <- undefined -- [TODO EPOCH CONTEXT PLUMBING/SOMEHOW GET SUMMARY] + case runPerasQry summary qry of + Left err -> throwSTM err + Right view -> pure view + -- | Wait until the slot of the given point is smaller or equal than the immutable tip slot, -- and then return: -- - the block at the target slot if there is a block in the immutable DB at that slot; diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index 3a98cbfc9a..8a454b5fd3 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -118,7 +118,13 @@ import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) ) -import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting (..), MockPerasEpochContextResolver, mockAbsorbErrorInResolver, mockPerasEpochContextResolver, mockResolveRoundNo) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (..) + , MockPerasEpochContextResolver + , mockAbsorbErrorInResolver + , mockPerasEpochContextResolver + , mockResolveRoundNo + ) import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCrypto, MockPerasVotingCommitteeScheme) import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) import Ouroboros.Consensus.Peras.State.Mock (ledgerStateHeaderStateMkMockPerasVotingCommitteeInput) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index c458391b54..6c58ec8398 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -145,7 +145,13 @@ import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Peras.Cert.Mock ( MockPerasCert (..) ) -import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting (..), MockPerasEpochContextResolver, mockAbsorbErrorInResolver, mockPerasEpochContextResolver, mockResolveRoundNo) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting (..) + , MockPerasEpochContextResolver + , mockAbsorbErrorInResolver + , mockPerasEpochContextResolver + , mockResolveRoundNo + ) import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasCrypto, MockPerasVotingCommitteeScheme) import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError) import Ouroboros.Consensus.Peras.SelectView (weightedSelectView) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs index 466d74a079..ffa7fe73c0 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasVote/Smoke.hs @@ -19,7 +19,11 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote -import Ouroboros.Consensus.Peras.Context (LedgerStateHeaderStateSupportsPerasVoting, PerasEpochContextResolverHandle, mockPerasEpochContextResolverHandle) +import Ouroboros.Consensus.Peras.Context + ( LedgerStateHeaderStateSupportsPerasVoting + , PerasEpochContextResolverHandle + , mockPerasEpochContextResolverHandle + ) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs index f6bfbe722f..89f3463c8f 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs @@ -142,9 +142,9 @@ isPerasVotingAllowedModel vr2b = case latestCertOnChain of NotOrigin cert -> - (currRoundNo > getPerasCertRound (lcocCert cert)) + (currRoundNo > lcocCertRoundNo cert) && ( (currRoundNo `rmod` _K) - == (getPerasCertRound (lcocCert cert) `rmod` _K) + == (lcocCertRoundNo cert `rmod` _K) ) Origin -> currRoundNo `rmod` _K == _K - 1 @@ -287,8 +287,8 @@ genTestCert roundNo = do -- * Certificate and voting views -genLatestCertSeen :: PerasRoundNo -> Gen (LatestCertSeenView TestCert) -genLatestCertSeen roundNo = do +genLatestCertSeenView :: PerasRoundNo -> Gen (LatestCertSeenView TestCert) +genLatestCertSeenView roundNo = do cert <- genTestCert roundNo arrivalSlot <- genSlotNo roundStartSlot <- genSlotNo @@ -301,20 +301,20 @@ genLatestCertSeen roundNo = do , lcsCandidateBlockExtendsCert = candidateBlockExtendsCert } -genLatestCertOnChain :: PerasRoundNo -> Gen (LatestCertOnChainView TestCert) -genLatestCertOnChain roundNo = do +genLatestCertOnChainView :: PerasRoundNo -> Gen (LatestCertOnChainView TestCert) +genLatestCertOnChainView roundNo = do cert <- genTestCert roundNo pure $ LatestCertOnChainView - { lcocCert = cert + { lcocCertRoundNo = getPerasCertRound cert } genPerasVotingView :: Gen (PerasVotingView TestCert TestBlock) genPerasVotingView = do perasParams <- genPerasParams currRoundNo <- genPerasRoundNo - latestCertSeen <- genWithOrigin (genLatestCertSeen currRoundNo) - latestCertOnChain <- genWithOrigin (genLatestCertOnChain currRoundNo) + latestCertSeen <- genWithOrigin (genLatestCertSeenView currRoundNo) + latestCertOnChain <- genWithOrigin (genLatestCertOnChainView currRoundNo) pure PerasVotingView { perasParams From a2adac964ce906361a9508c7447ec767901d12a9 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 8 Jun 2026 10:59:48 +0200 Subject: [PATCH 55/62] Tweak voting rules to return candidate block --- .../Ouroboros/Consensus/Peras/Voting/Rules.hs | 20 +++++---- .../Ouroboros/Consensus/Peras/Voting/View.hs | 40 +++++++++++------ .../Test/Consensus/Peras/Voting/Rules.hs | 43 +++++++++++++------ 3 files changed, 68 insertions(+), 35 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs index ecb24db397..a160e905f3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs @@ -30,7 +30,9 @@ where import Ouroboros.Consensus.Block (WithOrigin (..)) import Ouroboros.Consensus.Block.Abstract - ( SlotNo (..) + ( Point + , SlotNo (..) + , StandardHash ) import Ouroboros.Consensus.Block.SupportsPeras ( IsPerasCert (..) @@ -61,25 +63,27 @@ import Ouroboros.Consensus.Util.Pred -- | Whether we are allowed to vote according to the rules. -- -- This type additionally carries the evidence for the decision taken. -data PerasVotingRulesDecision - = Vote (Evidence True PerasVotingRule) +data PerasVotingRulesDecision blk + = Vote (Evidence True PerasVotingRule) (Point blk) | NoVote (Evidence False PerasVotingRule) deriving Show -instance Explainable PerasVotingRulesDecision where +instance StandardHash blk => Explainable (PerasVotingRulesDecision blk) where explain mode = \case - Vote (ETrue e) -> "Vote(" <> explain mode e <> ")" - NoVote (EFalse e) -> "NoVote(" <> explain mode e <> ")" + Vote (ETrue e) candidate -> + "Vote(" <> show candidate <> "," <> explain mode e <> ")" + NoVote (EFalse e) -> + "NoVote(" <> explain mode e <> ")" -- | Evaluate whether voting is allowed or not according to the voting rules isPerasVotingAllowed :: IsPerasCert cert blk => PerasVotingView cert blk -> - PerasVotingRulesDecision + PerasVotingRulesDecision blk isPerasVotingAllowed pvv = evalPred (perasVotingRules pvv) $ \e -> case e of - ETrue{} -> Vote e + ETrue{} -> Vote e (candidateBlock pvv) EFalse{} -> NoVote e -- | Voting rules diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs index 9d56102502..0c201c8311 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs @@ -41,6 +41,7 @@ import Control.Monad.Reader (MonadReader (..), Reader, runReader) import Ouroboros.Consensus.Block.Abstract ( GetHeader (..) , Header + , Point , SlotNo (..) , castPoint ) @@ -154,7 +155,7 @@ perasChainAtCandidateBlock blockMinSlots currRoundNo currChain = do Voting interface -------------------------------------------------------------------------------} --- | View of the latest certificate seen by the voter +-- | View of the latest certificate seen by the voter. -- -- NOTE: the voting rules depend on the candidate block indirectly. This is -- reflected in the fact that the voting view does not contain the candidate @@ -174,7 +175,7 @@ data LatestCertSeenView cert } deriving Show --- | View of the latest certificate present in our preferred chain +-- | View of the latest certificate present in our preferred chain. -- -- NOTE: if we add more fields here in the future, do not forget to add -- strictness annotations as needed. @@ -182,17 +183,16 @@ newtype LatestCertOnChainView cert = LatestCertOnChainView { lcocCertRoundNo :: PerasRoundNo -- ^ 'PerasRoundNo' of the latest certificate present in our preferred chain - -- (we don't actually need the whole cert here) + -- (we don't actually need the whole certificate here). } deriving Show -- | Interface needed to evaluate the Peras voting rules -- --- NOTE: the voting rules depend on the candidate block indirectly. This is --- reflected in the fact that the voting view does not contain the candidate --- block or its point, but only whether the candidate block extends the block --- boosted by the most recent certificate seen by the voter, which is provided --- to the rules via 'lcsCandidateBlockExtendsCert' inside 'latestCertSeen'. +-- NOTE: the voting rules depend on the candidate block only indirectly. The +-- only reason to include the point of the block being voted for +-- ('candidateBlock') here is to be able to return it as part of the result of +-- 'isPerasVotingAllowed' in the positive case. data PerasVotingView cert blk = PerasVotingView { perasParams :: !(PerasParams blk) -- ^ Peras protocol parameters @@ -202,6 +202,11 @@ data PerasVotingView cert blk = PerasVotingView -- ^ The most recent certificate seen by the voter , latestCertOnChain :: !(WithOrigin (LatestCertOnChainView cert)) -- ^ The most recent certificate present in our preferred chain + , candidateBlock :: Point blk + -- ^ The candidate block being voted for. + -- + -- NOTE: this is the tip of the 'chainAtCandidateBlock' used to initialize + -- the voting view. } deriving Show @@ -209,16 +214,16 @@ data PerasVotingView cert blk = PerasVotingView -- chain's immutable prefix and volatile suffix. data WithBoostedBlockStatus cert = -- | Certificate boosting a block within the immutable prefix - CertWithImmutableBlock cert + CertBoostingImmutableBlock cert | -- | Certificate boosting a block within the volatile suffix - CertWithVolatileBlock cert + CertBoostingVolatileBlock cert deriving Show -- | Deconstruct a certificate from its provenance wrapper forgetBoostedBlockStatus :: WithBoostedBlockStatus cert -> cert forgetBoostedBlockStatus = \case - CertWithVolatileBlock cert -> cert - CertWithImmutableBlock cert -> cert + CertBoostingVolatileBlock cert -> cert + CertBoostingImmutableBlock cert -> cert -- | Construct a 'PerasVotingView'. -- @@ -257,6 +262,7 @@ mkPerasVotingView , currRoundNo = currRoundNo , latestCertSeen = latestCertSeenView , latestCertOnChain = latestCertOnChainView + , candidateBlock = candidateBlock } where mkLatestCertSeenView certWithProvenance = do @@ -289,17 +295,23 @@ mkPerasVotingView -- NOTE: the case of an extremely old certificate boosting a block beyond -- the volatile suffix is covered by also providing the status of the -- boosted block w.r.t. the chain's immutable prefix and volatile suffix. - candidateBlockExtendsCert (CertWithImmutableBlock _) = + candidateBlockExtendsCert (CertBoostingImmutableBlock _) = -- This case is vacuously true: an immutable block is always part of -- any volatile suffix, so the candidate block trivially extends it. True - candidateBlockExtendsCert (CertWithVolatileBlock cert) = + candidateBlockExtendsCert (CertBoostingVolatileBlock cert) = -- Check whether the boosted block is within the volatile fragment leading -- to the candidate block. AF.withinFragmentBounds (castPoint (getPerasCertPoint cert)) chainAtCandidateBlock + candidateBlock = + AF.anchorToPoint + . AF.castAnchor + . AF.headAnchor + $ chainAtCandidateBlock + newtype PerasVotingViewHandle m blk = PerasVotingViewHandle (PerasRoundNo -> STM m (PerasVotingView (WithArrivalTime (ValidatedPerasCert blk)) blk)) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs index 89f3463c8f..ce85528a9c 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting/Rules.hs @@ -15,6 +15,7 @@ -- do not denote ignored variables. module Test.Consensus.Peras.Voting.Rules (tests) where +import Data.Maybe (isJust) import GHC.Generics (Generic) import Ouroboros.Consensus.Block (Point (..)) import Ouroboros.Consensus.Block.Abstract @@ -60,6 +61,7 @@ import Test.Tasty.QuickCheck , testProperty ) import Test.Util.Orphans.Arbitrary (genNominalDiffTime50Years) +import Test.Util.Peras (genPointTestBlock) import Test.Util.QuickCheck (geometric) import Test.Util.TestBlock (TestBlock) import Test.Util.TestEnv (adjustQuickCheckTests) @@ -82,7 +84,7 @@ tests = data PerasVotingRulesDecisionModel = PerasVotingDecisionModel - { shouldVote :: Bool + { shouldVote :: Maybe (Point TestBlock) , vr1a :: Bool , vr1b :: Bool , vr2a :: Bool @@ -104,15 +106,20 @@ isPerasVotingAllowedModel , currRoundNo , latestCertSeen , latestCertOnChain + , candidateBlock } = PerasVotingDecisionModel - { shouldVote = vr1a && vr1b || vr2a && vr2b - , vr1a = vr1a - , vr1b = vr1b - , vr2a = vr2a - , vr2b = vr2b + { shouldVote + , vr1a + , vr1b + , vr2a + , vr2b } where + shouldVote + | (vr1a && vr1b) || (vr2a && vr2b) = Just candidateBlock + | otherwise = Nothing + vr1a = vr1a1 && vr1a2 vr1a1 = @@ -183,7 +190,7 @@ prop_isPerasVotingAllowed = forAll genPerasVotingView $ \pvv -> do , tabulate "VR-2A" [show vr2a] , tabulate "VR-2B" [show vr2b] , tabulate "VR-(1A|1B|2A|2B)" [show (vr1a, vr1b, vr2a, vr2b)] - , tabulate "Should vote according to model" [show shouldVote] + , tabulate "Should vote according to model" [show (isJust shouldVote)] , tabulate "Actual result" [desc] ] $ property True @@ -193,13 +200,21 @@ prop_isPerasVotingAllowed = forAll genPerasVotingView $ \pvv -> do -- Now check that the real implementation agrees with the model let votingDecision = isPerasVotingAllowed pvv case votingDecision of - Vote (ETrue voteReason) - | shouldVote -> - ok $ "Vote(" <> explainShallow voteReason <> ")" + Vote (ETrue voteReason) actualCandidate + | Just expectedCandidate <- shouldVote -> + if expectedCandidate == actualCandidate + then + ok $ "Vote(Point{..}," <> explainShallow voteReason <> ")" + else + failure $ + "Expected to vote for " + <> show expectedCandidate + <> ", but got: " + <> show actualCandidate | otherwise -> failure $ "Expected not to vote, but got: " <> show votingDecision NoVote (EFalse noVoteReason) - | not shouldVote -> + | Nothing <- shouldVote -> ok $ "NoVote(" <> explainShallow noVoteReason <> ")" | otherwise -> failure $ "Expected to vote, but got: " <> show votingDecision @@ -315,12 +330,14 @@ genPerasVotingView = do currRoundNo <- genPerasRoundNo latestCertSeen <- genWithOrigin (genLatestCertSeenView currRoundNo) latestCertOnChain <- genWithOrigin (genLatestCertOnChainView currRoundNo) + candidateBlock <- genPointTestBlock pure PerasVotingView { perasParams , currRoundNo - , latestCertSeen = latestCertSeen - , latestCertOnChain = latestCertOnChain + , latestCertSeen + , latestCertOnChain + , candidateBlock } where genWithOrigin gen = From 2cb9396481feff05d8cda3f4fd1de5c5d8e3d8dc Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 8 Jun 2026 15:01:59 +0200 Subject: [PATCH 56/62] Extend PerasCertDB.getLatestCertSeen to keep track of cert boosted block status --- .../Ouroboros/Consensus/Peras/Voting/View.hs | 40 ++++++--------- .../Consensus/Storage/ChainDB/API.hs | 7 ++- .../Consensus/Storage/ChainDB/Impl/Query.hs | 17 +++---- .../Consensus/Storage/PerasCertDB/API.hs | 51 +++++++++++++++---- .../Consensus/Storage/PerasCertDB/Impl.hs | 32 +++++++++--- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 3 +- .../Ouroboros/Storage/PerasCertDB/Model.hs | 38 ++++++++++---- .../Storage/PerasCertDB/StateMachine.hs | 9 +++- 8 files changed, 133 insertions(+), 64 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs index 0c201c8311..d063bd73c7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/View.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeOperators #-} @@ -64,6 +63,10 @@ import Ouroboros.Consensus.Peras.Params , PerasParams (..) ) import Ouroboros.Consensus.Peras.Types (PerasRoundNo) +import Ouroboros.Consensus.Storage.PerasCertDB.API + ( WithBoostedBlockStatus (..) + , forgetBoostedBlockStatus + ) import Ouroboros.Consensus.Util.IOLike (MonadSTM (..)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -210,21 +213,6 @@ data PerasVotingView cert blk = PerasVotingView } deriving Show --- | Indicate the status of a block boosted by a certificate w.r.t. the --- chain's immutable prefix and volatile suffix. -data WithBoostedBlockStatus cert - = -- | Certificate boosting a block within the immutable prefix - CertBoostingImmutableBlock cert - | -- | Certificate boosting a block within the volatile suffix - CertBoostingVolatileBlock cert - deriving Show - --- | Deconstruct a certificate from its provenance wrapper -forgetBoostedBlockStatus :: WithBoostedBlockStatus cert -> cert -forgetBoostedBlockStatus = \case - CertBoostingVolatileBlock cert -> cert - CertBoostingImmutableBlock cert -> cert - -- | Construct a 'PerasVotingView'. -- -- NOTE: this assumes that the client code computes all the needed inputs @@ -294,14 +282,16 @@ mkPerasVotingView -- -- NOTE: the case of an extremely old certificate boosting a block beyond -- the volatile suffix is covered by also providing the status of the - -- boosted block w.r.t. the chain's immutable prefix and volatile suffix. - candidateBlockExtendsCert (CertBoostingImmutableBlock _) = - -- This case is vacuously true: an immutable block is always part of - -- any volatile suffix, so the candidate block trivially extends it. + -- boosted block w.r.t. the volatile suffix. + candidateBlockExtendsCert (CertBoostingBlockNoLongerInVolatileDB _) = + -- This case is vacuously true: the boosted block is from a slot that has + -- already been garbage collected from the volatile suffix, which implies + -- that it extends any volatile suffix. True - candidateBlockExtendsCert (CertBoostingVolatileBlock cert) = - -- Check whether the boosted block is within the volatile fragment leading - -- to the candidate block. + candidateBlockExtendsCert (CertBoostingBlockInVolatileDB cert) = + -- The block boosted by the latest certificate seen is still in the + -- VolatileDB, so we can check whether it is within the bounds of the + -- anchored fragment leading to the candidate block. AF.withinFragmentBounds (castPoint (getPerasCertPoint cert)) chainAtCandidateBlock @@ -314,4 +304,6 @@ mkPerasVotingView newtype PerasVotingViewHandle m blk = PerasVotingViewHandle - (PerasRoundNo -> STM m (PerasVotingView (WithArrivalTime (ValidatedPerasCert blk)) blk)) + ( PerasRoundNo -> + STM m (PerasVotingView (WithArrivalTime (ValidatedPerasCert blk)) blk) + ) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 2dc4ea34ee..3bf4da8995 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -25,6 +25,8 @@ module Ouroboros.Consensus.Storage.ChainDB.API , AddPerasCertPromise (..) , addPerasCertSync , addPerasVoteSync + , WithBoostedBlockStatus (..) + , forgetBoostedBlockStatus -- * Trigger chain selection , ChainSelectionPromise (..) @@ -106,6 +108,8 @@ import Ouroboros.Consensus.Storage.LedgerDB ) import Ouroboros.Consensus.Storage.PerasCertDB.API ( PerasCertTicketNo + , WithBoostedBlockStatus (..) + , forgetBoostedBlockStatus ) import Ouroboros.Consensus.Storage.PerasVoteDB.API ( PerasVoteTicketNo @@ -429,7 +433,8 @@ data ChainDB m blk = ChainDB , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) -- ^ Get the 'PerasWeightSnapshot', representing the Peras weight boosts for -- all blocks newer than the current immutable tip. - , getLatestPerasCertSeen :: STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk))) + , getLatestPerasCertSeen :: + STM m (Maybe (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))) -- ^ Get the latest Peras certificate that has been seen by this node. , getLatestPerasCertOnChainRound :: STM m (Maybe PerasRoundNo) -- ^ Get the round number of the latest Peras certificate on the currently diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index c3565872c9..f6970d3af9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -359,7 +359,8 @@ getPerasWeightSnapshot :: getPerasWeightSnapshot CDB{..} = PerasCertDB.getWeightSnapshot cdbPerasCertDB getLatestPerasCertSeen :: - ChainDbEnv m blk -> STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk))) + ChainDbEnv m blk -> + STM m (Maybe (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))) getLatestPerasCertSeen CDB{..} = PerasCertDB.getLatestCertSeen cdbPerasCertDB getPerasCertsAfter :: @@ -389,13 +390,6 @@ getPerasEpochContextResolver :: getPerasEpochContextResolver = fmap perasEpochContextResolver . getCurrentLedger -fixWithBoostedBlockStatusInDbAPI :: - WithArrivalTime (ValidatedPerasCert blk) -> - WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)) -fixWithBoostedBlockStatusInDbAPI _cert = undefined - --- [TODO EPOCH CONTEXT PLUMBING/CHAIN DB LATEST CERT SEEN] - getPerasVotingView :: ( BlockSupportsPeras blk , LedgerStateHeaderStateSupportsPerasVoting blk @@ -414,8 +408,11 @@ getPerasVotingView _topLevelConfig roundNo env = do Left err -> throwSTM err Right perasContext -> pure $ pecPerasParams perasContext latestCertSeen <- - withOriginFromMaybe . fmap fixWithBoostedBlockStatusInDbAPI <$> getLatestPerasCertSeen env - latestCertOnChainRoundNo <- withOriginFromMaybe <$> getLatestPerasCertOnChainRound env + withOriginFromMaybe + <$> getLatestPerasCertSeen env + latestCertOnChainRoundNo <- + withOriginFromMaybe + <$> getLatestPerasCertOnChainRound env let blockMinSlots = perasBlockMinSlots perasParams currentChain <- getCurrentChain env let qry = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs index 1cd51a9b21..13d0c0e556 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -3,10 +3,15 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Ouroboros.Consensus.Storage.PerasCertDB.API ( PerasCertDB (..) + , WithBoostedBlockStatus (..) + , forgetBoostedBlockStatus , AddPerasCertResult (..) , PerasCertTicketNo , zeroPerasCertTicketNo @@ -67,7 +72,7 @@ data PerasCertDB m blk = PerasCertDB -- The 'Fingerprint' is updated every time a new certificate is added, but it -- stays the same when certificates are garbage-collected. , getLatestCertSeen :: - STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk))) + STM m (Maybe (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))) -- ^ This field impacts voting directly because having seen a certificate is a -- precondition for voting in any round except for the very first one -- (at origin). @@ -84,6 +89,34 @@ data PerasCertDB m blk = PerasCertDB } deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk) +-- | Indicate whether the block being boosted by a certificate is expected to +-- still be part of the volatile chain suffix or not. +-- +-- This is relevant for Peras voting because we need to know if a candidate +-- block extends the chain that contains the block being boosted by the latest +-- certificate seen. For this purpose, we want to limit the voting rules to only +-- look within the volatile chain suffix, and assume that, if the boosted block +-- is no longer in the volatile suffix, then it trivially extends the candidate +-- block (because it must have been copied into the immutable chain prefix). For +-- this reason, we need to manually keep track of whether the boosted block of +-- this certificate has already been garbage collected from the volatile suffix +-- or not. +data WithBoostedBlockStatus cert + = -- | Certificate boosting a block within the volatile chain suffix + CertBoostingBlockInVolatileDB cert + | -- | Certificate boosting a block that no longer belongs to the volatile + -- chain suffix. This typically means that the block has been copied to the + -- immutable prefix, and then garbage collected from the volatile suffix. + CertBoostingBlockNoLongerInVolatileDB cert + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks + +-- | Deconstruct a certificate from its provenance wrapper +forgetBoostedBlockStatus :: WithBoostedBlockStatus cert -> cert +forgetBoostedBlockStatus = \case + CertBoostingBlockInVolatileDB cert -> cert + CertBoostingBlockNoLongerInVolatileDB cert -> cert + -- | A sequence number, incremented every time we receive a new certificate. -- -- Note that we will /usually/ receive certificates monotonically by round @@ -140,10 +173,9 @@ prop_getCertsAfterZero db = do pure (allCerts, certIds) allCertValues <- sequence (Map.elems allCertActions) let allCertIds = - Set.fromList $ - fmap - (getPerasCertRound . forgetArrivalTime) - allCertValues + Set.fromList + . fmap getPerasCertRound + $ allCertValues pure $ length allCertActions == Set.size certIds && allCertIds == certIds @@ -176,7 +208,7 @@ prop_garbageCollectRemovesOldCerts db slotNo = do _ <- garbageCollect db slotNo getCertsAfter db zeroPerasCertTicketNo allCertValues <- sequence (Map.elems allCertActions) - let targetSlots = pointSlot . getPerasCertPoint . forgetArrivalTime <$> allCertValues + let targetSlots = pointSlot . getPerasCertPoint <$> allCertValues pure $ all (>= NotOrigin slotNo) targetSlots @@ -194,7 +226,7 @@ prop_addCertLatestCertSeenMonotonic db cert = prevLatest <- getLatestCertSeen db _ <- addCert db cert newLatest <- getLatestCertSeen db - let getRound = getPerasCertRound . forgetArrivalTime + let getRound = getPerasCertRound . forgetBoostedBlockStatus pure $ case (prevLatest, newLatest) of (_, Nothing) -> False -- after adding a cert, the latest cert seen should not go back to 'Nothing' (Nothing, Just _) -> True -- if there was no cert seen before, any new cert should be greater than or equal to it @@ -203,7 +235,7 @@ prop_addCertLatestCertSeenMonotonic db cert = -- | 'getLatestCertSeen' is not affected by garbage collection. prop_garbageCollectPreservesLatestCertSeen :: ( MonadSTM m - , Eq (PerasCert blk) + , IsPerasCert (PerasCert blk) blk ) => PerasCertDB m blk -> SlotNo -> @@ -213,4 +245,5 @@ prop_garbageCollectPreservesLatestCertSeen db slotNo = prevLatest <- getLatestCertSeen db _ <- garbageCollect db slotNo newLatest <- getLatestCertSeen db - pure $ prevLatest == newLatest + let getRound = getPerasCertRound . forgetBoostedBlockStatus + pure $ fmap getRound prevLatest == fmap getRound newLatest diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index 71dcb012a4..d86fee017b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -60,7 +60,7 @@ data PerasCertDbState blk = PerasCertDbState , pcdsLastTicketNo :: !PerasCertTicketNo -- ^ The most recent 'PerasCertTicketNo' (or 'zeroPerasCertTicketNo' -- otherwise). - , pcdsLatestCertSeen :: !(Maybe (WithArrivalTime (ValidatedPerasCert blk))) + , pcdsLatestCertSeen :: !(Maybe (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))) -- ^ The certificate with the highest round number that has been added to the -- db since it has been opened. } @@ -202,11 +202,16 @@ implAddCert PerasCertDbEnv{pcdbTracer, pcdbState} cert = do let pcdsLastTicketNo' = succ (pcdsLastTicketNo pcds) pcdsCertIds' = Set.insert roundNo (pcdsCertIds pcds) pcdsCertsByTicket' = Map.insert pcdsLastTicketNo' cert (pcdsCertsByTicket pcds) - pcdsLatestCertSeen' = case pcdsLatestCertSeen pcds of - Nothing -> Just cert - Just prev - | getPerasCertRound cert > getPerasCertRound prev -> Just cert - | otherwise -> Just prev + pcdsLatestCertSeen' = + case pcdsLatestCertSeen pcds of + Nothing -> + Just (CertBoostingBlockInVolatileDB cert) + Just prev + | getPerasCertRound cert + > getPerasCertRound (forgetBoostedBlockStatus prev) -> + Just (CertBoostingBlockInVolatileDB cert) + | otherwise -> + Just prev writeTVar pcdbState $ WithFingerprint PerasCertDbState @@ -260,7 +265,7 @@ implGetCertsAfter PerasCertDbEnv{pcdbState} ticketNo = do implGetLatestCertSeen :: IOLike m => PerasCertDbEnv m blk -> - STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk))) + STM m (Maybe (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk)))) implGetLatestCertSeen PerasCertDbEnv{pcdbState} = do PerasCertDbState{pcdsLatestCertSeen} <- forgetFingerprint <$> readTVar pcdbState @@ -293,9 +298,20 @@ implGarbageCollect PerasCertDbEnv{pcdbTracer, pcdbState} slotNo = do pcdsCertsByTicket pcdsCertIds' = Set.fromList (getPerasCertRound <$> Map.elems pcdsCertsByTicket') + pcdsLatestCertSeen' = + updateIfBoostingGarbageCollectedBlock <$> pcdsLatestCertSeen + + -- Update the latest certificate seen status when its corresponding + -- boosted block gets garbage collected. + updateIfBoostingGarbageCollectedBlock cert + | pointSlot (getPerasCertPoint (forgetBoostedBlockStatus cert)) + < NotOrigin slotNo = + CertBoostingBlockNoLongerInVolatileDB (forgetBoostedBlockStatus cert) + | otherwise = + cert in PerasCertDbState { pcdsCertIds = pcdsCertIds' , pcdsCertsByTicket = pcdsCertsByTicket' , pcdsLastTicketNo = pcdsLastTicketNo - , pcdsLatestCertSeen = pcdsLatestCertSeen + , pcdsLatestCertSeen = pcdsLatestCertSeen' } diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index d1e016cc0d..1ddad8c870 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -136,6 +136,7 @@ import Ouroboros.Consensus.Storage.ChainDB.API ) import Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel (olderThanImmTip) import Ouroboros.Consensus.Storage.Common () +import Ouroboros.Consensus.Storage.PerasCertDB.API (forgetBoostedBlockStatus) import Ouroboros.Consensus.Storage.PerasVoteDB.API (AddPerasVoteResult (..)) import Ouroboros.Consensus.Util (repeatedly) import qualified Ouroboros.Consensus.Util.AnchoredFragment as Fragment @@ -434,7 +435,7 @@ roundNoOfLatestCertSeen :: IsPerasCert (PerasCert blk) blk => Model blk -> Maybe PerasRoundNo roundNoOfLatestCertSeen m = - getPerasCertRound + getPerasCertRound . forgetBoostedBlockStatus <$> PerasCertDBModel.getLatestCertSeen (perasCertModel m) {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs index c3e2202a4b..740b16ae98 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -25,10 +25,14 @@ import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot , mkPerasWeightSnapshot ) +import Ouroboros.Consensus.Storage.PerasCertDB.API + ( WithBoostedBlockStatus (..) + , forgetBoostedBlockStatus + ) data Model blk = Model { certs :: Set (WithArrivalTime (ValidatedPerasCert blk)) - , latestCertSeen :: Maybe (WithArrivalTime (ValidatedPerasCert blk)) + , latestCertSeen :: Maybe (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))) , open :: Bool } deriving Generic @@ -54,11 +58,16 @@ addCert model@Model{certs, latestCertSeen} cert | otherwise = model{certs = certs', latestCertSeen = latestCertSeen'} where certs' = Set.insert cert certs - latestCertSeen' = case latestCertSeen of - Nothing -> Just cert - Just prev - | getPerasCertRound cert > getPerasCertRound prev -> Just cert - | otherwise -> Just prev + latestCertSeen' = + case latestCertSeen of + Nothing -> + Just (CertBoostingBlockInVolatileDB cert) + Just prev + | getPerasCertRound cert + > getPerasCertRound (forgetBoostedBlockStatus prev) -> + Just (CertBoostingBlockInVolatileDB cert) + | otherwise -> + Just prev hasRoundNo :: IsPerasCert (PerasCert blk) blk => @@ -80,14 +89,25 @@ getWeightSnapshot Model{certs} = ] getLatestCertSeen :: - Model blk -> Maybe (WithArrivalTime (ValidatedPerasCert blk)) + Model blk -> + Maybe (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert blk))) getLatestCertSeen Model{latestCertSeen} = latestCertSeen garbageCollect :: IsPerasCert (PerasCert blk) blk => SlotNo -> Model blk -> Model blk -garbageCollect slotNo model@Model{certs} = - model{certs = Set.filter keepCert certs} +garbageCollect slotNo model@Model{certs, latestCertSeen} = + model + { certs = Set.filter keepCert certs + , latestCertSeen = updateIfBoostingGarbageCollectedBlock <$> latestCertSeen + } where keepCert cert = pointSlot (getPerasCertPoint cert) >= NotOrigin slotNo + + updateIfBoostingGarbageCollectedBlock cert + | pointSlot (getPerasCertPoint (forgetBoostedBlockStatus cert)) + < NotOrigin slotNo = + CertBoostingBlockNoLongerInVolatileDB (forgetBoostedBlockStatus cert) + | otherwise = + cert diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index 51da6bf2a1..0fb38c6071 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -34,7 +34,11 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..)) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB -import Ouroboros.Consensus.Storage.PerasCertDB.API (AddPerasCertResult (..), PerasCertDB) +import Ouroboros.Consensus.Storage.PerasCertDB.API + ( AddPerasCertResult (..) + , PerasCertDB + , WithBoostedBlockStatus + ) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.STM @@ -71,7 +75,8 @@ instance StateModel Model where OpenDB :: Action Model () AddCert :: WithArrivalTime (ValidatedPerasCert TestBlock) -> Action Model AddPerasCertResult GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock) - GetLatestCertSeen :: Action Model (Maybe (WithArrivalTime (ValidatedPerasCert TestBlock))) + GetLatestCertSeen :: + Action Model (Maybe (WithBoostedBlockStatus (WithArrivalTime (ValidatedPerasCert TestBlock)))) GarbageCollect :: SlotNo -> Action Model () arbitraryAction _ (Model model) From a80be948c2b0b52daa538258ccdc8622ab12f485 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Wed, 4 Mar 2026 17:35:08 +0100 Subject: [PATCH 57/62] Fix nix warning --- nix/ci.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/nix/ci.nix b/nix/ci.nix index 3093742d85..d0317c6983 100644 --- a/nix/ci.nix +++ b/nix/ci.nix @@ -3,7 +3,7 @@ let inherit (pkgs) lib haskell-nix; inherit (haskell-nix) haskellLib; - buildSystem = pkgs.buildPlatform.system; + buildSystem = pkgs.stdenv.buildPlatform.system; mkHaskellJobsFor = hsPkgs: let From 9379b69758f6ecf4adc4896338efe56110bd50e5 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 9 Jun 2026 13:29:57 +0200 Subject: [PATCH 58/62] Add Time resolution/conversion module for Peras --- ouroboros-consensus.cabal | 1 + .../Ouroboros/Consensus/Ledger/Extended.hs | 6 +- .../Ouroboros/Consensus/Peras/Time.hs | 516 ++++++++++++++++++ .../Consensus/Storage/ChainDB/Impl.hs | 4 +- 4 files changed, 522 insertions(+), 5 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 165ce40898..88e2fac2b0 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -250,6 +250,7 @@ library Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.State.Mock Ouroboros.Consensus.Peras.State.V1 + Ouroboros.Consensus.Peras.Time Ouroboros.Consensus.Peras.Types Ouroboros.Consensus.Peras.Vote.Aggregation Ouroboros.Consensus.Peras.Vote.Mock diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs index 32c0fca362..f22d700522 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -28,7 +28,7 @@ module Ouroboros.Consensus.Ledger.Extended , decodeExtLedgerState , encodeDiskExtLedgerState , encodeExtLedgerState - , getPerasEpochContextResolverHandle + , mkPerasEpochContextResolverHandle -- * Type family instances , LedgerTables (..) @@ -82,9 +82,9 @@ data ExtLedgerState blk mk = ExtLedgerState } deriving Generic -getPerasEpochContextResolverHandle :: +mkPerasEpochContextResolverHandle :: MonadSTM m => STM m (ExtLedgerState blk mk) -> PerasEpochContextResolverHandle m blk -getPerasEpochContextResolverHandle getLedgerStateSTM = +mkPerasEpochContextResolverHandle getLedgerStateSTM = PerasEpochContextResolverHandle $ perasEpochContextResolver <$> getLedgerStateSTM deriving instance diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs new file mode 100644 index 0000000000..b479d8937a --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs @@ -0,0 +1,516 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +module Ouroboros.Consensus.Peras.Time + ( -- * Time-resolution context + TimeResolutionContext (..) + , TimeResolutionContextHandle (..) + , mkTimeResolutionContextHandle + + -- * Errors + , TimeResolutionError (..) + + -- * Time resolution info types + , SlotToTimeInfo (..) + , TimeToSlotInfo (..) + , EpochToSlotInfo (..) + , SlotToEpochInfo (..) + , PerasRoundToSlotInfo (..) + , SlotToPerasRoundInfo (..) + , EpochToPerasRoundInfo (..) + , PerasRoundToEpochInfo (..) + + -- * Smart accessors for time resolution info types + , ttsiSlotNo + , ttsiSlotStartTime + , ttsiSlotEndTime + , ttsiSlotLength + , steiEpochNo + , steiEpochStartSlot + , steiEpochEndSlot + , steiEpochSize + , steiIsNewEpoch + , stpriPerasRoundNo + , stpriPerasRoundStartSlot + , stpriPerasRoundEndSlot + , stpriPerasRoundLength + , stpriIsNewPerasRound + , prteiEpochNo + , prteiEpochStartPerasRound + , prteiEpochEndPerasRound + , prteiEpochSizeInPerasRounds + , prteiIsNewEpoch + + -- * Time resolution within a context + , runQueryInContext + , resolveTimeToSlotInfo + , resolveSlotToTimeInfo + , resolveSlotToEpochInfo + , resolveEpochToSlotInfo + , resolveSlotToPerasRoundInfo + , resolvePerasRoundToSlotInfo + , resolveEpochToPerasRoundInfo + , resolvePerasRoundToEpochInfo + + -- * Time resolution through a context handle + , withHandle + , resolveTimeToSlotInfoWithHandle + , resolveSlotToTimeInfoWithHandle + , resolveSlotToEpochInfoWithHandle + , resolveEpochToSlotInfoWithHandle + , resolveSlotToPerasRoundInfoWithHandle + , resolvePerasRoundToSlotInfoWithHandle + , resolveEpochToPerasRoundInfoWithHandle + , resolvePerasRoundToEpochInfoWithHandle + ) where + +import Cardano.Prelude (Bifunctor (bimap)) +import Cardano.Slotting.Time (addRelativeTime, getSlotLength) +import Control.Exception.Base (Exception) +import Data.Time (NominalDiffTime) +import Data.Word (Word64) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block + ( EpochNo + , EpochSize (..) + , PerasRoundNo (..) + , SlotNo + ) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime + , SlotLength + ) +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (hardForkSummary)) +import Ouroboros.Consensus.HardFork.History.EraParams (PerasEnabled, fromPerasEnabled) +import Ouroboros.Consensus.HardFork.History.Qry + ( PastHorizonException + , Qry + , epochToSlot + , perasRoundNoToSlot + , runQuery + , slotToEpoch + , slotToEpoch' + , slotToPerasRoundNo + , slotToWallclock + , wallclockToSlot + ) +import Ouroboros.Consensus.HardFork.History.Util (addSlots) +import Ouroboros.Consensus.Ledger.Abstract (LedgerConfig, LedgerState) +import Ouroboros.Consensus.Peras.Params (PerasRoundLength (..)) +import Ouroboros.Consensus.Util.IOLike + ( MonadSTM (..) + , MonadThrow + , throwSTM + ) + +data TimeResolutionContext blk where + TimeResolutionContext :: forall blk mk. LedgerConfig blk -> LedgerState blk mk -> TimeResolutionContext blk + +newtype TimeResolutionContextHandle m blk = TimeResolutionContextHandle (STM m (TimeResolutionContext blk)) + +mkTimeResolutionContextHandle :: + MonadSTM m => LedgerConfig blk -> STM m (LedgerState blk mk) -> TimeResolutionContextHandle m blk +mkTimeResolutionContextHandle cfg mkState = TimeResolutionContextHandle $ TimeResolutionContext cfg <$> mkState + +data TimeResolutionError + = TimeResolutionErrorPastHorizon PastHorizonException + | TimeResolutionPerasNotEnabled + deriving (Show, Exception) + +-- | Absorb a 'NoPerasEnabled' result into a 'TimeResolutionPerasNotEnabled' +-- error. +absorbNoPerasEnabled :: PerasEnabled a -> Either TimeResolutionError a +absorbNoPerasEnabled = fromPerasEnabled (Left TimeResolutionPerasNotEnabled) . fmap Right + +data SlotToTimeInfo = SlotToTimeInfo + { sttiSlotNo :: SlotNo + , sttiSlotStartTime :: RelativeTime + , sttiSlotEndTime :: RelativeTime + , sttiSlotLength :: SlotLength + } + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks + +data TimeToSlotInfo = TimeToSlotInfo + { ttsiSlotToTimeInfo :: SlotToTimeInfo + , ttsiTimeSpentInSlot :: NominalDiffTime + , ttsiTimeLeftInSlot :: NominalDiffTime + , ttsiCurrentTime :: RelativeTime + } + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks + +ttsiSlotNo :: TimeToSlotInfo -> SlotNo +ttsiSlotNo = sttiSlotNo . ttsiSlotToTimeInfo +ttsiSlotStartTime :: TimeToSlotInfo -> RelativeTime +ttsiSlotStartTime = sttiSlotStartTime . ttsiSlotToTimeInfo +ttsiSlotEndTime :: TimeToSlotInfo -> RelativeTime +ttsiSlotEndTime = sttiSlotEndTime . ttsiSlotToTimeInfo +ttsiSlotLength :: TimeToSlotInfo -> SlotLength +ttsiSlotLength = sttiSlotLength . ttsiSlotToTimeInfo + +data EpochToSlotInfo = EpochToSlotInfo + { etsiEpochNo :: EpochNo + , etsiEpochStartSlot :: SlotNo + , etsiEpochEndSlot :: SlotNo + , etsiEpochSize :: EpochSize + } + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks + +data SlotToEpochInfo = SlotToEpochInfo + { steiEpochToSlotInfo :: EpochToSlotInfo + , steiCurrentSlot :: SlotNo + , steiSlotsSpentInEpoch :: Word64 + , steiSlotsLeftInEpoch :: Word64 + } + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks + +steiEpochNo :: SlotToEpochInfo -> EpochNo +steiEpochNo = etsiEpochNo . steiEpochToSlotInfo +steiEpochStartSlot :: SlotToEpochInfo -> SlotNo +steiEpochStartSlot = etsiEpochStartSlot . steiEpochToSlotInfo +steiEpochEndSlot :: SlotToEpochInfo -> SlotNo +steiEpochEndSlot = etsiEpochEndSlot . steiEpochToSlotInfo +steiEpochSize :: SlotToEpochInfo -> EpochSize +steiEpochSize = etsiEpochSize . steiEpochToSlotInfo + +steiIsNewEpoch :: SlotToEpochInfo -> Bool +steiIsNewEpoch stei = steiSlotsSpentInEpoch stei == 0 + +data PerasRoundToSlotInfo = PerasRoundToSlotInfo + { prtsiPerasRoundNo :: PerasRoundNo + , prtsiPerasRoundStartSlot :: SlotNo + , prtsiPerasRoundEndSlot :: SlotNo + , prtsiPerasRoundLength :: PerasRoundLength + } + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks + +data SlotToPerasRoundInfo = SlotToPerasRoundInfo + { stpriPerasRoundToSlotInfo :: PerasRoundToSlotInfo + , stpriCurrentSlot :: SlotNo + , stpriSlotsSpentInPerasRound :: Word64 + , stpriSlotsLeftInPerasRound :: Word64 + } + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks + +stpriPerasRoundNo :: SlotToPerasRoundInfo -> PerasRoundNo +stpriPerasRoundNo = prtsiPerasRoundNo . stpriPerasRoundToSlotInfo +stpriPerasRoundStartSlot :: SlotToPerasRoundInfo -> SlotNo +stpriPerasRoundStartSlot = prtsiPerasRoundStartSlot . stpriPerasRoundToSlotInfo +stpriPerasRoundEndSlot :: SlotToPerasRoundInfo -> SlotNo +stpriPerasRoundEndSlot = prtsiPerasRoundEndSlot . stpriPerasRoundToSlotInfo +stpriPerasRoundLength :: SlotToPerasRoundInfo -> PerasRoundLength +stpriPerasRoundLength = prtsiPerasRoundLength . stpriPerasRoundToSlotInfo + +stpriIsNewPerasRound :: SlotToPerasRoundInfo -> Bool +stpriIsNewPerasRound stpri = stpriSlotsSpentInPerasRound stpri == 0 + +data EpochToPerasRoundInfo = EpochToPerasRoundInfo + { etpriEpochNo :: EpochNo + , etpriEpochStartPerasRound :: PerasRoundNo + , etpriEpochEndPerasRound :: PerasRoundNo + , etpriEpochSizeInPerasRounds :: Word64 + } + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks + +data PerasRoundToEpochInfo = PerasRoundToEpochInfo + { prteiEpochToPerasRoundInfo :: EpochToPerasRoundInfo + , prteiCurrentPerasRound :: PerasRoundNo + , prteiPerasRoundsSpentInEpoch :: Word64 + , prteiPerasRoundsLeftInEpoch :: Word64 + } + deriving stock (Show, Eq, Generic) + deriving anyclass NoThunks + +prteiEpochNo :: PerasRoundToEpochInfo -> EpochNo +prteiEpochNo = etpriEpochNo . prteiEpochToPerasRoundInfo +prteiEpochStartPerasRound :: PerasRoundToEpochInfo -> PerasRoundNo +prteiEpochStartPerasRound = etpriEpochStartPerasRound . prteiEpochToPerasRoundInfo +prteiEpochEndPerasRound :: PerasRoundToEpochInfo -> PerasRoundNo +prteiEpochEndPerasRound = etpriEpochEndPerasRound . prteiEpochToPerasRoundInfo +prteiEpochSizeInPerasRounds :: PerasRoundToEpochInfo -> Word64 +prteiEpochSizeInPerasRounds = etpriEpochSizeInPerasRounds . prteiEpochToPerasRoundInfo + +prteiIsNewEpoch :: PerasRoundToEpochInfo -> Bool +prteiIsNewEpoch prtei = prteiPerasRoundsSpentInEpoch prtei == 0 + +runQueryInContext :: + HasHardForkHistory blk => + TimeResolutionContext blk -> + Qry a -> + Either TimeResolutionError a +runQueryInContext (TimeResolutionContext cfg state) qry = + bimap TimeResolutionErrorPastHorizon id $ runQuery qry (hardForkSummary cfg state) + +-- | Get the 'TimeToSlotInfo' for a given 'RelativeTime'. +resolveTimeToSlotInfo :: + HasHardForkHistory blk => + TimeResolutionContext blk -> + RelativeTime -> + Either TimeResolutionError TimeToSlotInfo +resolveTimeToSlotInfo ctx absTime = + runQueryInContext ctx (wallclockToSlot absTime) >>= \(absSlot, timeSpentInSlot, timeLeftInSlot) -> do + (startTime, slotLength) <- runQueryInContext ctx (slotToWallclock absSlot) + pure $ + TimeToSlotInfo + { ttsiSlotToTimeInfo = + SlotToTimeInfo + { sttiSlotNo = absSlot + , sttiSlotStartTime = startTime + , sttiSlotEndTime = addRelativeTime timeLeftInSlot absTime + , sttiSlotLength = slotLength + } + , ttsiTimeSpentInSlot = timeSpentInSlot + , ttsiTimeLeftInSlot = timeLeftInSlot + , ttsiCurrentTime = absTime + } + +-- | Get the 'SlotToTimeInfo' for the initial 'SlotNo'. +resolveSlotToTimeInfo :: + HasHardForkHistory blk => + TimeResolutionContext blk -> + SlotNo -> + Either TimeResolutionError SlotToTimeInfo +resolveSlotToTimeInfo ctx absSlot = + runQueryInContext ctx (slotToWallclock absSlot) >>= \(startTime, slotLength) -> + pure $ + SlotToTimeInfo + { sttiSlotNo = absSlot + , sttiSlotStartTime = startTime + , sttiSlotEndTime = addRelativeTime (getSlotLength slotLength) startTime + , sttiSlotLength = slotLength + } + +-- | Get the 'SlotToEpochInfo' for a given 'SlotNo'. +resolveSlotToEpochInfo :: + HasHardForkHistory blk => + TimeResolutionContext blk -> + SlotNo -> + Either TimeResolutionError SlotToEpochInfo +resolveSlotToEpochInfo ctx absSlot = + runQueryInContext ctx (slotToEpoch absSlot) >>= \(absEpoch, slotsSpentInEpoch, slotsLeftInEpoch) -> do + (startSlot, epochSize) <- runQueryInContext ctx (epochToSlot absEpoch) + pure $ + SlotToEpochInfo + { steiEpochToSlotInfo = + EpochToSlotInfo + { etsiEpochNo = absEpoch + , etsiEpochStartSlot = startSlot + , etsiEpochEndSlot = addSlots (unEpochSize epochSize) startSlot + , etsiEpochSize = epochSize + } + , steiCurrentSlot = absSlot + , steiSlotsSpentInEpoch = slotsSpentInEpoch + , steiSlotsLeftInEpoch = slotsLeftInEpoch + } + +-- | Get the 'EpochToSlotInfo' for a given 'EpochNo'. +resolveEpochToSlotInfo :: + HasHardForkHistory blk => + TimeResolutionContext blk -> + EpochNo -> + Either TimeResolutionError EpochToSlotInfo +resolveEpochToSlotInfo ctx absEpoch = + runQueryInContext ctx (epochToSlot absEpoch) >>= \(startSlot, epochSize) -> + pure $ + EpochToSlotInfo + { etsiEpochNo = absEpoch + , etsiEpochStartSlot = startSlot + , etsiEpochEndSlot = addSlots (unEpochSize epochSize) startSlot + , etsiEpochSize = epochSize + } + +-- | Get the 'SlotToPerasRoundInfo' for a given 'SlotNo'. +resolveSlotToPerasRoundInfo :: + HasHardForkHistory blk => + TimeResolutionContext blk -> + SlotNo -> + Either TimeResolutionError SlotToPerasRoundInfo +resolveSlotToPerasRoundInfo ctx absSlot = + runQueryInContext ctx (slotToPerasRoundNo absSlot) + >>= absorbNoPerasEnabled + >>= \(absPerasRoundNo, slotsSpentInPerasRound, slotsLeftInPerasRound) -> do + (startSlot, roundLength) <- + runQueryInContext ctx (perasRoundNoToSlot absPerasRoundNo) >>= absorbNoPerasEnabled + pure $ + SlotToPerasRoundInfo + { stpriPerasRoundToSlotInfo = + PerasRoundToSlotInfo + { prtsiPerasRoundNo = absPerasRoundNo + , prtsiPerasRoundStartSlot = startSlot + , prtsiPerasRoundEndSlot = addSlots (unPerasRoundLength roundLength) startSlot + , prtsiPerasRoundLength = roundLength + } + , stpriCurrentSlot = absSlot + , stpriSlotsSpentInPerasRound = slotsSpentInPerasRound + , stpriSlotsLeftInPerasRound = slotsLeftInPerasRound + } + +-- | Get the 'PerasRoundToSlotInfo' for a given 'PerasRoundNo'. +resolvePerasRoundToSlotInfo :: + HasHardForkHistory blk => + TimeResolutionContext blk -> + PerasRoundNo -> + Either TimeResolutionError PerasRoundToSlotInfo +resolvePerasRoundToSlotInfo ctx perasRoundNo = + runQueryInContext ctx (perasRoundNoToSlot perasRoundNo) + >>= absorbNoPerasEnabled + >>= \(startSlot, roundLength) -> + pure $ + PerasRoundToSlotInfo + { prtsiPerasRoundNo = perasRoundNo + , prtsiPerasRoundStartSlot = startSlot + , prtsiPerasRoundEndSlot = addSlots (unPerasRoundLength roundLength) startSlot + , prtsiPerasRoundLength = roundLength + } + +-- | Get the 'EpochToPerasRoundInfo' for a given 'EpochNo'. +resolveEpochToPerasRoundInfo :: + HasHardForkHistory blk => + TimeResolutionContext blk -> + EpochNo -> + Either TimeResolutionError EpochToPerasRoundInfo +resolveEpochToPerasRoundInfo ctx absEpoch = + runQueryInContext ctx (epochToSlot absEpoch) >>= \(epochStartSlot, epochSize) -> do + let epochEndSlot = addSlots (unEpochSize epochSize) epochStartSlot + (epochStartPerasRound, _, _) <- + runQueryInContext ctx (slotToPerasRoundNo epochStartSlot) >>= absorbNoPerasEnabled + (epochEndPerasRound, _, _) <- + runQueryInContext ctx (slotToPerasRoundNo epochEndSlot) >>= absorbNoPerasEnabled + pure $ + EpochToPerasRoundInfo + { etpriEpochNo = absEpoch + , etpriEpochStartPerasRound = epochStartPerasRound + , etpriEpochEndPerasRound = epochEndPerasRound + , etpriEpochSizeInPerasRounds = + -- TODO: check if EndPerasRound is inclusive or exclusive. If exclusive, we need to add 1 here. + -- Or maybe we want to do a division of epoch size (in slots) by round size (in slots) instead? + unPerasRoundNo epochEndPerasRound - unPerasRoundNo epochStartPerasRound + } + +-- | Get the 'PerasRoundToEpochInfo' for a given 'PerasRoundNo'. +resolvePerasRoundToEpochInfo :: + HasHardForkHistory blk => + TimeResolutionContext blk -> + PerasRoundNo -> + Either TimeResolutionError PerasRoundToEpochInfo +resolvePerasRoundToEpochInfo ctx perasRoundNo = + runQueryInContext ctx (perasRoundNoToSlot perasRoundNo) + >>= absorbNoPerasEnabled + >>= \(roundStartSlot, _) -> do + (absEpoch, _) <- runQueryInContext ctx (slotToEpoch' roundStartSlot) + (epochStartSlot, epochSize) <- runQueryInContext ctx (epochToSlot absEpoch) + let epochEndSlot = addSlots (unEpochSize epochSize) epochStartSlot + (epochStartPerasRound, _, _) <- + runQueryInContext ctx (slotToPerasRoundNo epochStartSlot) >>= absorbNoPerasEnabled + (epochEndPerasRound, _, _) <- + runQueryInContext ctx (slotToPerasRoundNo epochEndSlot) >>= absorbNoPerasEnabled + pure $ + PerasRoundToEpochInfo + { prteiEpochToPerasRoundInfo = + EpochToPerasRoundInfo + { etpriEpochNo = absEpoch + , etpriEpochStartPerasRound = epochStartPerasRound + , etpriEpochEndPerasRound = epochEndPerasRound + , etpriEpochSizeInPerasRounds = + -- TODO: check if EndPerasRound is inclusive or exclusive. If exclusive, we need to add 1 here. + -- Or maybe we want to do a division of epoch size (in slots) by round size (in slots) instead? + unPerasRoundNo epochEndPerasRound - unPerasRoundNo epochStartPerasRound + } + , prteiCurrentPerasRound = perasRoundNo + , prteiPerasRoundsSpentInEpoch = + unPerasRoundNo perasRoundNo - unPerasRoundNo epochStartPerasRound + , prteiPerasRoundsLeftInEpoch = + unPerasRoundNo epochEndPerasRound - unPerasRoundNo perasRoundNo + } + +-- ------------------------------------------------------------------------------- +-- Time resolution through a context handle +-- ------------------------------------------------------------------------------- + +-- | Run a pure context resolver against a 'TimeResolutionContextHandle', reading +-- the current context from the handle and throwing any 'TimeResolutionError' in +-- 'STM'. +withHandle :: + (MonadSTM m, MonadThrow (STM m)) => + (TimeResolutionContext blk -> a -> Either TimeResolutionError b) -> + TimeResolutionContextHandle m blk -> + a -> + STM m b +withHandle f (TimeResolutionContextHandle getContext) x = do + ctx <- getContext + either throwSTM pure (f ctx x) + +-- | Get the 'TimeToSlotInfo' for a given 'RelativeTime'. +resolveTimeToSlotInfoWithHandle :: + (MonadSTM m, MonadThrow (STM m), HasHardForkHistory blk) => + TimeResolutionContextHandle m blk -> + RelativeTime -> + STM m TimeToSlotInfo +resolveTimeToSlotInfoWithHandle = withHandle resolveTimeToSlotInfo + +-- | Get the 'SlotToTimeInfo' for the initial 'SlotNo'. +resolveSlotToTimeInfoWithHandle :: + (MonadSTM m, MonadThrow (STM m), HasHardForkHistory blk) => + TimeResolutionContextHandle m blk -> + SlotNo -> + STM m SlotToTimeInfo +resolveSlotToTimeInfoWithHandle = withHandle resolveSlotToTimeInfo + +-- | Get the 'SlotToEpochInfo' for a given 'SlotNo'. +resolveSlotToEpochInfoWithHandle :: + (MonadSTM m, MonadThrow (STM m), HasHardForkHistory blk) => + TimeResolutionContextHandle m blk -> + SlotNo -> + STM m SlotToEpochInfo +resolveSlotToEpochInfoWithHandle = withHandle resolveSlotToEpochInfo + +-- | Get the 'EpochToSlotInfo' for a given 'EpochNo'. +resolveEpochToSlotInfoWithHandle :: + (MonadSTM m, MonadThrow (STM m), HasHardForkHistory blk) => + TimeResolutionContextHandle m blk -> + EpochNo -> + STM m EpochToSlotInfo +resolveEpochToSlotInfoWithHandle = withHandle resolveEpochToSlotInfo + +-- | Get the 'SlotToPerasRoundInfo' for a given 'SlotNo'. +resolveSlotToPerasRoundInfoWithHandle :: + (MonadSTM m, MonadThrow (STM m), HasHardForkHistory blk) => + TimeResolutionContextHandle m blk -> + SlotNo -> + STM m SlotToPerasRoundInfo +resolveSlotToPerasRoundInfoWithHandle = withHandle resolveSlotToPerasRoundInfo + +-- | Get the 'PerasRoundToSlotInfo' for a given 'PerasRoundNo'. +resolvePerasRoundToSlotInfoWithHandle :: + (MonadSTM m, MonadThrow (STM m), HasHardForkHistory blk) => + TimeResolutionContextHandle m blk -> + PerasRoundNo -> + STM m PerasRoundToSlotInfo +resolvePerasRoundToSlotInfoWithHandle = withHandle resolvePerasRoundToSlotInfo + +-- | Get the 'EpochToPerasRoundInfo' for a given 'EpochNo'. +resolveEpochToPerasRoundInfoWithHandle :: + (MonadSTM m, MonadThrow (STM m), HasHardForkHistory blk) => + TimeResolutionContextHandle m blk -> + EpochNo -> + STM m EpochToPerasRoundInfo +resolveEpochToPerasRoundInfoWithHandle = withHandle resolveEpochToPerasRoundInfo + +-- | Get the 'PerasRoundToEpochInfo' for a given 'PerasRoundNo'. +resolvePerasRoundToEpochInfoWithHandle :: + (MonadSTM m, MonadThrow (STM m), HasHardForkHistory blk) => + TimeResolutionContextHandle m blk -> + PerasRoundNo -> + STM m PerasRoundToEpochInfo +resolvePerasRoundToEpochInfoWithHandle = withHandle resolvePerasRoundToEpochInfo 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 35a7cf5740..6464fdb1aa 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 @@ -57,7 +57,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HeaderValidation (mkHeaderWithTime) -import Ouroboros.Consensus.Ledger.Extended (getPerasEpochContextResolverHandle, ledgerState) +import Ouroboros.Consensus.Ledger.Extended (ledgerState, mkPerasEpochContextResolverHandle) import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras) import Ouroboros.Consensus.Ledger.SupportsProtocol @@ -208,7 +208,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do PerasVoteDB.PerasVoteDbArgs { PerasVoteDB.pvdbaTracer = PerasVoteDB.pvdbaTracer incompleteArgsPerasVoteDB , PerasVoteDB.pvdbaPerasEpochContextResolverHandle = - getPerasEpochContextResolverHandle (LedgerDB.getVolatileTip lgrDB) + mkPerasEpochContextResolverHandle (LedgerDB.getVolatileTip lgrDB) } varInvalid <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0)) From 33599e1ed0069658258c634bdad410299a424bbe Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 9 Jun 2026 13:53:29 +0200 Subject: [PATCH 59/62] Add TimeResolutionContext(Handle) to the ChainDB --- .../Ouroboros/Consensus/Peras/Time.hs | 64 +++++++++---------- .../Consensus/Storage/ChainDB/API.hs | 3 + .../Consensus/Storage/ChainDB/Impl.hs | 10 ++- .../Consensus/Storage/ChainDB/Impl/Query.hs | 19 +++++- 4 files changed, 60 insertions(+), 36 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs index b479d8937a..946a942e20 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs @@ -128,19 +128,19 @@ absorbNoPerasEnabled :: PerasEnabled a -> Either TimeResolutionError a absorbNoPerasEnabled = fromPerasEnabled (Left TimeResolutionPerasNotEnabled) . fmap Right data SlotToTimeInfo = SlotToTimeInfo - { sttiSlotNo :: SlotNo - , sttiSlotStartTime :: RelativeTime - , sttiSlotEndTime :: RelativeTime - , sttiSlotLength :: SlotLength + { sttiSlotNo :: !SlotNo + , sttiSlotStartTime :: !RelativeTime + , sttiSlotEndTime :: !RelativeTime + , sttiSlotLength :: !SlotLength } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks data TimeToSlotInfo = TimeToSlotInfo - { ttsiSlotToTimeInfo :: SlotToTimeInfo - , ttsiTimeSpentInSlot :: NominalDiffTime - , ttsiTimeLeftInSlot :: NominalDiffTime - , ttsiCurrentTime :: RelativeTime + { ttsiSlotToTimeInfo :: !SlotToTimeInfo + , ttsiTimeSpentInSlot :: !NominalDiffTime + , ttsiTimeLeftInSlot :: !NominalDiffTime + , ttsiCurrentTime :: !RelativeTime } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks @@ -155,19 +155,19 @@ ttsiSlotLength :: TimeToSlotInfo -> SlotLength ttsiSlotLength = sttiSlotLength . ttsiSlotToTimeInfo data EpochToSlotInfo = EpochToSlotInfo - { etsiEpochNo :: EpochNo - , etsiEpochStartSlot :: SlotNo - , etsiEpochEndSlot :: SlotNo - , etsiEpochSize :: EpochSize + { etsiEpochNo :: !EpochNo + , etsiEpochStartSlot :: !SlotNo + , etsiEpochEndSlot :: !SlotNo + , etsiEpochSize :: !EpochSize } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks data SlotToEpochInfo = SlotToEpochInfo - { steiEpochToSlotInfo :: EpochToSlotInfo - , steiCurrentSlot :: SlotNo - , steiSlotsSpentInEpoch :: Word64 - , steiSlotsLeftInEpoch :: Word64 + { steiEpochToSlotInfo :: !EpochToSlotInfo + , steiCurrentSlot :: !SlotNo + , steiSlotsSpentInEpoch :: !Word64 + , steiSlotsLeftInEpoch :: !Word64 } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks @@ -185,19 +185,19 @@ steiIsNewEpoch :: SlotToEpochInfo -> Bool steiIsNewEpoch stei = steiSlotsSpentInEpoch stei == 0 data PerasRoundToSlotInfo = PerasRoundToSlotInfo - { prtsiPerasRoundNo :: PerasRoundNo - , prtsiPerasRoundStartSlot :: SlotNo - , prtsiPerasRoundEndSlot :: SlotNo - , prtsiPerasRoundLength :: PerasRoundLength + { prtsiPerasRoundNo :: !PerasRoundNo + , prtsiPerasRoundStartSlot :: !SlotNo + , prtsiPerasRoundEndSlot :: !SlotNo + , prtsiPerasRoundLength :: !PerasRoundLength } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks data SlotToPerasRoundInfo = SlotToPerasRoundInfo - { stpriPerasRoundToSlotInfo :: PerasRoundToSlotInfo - , stpriCurrentSlot :: SlotNo - , stpriSlotsSpentInPerasRound :: Word64 - , stpriSlotsLeftInPerasRound :: Word64 + { stpriPerasRoundToSlotInfo :: !PerasRoundToSlotInfo + , stpriCurrentSlot :: !SlotNo + , stpriSlotsSpentInPerasRound :: !Word64 + , stpriSlotsLeftInPerasRound :: !Word64 } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks @@ -215,19 +215,19 @@ stpriIsNewPerasRound :: SlotToPerasRoundInfo -> Bool stpriIsNewPerasRound stpri = stpriSlotsSpentInPerasRound stpri == 0 data EpochToPerasRoundInfo = EpochToPerasRoundInfo - { etpriEpochNo :: EpochNo - , etpriEpochStartPerasRound :: PerasRoundNo - , etpriEpochEndPerasRound :: PerasRoundNo - , etpriEpochSizeInPerasRounds :: Word64 + { etpriEpochNo :: !EpochNo + , etpriEpochStartPerasRound :: !PerasRoundNo + , etpriEpochEndPerasRound :: !PerasRoundNo + , etpriEpochSizeInPerasRounds :: !Word64 } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks data PerasRoundToEpochInfo = PerasRoundToEpochInfo - { prteiEpochToPerasRoundInfo :: EpochToPerasRoundInfo - , prteiCurrentPerasRound :: PerasRoundNo - , prteiPerasRoundsSpentInEpoch :: Word64 - , prteiPerasRoundsLeftInEpoch :: Word64 + { prteiEpochToPerasRoundInfo :: !EpochToPerasRoundInfo + , prteiCurrentPerasRound :: !PerasRoundNo + , prteiPerasRoundsSpentInEpoch :: !Word64 + , prteiPerasRoundsLeftInEpoch :: !Word64 } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 3bf4da8995..185f7e5e97 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -96,6 +96,7 @@ import Ouroboros.Consensus.Ledger.Extended , ExtValidationError ) import Ouroboros.Consensus.Peras.Context (PerasEpochContextResolverHandle) +import Ouroboros.Consensus.Peras.Time (TimeResolutionContextHandle) import Ouroboros.Consensus.Peras.Voting.View (PerasVotingViewHandle (..)) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment @@ -475,6 +476,8 @@ data ChainDB m blk = ChainDB -- NOTE: This needs to be part of the API because the implementation of the ChainDB -- has access, during initialization, to the 'TopLevelConfig', but it isn't -- stored/exposed by the API itself. + , getTimeResolutionContextHandle :: + TimeResolutionContextHandle m blk , getPerasEpochContextResolverHandle :: PerasEpochContextResolverHandle m blk -- ^ Returns a handle to obtain the 'PerasEpochContext' for a given 'PerasRoundNo' 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 6464fdb1aa..14d5a1e4c1 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 @@ -65,6 +65,7 @@ import Ouroboros.Consensus.Peras.Context ( LedgerStateHeaderStateSupportsPerasVoting , PerasEpochContextResolverHandle (PerasEpochContextResolverHandle) ) +import Ouroboros.Consensus.Peras.Time (TimeResolutionContextHandle (..)) import Ouroboros.Consensus.Peras.Voting.View (PerasVotingViewHandle (PerasVotingViewHandle)) import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as API @@ -326,10 +327,17 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , getPerasVoteIds = getEnvSTM h Query.getPerasVoteIds , getPerasVotingViewHandle = PerasVotingViewHandle $ \roundNo -> - getEnvSTM h (Query.getPerasVotingView (Args.cdbsTopLevelConfig cdbSpecificArgs) roundNo) + getEnvSTM + h + (Query.getPerasVotingView (topLevelConfigLedger $ Args.cdbsTopLevelConfig cdbSpecificArgs) roundNo) , getPerasEpochContextResolverHandle = PerasEpochContextResolverHandle $ getEnvSTM h Query.getPerasEpochContextResolver + , getTimeResolutionContextHandle = + TimeResolutionContextHandle $ + getEnvSTM + h + (Query.getTimeResolutionContext (topLevelConfigLedger $ Args.cdbsTopLevelConfig cdbSpecificArgs)) , waitForImmutableBlock = getEnv1 h Query.waitForImmutableBlock , getLatestPerasCertOnChainRound = getEnvSTM h Query.getLatestPerasCertOnChainRound } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index f6970d3af9..09cdea8e29 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -29,6 +29,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query , getPerasVoteIds , getPerasVotingView , getPerasEpochContextResolver + , getTimeResolutionContext , getLatestPerasCertOnChainRound , getStatistics , getTipBlock @@ -57,17 +58,20 @@ import Data.Typeable import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config +import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (hardForkSummary)) import Ouroboros.Consensus.HeaderStateHistory ( HeaderStateHistory (..) ) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime) import Ouroboros.Consensus.Ledger.Abstract (EmptyMK) +import Ouroboros.Consensus.Ledger.Basics (LedgerConfig) import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerSupportsPeras (..)) import Ouroboros.Consensus.Peras.Context ( LedgerStateHeaderStateSupportsPerasVoting (resolveRoundNo) , PerasEpochContextResolver ) +import Ouroboros.Consensus.Peras.Time (TimeResolutionContext (..)) import Ouroboros.Consensus.Peras.Voting.View ( PerasVotingView , WithBoostedBlockStatus @@ -397,12 +401,13 @@ getPerasVotingView :: , LedgerSupportsPeras blk , ConsensusProtocol (BlockProtocol blk) , GetHeader blk + , HasHardForkHistory blk ) => - TopLevelConfig blk -> + LedgerConfig blk -> PerasRoundNo -> ChainDbEnv m blk -> STM m (PerasVotingView (WithArrivalTime (ValidatedPerasCert blk)) blk) -getPerasVotingView _topLevelConfig roundNo env = do +getPerasVotingView ledgerConfig roundNo env = do resolver <- getPerasEpochContextResolver env perasParams <- case resolveRoundNo resolver roundNo of Left err -> throwSTM err @@ -423,11 +428,19 @@ getPerasVotingView _topLevelConfig roundNo env = do latestCertSeen latestCertOnChainRoundNo chainAtCandidateBlock - summary <- undefined -- [TODO EPOCH CONTEXT PLUMBING/SOMEHOW GET SUMMARY] + summary <- hardForkSummary ledgerConfig . ledgerState <$> getCurrentLedger env case runPerasQry summary qry of Left err -> throwSTM err Right view -> pure view +getTimeResolutionContext :: + MonadSTM m => + LedgerConfig blk -> + ChainDbEnv m blk -> + STM m (TimeResolutionContext blk) +getTimeResolutionContext ledgerConfig = + fmap (TimeResolutionContext ledgerConfig . ledgerState) . getCurrentLedger + -- | Wait until the slot of the given point is smaller or equal than the immutable tip slot, -- and then return: -- - the block at the target slot if there is a block in the immutable DB at that slot; From 8326b78dc9a36b375fe1e4501056d00a898a9abc Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 9 Jun 2026 14:10:44 +0200 Subject: [PATCH 60/62] better function naming in Time resolution module --- .../Ouroboros/Consensus/Peras/Time.hs | 20 ++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs index 946a942e20..4ba2752e8c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Time.hs @@ -33,17 +33,17 @@ module Ouroboros.Consensus.Peras.Time , steiEpochStartSlot , steiEpochEndSlot , steiEpochSize - , steiIsNewEpoch + , steiIsFirstSlotOfEpoch , stpriPerasRoundNo , stpriPerasRoundStartSlot , stpriPerasRoundEndSlot , stpriPerasRoundLength - , stpriIsNewPerasRound + , stpriIsFirstSlotOfPerasRound , prteiEpochNo , prteiEpochStartPerasRound , prteiEpochEndPerasRound , prteiEpochSizeInPerasRounds - , prteiIsNewEpoch + , prteiIsFirstPerasRoundOfEpoch -- * Time resolution within a context , runQueryInContext @@ -181,8 +181,10 @@ steiEpochEndSlot = etsiEpochEndSlot . steiEpochToSlotInfo steiEpochSize :: SlotToEpochInfo -> EpochSize steiEpochSize = etsiEpochSize . steiEpochToSlotInfo -steiIsNewEpoch :: SlotToEpochInfo -> Bool -steiIsNewEpoch stei = steiSlotsSpentInEpoch stei == 0 +-- TODO: check with consensus team if that is resilient enough to detect epoch +-- boundaries +steiIsFirstSlotOfEpoch :: SlotToEpochInfo -> Bool +steiIsFirstSlotOfEpoch stei = steiSlotsSpentInEpoch stei == 0 data PerasRoundToSlotInfo = PerasRoundToSlotInfo { prtsiPerasRoundNo :: !PerasRoundNo @@ -211,8 +213,8 @@ stpriPerasRoundEndSlot = prtsiPerasRoundEndSlot . stpriPerasRoundToSlotInfo stpriPerasRoundLength :: SlotToPerasRoundInfo -> PerasRoundLength stpriPerasRoundLength = prtsiPerasRoundLength . stpriPerasRoundToSlotInfo -stpriIsNewPerasRound :: SlotToPerasRoundInfo -> Bool -stpriIsNewPerasRound stpri = stpriSlotsSpentInPerasRound stpri == 0 +stpriIsFirstSlotOfPerasRound :: SlotToPerasRoundInfo -> Bool +stpriIsFirstSlotOfPerasRound stpri = stpriSlotsSpentInPerasRound stpri == 0 data EpochToPerasRoundInfo = EpochToPerasRoundInfo { etpriEpochNo :: !EpochNo @@ -241,8 +243,8 @@ prteiEpochEndPerasRound = etpriEpochEndPerasRound . prteiEpochToPerasRoundInfo prteiEpochSizeInPerasRounds :: PerasRoundToEpochInfo -> Word64 prteiEpochSizeInPerasRounds = etpriEpochSizeInPerasRounds . prteiEpochToPerasRoundInfo -prteiIsNewEpoch :: PerasRoundToEpochInfo -> Bool -prteiIsNewEpoch prtei = prteiPerasRoundsSpentInEpoch prtei == 0 +prteiIsFirstPerasRoundOfEpoch :: PerasRoundToEpochInfo -> Bool +prteiIsFirstPerasRoundOfEpoch prtei = prteiPerasRoundsSpentInEpoch prtei == 0 runQueryInContext :: HasHardForkHistory blk => From f37c3fc4389b8e6d7a8c9339a7a5b63d401a81cb Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 9 Jun 2026 14:22:30 +0200 Subject: [PATCH 61/62] add isPerasVotingAllowedInContext --- .../Ouroboros/Consensus/Peras/Voting/Rules.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs index a160e905f3..1cf88e7c36 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting/Rules.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -16,6 +18,7 @@ -- do not denote ignored variables. module Ouroboros.Consensus.Peras.Voting.Rules ( isPerasVotingAllowed + , isPerasVotingAllowedInContext , PerasVotingRule (..) , PerasVotingRulesDecision (..) , perasVR1A @@ -41,13 +44,17 @@ import Ouroboros.Consensus.Block.SupportsPeras , PerasIgnoranceRounds (..) , PerasParams (..) , PerasRoundNo (..) + , ValidatedPerasCert , onPerasRoundNo ) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Peras.Voting.View ( LatestCertOnChainView (..) , LatestCertSeenView (..) , PerasVotingView (..) + , PerasVotingViewHandle (..) ) +import Ouroboros.Consensus.Util.IOLike (MonadSTM (..)) import Ouroboros.Consensus.Util.Pred ( Evidence (..) , Explainable (..) @@ -86,6 +93,14 @@ isPerasVotingAllowed pvv = ETrue{} -> Vote e (candidateBlock pvv) EFalse{} -> NoVote e +isPerasVotingAllowedInContext :: + (IsPerasCert (WithArrivalTime (ValidatedPerasCert blk)) blk, MonadSTM m) => + PerasVotingViewHandle m blk -> + PerasRoundNo -> + STM m (PerasVotingRulesDecision blk) +isPerasVotingAllowedInContext (PerasVotingViewHandle getPerasVotingView) = + fmap isPerasVotingAllowed . getPerasVotingView + -- | Voting rules -- -- Each constructor corresponds to a voting rule as per CIP-0140. From 4410c5dc789fddf0d6163efff26ce67d38638257 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 9 Jun 2026 13:02:16 +0200 Subject: [PATCH 62/62] WIP Hack to extract certs from Shelley and HFC blocks --- .../Ouroboros/Consensus/Shelley/Node/Peras.hs | 20 +++++++++++-- .../Combinator/Abstract/SingleEraBlock.hs | 1 + .../Consensus/HardFork/Combinator/Basics.hs | 29 +++++++++++++++++-- 3 files changed, 44 insertions(+), 6 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs index 180acaf2cb..def2ec95b9 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Peras.hs @@ -14,6 +14,11 @@ module Ouroboros.Consensus.Shelley.Node.Peras () where import Cardano.Ledger.Api +import qualified Cardano.Ledger.BaseTypes as Ledger +import qualified Cardano.Ledger.Dijkstra.BlockBody as Dijkstra +import qualified Cardano.Ledger.Shelley.API as SL +import Data.Maybe.Strict (strictMaybeToMaybe) +import Lens.Micro ((^.)) import Ouroboros.Consensus.Block.SupportsPeras ( BlockSupportsPeras (..) ) @@ -32,7 +37,7 @@ import qualified Ouroboros.Consensus.Peras.State.V1 as V1 import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1 import qualified Ouroboros.Consensus.Peras.Voting.V1 as V1 import Ouroboros.Consensus.Shelley.Ledger.Block - ( ShelleyBlock + ( ShelleyBlock (..) , ShelleyCompatible ) import Ouroboros.Consensus.Shelley.Ledger.Ledger () @@ -61,8 +66,17 @@ instance type PerasCrypto (ShelleyBlock proto DijkstraEra) = BLS.PerasBLSCrypto type PerasVotingCommitteeScheme (ShelleyBlock proto DijkstraEra) = V1.PerasVotingCommitteeScheme - -- [TODO EPOCH CONTEXT PLUMBING/EXTRACT CERT] extract actual Peras certificates from blocks - getPerasCertInBlock _ = Nothing + getPerasCertInBlock blk = do + -- [TODO PERAS CERTS IN BLOCKS] there will be a bytearray here after + -- integrating a newer version of Ledger. From there, we would need to + -- deserialize into a V1.PerasCert. For now, we could simply blow up if + -- the decoding fails. + Ledger.PerasCert <- + strictMaybeToMaybe $ + SL.blockBody (shelleyBlockRaw blk) + ^. Dijkstra.perasCertBlockBodyL + + Nothing -- to be replaced with the deserialized certificate instance ShelleyCompatible proto ShelleyEra => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs index 42dd418feb..7d84b7e0b0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs @@ -73,6 +73,7 @@ class , ConfigSupportsNode blk , NodeInitStorage blk , BlockSupportsDiffusionPipelining blk + , BlockSupportsPeras blk , BlockSupportsMetrics blk , SerialiseNodeToClient blk (PartialLedgerConfig blk) , -- LedgerTables diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index 15d5997742..c27dd89370 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -38,8 +38,9 @@ module Ouroboros.Consensus.HardFork.Combinator.Basics ) where import Cardano.Slotting.EpochInfo +import Control.Monad ((<=<)) import Data.Kind (Type) -import Data.SOP (K (..)) +import Data.SOP (K (..), unI) import Data.SOP.Constraint import Data.SOP.Functors import Data.SOP.Strict @@ -75,6 +76,8 @@ import qualified Ouroboros.Consensus.Peras.Voting.V1 as V1 import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (ShowProxy) +import Type.Reflection (someTypeRep) +import Unsafe.Coerce (unsafeCoerce) {------------------------------------------------------------------------------- Hard fork protocol, block, and ledger state @@ -298,8 +301,28 @@ instance type PerasCrypto (HardForkBlock xs) = BLS.PerasBLSCrypto type PerasVotingCommitteeScheme (HardForkBlock xs) = V1.PerasVotingCommitteeScheme - -- [TODO EPOCH CONTEXT PLUMBING/EXTRACT CERT] extract actual Peras certificates from blocks - getPerasCertInBlock _ = Nothing + getPerasCertInBlock = + hcollapse + . hcmap + proxySingle + (K . (unsafeCastPerasCertV1 <=< getPerasCertInBlock) . unI) + . getOneEraBlock + . getHardForkBlock + +-- [TODO PERAS CERTS IN BLOCKS] this is a nasty hack +unsafeCastPerasCertV1 :: + forall x xs. + ( Typeable xs + , Typeable (PerasCert x) + ) => + PerasCert x -> + Maybe (V1.PerasCert (HardForkBlock xs)) +unsafeCastPerasCertV1 cert = do + let xCertRep = someTypeRep (Proxy @(PerasCert x)) + let xsCertRep = someTypeRep (Proxy @(V1.PerasCert (HardForkBlock xs))) + if typeRepTyCon xCertRep == typeRepTyCon xsCertRep + then Just (unsafeCoerce cert) + else Nothing {------------------------------------------------------------------------------- ConvertRawHash