{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

-- | What one LeiosNotify client remembers about its upstream peer, and how it
-- judges that peer's replies against it.
module Ouroboros.Consensus.MiniProtocol.LeiosNotify.Client.State
  ( ExnLeiosNotifyInvalidAnnouncement (..)
  , ExnLeiosNotifyInvalidVotes (..)
  , InvalidVoteReason (..)
  , AcceptedVote (..)
  , checkLeiosVotes
  , VoteWindow (..)
  , leiosVoteWindow
  , voteLateGrace
  , ExnLeiosNotifyInvalidOffer (..)
  , checkLeiosBlockOffer
  , checkLeiosClosureOffer
  , LeiosNotifyPeerState (..)
  , emptyLeiosNotifyPeerState
  , onLeiosNotifyAnnouncement
  , pruneLeiosNotifyPeerState
  ) where

import Cardano.Crypto.Leios (LeiosCommittee, LeiosSeatId)
import Control.Monad (foldM, when)
import Control.Monad.Except (Except, ExceptT, liftEither, throwError, withExcept, withExceptT)
import Control.Monad.Trans (lift)
import Data.Bifunctor (first)
import qualified Data.Foldable as Foldable
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Time.Clock (NominalDiffTime)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block
  ( BlockProtocol
  , ConvertRawHash (..)
  , GetHeader (..)
  , Header
  , Proxy (..)
  , SlotNo (..)
  , WithOrigin (NotOrigin)
  , blockSlot
  )
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
  ( RelativeTime
  , SystemTime (..)
  , addRelTime
  , diffRelTime
  )
import Ouroboros.Consensus.Config (TopLevelConfig, configLedger)
import Ouroboros.Consensus.Forecast (OutsideForecastRange, forecastFor)
import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..))
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError)
import Ouroboros.Consensus.Ledger.Abstract (EmptyMK, getTipSlot)
import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, ledgerState)
import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol, ledgerViewForecastAt)
import Ouroboros.Consensus.Leios.AnnounceState (AnnounceState, onValidAnnouncement)
import Ouroboros.Consensus.Leios.Protocol
  ( LeiosAnnouncement (..)
  , LeiosLedgerView (..)
  , LeiosProtocol (..)
  )
import Ouroboros.Consensus.Leios.Types
  ( BytesSize
  , LeiosPoint (..)
  , LeiosVote (..)
  , RankingBlockHash
  , milliseconds32ToNominalDiffTime
  )
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck
import qualified Ouroboros.Consensus.MiniProtocol.LeiosNotify.Client.Announcements as Announcements
import Ouroboros.Consensus.MiniProtocol.LeiosNotify.Client.Announcements.Validation
  ( AnnouncementInvalidity
  , AnnouncingHeader (ancAnnouncement, ancElectionId)
  , announcementValidity
  , announcingRbHash
  , maxAnnouncementAgeSend
  , mkAnnouncingHeader
  )
import Ouroboros.Consensus.Protocol.Abstract (ValidationErr)
import Ouroboros.Consensus.Util.IOLike (Exception, IOLike, atomically)

-- | What one LeiosNotify client remembers about its upstream peer.
--
-- Only an announcement adds to it, and every entry is for an election at or
-- after 'lnpsPruneSlot'; the node prunes it as its immutable tip advances.
data LeiosNotifyPeerState blk = MkLeiosNotifyPeerState
  { forall blk. LeiosNotifyPeerState blk -> SlotNo
lnpsPruneSlot :: !SlotNo
  -- ^ The slot the state has been pruned up to.
  , forall blk.
LeiosNotifyPeerState blk -> State (AnnouncingHeader blk)
lnpsAnnouncements :: !(Announcements.State (AnnouncingHeader blk))
  -- ^ What this peer has announced, for dedup and equivocation counting.
  , forall blk. LeiosNotifyPeerState blk -> Set LeiosPoint
lnpsBodyOffers :: !(Set LeiosPoint)
  -- ^ Which endorser blocks this peer has offered the body of, so that
  -- repeating an offer costs it the connection.
  , forall blk. LeiosNotifyPeerState blk -> Set LeiosPoint
lnpsClosureOffers :: !(Set LeiosPoint)
  -- ^ Likewise, which it has offered the transaction closure of.
  , forall blk. LeiosNotifyPeerState blk -> Map RankingBlockHash SlotNo
lnpsAnnouncedRbHashes :: !(Map RankingBlockHash SlotNo)
  -- ^ The announcing blocks this peer has sent, with their election slots, so
  -- that its votes can be held to them.
  , forall blk. LeiosNotifyPeerState blk -> Set (SlotNo, LeiosSeatId)
lnpsVotes :: !(Set (SlotNo, LeiosSeatId))
  -- ^ The slots and seats this peer has sent votes for.
  }
  deriving stock (forall x.
 LeiosNotifyPeerState blk -> Rep (LeiosNotifyPeerState blk) x)
-> (forall x.
    Rep (LeiosNotifyPeerState blk) x -> LeiosNotifyPeerState blk)
-> Generic (LeiosNotifyPeerState blk)
forall x.
Rep (LeiosNotifyPeerState blk) x -> LeiosNotifyPeerState blk
forall x.
LeiosNotifyPeerState blk -> Rep (LeiosNotifyPeerState blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (LeiosNotifyPeerState blk) x -> LeiosNotifyPeerState blk
forall blk x.
LeiosNotifyPeerState blk -> Rep (LeiosNotifyPeerState blk) x
$cfrom :: forall blk x.
LeiosNotifyPeerState blk -> Rep (LeiosNotifyPeerState blk) x
from :: forall x.
LeiosNotifyPeerState blk -> Rep (LeiosNotifyPeerState blk) x
$cto :: forall blk x.
Rep (LeiosNotifyPeerState blk) x -> LeiosNotifyPeerState blk
to :: forall x.
Rep (LeiosNotifyPeerState blk) x -> LeiosNotifyPeerState blk
Generic

deriving anyclass instance NoThunks (Header blk) => NoThunks (LeiosNotifyPeerState blk)

emptyLeiosNotifyPeerState :: LeiosNotifyPeerState blk
emptyLeiosNotifyPeerState :: forall blk. LeiosNotifyPeerState blk
emptyLeiosNotifyPeerState =
  MkLeiosNotifyPeerState
    { lnpsPruneSlot :: SlotNo
lnpsPruneSlot = Word64 -> SlotNo
SlotNo Word64
0
    , lnpsAnnouncements :: State (AnnouncingHeader blk)
lnpsAnnouncements = State (AnnouncingHeader blk)
forall anc. State anc
Announcements.empty
    , lnpsBodyOffers :: Set LeiosPoint
lnpsBodyOffers = Set LeiosPoint
forall a. Set a
Set.empty
    , lnpsClosureOffers :: Set LeiosPoint
lnpsClosureOffers = Set LeiosPoint
forall a. Set a
Set.empty
    , lnpsAnnouncedRbHashes :: Map RankingBlockHash SlotNo
lnpsAnnouncedRbHashes = Map RankingBlockHash SlotNo
forall k a. Map k a
Map.empty
    , lnpsVotes :: Set (SlotNo, LeiosSeatId)
lnpsVotes = Set (SlotNo, LeiosSeatId)
forall a. Set a
Set.empty
    }

-- | Forget everything about elections before the given slot, which is the
-- immutable tip's.
pruneLeiosNotifyPeerState ::
  forall blk.
  (ConvertRawHash blk, GetHeader blk) =>
  SlotNo ->
  LeiosNotifyPeerState blk ->
  LeiosNotifyPeerState blk
pruneLeiosNotifyPeerState :: forall blk.
(ConvertRawHash blk, GetHeader blk) =>
SlotNo -> LeiosNotifyPeerState blk -> LeiosNotifyPeerState blk
pruneLeiosNotifyPeerState SlotNo
immTipSlot LeiosNotifyPeerState blk
st
  | LeiosNotifyPeerState blk -> SlotNo
forall blk. LeiosNotifyPeerState blk -> SlotNo
lnpsPruneSlot LeiosNotifyPeerState blk
st SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
immTipSlot =
      MkLeiosNotifyPeerState
        { lnpsPruneSlot :: SlotNo
lnpsPruneSlot = SlotNo
immTipSlot
        , lnpsAnnouncements :: State (AnnouncingHeader blk)
lnpsAnnouncements = State (AnnouncingHeader blk)
announcements
        , lnpsBodyOffers :: Set LeiosPoint
lnpsBodyOffers =
            -- 'LeiosPoint' orders slot-first, so the pruned points are a prefix.
            (LeiosPoint -> Bool) -> Set LeiosPoint -> Set LeiosPoint
forall a. (a -> Bool) -> Set a -> Set a
Set.dropWhileAntitone (\LeiosPoint
p -> LeiosPoint -> SlotNo
pointSlotNo LeiosPoint
p SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
immTipSlot) (LeiosNotifyPeerState blk -> Set LeiosPoint
forall blk. LeiosNotifyPeerState blk -> Set LeiosPoint
lnpsBodyOffers LeiosNotifyPeerState blk
st)
        , lnpsClosureOffers :: Set LeiosPoint
lnpsClosureOffers =
            (LeiosPoint -> Bool) -> Set LeiosPoint -> Set LeiosPoint
forall a. (a -> Bool) -> Set a -> Set a
Set.dropWhileAntitone (\LeiosPoint
p -> LeiosPoint -> SlotNo
pointSlotNo LeiosPoint
p SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
immTipSlot) (LeiosNotifyPeerState blk -> Set LeiosPoint
forall blk. LeiosNotifyPeerState blk -> Set LeiosPoint
lnpsClosureOffers LeiosNotifyPeerState blk
st)
        , lnpsAnnouncedRbHashes :: Map RankingBlockHash SlotNo
lnpsAnnouncedRbHashes =
            (Map RankingBlockHash SlotNo
 -> AnnouncingHeader blk -> Map RankingBlockHash SlotNo)
-> Map RankingBlockHash SlotNo
-> [AnnouncingHeader blk]
-> Map RankingBlockHash SlotNo
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl'
              (\Map RankingBlockHash SlotNo
m AnnouncingHeader blk
anc -> RankingBlockHash
-> Map RankingBlockHash SlotNo -> Map RankingBlockHash SlotNo
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (AnnouncingHeader blk -> RankingBlockHash
forall blk.
(ConvertRawHash blk, GetHeader blk) =>
AnnouncingHeader blk -> RankingBlockHash
announcingRbHash AnnouncingHeader blk
anc) Map RankingBlockHash SlotNo
m)
              (LeiosNotifyPeerState blk -> Map RankingBlockHash SlotNo
forall blk. LeiosNotifyPeerState blk -> Map RankingBlockHash SlotNo
lnpsAnnouncedRbHashes LeiosNotifyPeerState blk
st)
              [AnnouncingHeader blk]
prunedAnnouncements
        , lnpsVotes :: Set (SlotNo, LeiosSeatId)
lnpsVotes = ((SlotNo, LeiosSeatId) -> Bool)
-> Set (SlotNo, LeiosSeatId) -> Set (SlotNo, LeiosSeatId)
forall a. (a -> Bool) -> Set a -> Set a
Set.dropWhileAntitone (\(SlotNo
slot, LeiosSeatId
_seat) -> SlotNo
slot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
immTipSlot) (LeiosNotifyPeerState blk -> Set (SlotNo, LeiosSeatId)
forall blk. LeiosNotifyPeerState blk -> Set (SlotNo, LeiosSeatId)
lnpsVotes LeiosNotifyPeerState blk
st)
        }
  | Bool
otherwise = LeiosNotifyPeerState blk
st
 where
  ([AnnouncingHeader blk]
prunedAnnouncements, State (AnnouncingHeader blk)
announcements) =
    SlotNo
-> State (AnnouncingHeader blk)
-> ([AnnouncingHeader blk], State (AnnouncingHeader blk))
forall anc. SlotNo -> State anc -> ([anc], State anc)
Announcements.prune SlotNo
immTipSlot (LeiosNotifyPeerState blk -> State (AnnouncingHeader blk)
forall blk.
LeiosNotifyPeerState blk -> State (AnnouncingHeader blk)
lnpsAnnouncements LeiosNotifyPeerState blk
st)

-- | Thrown when a peer's offer over LeiosNotify is one an honest peer would not
-- send; the ensuing thread death disconnects it.
--
-- Without these checks, peers could send bogus offers, and there are infinitely
-- many of those.
data ExnLeiosNotifyInvalidOffer
  = -- | A body offer of an endorser block this peer never announced.
    ExnLeiosBlockOfferWithoutAnnouncement
      !LeiosPoint
      -- | the size it claimed
      !BytesSize
  | -- | A body offer claiming no bytes, or more bytes than the ledger lets an
    -- endorser block in that slot have.
    ExnLeiosBlockOfferBadSize
      !LeiosPoint
      -- | the size it claimed
      !BytesSize
      -- | the most the ledger allows
      !BytesSize
  | -- | A second body offer of an endorser block.
    ExnLeiosRepeatedBlockOffer !LeiosPoint
  | -- | A closure offer of an endorser block this peer never announced.
    ExnLeiosClosureOfferWithoutAnnouncement !LeiosPoint
  | -- | A second closure offer of an endorser block.
    ExnLeiosRepeatedClosureOffer !LeiosPoint
  | -- | An offer below the slot this peer's state has been pruned to, which is
    -- therefore unanswerable on its own terms.
    --
    -- TODO When the honest server offers endorser blocks, explain why it never
    -- trips this, eg because it offers one only while it is at least a minimum
    -- lead younger than its own immutable tip.
    ExnLeiosOfferTooOld
      !LeiosPoint
      -- | the slot this peer's state has been pruned to
      !SlotNo
  | -- | A body offer whose slot the immutable tip cannot forecast to. Its
    -- announcement was validated by such a forecast, from an older immutable
    -- tip, so this should never happen.
    ExnLeiosBlockOfferOutsideHorizon !LeiosPoint !OutsideForecastRange
  deriving Int -> ExnLeiosNotifyInvalidOffer -> ShowS
[ExnLeiosNotifyInvalidOffer] -> ShowS
ExnLeiosNotifyInvalidOffer -> String
(Int -> ExnLeiosNotifyInvalidOffer -> ShowS)
-> (ExnLeiosNotifyInvalidOffer -> String)
-> ([ExnLeiosNotifyInvalidOffer] -> ShowS)
-> Show ExnLeiosNotifyInvalidOffer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExnLeiosNotifyInvalidOffer -> ShowS
showsPrec :: Int -> ExnLeiosNotifyInvalidOffer -> ShowS
$cshow :: ExnLeiosNotifyInvalidOffer -> String
show :: ExnLeiosNotifyInvalidOffer -> String
$cshowList :: [ExnLeiosNotifyInvalidOffer] -> ShowS
showList :: [ExnLeiosNotifyInvalidOffer] -> ShowS
Show

instance Exception ExnLeiosNotifyInvalidOffer

-- | Accept a peer's 'MsgLeiosBlockOffer', or say why the peer must go.
--
-- A peer may offer only an endorser block it has itself announced. That is
-- what stops an offer from being an independent way to make us track an
-- endorser block, outside the two-per-election cap on announcements.
--
-- Only the point is held to the announcements; the size is free, within the
-- ledger's bound. An offer claims to hold a body, and whoever holds a body
-- knows its size, so a peer may well state a size that no announcement we
-- received claimed.
checkLeiosBlockOffer ::
  forall blk.
  LedgerSupportsProtocol blk =>
  TopLevelConfig blk ->
  -- | the immutable tip's ledger state
  ExtLedgerState blk EmptyMK ->
  LeiosPoint ->
  BytesSize ->
  LeiosNotifyPeerState blk ->
  Except ExnLeiosNotifyInvalidOffer (LeiosNotifyPeerState blk)
checkLeiosBlockOffer :: forall blk.
LedgerSupportsProtocol blk =>
TopLevelConfig blk
-> ExtLedgerState blk EmptyMK
-> LeiosPoint
-> Word32
-> LeiosNotifyPeerState blk
-> Except ExnLeiosNotifyInvalidOffer (LeiosNotifyPeerState blk)
checkLeiosBlockOffer TopLevelConfig blk
cfg ExtLedgerState blk EmptyMK
immLedger LeiosPoint
point Word32
claimed LeiosNotifyPeerState blk
st
  | LeiosPoint -> SlotNo
pointSlotNo LeiosPoint
point SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< LeiosNotifyPeerState blk -> SlotNo
forall blk. LeiosNotifyPeerState blk -> SlotNo
lnpsPruneSlot LeiosNotifyPeerState blk
st =
      ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a.
ExnLeiosNotifyInvalidOffer
-> ExceptT ExnLeiosNotifyInvalidOffer Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ExnLeiosNotifyInvalidOffer
 -> ExceptT
      ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk))
-> ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a b. (a -> b) -> a -> b
$ LeiosPoint -> SlotNo -> ExnLeiosNotifyInvalidOffer
ExnLeiosOfferTooOld LeiosPoint
point (LeiosNotifyPeerState blk -> SlotNo
forall blk. LeiosNotifyPeerState blk -> SlotNo
lnpsPruneSlot LeiosNotifyPeerState blk
st)
  | LeiosPoint -> Set LeiosPoint -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member LeiosPoint
point (LeiosNotifyPeerState blk -> Set LeiosPoint
forall blk. LeiosNotifyPeerState blk -> Set LeiosPoint
lnpsBodyOffers LeiosNotifyPeerState blk
st) =
      ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a.
ExnLeiosNotifyInvalidOffer
-> ExceptT ExnLeiosNotifyInvalidOffer Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ExnLeiosNotifyInvalidOffer
 -> ExceptT
      ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk))
-> ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a b. (a -> b) -> a -> b
$ LeiosPoint -> ExnLeiosNotifyInvalidOffer
ExnLeiosRepeatedBlockOffer LeiosPoint
point
  | Bool -> Bool
not (LeiosPoint -> LeiosNotifyPeerState blk -> Bool
forall blk. LeiosPoint -> LeiosNotifyPeerState blk -> Bool
announcedIt LeiosPoint
point LeiosNotifyPeerState blk
st) =
      ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a.
ExnLeiosNotifyInvalidOffer
-> ExceptT ExnLeiosNotifyInvalidOffer Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ExnLeiosNotifyInvalidOffer
 -> ExceptT
      ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk))
-> ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a b. (a -> b) -> a -> b
$ LeiosPoint -> Word32 -> ExnLeiosNotifyInvalidOffer
ExnLeiosBlockOfferWithoutAnnouncement LeiosPoint
point Word32
claimed
  | Bool
otherwise = do
      view <-
        (OutsideForecastRange -> ExnLeiosNotifyInvalidOffer)
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Except
     ExnLeiosNotifyInvalidOffer (LedgerView (BlockProtocol blk))
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept (LeiosPoint -> OutsideForecastRange -> ExnLeiosNotifyInvalidOffer
ExnLeiosBlockOfferOutsideHorizon LeiosPoint
point) (Except OutsideForecastRange (LedgerView (BlockProtocol blk))
 -> Except
      ExnLeiosNotifyInvalidOffer (LedgerView (BlockProtocol blk)))
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Except
     ExnLeiosNotifyInvalidOffer (LedgerView (BlockProtocol blk))
forall a b. (a -> b) -> a -> b
$
          Forecast (LedgerView (BlockProtocol blk))
-> SlotNo
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
forecastFor
            (LedgerConfig blk
-> LedgerState blk EmptyMK
-> Forecast (LedgerView (BlockProtocol blk))
forall blk (mk :: MapKind).
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
forall (mk :: MapKind).
HasCallStack =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg) (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState ExtLedgerState blk EmptyMK
immLedger))
            (LeiosPoint -> SlotNo
pointSlotNo LeiosPoint
point)
      let bound = Word32
-> (LeiosLedgerView -> Word32) -> Maybe LeiosLedgerView -> Word32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 LeiosLedgerView -> Word32
llvMaxEbBodySize (Maybe LeiosLedgerView -> Word32)
-> Maybe LeiosLedgerView -> Word32
forall a b. (a -> b) -> a -> b
$ Proxy (BlockProtocol blk)
-> LedgerView (BlockProtocol blk) -> Maybe LeiosLedgerView
forall p (proxy :: * -> *).
LeiosProtocol p =>
proxy p -> LedgerView p -> Maybe LeiosLedgerView
forall (proxy :: * -> *).
proxy (BlockProtocol blk)
-> LedgerView (BlockProtocol blk) -> Maybe LeiosLedgerView
getLeiosLedgerView (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(BlockProtocol blk)) LedgerView (BlockProtocol blk)
view
      if claimed == 0 || claimed > bound
        then throwError $ ExnLeiosBlockOfferBadSize point claimed bound
        else pure st{lnpsBodyOffers = Set.insert point (lnpsBodyOffers st)}

-- | Accept a peer's 'MsgLeiosBlockTxsOffer', or say why the peer must go.
--
-- Held to the same announcement as the body offer and otherwise independent of
-- it: either may arrive first, or alone. So a LeiosNotify server never has to
-- track what it has already offered a peer in order to synthesise a body offer
-- ahead of a closure offer.
checkLeiosClosureOffer ::
  LeiosPoint ->
  LeiosNotifyPeerState blk ->
  Except ExnLeiosNotifyInvalidOffer (LeiosNotifyPeerState blk)
checkLeiosClosureOffer :: forall blk.
LeiosPoint
-> LeiosNotifyPeerState blk
-> Except ExnLeiosNotifyInvalidOffer (LeiosNotifyPeerState blk)
checkLeiosClosureOffer LeiosPoint
point LeiosNotifyPeerState blk
st
  | LeiosPoint -> SlotNo
pointSlotNo LeiosPoint
point SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< LeiosNotifyPeerState blk -> SlotNo
forall blk. LeiosNotifyPeerState blk -> SlotNo
lnpsPruneSlot LeiosNotifyPeerState blk
st =
      ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a.
ExnLeiosNotifyInvalidOffer
-> ExceptT ExnLeiosNotifyInvalidOffer Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ExnLeiosNotifyInvalidOffer
 -> ExceptT
      ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk))
-> ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a b. (a -> b) -> a -> b
$ LeiosPoint -> SlotNo -> ExnLeiosNotifyInvalidOffer
ExnLeiosOfferTooOld LeiosPoint
point (LeiosNotifyPeerState blk -> SlotNo
forall blk. LeiosNotifyPeerState blk -> SlotNo
lnpsPruneSlot LeiosNotifyPeerState blk
st)
  | LeiosPoint -> Set LeiosPoint -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member LeiosPoint
point (LeiosNotifyPeerState blk -> Set LeiosPoint
forall blk. LeiosNotifyPeerState blk -> Set LeiosPoint
lnpsClosureOffers LeiosNotifyPeerState blk
st) =
      ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a.
ExnLeiosNotifyInvalidOffer
-> ExceptT ExnLeiosNotifyInvalidOffer Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ExnLeiosNotifyInvalidOffer
 -> ExceptT
      ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk))
-> ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a b. (a -> b) -> a -> b
$ LeiosPoint -> ExnLeiosNotifyInvalidOffer
ExnLeiosRepeatedClosureOffer LeiosPoint
point
  | Bool -> Bool
not (LeiosPoint -> LeiosNotifyPeerState blk -> Bool
forall blk. LeiosPoint -> LeiosNotifyPeerState blk -> Bool
announcedIt LeiosPoint
point LeiosNotifyPeerState blk
st) =
      ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a.
ExnLeiosNotifyInvalidOffer
-> ExceptT ExnLeiosNotifyInvalidOffer Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ExnLeiosNotifyInvalidOffer
 -> ExceptT
      ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk))
-> ExnLeiosNotifyInvalidOffer
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a b. (a -> b) -> a -> b
$ LeiosPoint -> ExnLeiosNotifyInvalidOffer
ExnLeiosClosureOfferWithoutAnnouncement LeiosPoint
point
  | Bool
otherwise =
      LeiosNotifyPeerState blk
-> ExceptT
     ExnLeiosNotifyInvalidOffer Identity (LeiosNotifyPeerState blk)
forall a. a -> ExceptT ExnLeiosNotifyInvalidOffer Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LeiosNotifyPeerState blk
st{lnpsClosureOffers = Set.insert point (lnpsClosureOffers st)}

-- | Whether this peer has announced this endorser block.
announcedIt :: LeiosPoint -> LeiosNotifyPeerState blk -> Bool
announcedIt :: forall blk. LeiosPoint -> LeiosNotifyPeerState blk -> Bool
announcedIt LeiosPoint
point LeiosNotifyPeerState blk
st =
  (AnnouncingHeader blk -> Bool) -> [AnnouncingHeader blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
    (\AnnouncingHeader blk
ancHdr -> LeiosAnnouncement -> Hash HASH EraIndependentEbReferences
announcementEbHash (AnnouncingHeader blk -> LeiosAnnouncement
forall blk. AnnouncingHeader blk -> LeiosAnnouncement
ancAnnouncement AnnouncingHeader blk
ancHdr) Hash HASH EraIndependentEbReferences
-> Hash HASH EraIndependentEbReferences -> Bool
forall a. Eq a => a -> a -> Bool
== LeiosPoint -> Hash HASH EraIndependentEbReferences
pointEbHash LeiosPoint
point)
    (SlotNo -> State (AnnouncingHeader blk) -> [AnnouncingHeader blk]
forall anc. SlotNo -> State anc -> [anc]
Announcements.inSlot (LeiosPoint -> SlotNo
pointSlotNo LeiosPoint
point) (LeiosNotifyPeerState blk -> State (AnnouncingHeader blk)
forall blk.
LeiosNotifyPeerState blk -> State (AnnouncingHeader blk)
lnpsAnnouncements LeiosNotifyPeerState blk
st))

-- | Thrown when a peer's 'MsgLeiosBlockAnnouncement' is one an honest peer
-- would not send; the ensuing thread death disconnects it.
data ExnLeiosNotifyInvalidAnnouncement blk
  = -- | The header carries no announcement, so it should not have been relayed
    -- as one.
    ExnLeiosNotifyAnnouncementMissing
  | ExnLeiosNotifyInvalidAnnouncement !(Announcements.Error (AnnouncementInvalidity blk))

deriving stock instance
  (Show (ValidationErr (BlockProtocol blk)), Show (OtherHeaderEnvelopeError blk)) =>
  Show (ExnLeiosNotifyInvalidAnnouncement blk)

instance
  ( Typeable blk
  , Show (ValidationErr (BlockProtocol blk))
  , Show (OtherHeaderEnvelopeError blk)
  ) =>
  Exception (ExnLeiosNotifyInvalidAnnouncement blk)

-- | Accept a peer's 'MsgLeiosBlockAnnouncement', or say why the peer must go.
--
-- An accepted announcement goes on to the node's 'AnnounceState'.
onLeiosNotifyAnnouncement ::
  forall m blk.
  ( IOLike m
  , LedgerSupportsProtocol blk
  , ConvertRawHash blk
  ) =>
  SystemTime m ->
  InFutureCheck.SomeHeaderInFutureCheck m blk ->
  TopLevelConfig blk ->
  AnnounceState m blk ->
  -- | the immutable tip's ledger state
  ExtLedgerState blk EmptyMK ->
  LeiosNotifyPeerState blk ->
  Header blk ->
  ExceptT (ExnLeiosNotifyInvalidAnnouncement blk) m (LeiosNotifyPeerState blk)
onLeiosNotifyAnnouncement :: forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, ConvertRawHash blk) =>
SystemTime m
-> SomeHeaderInFutureCheck m blk
-> TopLevelConfig blk
-> AnnounceState m blk
-> ExtLedgerState blk EmptyMK
-> LeiosNotifyPeerState blk
-> Header blk
-> ExceptT
     (ExnLeiosNotifyInvalidAnnouncement blk)
     m
     (LeiosNotifyPeerState blk)
onLeiosNotifyAnnouncement SystemTime m
systemTime SomeHeaderInFutureCheck m blk
futureCheck TopLevelConfig blk
cfg AnnounceState m blk
announceState ExtLedgerState blk EmptyMK
immLedger LeiosNotifyPeerState blk
st Header blk
hdr = do
  anc <- ExceptT
  (ExnLeiosNotifyInvalidAnnouncement blk) m (AnnouncingHeader blk)
-> (AnnouncingHeader blk
    -> ExceptT
         (ExnLeiosNotifyInvalidAnnouncement blk) m (AnnouncingHeader blk))
-> Maybe (AnnouncingHeader blk)
-> ExceptT
     (ExnLeiosNotifyInvalidAnnouncement blk) m (AnnouncingHeader blk)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ExnLeiosNotifyInvalidAnnouncement blk
-> ExceptT
     (ExnLeiosNotifyInvalidAnnouncement blk) m (AnnouncingHeader blk)
forall a.
ExnLeiosNotifyInvalidAnnouncement blk
-> ExceptT (ExnLeiosNotifyInvalidAnnouncement blk) m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ExnLeiosNotifyInvalidAnnouncement blk
forall blk. ExnLeiosNotifyInvalidAnnouncement blk
ExnLeiosNotifyAnnouncementMissing) AnnouncingHeader blk
-> ExceptT
     (ExnLeiosNotifyInvalidAnnouncement blk) m (AnnouncingHeader blk)
forall a. a -> ExceptT (ExnLeiosNotifyInvalidAnnouncement blk) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (AnnouncingHeader blk)
 -> ExceptT
      (ExnLeiosNotifyInvalidAnnouncement blk) m (AnnouncingHeader blk))
-> Maybe (AnnouncingHeader blk)
-> ExceptT
     (ExnLeiosNotifyInvalidAnnouncement blk) m (AnnouncingHeader blk)
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk -> Header blk -> Maybe (AnnouncingHeader blk)
forall blk.
BlockSupportsProtocol blk =>
TopLevelConfig blk -> Header blk -> Maybe (AnnouncingHeader blk)
mkAnnouncingHeader TopLevelConfig blk
cfg Header blk
hdr
  withExceptT ExnLeiosNotifyInvalidAnnouncement $ do
    announcements <-
      liftEither $ Announcements.insert (ancElectionId anc) anc (lnpsAnnouncements st)
    -- The expensive validation comes after the trivial counting checks. Even a
    -- 'StaleOCIN' announcement counts against the peer.
    valid <- announcementValidity systemTime futureCheck cfg immLedger anc
    lift $ atomically $ onValidAnnouncement announceState valid
    pure
      st
        { lnpsAnnouncements = announcements
        , lnpsAnnouncedRbHashes =
            Map.insert (announcingRbHash anc) (blockSlot hdr) (lnpsAnnouncedRbHashes st)
        }

-- | Thrown when a peer's 'MsgLeiosVotes' holds a vote an honest peer would not
-- send; the ensuing thread death disconnects it.
data ExnLeiosNotifyInvalidVotes
  = -- | A vote for an announcing block this peer never sent us. This also rules
    -- out a vote in an empty slot.
    ExnLeiosVoteWithoutAnnouncement !RankingBlockHash
  | -- | A second vote from one seat in one slot.
    ExnLeiosRepeatedVote
      -- | the election slot
      !SlotNo
      -- | the seat
      !LeiosSeatId
  | -- | A vote too young to have been cast. Votes are cast 3 L_hdr after the
    -- slot began, the time equivocations take to come to light, widened by the
    -- node's maximum clock skew so that an honest peer is never disconnected.
    ExnLeiosVoteTooEarly
      -- | the announcing block
      !RankingBlockHash
      -- | the election slot
      !SlotNo
      -- | how long after the election slot began the vote arrived
      !NominalDiffTime
  | -- | A vote too old to still be relayed. Votes stop being relayed when
    -- their diffusion period ends, 3 L_hdr + L_vote + L_diff after the slot
    -- began, widened by 'voteLateGrace' so that an honest peer is never
    -- disconnected. A vote for a slot behind the immutable tip is among these,
    -- long past its diffusion period.
    ExnLeiosVoteTooLate
      -- | the announcing block
      !RankingBlockHash
      -- | the election slot
      !SlotNo
      -- | how long after the election slot began the vote arrived
      !NominalDiffTime
  | -- | A vote whose election slot the immutable tip cannot forecast to. Its
    -- announcement was validated by such a forecast, from an older immutable
    -- tip, so this should never happen.
    ExnLeiosVoteOutsideHorizon
      -- | the announcing block
      !RankingBlockHash
      -- | the election slot
      !SlotNo
  | -- | An accepted vote turned out to be invalid.
    ExnLeiosInvalidVote
      !AcceptedVote
      !InvalidVoteReason
  deriving Int -> ExnLeiosNotifyInvalidVotes -> ShowS
[ExnLeiosNotifyInvalidVotes] -> ShowS
ExnLeiosNotifyInvalidVotes -> String
(Int -> ExnLeiosNotifyInvalidVotes -> ShowS)
-> (ExnLeiosNotifyInvalidVotes -> String)
-> ([ExnLeiosNotifyInvalidVotes] -> ShowS)
-> Show ExnLeiosNotifyInvalidVotes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExnLeiosNotifyInvalidVotes -> ShowS
showsPrec :: Int -> ExnLeiosNotifyInvalidVotes -> ShowS
$cshow :: ExnLeiosNotifyInvalidVotes -> String
show :: ExnLeiosNotifyInvalidVotes -> String
$cshowList :: [ExnLeiosNotifyInvalidVotes] -> ShowS
showList :: [ExnLeiosNotifyInvalidVotes] -> ShowS
Show

instance Exception ExnLeiosNotifyInvalidVotes

-- | Why a vote is invalid.
data InvalidVoteReason
  = -- | Its seat is not in the election's committee.
    SeatNotResolvable
  | -- | Its seat is in the election's committee, but holds no key.
    SeatHasNoKey
  | -- | Its signature does not verify under its seat's key.
    BadSignature !Text
  deriving stock (InvalidVoteReason -> InvalidVoteReason -> Bool
(InvalidVoteReason -> InvalidVoteReason -> Bool)
-> (InvalidVoteReason -> InvalidVoteReason -> Bool)
-> Eq InvalidVoteReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InvalidVoteReason -> InvalidVoteReason -> Bool
== :: InvalidVoteReason -> InvalidVoteReason -> Bool
$c/= :: InvalidVoteReason -> InvalidVoteReason -> Bool
/= :: InvalidVoteReason -> InvalidVoteReason -> Bool
Eq, Int -> InvalidVoteReason -> ShowS
[InvalidVoteReason] -> ShowS
InvalidVoteReason -> String
(Int -> InvalidVoteReason -> ShowS)
-> (InvalidVoteReason -> String)
-> ([InvalidVoteReason] -> ShowS)
-> Show InvalidVoteReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InvalidVoteReason -> ShowS
showsPrec :: Int -> InvalidVoteReason -> ShowS
$cshow :: InvalidVoteReason -> String
show :: InvalidVoteReason -> String
$cshowList :: [InvalidVoteReason] -> ShowS
showList :: [InvalidVoteReason] -> ShowS
Show)

-- | A vote a client accepted from its peer, with what the node's 'VoteState'
-- needs to judge and relay it.
data AcceptedVote = MkAcceptedVote
  { AcceptedVote -> LeiosVote
acceptedVote :: !LeiosVote
  , AcceptedVote -> SlotNo
voteElectionSlot :: !SlotNo
  , AcceptedVote -> LeiosCommittee
voteCommittee :: !LeiosCommittee
  -- ^ The committee of the election slot's ledger view.
  , AcceptedVote -> VoteWindow
voteWindow :: !VoteWindow
  -- ^ See 'leiosVoteWindow'.
  }
  deriving Int -> AcceptedVote -> ShowS
[AcceptedVote] -> ShowS
AcceptedVote -> String
(Int -> AcceptedVote -> ShowS)
-> (AcceptedVote -> String)
-> ([AcceptedVote] -> ShowS)
-> Show AcceptedVote
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AcceptedVote -> ShowS
showsPrec :: Int -> AcceptedVote -> ShowS
$cshow :: AcceptedVote -> String
show :: AcceptedVote -> String
$cshowList :: [AcceptedVote] -> ShowS
showList :: [AcceptedVote] -> ShowS
Show

-- | When a vote should be cast and relayed.
data VoteWindow = MkVoteWindow
  { VoteWindow -> RelativeTime
voteFrom :: !RelativeTime
  -- ^ Before this, a downstream peer whose clock is behind ours could reject
  -- the vote.
  , VoteWindow -> RelativeTime
voteUntil :: !RelativeTime
  -- ^ The vote's deadline: the earliest block that can certify its
  -- announcement is in the first slot at or after it, and the node uses no
  -- vote it has only after it.
  }
  deriving stock (VoteWindow -> VoteWindow -> Bool
(VoteWindow -> VoteWindow -> Bool)
-> (VoteWindow -> VoteWindow -> Bool) -> Eq VoteWindow
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VoteWindow -> VoteWindow -> Bool
== :: VoteWindow -> VoteWindow -> Bool
$c/= :: VoteWindow -> VoteWindow -> Bool
/= :: VoteWindow -> VoteWindow -> Bool
Eq, Int -> VoteWindow -> ShowS
[VoteWindow] -> ShowS
VoteWindow -> String
(Int -> VoteWindow -> ShowS)
-> (VoteWindow -> String)
-> ([VoteWindow] -> ShowS)
-> Show VoteWindow
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VoteWindow -> ShowS
showsPrec :: Int -> VoteWindow -> ShowS
$cshow :: VoteWindow -> String
show :: VoteWindow -> String
$cshowList :: [VoteWindow] -> ShowS
showList :: [VoteWindow] -> ShowS
Show, (forall x. VoteWindow -> Rep VoteWindow x)
-> (forall x. Rep VoteWindow x -> VoteWindow) -> Generic VoteWindow
forall x. Rep VoteWindow x -> VoteWindow
forall x. VoteWindow -> Rep VoteWindow x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. VoteWindow -> Rep VoteWindow x
from :: forall x. VoteWindow -> Rep VoteWindow x
$cto :: forall x. Rep VoteWindow x -> VoteWindow
to :: forall x. Rep VoteWindow x -> VoteWindow
Generic)
  deriving anyclass Context -> VoteWindow -> IO (Maybe ThunkInfo)
Proxy VoteWindow -> String
(Context -> VoteWindow -> IO (Maybe ThunkInfo))
-> (Context -> VoteWindow -> IO (Maybe ThunkInfo))
-> (Proxy VoteWindow -> String)
-> NoThunks VoteWindow
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> VoteWindow -> IO (Maybe ThunkInfo)
noThunks :: Context -> VoteWindow -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> VoteWindow -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> VoteWindow -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy VoteWindow -> String
showTypeOf :: Proxy VoteWindow -> String
NoThunks

-- | When a vote is worth relaying, given its election's ledger view and when
-- its election slot began: from 3 L_hdr after until 3 L_hdr + L_vote + L_diff
-- after, or until its announcement is no longer relayed, if sooner.
leiosVoteWindow :: LeiosLedgerView -> RelativeTime -> VoteWindow
leiosVoteWindow :: LeiosLedgerView -> RelativeTime -> VoteWindow
leiosVoteWindow MkLeiosLedgerView{Milliseconds32
llvAnnouncementPeriod :: Milliseconds32
llvAnnouncementPeriod :: LeiosLedgerView -> Milliseconds32
llvAnnouncementPeriod, Milliseconds32
llvVotePeriod :: Milliseconds32
llvVotePeriod :: LeiosLedgerView -> Milliseconds32
llvVotePeriod, Milliseconds32
llvDiffusionPeriod :: Milliseconds32
llvDiffusionPeriod :: LeiosLedgerView -> Milliseconds32
llvDiffusionPeriod} RelativeTime
onset =
  RelativeTime -> RelativeTime -> VoteWindow
MkVoteWindow
    (RelativeTime
onset RelativeTime -> NominalDiffTime -> RelativeTime
`plus` (NominalDiffTime
3 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
lHdr))
    -- NOTE: This cap never applies on mainnet, as L_diff is under 20 s.
    (RelativeTime
onset RelativeTime -> NominalDiffTime -> RelativeTime
`plus` (NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Ord a => a -> a -> a
min (NominalDiffTime
3 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
lHdr NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
lVote NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
lDiff) NominalDiffTime
maxAnnouncementAgeSend))
 where
  plus :: RelativeTime -> NominalDiffTime -> RelativeTime
plus = (NominalDiffTime -> RelativeTime -> RelativeTime)
-> RelativeTime -> NominalDiffTime -> RelativeTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> RelativeTime -> RelativeTime
addRelTime

  lHdr :: NominalDiffTime
lHdr = Milliseconds32 -> NominalDiffTime
milliseconds32ToNominalDiffTime Milliseconds32
llvAnnouncementPeriod
  lVote :: NominalDiffTime
lVote = Milliseconds32 -> NominalDiffTime
milliseconds32ToNominalDiffTime Milliseconds32
llvVotePeriod
  lDiff :: NominalDiffTime
lDiff = Milliseconds32 -> NominalDiffTime
milliseconds32ToNominalDiffTime Milliseconds32
llvDiffusionPeriod

-- | Accept a peer's 'MsgLeiosVotes', or say why the peer must go; see
-- 'ExnLeiosNotifyInvalidVotes'.
--
-- This does not check a vote's seat or signature. The node's 'VoteState' will,
-- once per vote, unless copies arrive simultaneously, so a badly signed copy of
-- a vote the node already has costs it only the bytes; see
-- 'ExnLeiosInvalidVote'.
checkLeiosVotes ::
  forall blk.
  ( LedgerSupportsProtocol blk
  , HasHardForkHistory blk
  ) =>
  TopLevelConfig blk ->
  -- | the most that an honest peer's clock may differ from ours
  InFutureCheck.ClockSkew ->
  -- | the immutable tip's ledger state
  ExtLedgerState blk EmptyMK ->
  -- | now
  RelativeTime ->
  NonEmpty LeiosVote ->
  LeiosNotifyPeerState blk ->
  Except ExnLeiosNotifyInvalidVotes (LeiosNotifyPeerState blk, [AcceptedVote])
checkLeiosVotes :: forall blk.
(LedgerSupportsProtocol blk, HasHardForkHistory blk) =>
TopLevelConfig blk
-> ClockSkew
-> ExtLedgerState blk EmptyMK
-> RelativeTime
-> NonEmpty LeiosVote
-> LeiosNotifyPeerState blk
-> Except
     ExnLeiosNotifyInvalidVotes
     (LeiosNotifyPeerState blk, [AcceptedVote])
checkLeiosVotes TopLevelConfig blk
cfg ClockSkew
skew ExtLedgerState blk EmptyMK
immLedger RelativeTime
now NonEmpty LeiosVote
votes LeiosNotifyPeerState blk
st0 =
  ([AcceptedVote] -> [AcceptedVote])
-> (LeiosNotifyPeerState blk, [AcceptedVote])
-> (LeiosNotifyPeerState blk, [AcceptedVote])
forall a b.
(a -> b)
-> (LeiosNotifyPeerState blk, a) -> (LeiosNotifyPeerState blk, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [AcceptedVote] -> [AcceptedVote]
forall a. [a] -> [a]
reverse ((LeiosNotifyPeerState blk, [AcceptedVote])
 -> (LeiosNotifyPeerState blk, [AcceptedVote]))
-> ExceptT
     ExnLeiosNotifyInvalidVotes
     Identity
     (LeiosNotifyPeerState blk, [AcceptedVote])
-> ExceptT
     ExnLeiosNotifyInvalidVotes
     Identity
     (LeiosNotifyPeerState blk, [AcceptedVote])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((LeiosNotifyPeerState blk, [AcceptedVote])
 -> LeiosVote
 -> ExceptT
      ExnLeiosNotifyInvalidVotes
      Identity
      (LeiosNotifyPeerState blk, [AcceptedVote]))
-> (LeiosNotifyPeerState blk, [AcceptedVote])
-> NonEmpty LeiosVote
-> ExceptT
     ExnLeiosNotifyInvalidVotes
     Identity
     (LeiosNotifyPeerState blk, [AcceptedVote])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (LeiosNotifyPeerState blk, [AcceptedVote])
-> LeiosVote
-> ExceptT
     ExnLeiosNotifyInvalidVotes
     Identity
     (LeiosNotifyPeerState blk, [AcceptedVote])
forall {blk}.
(LeiosNotifyPeerState blk, [AcceptedVote])
-> LeiosVote
-> ExceptT
     ExnLeiosNotifyInvalidVotes
     Identity
     (LeiosNotifyPeerState blk, [AcceptedVote])
checkOne (LeiosNotifyPeerState blk
st0, []) NonEmpty LeiosVote
votes
 where
  checkOne :: (LeiosNotifyPeerState blk, [AcceptedVote])
-> LeiosVote
-> ExceptT
     ExnLeiosNotifyInvalidVotes
     Identity
     (LeiosNotifyPeerState blk, [AcceptedVote])
checkOne (LeiosNotifyPeerState blk
st, [AcceptedVote]
accepted) LeiosVote
vote = do
    slot <-
      ExceptT ExnLeiosNotifyInvalidVotes Identity SlotNo
-> (SlotNo -> ExceptT ExnLeiosNotifyInvalidVotes Identity SlotNo)
-> Maybe SlotNo
-> ExceptT ExnLeiosNotifyInvalidVotes Identity SlotNo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ExnLeiosNotifyInvalidVotes
-> ExceptT ExnLeiosNotifyInvalidVotes Identity SlotNo
forall a.
ExnLeiosNotifyInvalidVotes
-> ExceptT ExnLeiosNotifyInvalidVotes Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RankingBlockHash -> ExnLeiosNotifyInvalidVotes
ExnLeiosVoteWithoutAnnouncement RankingBlockHash
rbHash)) SlotNo -> ExceptT ExnLeiosNotifyInvalidVotes Identity SlotNo
forall a. a -> ExceptT ExnLeiosNotifyInvalidVotes Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SlotNo
 -> ExceptT ExnLeiosNotifyInvalidVotes Identity SlotNo)
-> Maybe SlotNo
-> ExceptT ExnLeiosNotifyInvalidVotes Identity SlotNo
forall a b. (a -> b) -> a -> b
$
        RankingBlockHash -> Map RankingBlockHash SlotNo -> Maybe SlotNo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RankingBlockHash
rbHash (LeiosNotifyPeerState blk -> Map RankingBlockHash SlotNo
forall blk. LeiosNotifyPeerState blk -> Map RankingBlockHash SlotNo
lnpsAnnouncedRbHashes LeiosNotifyPeerState blk
st)
    when (Set.member (slot, seat) (lnpsVotes st)) $
      throwError (ExnLeiosRepeatedVote slot seat)
    (onset, _slotLength) <-
      liftEither . first (const (ExnLeiosVoteOutsideHorizon rbHash slot)) $
        HardFork.runQuery
          (HardFork.slotToWallclock slot)
          (hardForkSummary (configLedger cfg) (ledgerState immLedger))
    let age = RelativeTime -> RelativeTime -> NominalDiffTime
diffRelTime RelativeTime
now RelativeTime
onset
    -- 'forecastFor' cannot judge a slot behind its anchor, the immutable tip.
    when (NotOrigin slot < getTipSlot (ledgerState immLedger)) $
      throwError (ExnLeiosVoteTooLate rbHash slot age)
    view <-
      withExcept (const (ExnLeiosVoteOutsideHorizon rbHash slot)) $
        forecastFor
          (ledgerViewForecastAt (configLedger cfg) (ledgerState immLedger))
          slot
    -- Without Leios at this slot, the protocol announces nothing there, so no
    -- vote in it can have an announcement.
    leiosView@MkLeiosLedgerView{llvCommittee} <-
      maybe (throwError (ExnLeiosVoteWithoutAnnouncement rbHash)) pure $
        getLeiosLedgerView (Proxy @(BlockProtocol blk)) view
    let window = LeiosLedgerView -> RelativeTime -> VoteWindow
leiosVoteWindow LeiosLedgerView
leiosView RelativeTime
onset
    when (now < addRelTime (negate (InFutureCheck.unClockSkew skew)) (voteFrom window)) $
      throwError (ExnLeiosVoteTooEarly rbHash slot age)
    when (now > addRelTime voteLateGrace (voteUntil window)) $
      throwError (ExnLeiosVoteTooLate rbHash slot age)
    pure
      ( st{lnpsVotes = Set.insert (slot, seat) (lnpsVotes st)}
      , MkAcceptedVote
          vote
          slot
          llvCommittee
          window
          : accepted
      )
   where
    rbHash :: RankingBlockHash
rbHash = LeiosVote -> RankingBlockHash
voteAnnouncingRbHash LeiosVote
vote
    seat :: LeiosSeatId
seat = LeiosVote -> LeiosSeatId
voteSeatId LeiosVote
vote

-- | How much later than its deadline a vote may arrive without the node
-- disconnecting the peer: enough for transmission, clock skew, and votes queued
-- behind other traffic. Such a vote is too late to use, and the node's
-- 'VoteState' traces it.
--
-- TODO magic number; measure buffer bloat on a loaded network.
voteLateGrace :: NominalDiffTime
voteLateGrace :: NominalDiffTime
voteLateGrace = NominalDiffTime
60