|
| 1 | +{-# LANGUAGE GADTs #-} |
| 2 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 3 | +{-# LANGUAGE StandaloneDeriving #-} |
| 4 | + |
| 5 | +-- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras |
| 6 | +-- votes from the 'PerasVoteDB' (or the 'ChainDB' which is wrapping the |
| 7 | +-- 'PerasVoteDB'). |
| 8 | +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote |
| 9 | + ( makePerasVotePoolReaderFromVoteDB |
| 10 | + , makePerasVotePoolWriterFromVoteDB |
| 11 | + ) where |
| 12 | + |
| 13 | +import Data.Map (Map) |
| 14 | +import qualified Data.Map as Map |
| 15 | +import GHC.Exception (throw) |
| 16 | +import Ouroboros.Consensus.Block |
| 17 | +import Ouroboros.Consensus.BlockchainTime.WallClock.Types |
| 18 | + ( SystemTime (..) |
| 19 | + , WithArrivalTime (..) |
| 20 | + , addArrivalTime |
| 21 | + ) |
| 22 | +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API |
| 23 | +import Ouroboros.Consensus.Storage.PerasVoteDB.API |
| 24 | + ( PerasVoteDB |
| 25 | + , PerasVoteSnapshot |
| 26 | + , PerasVoteTicketNo |
| 27 | + ) |
| 28 | +import qualified Ouroboros.Consensus.Storage.PerasVoteDB.API as PerasVoteDB |
| 29 | +import Ouroboros.Consensus.Util.IOLike |
| 30 | + |
| 31 | +-- | TODO: replace by `Data.Map.take` as soon as we move to GHC 9.8 |
| 32 | +takeAscMap :: Int -> Map k v -> Map k v |
| 33 | +takeAscMap n = Map.fromDistinctAscList . take n . Map.toAscList |
| 34 | + |
| 35 | +makePerasVotePoolReaderFromSnapshot :: |
| 36 | + IOLike m => |
| 37 | + STM m (PerasVoteSnapshot blk) -> |
| 38 | + ObjectPoolReader (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m |
| 39 | +makePerasVotePoolReaderFromSnapshot getVoteSnapshot = |
| 40 | + ObjectPoolReader |
| 41 | + { oprObjectId = getPerasVoteId |
| 42 | + , oprZeroTicketNo = PerasVoteDB.zeroPerasVoteTicketNo |
| 43 | + , oprObjectsAfter = \lastKnown limit -> do |
| 44 | + voteSnapshot <- getVoteSnapshot |
| 45 | + let votesAfterLastKnown = |
| 46 | + PerasVoteDB.getVotesAfter voteSnapshot lastKnown |
| 47 | + let loadVotesAfterLastKnown = |
| 48 | + pure $ |
| 49 | + fmap |
| 50 | + (vpvVote . forgetArrivalTime) |
| 51 | + (takeAscMap (fromIntegral limit) votesAfterLastKnown) |
| 52 | + pure $ |
| 53 | + if Map.null votesAfterLastKnown |
| 54 | + then Nothing |
| 55 | + else Just loadVotesAfterLastKnown |
| 56 | + } |
| 57 | + |
| 58 | +makePerasVotePoolReaderFromVoteDB :: |
| 59 | + IOLike m => |
| 60 | + PerasVoteDB m blk -> ObjectPoolReader (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m |
| 61 | +makePerasVotePoolReaderFromVoteDB perasVoteDB = |
| 62 | + makePerasVotePoolReaderFromSnapshot (PerasVoteDB.getVoteSnapshot perasVoteDB) |
| 63 | + |
| 64 | +makePerasVotePoolWriterFromVoteDB :: |
| 65 | + (StandardHash blk, IOLike m) => |
| 66 | + -- TODO: We probably want to be able to fetch updated stake distribution throughout |
| 67 | + -- the lifetime of the writer |
| 68 | + -- But `StrictTVar m PerasVoteStakeDistr` might not be the best choice for that. |
| 69 | + StrictTVar m PerasVoteStakeDistr -> |
| 70 | + SystemTime m -> |
| 71 | + PerasVoteDB m blk -> |
| 72 | + ObjectPoolWriter (PerasVoteId blk) (PerasVote blk) m |
| 73 | +makePerasVotePoolWriterFromVoteDB distrVar systemTime perasVoteDB = |
| 74 | + ObjectPoolWriter |
| 75 | + { opwObjectId = getPerasVoteId |
| 76 | + , opwAddObjects = \votes -> do |
| 77 | + distr <- readTVarIO distrVar |
| 78 | + addPerasVotes distr systemTime (PerasVoteDB.addVote perasVoteDB) votes |
| 79 | + , opwHasObject = do |
| 80 | + voteSnapshot <- PerasVoteDB.getVoteSnapshot perasVoteDB |
| 81 | + pure $ PerasVoteDB.containsVote voteSnapshot |
| 82 | + } |
| 83 | + |
| 84 | +data PerasVoteInboundException |
| 85 | + = forall blk. PerasVoteValidationError (PerasValidationErr blk) |
| 86 | + |
| 87 | +deriving instance Show PerasVoteInboundException |
| 88 | + |
| 89 | +instance Exception PerasVoteInboundException |
| 90 | + |
| 91 | +-- | Validate a list of 'PerasVote's, throwing a 'PerasVoteInboundException' if |
| 92 | +-- any of them are invalid. |
| 93 | +validatePerasVotes :: |
| 94 | + (StandardHash blk, MonadThrow m) => |
| 95 | + PerasVoteStakeDistr -> |
| 96 | + [PerasVote blk] -> |
| 97 | + m [ValidatedPerasVote blk] |
| 98 | +validatePerasVotes distr votes = do |
| 99 | + let perasParams = mkPerasParams |
| 100 | + -- TODO pass down 'BlockConfig' when all the plumbing is in place |
| 101 | + -- see https://github.com/tweag/cardano-peras/issues/73 |
| 102 | + -- see https://github.com/tweag/cardano-peras/issues/120 |
| 103 | + case traverse (validatePerasVote perasParams distr) votes of |
| 104 | + Left validationErr -> throw (PerasVoteValidationError validationErr) |
| 105 | + Right validatedVotes -> return validatedVotes |
| 106 | + |
| 107 | +-- | Add a list of 'PerasVote's into an object pool. |
| 108 | +-- |
| 109 | +-- NOTE: we first validate the votes, throwing an exception if any of |
| 110 | +-- them are invalid. We then wrap them with their arrival time, and finally add |
| 111 | +-- them to the pool using the provided adder function. |
| 112 | +-- |
| 113 | +-- The order of the first two operations (i.e., validation and timestamping) are |
| 114 | +-- rather arbitrary, and the abstract Peras protocol just assumes it can happen |
| 115 | +-- "within" a slot. |
| 116 | +addPerasVotes :: |
| 117 | + (StandardHash blk, MonadThrow m) => |
| 118 | + PerasVoteStakeDistr -> |
| 119 | + SystemTime m -> |
| 120 | + (WithArrivalTime (ValidatedPerasVote blk) -> m a) -> |
| 121 | + [PerasVote blk] -> |
| 122 | + m () |
| 123 | +addPerasVotes distr systemTime adder votes = do |
| 124 | + validatePerasVotes distr votes |
| 125 | + >>= mapM (addArrivalTime systemTime) |
| 126 | + >>= mapM_ adder |
0 commit comments