{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}

-- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras
-- votes from the 'PerasVoteDB' (or the 'ChainDB' which is wrapping the
-- 'PerasVoteDB').
module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote
  ( makePerasVotePoolReaderFromVoteDB
  , makePerasVotePoolWriterFromVoteDB
  , makePerasVotePoolReaderFromChainDB
  , makePerasVotePoolWriterFromChainDB
  ) where

import Control.Monad (join)
import Data.Either (partitionEithers)
import Data.Functor (void)
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.BlockchainTime.WallClock.Types
  ( SystemTime (..)
  , WithArrivalTime (..)
  )
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import Ouroboros.Consensus.Storage.PerasVoteDB.API
  ( PerasVoteDB
  , PerasVoteTicketNo
  , zeroPerasVoteTicketNo
  )
import qualified Ouroboros.Consensus.Storage.PerasVoteDB.API as PerasVoteDB
import Ouroboros.Consensus.Util.IOLike

-- | TODO: replace by `Data.Map.take` as soon as we move to GHC 9.8
takeAscMap :: Int -> Map k v -> Map k v
takeAscMap :: forall k v. Int -> Map k v -> Map k v
takeAscMap Int
n = [(k, v)] -> Map k v
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList ([(k, v)] -> Map k v)
-> (Map k v -> [(k, v)]) -> Map k v -> Map k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [(k, v)] -> [(k, v)]
forall a. Int -> [a] -> [a]
take Int
n ([(k, v)] -> [(k, v)])
-> (Map k v -> [(k, v)]) -> Map k v -> [(k, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toAscList

-------------------------------------------------------------------------------
-- Readers
-------------------------------------------------------------------------------

-- | Internal helper: create a pool reader from a @getVotesAfter@ function.
makePerasVotePoolReader ::
  IOLike m =>
  ( PerasVoteTicketNo ->
    STM m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
  ) ->
  ObjectPoolReader (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m
makePerasVotePoolReader :: forall (m :: * -> *) blk.
IOLike m =>
(PerasVoteTicketNo
 -> STM
      m
      (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))))
-> ObjectPoolReader
     (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m
makePerasVotePoolReader PerasVoteTicketNo
-> STM
     m
     (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
getVotesAfterSTM =
  ObjectPoolReader
    { oprObjectId :: PerasVote blk -> PerasVoteId blk
oprObjectId = PerasVote blk -> PerasVoteId blk
forall vote blk. HasPerasVoteId vote blk => vote -> PerasVoteId blk
getPerasVoteId
    , oprZeroTicketNo :: PerasVoteTicketNo
oprZeroTicketNo = PerasVoteTicketNo
zeroPerasVoteTicketNo
    , oprObjectsAfter :: PerasVoteTicketNo
-> Word64
-> STM m (Maybe (m (Map PerasVoteTicketNo (PerasVote blk))))
oprObjectsAfter = \PerasVoteTicketNo
lastKnown Word64
limit -> do
        votesAfterLastKnownNoLimit <- PerasVoteTicketNo
-> STM
     m
     (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
getVotesAfterSTM PerasVoteTicketNo
lastKnown
        if Map.null votesAfterLastKnownNoLimit
          then pure Nothing
          else pure . Just $ do
            let votesAfterLastKnown = Int
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
-> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
forall k v. Int -> Map k v -> Map k v
takeAscMap (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
limit) Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))
votesAfterLastKnownNoLimit
            pure $ Map.map (vpvVote . forgetArrivalTime) votesAfterLastKnown
    }

makePerasVotePoolReaderFromVoteDB ::
  IOLike m =>
  PerasVoteDB m blk ->
  ObjectPoolReader (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m
makePerasVotePoolReaderFromVoteDB :: forall (m :: * -> *) blk.
IOLike m =>
PerasVoteDB m blk
-> ObjectPoolReader
     (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m
makePerasVotePoolReaderFromVoteDB PerasVoteDB m blk
perasVoteDB =
  (PerasVoteTicketNo
 -> STM
      m
      (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))))
-> ObjectPoolReader
     (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m
forall (m :: * -> *) blk.
IOLike m =>
(PerasVoteTicketNo
 -> STM
      m
      (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))))
-> ObjectPoolReader
     (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m
makePerasVotePoolReader
    (PerasVoteDB m blk
-> PerasVoteTicketNo
-> STM
     m
     (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
forall (m :: * -> *) blk.
PerasVoteDB m blk
-> PerasVoteTicketNo
-> STM
     m
     (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
PerasVoteDB.getVotesAfter PerasVoteDB m blk
perasVoteDB)

makePerasVotePoolReaderFromChainDB ::
  IOLike m =>
  ChainDB m blk ->
  ObjectPoolReader (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m
makePerasVotePoolReaderFromChainDB :: forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk
-> ObjectPoolReader
     (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m
makePerasVotePoolReaderFromChainDB ChainDB m blk
chainDB =
  (PerasVoteTicketNo
 -> STM
      m
      (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))))
-> ObjectPoolReader
     (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m
forall (m :: * -> *) blk.
IOLike m =>
(PerasVoteTicketNo
 -> STM
      m
      (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))))
-> ObjectPoolReader
     (PerasVoteId blk) (PerasVote blk) PerasVoteTicketNo m
makePerasVotePoolReader
    (ChainDB m blk
-> PerasVoteTicketNo
-> STM
     m
     (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
forall (m :: * -> *) blk.
ChainDB m blk
-> PerasVoteTicketNo
-> STM
     m
     (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)))
ChainDB.getPerasVotesAfter ChainDB m blk
chainDB)

-------------------------------------------------------------------------------
-- Writers
-------------------------------------------------------------------------------

-- | Create a pool writer directly from a 'PerasVoteDB'.
-- In particular, the result of 'addVote' is ignored, so any produced cert will
-- have to be handled manually by another mean. This function is mostly meant
-- for tests against the 'PerasVoteDB' in isolation; for actual production use,
-- see 'makePerasVotePoolWriterFromChainDB' which creates a pool writer from the
-- 'ChainDB' and thus properly handles the produced certs.
makePerasVotePoolWriterFromVoteDB ::
  (StandardHash blk, 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
  -- from the stake distr directly, but rather use the committee selection data)
  STM m PerasVoteStakeDistr ->
  PerasVoteDB m blk ->
  ObjectPoolWriter (PerasVoteId blk) (PerasVote blk) m
makePerasVotePoolWriterFromVoteDB :: forall blk (m :: * -> *).
(StandardHash blk, IOLike m) =>
SystemTime m
-> STM m PerasVoteStakeDistr
-> PerasVoteDB m blk
-> ObjectPoolWriter (PerasVoteId blk) (PerasVote blk) m
makePerasVotePoolWriterFromVoteDB SystemTime m
systemTime STM m PerasVoteStakeDistr
getStakeDistrSTM PerasVoteDB m blk
perasVoteDB =
  ObjectPoolWriter
    { opwObjectId :: PerasVote blk -> PerasVoteId blk
opwObjectId = PerasVote blk -> PerasVoteId blk
forall vote blk. HasPerasVoteId vote blk => vote -> PerasVoteId blk
getPerasVoteId
    , opwAddObjects :: [PerasVote blk] -> m ()
opwAddObjects = \[PerasVote blk]
votes ->
        SystemTime m
-> STM m (Set (PerasVoteId blk))
-> (PerasVote blk
    -> STM
         m (Either (PerasValidationErr blk) (ValidatedPerasVote blk)))
-> (WithArrivalTime (ValidatedPerasVote blk) -> m ())
-> [PerasVote blk]
-> m ()
forall (m :: * -> *) blk.
MonadSTM m =>
SystemTime m
-> STM m (Set (PerasVoteId blk))
-> (PerasVote blk
    -> STM
         m (Either (PerasValidationErr blk) (ValidatedPerasVote blk)))
-> (WithArrivalTime (ValidatedPerasVote blk) -> m ())
-> [PerasVote blk]
-> m ()
processVotes
          SystemTime m
systemTime
          (PerasVoteDB m blk -> STM m (Set (PerasVoteId blk))
forall (m :: * -> *) blk.
PerasVoteDB m blk -> STM m (Set (PerasVoteId blk))
PerasVoteDB.getVoteIds PerasVoteDB m blk
perasVoteDB)
          -- TODO: in the future we won't need just the stake distribution for
          -- validating votes, but also the whole committee selection context
          -- (containing vote weights of committee members = voters)
          (\PerasVote blk
vote -> STM m PerasVoteStakeDistr
getStakeDistrSTM STM m PerasVoteStakeDistr
-> (PerasVoteStakeDistr
    -> STM
         m (Either (PerasValidationErr blk) (ValidatedPerasVote blk)))
-> STM m (Either (PerasValidationErr blk) (ValidatedPerasVote blk))
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PerasVoteStakeDistr
sd -> Either (PerasValidationErr blk) (ValidatedPerasVote blk)
-> STM m (Either (PerasValidationErr blk) (ValidatedPerasVote blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (PerasValidationErr blk) (ValidatedPerasVote blk)
 -> STM
      m (Either (PerasValidationErr blk) (ValidatedPerasVote blk)))
-> Either (PerasValidationErr blk) (ValidatedPerasVote blk)
-> STM m (Either (PerasValidationErr blk) (ValidatedPerasVote blk))
forall a b. (a -> b) -> a -> b
$ PerasCfg blk
-> PerasVoteStakeDistr
-> PerasVote blk
-> Either (PerasValidationErr blk) (ValidatedPerasVote blk)
forall blk.
BlockSupportsPeras blk =>
PerasCfg blk
-> PerasVoteStakeDistr
-> PerasVote blk
-> Either (PerasValidationErr blk) (ValidatedPerasVote blk)
validatePerasVote PerasParams
PerasCfg blk
mkPerasParams PerasVoteStakeDistr
sd PerasVote blk
vote)
          (m (AddPerasVoteResult blk) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (AddPerasVoteResult blk) -> m ())
-> (WithArrivalTime (ValidatedPerasVote blk)
    -> m (AddPerasVoteResult blk))
-> WithArrivalTime (ValidatedPerasVote blk)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (m (AddPerasVoteResult blk)) -> m (AddPerasVoteResult blk)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m (AddPerasVoteResult blk)) -> m (AddPerasVoteResult blk))
-> (WithArrivalTime (ValidatedPerasVote blk)
    -> m (m (AddPerasVoteResult blk)))
-> WithArrivalTime (ValidatedPerasVote blk)
-> m (AddPerasVoteResult blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM m (m (AddPerasVoteResult blk))
-> m (m (AddPerasVoteResult blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m (AddPerasVoteResult blk))
 -> m (m (AddPerasVoteResult blk)))
-> (WithArrivalTime (ValidatedPerasVote blk)
    -> STM m (m (AddPerasVoteResult blk)))
-> WithArrivalTime (ValidatedPerasVote blk)
-> m (m (AddPerasVoteResult blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasVoteDB m blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> STM m (m (AddPerasVoteResult blk))
forall (m :: * -> *) blk.
PerasVoteDB m blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> STM m (m (AddPerasVoteResult blk))
PerasVoteDB.addVote PerasVoteDB m blk
perasVoteDB)
          [PerasVote blk]
votes
    , opwHasObject :: STM m (PerasVoteId blk -> Bool)
opwHasObject = do
        voteIds <- PerasVoteDB m blk -> STM m (Set (PerasVoteId blk))
forall (m :: * -> *) blk.
PerasVoteDB m blk -> STM m (Set (PerasVoteId blk))
PerasVoteDB.getVoteIds PerasVoteDB m blk
perasVoteDB
        pure $ \PerasVoteId blk
voteId -> PerasVoteId blk -> Set (PerasVoteId blk) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PerasVoteId blk
voteId Set (PerasVoteId blk)
voteIds
    }

-- | Create a pool writer from the 'ChainDB'.
-- This properly handles the produced certs by letting the ChainDB take care
-- of them (see 'ChainDB.addPerasVoteWithAsyncCertHandling').
makePerasVotePoolWriterFromChainDB ::
  (StandardHash blk, 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
  -- from the stake distr directly, but rather use the committee selection data)
  STM m PerasVoteStakeDistr ->
  ChainDB m blk ->
  ObjectPoolWriter (PerasVoteId blk) (PerasVote blk) m
makePerasVotePoolWriterFromChainDB :: forall blk (m :: * -> *).
(StandardHash blk, IOLike m) =>
SystemTime m
-> STM m PerasVoteStakeDistr
-> ChainDB m blk
-> ObjectPoolWriter (PerasVoteId blk) (PerasVote blk) m
makePerasVotePoolWriterFromChainDB SystemTime m
systemTime STM m PerasVoteStakeDistr
getStakeDistrSTM ChainDB m blk
chainDB =
  ObjectPoolWriter
    { opwObjectId :: PerasVote blk -> PerasVoteId blk
opwObjectId = PerasVote blk -> PerasVoteId blk
forall vote blk. HasPerasVoteId vote blk => vote -> PerasVoteId blk
getPerasVoteId
    , opwAddObjects :: [PerasVote blk] -> m ()
opwAddObjects = \[PerasVote blk]
votes ->
        SystemTime m
-> STM m (Set (PerasVoteId blk))
-> (PerasVote blk
    -> STM
         m (Either (PerasValidationErr blk) (ValidatedPerasVote blk)))
-> (WithArrivalTime (ValidatedPerasVote blk) -> m ())
-> [PerasVote blk]
-> m ()
forall (m :: * -> *) blk.
MonadSTM m =>
SystemTime m
-> STM m (Set (PerasVoteId blk))
-> (PerasVote blk
    -> STM
         m (Either (PerasValidationErr blk) (ValidatedPerasVote blk)))
-> (WithArrivalTime (ValidatedPerasVote blk) -> m ())
-> [PerasVote blk]
-> m ()
processVotes
          SystemTime m
systemTime
          (ChainDB m blk -> STM m (Set (PerasVoteId blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (Set (PerasVoteId blk))
ChainDB.getPerasVoteIds ChainDB m blk
chainDB)
          -- TODO: in the future we won't need just the stake distribution for
          -- validating votes, but also the whole committee selection context
          -- (containing vote weights of committee members = voters)
          (\PerasVote blk
vote -> STM m PerasVoteStakeDistr
getStakeDistrSTM STM m PerasVoteStakeDistr
-> (PerasVoteStakeDistr
    -> STM
         m (Either (PerasValidationErr blk) (ValidatedPerasVote blk)))
-> STM m (Either (PerasValidationErr blk) (ValidatedPerasVote blk))
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PerasVoteStakeDistr
sd -> Either (PerasValidationErr blk) (ValidatedPerasVote blk)
-> STM m (Either (PerasValidationErr blk) (ValidatedPerasVote blk))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (PerasValidationErr blk) (ValidatedPerasVote blk)
 -> STM
      m (Either (PerasValidationErr blk) (ValidatedPerasVote blk)))
-> Either (PerasValidationErr blk) (ValidatedPerasVote blk)
-> STM m (Either (PerasValidationErr blk) (ValidatedPerasVote blk))
forall a b. (a -> b) -> a -> b
$ PerasCfg blk
-> PerasVoteStakeDistr
-> PerasVote blk
-> Either (PerasValidationErr blk) (ValidatedPerasVote blk)
forall blk.
BlockSupportsPeras blk =>
PerasCfg blk
-> PerasVoteStakeDistr
-> PerasVote blk
-> Either (PerasValidationErr blk) (ValidatedPerasVote blk)
validatePerasVote PerasParams
PerasCfg blk
mkPerasParams PerasVoteStakeDistr
sd PerasVote blk
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.
          (m (Maybe (AddPerasCertPromise m)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (AddPerasCertPromise m)) -> m ())
-> (WithArrivalTime (ValidatedPerasVote blk)
    -> m (Maybe (AddPerasCertPromise m)))
-> WithArrivalTime (ValidatedPerasVote blk)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDB m blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> m (Maybe (AddPerasCertPromise m))
forall (m :: * -> *) blk.
ChainDB m blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> m (Maybe (AddPerasCertPromise m))
ChainDB.addPerasVoteWithAsyncCertHandling ChainDB m blk
chainDB)
          [PerasVote blk]
votes
    , opwHasObject :: STM m (PerasVoteId blk -> Bool)
opwHasObject = do
        voteIds <- ChainDB m blk -> STM m (Set (PerasVoteId blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (Set (PerasVoteId blk))
ChainDB.getPerasVoteIds ChainDB m blk
chainDB
        pure $ \PerasVoteId blk
voteId -> PerasVoteId blk -> Set (PerasVoteId blk) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PerasVoteId blk
voteId Set (PerasVoteId blk)
voteIds
    }

data PerasVoteInboundException
  = forall blk. PerasVoteValidationError [PerasValidationErr 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 =>
  SystemTime m ->
  STM m (Set (PerasVoteId blk)) ->
  (PerasVote blk -> STM m (Either (PerasValidationErr blk) (ValidatedPerasVote blk))) ->
  (WithArrivalTime (ValidatedPerasVote blk) -> m ()) ->
  [PerasVote blk] ->
  m ()
processVotes :: forall (m :: * -> *) blk.
MonadSTM m =>
SystemTime m
-> STM m (Set (PerasVoteId blk))
-> (PerasVote blk
    -> STM
         m (Either (PerasValidationErr blk) (ValidatedPerasVote blk)))
-> (WithArrivalTime (ValidatedPerasVote blk) -> m ())
-> [PerasVote blk]
-> m ()
processVotes SystemTime m
systemTime STM m (Set (PerasVoteId blk))
alreadyInDbSTM PerasVote blk
-> STM m (Either (PerasValidationErr blk) (ValidatedPerasVote blk))
validateVote WithArrivalTime (ValidatedPerasVote blk) -> m ()
addVote [PerasVote blk]
votes = do
  validationResults <- STM m [Either (PerasValidationErr blk) (ValidatedPerasVote blk)]
-> m [Either (PerasValidationErr blk) (ValidatedPerasVote blk)]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [Either (PerasValidationErr blk) (ValidatedPerasVote blk)]
 -> m [Either (PerasValidationErr blk) (ValidatedPerasVote blk)])
-> STM m [Either (PerasValidationErr blk) (ValidatedPerasVote blk)]
-> m [Either (PerasValidationErr blk) (ValidatedPerasVote blk)]
forall a b. (a -> b) -> a -> b
$ do
    alreadyInDb <- STM m (Set (PerasVoteId blk))
alreadyInDbSTM
    let votesNotAlreadyInDb = (PerasVote blk -> Bool) -> [PerasVote blk] -> [PerasVote blk]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (PerasVote blk -> Bool) -> PerasVote blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PerasVoteId blk -> Set (PerasVoteId blk) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (PerasVoteId blk)
alreadyInDb) (PerasVoteId blk -> Bool)
-> (PerasVote blk -> PerasVoteId blk) -> PerasVote blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasVote blk -> PerasVoteId blk
forall vote blk. HasPerasVoteId vote blk => vote -> PerasVoteId blk
getPerasVoteId) [PerasVote blk]
votes
    mapM validateVote votesNotAlreadyInDb
  now <- systemTimeCurrent systemTime
  case partitionEithers validationResults of
    -- All votes are valid => add them to the pool
    ([], [ValidatedPerasVote blk]
validatedVotes) ->
      (ValidatedPerasVote blk -> m ())
-> [ValidatedPerasVote blk] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
        (WithArrivalTime (ValidatedPerasVote blk) -> m ()
addVote (WithArrivalTime (ValidatedPerasVote blk) -> m ())
-> (ValidatedPerasVote blk
    -> WithArrivalTime (ValidatedPerasVote blk))
-> ValidatedPerasVote blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativeTime
-> ValidatedPerasVote blk
-> WithArrivalTime (ValidatedPerasVote blk)
forall a. RelativeTime -> a -> WithArrivalTime a
WithArrivalTime RelativeTime
now)
        [ValidatedPerasVote blk]
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.
    ([PerasValidationErr blk]
errs, [ValidatedPerasVote blk]
_) ->
      PerasVoteInboundException -> m ()
forall a e. (HasCallStack, Exception e) => e -> a
throw ([PerasValidationErr blk] -> PerasVoteInboundException
forall blk. [PerasValidationErr blk] -> PerasVoteInboundException
PerasVoteValidationError [PerasValidationErr blk]
errs)