{-# 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 (..)
  , checkLeiosVotes
  , voteLateGrace
  , ExnLeiosNotifyInvalidOffer (..)
  , checkLeiosBlockOffer
  , checkLeiosClosureOffer
  , LeiosNotifyPeerState (..)
  , emptyLeiosNotifyPeerState
  , onLeiosNotifyAnnouncement
  , pruneLeiosNotifyPeerState
  ) where

import Cardano.Crypto.Leios (LeiosSeatId)
import Control.Monad (foldM, when)
import Control.Monad.Except (Except, ExceptT, liftEither, throwError, withExcept, withExceptT)
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.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
  , headerHash
  )
import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime, SystemTime, 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.Protocol
  ( LeiosAnnouncement (..)
  , LeiosLedgerView (..)
  , LeiosProtocol (..)
  )
import Ouroboros.Consensus.Leios.Types
  ( BytesSize
  , LeiosPoint (..)
  , LeiosVote (..)
  , RbHash (..)
  , 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, ancHeader)
  , announcementValidity
  , mkAnnouncingHeader
  )
import Ouroboros.Consensus.Protocol.Abstract (ValidationErr)
import Ouroboros.Consensus.Util.IOLike (Exception, IOLike)

-- | 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 RbHash SlotNo
lnpsAnnouncedRbHashes :: !(Map RbHash 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 RbHash SlotNo
lnpsAnnouncedRbHashes = Map RbHash 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 RbHash SlotNo
lnpsAnnouncedRbHashes =
            (Map RbHash SlotNo -> AnnouncingHeader blk -> Map RbHash SlotNo)
-> Map RbHash SlotNo -> [AnnouncingHeader blk] -> Map RbHash 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 RbHash SlotNo
m AnnouncingHeader blk
anc -> RbHash -> Map RbHash SlotNo -> Map RbHash SlotNo
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (AnnouncingHeader blk -> RbHash
forall blk.
(ConvertRawHash blk, GetHeader blk) =>
AnnouncingHeader blk -> RbHash
announcingRbHash AnnouncingHeader blk
anc) Map RbHash SlotNo
m)
              (LeiosNotifyPeerState blk -> Map RbHash SlotNo
forall blk. LeiosNotifyPeerState blk -> Map RbHash 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)

-- | The hash of the announcing block, which votes name.
announcingRbHash ::
  forall blk. (ConvertRawHash blk, GetHeader blk) => AnnouncingHeader blk -> RbHash
announcingRbHash :: forall blk.
(ConvertRawHash blk, GetHeader blk) =>
AnnouncingHeader blk -> RbHash
announcingRbHash AnnouncingHeader blk
anc = ByteString -> RbHash
MkRbHash (Proxy blk -> HeaderHash blk -> ByteString
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> ByteString
forall (proxy :: * -> *). proxy blk -> HeaderHash blk -> ByteString
toRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash (AnnouncingHeader blk -> Header blk
forall blk. AnnouncingHeader blk -> Header blk
ancHeader AnnouncingHeader blk
anc)))

-- | 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, LeiosProtocol (BlockProtocol 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, LeiosProtocol (BlockProtocol 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 -> EbHash
announcementEbHash (AnnouncingHeader blk -> LeiosAnnouncement
forall blk. AnnouncingHeader blk -> LeiosAnnouncement
ancAnnouncement AnnouncingHeader blk
ancHdr) EbHash -> EbHash -> Bool
forall a. Eq a => a -> a -> Bool
== LeiosPoint -> EbHash
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.
--
-- Nothing else in the node processes the announcement yet.
onLeiosNotifyAnnouncement ::
  forall m blk.
  ( IOLike m
  , LedgerSupportsProtocol blk
  , ConvertRawHash blk
  , LeiosProtocol (BlockProtocol blk)
  ) =>
  SystemTime m ->
  InFutureCheck.SomeHeaderInFutureCheck m blk ->
  TopLevelConfig 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,
 LeiosProtocol (BlockProtocol blk)) =>
SystemTime m
-> SomeHeaderInFutureCheck m blk
-> TopLevelConfig 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 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, LeiosProtocol (BlockProtocol 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.
    --
    -- TODO When the node processes and relays announcements, have
    -- 'announcementValidity' also return a fresh announcement's slot onset and
    -- age: the age decides whether to relay it, and the onset dates the
    -- endorser block's arrival.
    _staleness <- announcementValidity systemTime futureCheck cfg immLedger anc
    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 !RbHash
  | -- | 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
      !RbHash
      -- | 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 3 L_hdr +
    -- L_vote 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 any window.
    ExnLeiosVoteTooLate
      -- | the announcing block
      !RbHash
      -- | 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
      !RbHash
      -- | the election slot
      !SlotNo
  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

-- | 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 central vote
-- processing will, once per vote, caching the result, so a badly signed copy of
-- a vote the node already has costs it only the bytes.
checkLeiosVotes ::
  forall blk.
  ( LedgerSupportsProtocol blk
  , HasHardForkHistory blk
  , LeiosProtocol (BlockProtocol 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)
checkLeiosVotes :: forall blk.
(LedgerSupportsProtocol blk, HasHardForkHistory blk,
 LeiosProtocol (BlockProtocol blk)) =>
TopLevelConfig blk
-> ClockSkew
-> ExtLedgerState blk EmptyMK
-> RelativeTime
-> NonEmpty LeiosVote
-> LeiosNotifyPeerState blk
-> Except ExnLeiosNotifyInvalidVotes (LeiosNotifyPeerState blk)
checkLeiosVotes TopLevelConfig blk
cfg ClockSkew
skew ExtLedgerState blk EmptyMK
immLedger RelativeTime
now NonEmpty LeiosVote
votes LeiosNotifyPeerState blk
st0 = (LeiosNotifyPeerState blk
 -> LeiosVote
 -> ExceptT
      ExnLeiosNotifyInvalidVotes Identity (LeiosNotifyPeerState blk))
-> LeiosNotifyPeerState blk
-> NonEmpty LeiosVote
-> ExceptT
     ExnLeiosNotifyInvalidVotes Identity (LeiosNotifyPeerState blk)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM LeiosNotifyPeerState blk
-> LeiosVote
-> ExceptT
     ExnLeiosNotifyInvalidVotes Identity (LeiosNotifyPeerState blk)
forall {blk}.
LeiosNotifyPeerState blk
-> LeiosVote
-> ExceptT
     ExnLeiosNotifyInvalidVotes Identity (LeiosNotifyPeerState blk)
checkOne LeiosNotifyPeerState blk
st0 NonEmpty LeiosVote
votes
 where
  checkOne :: LeiosNotifyPeerState blk
-> LeiosVote
-> ExceptT
     ExnLeiosNotifyInvalidVotes Identity (LeiosNotifyPeerState blk)
checkOne LeiosNotifyPeerState blk
st 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 (RbHash -> ExnLeiosNotifyInvalidVotes
ExnLeiosVoteWithoutAnnouncement RbHash
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
$
        RbHash -> Map RbHash SlotNo -> Maybe SlotNo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RbHash
rbHash (LeiosNotifyPeerState blk -> Map RbHash SlotNo
forall blk. LeiosNotifyPeerState blk -> Map RbHash 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.
    MkLeiosLedgerView{llvAnnouncementPeriod, llvVotePeriod} <-
      maybe (throwError (ExnLeiosVoteWithoutAnnouncement rbHash)) pure $
        getLeiosLedgerView (Proxy @(BlockProtocol blk)) view
    let lHdr = Milliseconds32 -> NominalDiffTime
milliseconds32ToNominalDiffTime Milliseconds32
llvAnnouncementPeriod
        lVote = Milliseconds32 -> NominalDiffTime
milliseconds32ToNominalDiffTime Milliseconds32
llvVotePeriod
    when (age < 3 * lHdr - InFutureCheck.unClockSkew skew) $
      throwError (ExnLeiosVoteTooEarly rbHash slot age)
    when (age > 3 * lHdr + lVote + voteLateGrace) $
      throwError (ExnLeiosVoteTooLate rbHash slot age)
    pure st{lnpsVotes = Set.insert (slot, seat) (lnpsVotes st)}
   where
    rbHash :: RbHash
rbHash = LeiosVote -> RbHash
voteAnnouncingRbHash LeiosVote
vote
    seat :: LeiosSeatId
seat = LeiosVote -> LeiosSeatId
voteSeatId LeiosVote
vote

-- | How much later than 3 L_hdr + L_vote after its election slot began a vote
-- may arrive: enough for transmission, clock skew, and votes queued behind
-- other traffic.
--
-- TODO magic number; measure buffer bloat on a loaded network.
voteLateGrace :: NominalDiffTime
voteLateGrace :: NominalDiffTime
voteLateGrace = NominalDiffTime
60