{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ViewPatterns #-}

-- | Praos, and the pieces every protocol built on Praos shares.
--
-- Each such protocol is its own @proto@ type with its own instances, so that
-- none of Praos's rules are reused by accident. The data types, however, are
-- shared: they carry a @proto@ parameter, so that there is one definition of
-- each Praos concept regardless of which extensions the protocol enables. The
-- functions suffixed @PolyPraos@ are the method implementations every such
-- protocol delegates to.
--
-- @Poly@ means "many": a @PolyPraos@ type or function handles multiple
-- extensions of/overlays on Praos, the ones used for Cardano. And the
-- @PolyPraos@ functions are indeed /polymorphic/ in the @proto@ tyvar.
--
-- This is not a fully modular design: subsequent additional extensions will
-- also need to add to these same definitions (eg adding fields for Ouroboros
-- Phalanx). That is intentional. This code does not need to be classically
-- extensible, since there is, unfortunately, no such thing as an extensible
-- security proof. Our protocol changes are well studied before implemented, and
-- have never happened concurrently.
--
-- In other words: it's a very important benefit that there is /one definition/
-- to look at in order to see everything all of the Praos extensions
-- /cumulatively/ do. The type-level DSL used to isolate extension components is
-- simple and legible; see the 'LeiosOnly' data family, for example.
module Ouroboros.Consensus.Protocol.PolyPraos
  ( PolyPraosCrypto
  , PolyPraosState (..)
  , PolyPraosValidationErr (..)
  , PraosCannotForge (..)
  , PraosFields (..)
  , PraosIsLeader (..)
  , PraosParams (..)
  , PraosToSign (..)
  , SerialisePraosState
  , Ticked (..)
  , checkIsLeaderPolyPraos
  , forgePraosFields
  , getOpCertCountersPolyPraos
  , getPraosNoncesPolyPraos
  , leiosContextFreeHeaderChecks
  , markUncertifiable
  , praosCheckCanForge
  , reupdateChainDepStatePolyPraos
  , updateChainDepStatePolyPraos
  , tickChainDepStatePolyPraos
  , validateKESSignature
  , validateVRFSignature

    -- * For testing purposes
  , doValidateKESSignature
  , doValidateKESSignature'
  , getLeiosAnnouncementPolyPraos
  , getLeiosLedgerViewPolyPraos
  , validateLeiosAnnouncementPolyPraos
  , WhetherToUpperBoundOCERT (..)
  , WhyNotCertifiable (..)
  , doValidateVRFSignature
  ) where

import Cardano.Binary (FromCBOR (..), ToCBOR (..), enforceSize)
import qualified Cardano.Crypto.DSIGN as DSIGN
import qualified Cardano.Crypto.Hash as Hash
import qualified Cardano.Crypto.KES as KES
import qualified Cardano.Crypto.VRF as VRF
import Cardano.Ledger.BaseTypes
  ( ActiveSlotCoeff
  , Nonce
  , StrictMaybe (..)
  , strictMaybe
  , strictMaybeToMaybe
  , (⭒)
  )
import qualified Cardano.Ledger.BaseTypes as SL
import Cardano.Ledger.Block (EbReferencesAnnouncement (..))
import Cardano.Ledger.Core (fromEraCBOR, toEraCBOR)
import Cardano.Ledger.Hashes (HASH, extractHash)
import Cardano.Ledger.Keys
  ( DSIGN
  , KeyHash
  , VKey (VKey)
  , coerceKeyRole
  , hashKey
  )
import qualified Cardano.Ledger.Keys as SL
import Cardano.Ledger.Shelley (ShelleyEra)
import qualified Cardano.Ledger.Shelley.API as SL
import Cardano.Ledger.Slot (Duration (Duration), (+*))
import qualified Cardano.Ledger.State as SL
import Cardano.Protocol.Crypto (Crypto, KES, VRF)
import Cardano.Protocol.Praos.VRF
  ( InputVRF
  , mkInputVRF
  , vrfLeaderValue
  , vrfNonceValue
  )
import Cardano.Protocol.TPraos.BlockHeader
  ( BoundedNatural (bvValue)
  , checkLeaderNatValue
  , prevHashToNonce
  )
import Cardano.Protocol.TPraos.OCert
  ( KESPeriod (KESPeriod)
  , OCert (OCert)
  , OCertSignable
  )
import qualified Cardano.Protocol.TPraos.OCert as OCert
import Cardano.Slotting.EpochInfo
  ( EpochInfo
  , epochInfoEpoch
  , epochInfoFirst
  , epochInfoSlotLength
  , hoistEpochInfo
  )
import Cardano.Slotting.Slot
  ( EpochNo (EpochNo)
  , SlotNo (SlotNo)
  , WithOrigin
  , unSlotNo
  )
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import Codec.Serialise (Serialise (decode, encode))
import Control.Exception (throw)
import Control.Monad (unless, when)
import Control.Monad.Except (Except, catchError, runExcept, throwError)
import Data.Coerce (coerce)
import Data.Foldable (traverse_)
import Data.Functor.Identity (runIdentity)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (Proxy))
import qualified Data.Strict.Either as Strict
import Data.Typeable (Typeable)
import Data.Word (Word32, Word64)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Numeric.Natural (Natural)
import Ouroboros.Consensus.Block (WithOrigin (NotOrigin, Origin))
import qualified Ouroboros.Consensus.HardFork.History as History
import Ouroboros.Consensus.Leios.Protocol
  ( LeiosAnnouncement (..)
  , LeiosLedgerView (..)
  , OCINStaleness (..)
  , decodeLeiosAnnouncement
  , encodeLeiosAnnouncement
  )
import qualified Ouroboros.Consensus.Leios.Types as Leios
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch)
import Ouroboros.Consensus.Protocol.Praos.Common
import Ouroboros.Consensus.Protocol.Praos.Orphans ()
import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views
import Ouroboros.Consensus.Protocol.Signed (Signed)
import Ouroboros.Consensus.Ticked (Ticked)
import Ouroboros.Consensus.Util.CBOR (decodeWithOrigin, encodeWithOrigin)

-- | What a protocol needs of its crypto: the Praos essentials, plus signing
-- whichever header body it is the protocol for.
class
  ( Crypto c
  , DSIGN.Signable DSIGN (OCertSignable c)
  , VRF.Signable (VRF c) InputVRF
  , KES.Signable (KES c) (Signed (ShelleyProtocolHeader proto))
  ) =>
  PolyPraosCrypto proto c

{-------------------------------------------------------------------------------
  Fields required by Praos in the header
-------------------------------------------------------------------------------}

data PraosFields c toSign = PraosFields
  { forall c toSign. PraosFields c toSign -> SignedKES (KES c) toSign
praosSignature :: KES.SignedKES (KES c) toSign
  , forall c toSign. PraosFields c toSign -> toSign
praosToSign :: toSign
  }
  deriving (forall x. PraosFields c toSign -> Rep (PraosFields c toSign) x)
-> (forall x. Rep (PraosFields c toSign) x -> PraosFields c toSign)
-> Generic (PraosFields c toSign)
forall x. Rep (PraosFields c toSign) x -> PraosFields c toSign
forall x. PraosFields c toSign -> Rep (PraosFields c toSign) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c toSign x.
Rep (PraosFields c toSign) x -> PraosFields c toSign
forall c toSign x.
PraosFields c toSign -> Rep (PraosFields c toSign) x
$cfrom :: forall c toSign x.
PraosFields c toSign -> Rep (PraosFields c toSign) x
from :: forall x. PraosFields c toSign -> Rep (PraosFields c toSign) x
$cto :: forall c toSign x.
Rep (PraosFields c toSign) x -> PraosFields c toSign
to :: forall x. Rep (PraosFields c toSign) x -> PraosFields c toSign
Generic

deriving instance
  (NoThunks toSign, Crypto c) =>
  NoThunks (PraosFields c toSign)

deriving instance
  (Show toSign, Crypto c) =>
  Show (PraosFields c toSign)

-- | Fields arising from praos execution which must be included in
-- the block signature.
data PraosToSign c = PraosToSign
  { forall c. PraosToSign c -> VKey BlockIssuer
praosToSignIssuerVK :: SL.VKey SL.BlockIssuer
  -- ^ Verification key for the issuer of this block.
  , forall c. PraosToSign c -> VerKeyVRF (VRF c)
praosToSignVrfVK :: VRF.VerKeyVRF (VRF c)
  , forall c. PraosToSign c -> CertifiedVRF (VRF c) InputVRF
praosToSignVrfRes :: VRF.CertifiedVRF (VRF c) InputVRF
  -- ^ Verifiable random value. This is used both to prove the issuer is
  -- eligible to issue a block, and to contribute to the evolving nonce.
  , forall c. PraosToSign c -> OCert c
praosToSignOCert :: OCert.OCert c
  -- ^ Lightweight delegation certificate mapping the cold (DSIGN) key to
  -- the online KES key.
  }
  deriving (forall x. PraosToSign c -> Rep (PraosToSign c) x)
-> (forall x. Rep (PraosToSign c) x -> PraosToSign c)
-> Generic (PraosToSign c)
forall x. Rep (PraosToSign c) x -> PraosToSign c
forall x. PraosToSign c -> Rep (PraosToSign c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PraosToSign c) x -> PraosToSign c
forall c x. PraosToSign c -> Rep (PraosToSign c) x
$cfrom :: forall c x. PraosToSign c -> Rep (PraosToSign c) x
from :: forall x. PraosToSign c -> Rep (PraosToSign c) x
$cto :: forall c x. Rep (PraosToSign c) x -> PraosToSign c
to :: forall x. Rep (PraosToSign c) x -> PraosToSign c
Generic

instance Crypto c => NoThunks (PraosToSign c)

deriving instance Crypto c => Show (PraosToSign c)

forgePraosFields ::
  ( Crypto c
  , KES.Signable (KES c) toSign
  , Monad m
  ) =>
  HotKey c m ->
  PraosCanBeLeader c ->
  PraosIsLeader c ->
  (PraosToSign c -> toSign) ->
  m (PraosFields c toSign)
forgePraosFields :: forall c toSign (m :: * -> *).
(Crypto c, Signable (KES c) toSign, Monad m) =>
HotKey c m
-> PraosCanBeLeader c
-> PraosIsLeader c
-> (PraosToSign c -> toSign)
-> m (PraosFields c toSign)
forgePraosFields
  HotKey c m
hotKey
  PraosCanBeLeader
    { VKey BlockIssuer
praosCanBeLeaderColdVerKey :: VKey BlockIssuer
praosCanBeLeaderColdVerKey :: forall c. PraosCanBeLeader c -> VKey BlockIssuer
praosCanBeLeaderColdVerKey
    , SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF :: SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF :: forall c. PraosCanBeLeader c -> SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF
    }
  PraosIsLeader{CertifiedVRF (VRF c) InputVRF
praosIsLeaderVrfRes :: CertifiedVRF (VRF c) InputVRF
praosIsLeaderVrfRes :: forall c. PraosIsLeader c -> CertifiedVRF (VRF c) InputVRF
praosIsLeaderVrfRes}
  PraosToSign c -> toSign
mkToSign = do
    ocert <- HotKey c m -> m (OCert c)
forall (m :: * -> *) c. Monad m => HotKey c m -> m (OCert c)
HotKey.getOCert HotKey c m
hotKey
    let signedFields =
          PraosToSign
            { praosToSignIssuerVK :: VKey BlockIssuer
praosToSignIssuerVK = VKey BlockIssuer
praosCanBeLeaderColdVerKey
            , praosToSignVrfVK :: VerKeyVRF (VRF c)
praosToSignVrfVK = SignKeyVRF (VRF c) -> VerKeyVRF (VRF c)
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
VRF.deriveVerKeyVRF SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF
            , praosToSignVrfRes :: CertifiedVRF (VRF c) InputVRF
praosToSignVrfRes = CertifiedVRF (VRF c) InputVRF
praosIsLeaderVrfRes
            , praosToSignOCert :: OCert c
praosToSignOCert = OCert c
ocert
            }
        toSign = PraosToSign c -> toSign
mkToSign PraosToSign c
signedFields
    signature <- HotKey.sign hotKey toSign
    return
      PraosFields
        { praosSignature = signature
        , praosToSign = toSign
        }

{-------------------------------------------------------------------------------
  Protocol proper
-------------------------------------------------------------------------------}

-- | Praos parameters that are node independent
data PraosParams = PraosParams
  { PraosParams -> Word64
praosSlotsPerKESPeriod :: !Word64
  -- ^ See 'Globals.slotsPerKESPeriod'.
  , PraosParams -> ActiveSlotCoeff
praosLeaderF :: !SL.ActiveSlotCoeff
  -- ^ Active slots coefficient. This parameter represents the proportion
  -- of slots in which blocks should be issued. This can be interpreted as
  -- the probability that a party holding all the stake will be elected as
  -- leader for a given slot.
  , PraosParams -> SecurityParam
praosSecurityParam :: !SecurityParam
  -- ^ See 'Globals.securityParameter'.
  , PraosParams -> Word64
praosMaxKESEvo :: !Word64
  -- ^ Maximum number of KES iterations, see 'Globals.maxKESEvo'.
  , PraosParams -> MaxMajorProtVer
praosMaxMajorPV :: !MaxMajorProtVer
  -- ^ All blocks invalid after this protocol version, see
  -- 'Globals.maxMajorPV'.
  , PraosParams -> Word64
praosRandomnessStabilisationWindow :: !Word64
  -- ^ The number of slots before the start of an epoch where the
  -- corresponding epoch nonce is snapshotted. This has to be at least one
  -- stability window such that the nonce is stable at the beginning of the
  -- epoch. Ouroboros Genesis requires this to be even larger, see
  -- 'SL.computeRandomnessStabilisationWindow'.
  }
  deriving ((forall x. PraosParams -> Rep PraosParams x)
-> (forall x. Rep PraosParams x -> PraosParams)
-> Generic PraosParams
forall x. Rep PraosParams x -> PraosParams
forall x. PraosParams -> Rep PraosParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PraosParams -> Rep PraosParams x
from :: forall x. PraosParams -> Rep PraosParams x
$cto :: forall x. Rep PraosParams x -> PraosParams
to :: forall x. Rep PraosParams x -> PraosParams
Generic, Context -> PraosParams -> IO (Maybe ThunkInfo)
Proxy PraosParams -> String
(Context -> PraosParams -> IO (Maybe ThunkInfo))
-> (Context -> PraosParams -> IO (Maybe ThunkInfo))
-> (Proxy PraosParams -> String)
-> NoThunks PraosParams
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PraosParams -> IO (Maybe ThunkInfo)
noThunks :: Context -> PraosParams -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PraosParams -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PraosParams -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PraosParams -> String
showTypeOf :: Proxy PraosParams -> String
NoThunks)

-- | Assembled proof that the issuer has the right to issue a block in the
-- selected slot.
newtype PraosIsLeader c = PraosIsLeader
  { forall c. PraosIsLeader c -> CertifiedVRF (VRF c) InputVRF
praosIsLeaderVrfRes :: VRF.CertifiedVRF (VRF c) InputVRF
  }
  deriving (forall x. PraosIsLeader c -> Rep (PraosIsLeader c) x)
-> (forall x. Rep (PraosIsLeader c) x -> PraosIsLeader c)
-> Generic (PraosIsLeader c)
forall x. Rep (PraosIsLeader c) x -> PraosIsLeader c
forall x. PraosIsLeader c -> Rep (PraosIsLeader c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PraosIsLeader c) x -> PraosIsLeader c
forall c x. PraosIsLeader c -> Rep (PraosIsLeader c) x
$cfrom :: forall c x. PraosIsLeader c -> Rep (PraosIsLeader c) x
from :: forall x. PraosIsLeader c -> Rep (PraosIsLeader c) x
$cto :: forall c x. Rep (PraosIsLeader c) x -> PraosIsLeader c
to :: forall x. Rep (PraosIsLeader c) x -> PraosIsLeader c
Generic

instance Crypto c => NoThunks (PraosIsLeader c)

{-------------------------------------------------------------------------------
  ConsensusProtocol
-------------------------------------------------------------------------------}

-- | Praos consensus state.
--
-- We track the last slot and the counters for operational certificates, as well
-- as a series of nonces which get updated in different ways over the course of
-- an epoch.
data PolyPraosState proto = PraosState
  { forall proto. PolyPraosState proto -> WithOrigin SlotNo
praosStateLastSlot :: !(WithOrigin SlotNo)
  , forall proto.
PolyPraosState proto -> Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters :: !(Map (KeyHash SL.BlockIssuer) Word64)
  -- ^ Operation Certificate counters
  , forall proto. PolyPraosState proto -> Nonce
praosStateEvolvingNonce :: !Nonce
  -- ^ Evolving nonce
  , forall proto. PolyPraosState proto -> Nonce
praosStateCandidateNonce :: !Nonce
  -- ^ Candidate nonce
  , forall proto. PolyPraosState proto -> Nonce
praosStateEpochNonce :: !Nonce
  -- ^ Epoch nonce
  , forall proto. PolyPraosState proto -> Nonce
praosStatePreviousEpochNonce :: !Nonce
  -- ^ Previous epoch nonce
  , forall proto. PolyPraosState proto -> Nonce
praosStateLabNonce :: !Nonce
  -- ^ Nonce constructed from the hash of the previous block
  , forall proto. PolyPraosState proto -> Nonce
praosStateLastEpochBlockNonce :: !Nonce
  -- ^ Nonce corresponding to the LAB nonce of the last block of the previous
  -- epoch
  , forall proto.
PolyPraosState proto
-> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
praosStateLeiosAnnouncement ::
      !(WhenLeios proto (Strict.Either WhyNotCertifiable LeiosAnnouncement))
  -- ^ Relevant only to the next header, and only if it sets its cert bit: the
  -- announcement it may certify, which is the one the most recently applied
  -- header carried, or why it may certify none.
  }
  deriving (forall x. PolyPraosState proto -> Rep (PolyPraosState proto) x)
-> (forall x. Rep (PolyPraosState proto) x -> PolyPraosState proto)
-> Generic (PolyPraosState proto)
forall x. Rep (PolyPraosState proto) x -> PolyPraosState proto
forall x. PolyPraosState proto -> Rep (PolyPraosState proto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto x.
Rep (PolyPraosState proto) x -> PolyPraosState proto
forall proto x.
PolyPraosState proto -> Rep (PolyPraosState proto) x
$cfrom :: forall proto x.
PolyPraosState proto -> Rep (PolyPraosState proto) x
from :: forall x. PolyPraosState proto -> Rep (PolyPraosState proto) x
$cto :: forall proto x.
Rep (PolyPraosState proto) x -> PolyPraosState proto
to :: forall x. Rep (PolyPraosState proto) x -> PolyPraosState proto
Generic

deriving instance
  Show (WhenLeios proto (Strict.Either WhyNotCertifiable LeiosAnnouncement)) =>
  Show (PolyPraosState proto)

deriving instance
  Eq (WhenLeios proto (Strict.Either WhyNotCertifiable LeiosAnnouncement)) =>
  Eq (PolyPraosState proto)

instance
  ( Typeable proto
  , NoThunks (WhenLeios proto (Strict.Either WhyNotCertifiable LeiosAnnouncement))
  ) =>
  NoThunks (PolyPraosState proto)

instance SerialisePraosState proto => ToCBOR (PolyPraosState proto) where
  toCBOR :: PolyPraosState proto -> Encoding
toCBOR = PolyPraosState proto -> Encoding
forall a. Serialise a => a -> Encoding
encode

instance SerialisePraosState proto => FromCBOR (PolyPraosState proto) where
  fromCBOR :: forall s. Decoder s (PolyPraosState proto)
fromCBOR = Decoder s (PolyPraosState proto)
forall s. Decoder s (PolyPraosState proto)
forall a s. Serialise a => Decoder s a
decode

-- | What encoding 'PolyPraosState' needs of its protocol.
--
-- 'LeiosOnly' decides which fields are written. There is no inner version: the
-- snapshot version covers it, and the HFC's era index precedes it, so the codec
-- is already chosen when it is read.
type SerialisePraosState proto =
  ( Typeable proto
  , Applicative (WhenLeios proto)
  , Traversable (WhenLeios proto)
  )

instance SerialisePraosState proto => Serialise (PolyPraosState proto) where
  encode :: PolyPraosState proto -> Encoding
encode
    PraosState
      { WithOrigin SlotNo
praosStateLastSlot :: forall proto. PolyPraosState proto -> WithOrigin SlotNo
praosStateLastSlot :: WithOrigin SlotNo
praosStateLastSlot
      , Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters :: forall proto.
PolyPraosState proto -> Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters :: Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters
      , Nonce
praosStateEvolvingNonce :: forall proto. PolyPraosState proto -> Nonce
praosStateEvolvingNonce :: Nonce
praosStateEvolvingNonce
      , Nonce
praosStateCandidateNonce :: forall proto. PolyPraosState proto -> Nonce
praosStateCandidateNonce :: Nonce
praosStateCandidateNonce
      , Nonce
praosStateEpochNonce :: forall proto. PolyPraosState proto -> Nonce
praosStateEpochNonce :: Nonce
praosStateEpochNonce
      , Nonce
praosStatePreviousEpochNonce :: forall proto. PolyPraosState proto -> Nonce
praosStatePreviousEpochNonce :: Nonce
praosStatePreviousEpochNonce
      , Nonce
praosStateLabNonce :: forall proto. PolyPraosState proto -> Nonce
praosStateLabNonce :: Nonce
praosStateLabNonce
      , Nonce
praosStateLastEpochBlockNonce :: forall proto. PolyPraosState proto -> Nonce
praosStateLastEpochBlockNonce :: Nonce
praosStateLastEpochBlockNonce
      , WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
praosStateLeiosAnnouncement :: forall proto.
PolyPraosState proto
-> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
praosStateLeiosAnnouncement :: WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
praosStateLeiosAnnouncement
      } =
      [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
        [ Word -> Encoding
CBOR.encodeListLen (Word
8 Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
nLeiosFields)
        , (SlotNo -> Encoding) -> WithOrigin SlotNo -> Encoding
forall a. (a -> Encoding) -> WithOrigin a -> Encoding
encodeWithOrigin SlotNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR WithOrigin SlotNo
praosStateLastSlot
        , Map (KeyHash BlockIssuer) Word64 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters
        , forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @ShelleyEra Nonce
praosStateEvolvingNonce
        , forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @ShelleyEra Nonce
praosStateCandidateNonce
        , forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @ShelleyEra Nonce
praosStateEpochNonce
        , forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @ShelleyEra Nonce
praosStatePreviousEpochNonce
        , forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @ShelleyEra Nonce
praosStateLabNonce
        , forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @ShelleyEra Nonce
praosStateLastEpochBlockNonce
        , (Either WhyNotCertifiable LeiosAnnouncement -> Encoding)
-> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
-> Encoding
forall m a. Monoid m => (a -> m) -> LeiosOnly proto () a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Either WhyNotCertifiable LeiosAnnouncement -> Encoding
encodeCertifiable WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
praosStateLeiosAnnouncement
        ]
     where
      nLeiosFields :: Word
nLeiosFields = (() -> Word -> Word) -> Word -> LeiosOnly proto () () -> Word
forall a b. (a -> b -> b) -> b -> LeiosOnly proto () a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\() Word
_ -> Word
1) Word
0 (forall proto b.
Applicative (WhenLeios proto) =>
b -> WhenLeios proto b
pureLeiosOnly @proto ())

  decode :: forall s. Decoder s (PolyPraosState proto)
decode = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"PraosState" (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nLeiosFields)
    WithOrigin SlotNo
-> Map (KeyHash BlockIssuer) Word64
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
-> PolyPraosState proto
forall proto.
WithOrigin SlotNo
-> Map (KeyHash BlockIssuer) Word64
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
-> PolyPraosState proto
PraosState
      (WithOrigin SlotNo
 -> Map (KeyHash BlockIssuer) Word64
 -> Nonce
 -> Nonce
 -> Nonce
 -> Nonce
 -> Nonce
 -> Nonce
 -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
 -> PolyPraosState proto)
-> Decoder s (WithOrigin SlotNo)
-> Decoder
     s
     (Map (KeyHash BlockIssuer) Word64
      -> Nonce
      -> Nonce
      -> Nonce
      -> Nonce
      -> Nonce
      -> Nonce
      -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
      -> PolyPraosState proto)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s SlotNo -> Decoder s (WithOrigin SlotNo)
forall s a. Decoder s a -> Decoder s (WithOrigin a)
decodeWithOrigin Decoder s SlotNo
forall s. Decoder s SlotNo
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder
  s
  (Map (KeyHash BlockIssuer) Word64
   -> Nonce
   -> Nonce
   -> Nonce
   -> Nonce
   -> Nonce
   -> Nonce
   -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
   -> PolyPraosState proto)
-> Decoder s (Map (KeyHash BlockIssuer) Word64)
-> Decoder
     s
     (Nonce
      -> Nonce
      -> Nonce
      -> Nonce
      -> Nonce
      -> Nonce
      -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
      -> PolyPraosState proto)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Map (KeyHash BlockIssuer) Word64)
forall s. Decoder s (Map (KeyHash BlockIssuer) Word64)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder
  s
  (Nonce
   -> Nonce
   -> Nonce
   -> Nonce
   -> Nonce
   -> Nonce
   -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
   -> PolyPraosState proto)
-> Decoder s Nonce
-> Decoder
     s
     (Nonce
      -> Nonce
      -> Nonce
      -> Nonce
      -> Nonce
      -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
      -> PolyPraosState proto)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @ShelleyEra
      Decoder
  s
  (Nonce
   -> Nonce
   -> Nonce
   -> Nonce
   -> Nonce
   -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
   -> PolyPraosState proto)
-> Decoder s Nonce
-> Decoder
     s
     (Nonce
      -> Nonce
      -> Nonce
      -> Nonce
      -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
      -> PolyPraosState proto)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @ShelleyEra
      Decoder
  s
  (Nonce
   -> Nonce
   -> Nonce
   -> Nonce
   -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
   -> PolyPraosState proto)
-> Decoder s Nonce
-> Decoder
     s
     (Nonce
      -> Nonce
      -> Nonce
      -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
      -> PolyPraosState proto)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @ShelleyEra
      Decoder
  s
  (Nonce
   -> Nonce
   -> Nonce
   -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
   -> PolyPraosState proto)
-> Decoder s Nonce
-> Decoder
     s
     (Nonce
      -> Nonce
      -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
      -> PolyPraosState proto)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @ShelleyEra
      Decoder
  s
  (Nonce
   -> Nonce
   -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
   -> PolyPraosState proto)
-> Decoder s Nonce
-> Decoder
     s
     (Nonce
      -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
      -> PolyPraosState proto)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @ShelleyEra
      Decoder
  s
  (Nonce
   -> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
   -> PolyPraosState proto)
-> Decoder s Nonce
-> Decoder
     s
     (WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
      -> PolyPraosState proto)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @ShelleyEra
      Decoder
  s
  (WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
   -> PolyPraosState proto)
-> Decoder
     s (WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement))
-> Decoder s (PolyPraosState proto)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (() -> Decoder s (Either WhyNotCertifiable LeiosAnnouncement))
-> LeiosOnly proto () ()
-> Decoder
     s (WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LeiosOnly proto () a -> f (LeiosOnly proto () b)
traverse (\() -> Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
forall s. Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
decodeCertifiable) (forall proto b.
Applicative (WhenLeios proto) =>
b -> WhenLeios proto b
pureLeiosOnly @proto ())
   where
    nLeiosFields :: Int
nLeiosFields = (() -> Int -> Int) -> Int -> LeiosOnly proto () () -> Int
forall a b. (a -> b -> b) -> b -> LeiosOnly proto () a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\() Int
_ -> Int
1) Int
0 (forall proto b.
Applicative (WhenLeios proto) =>
b -> WhenLeios proto b
pureLeiosOnly @proto ())

-- | Why the next header may certify no announcement.
data WhyNotCertifiable
  = -- | The most recently applied header carried none.
    NothingAnnounced
  | -- | It was announced in the previous era, and an endorser block may not be
    -- certified across an era boundary.
    AnnouncedInPreviousEra
  | -- | It was announced in the previous epoch, and an endorser block may not be
    -- certified across an epoch boundary.
    --
    -- (This restriction avoids some engineering complexity that wouldn't be
    -- worthwhile, since this restriction only loses one EB opportunity per
    -- epoch.)
    AnnouncedInPreviousEpoch
  deriving stock (WhyNotCertifiable -> WhyNotCertifiable -> Bool
(WhyNotCertifiable -> WhyNotCertifiable -> Bool)
-> (WhyNotCertifiable -> WhyNotCertifiable -> Bool)
-> Eq WhyNotCertifiable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WhyNotCertifiable -> WhyNotCertifiable -> Bool
== :: WhyNotCertifiable -> WhyNotCertifiable -> Bool
$c/= :: WhyNotCertifiable -> WhyNotCertifiable -> Bool
/= :: WhyNotCertifiable -> WhyNotCertifiable -> Bool
Eq, Int -> WhyNotCertifiable -> ShowS
[WhyNotCertifiable] -> ShowS
WhyNotCertifiable -> String
(Int -> WhyNotCertifiable -> ShowS)
-> (WhyNotCertifiable -> String)
-> ([WhyNotCertifiable] -> ShowS)
-> Show WhyNotCertifiable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WhyNotCertifiable -> ShowS
showsPrec :: Int -> WhyNotCertifiable -> ShowS
$cshow :: WhyNotCertifiable -> String
show :: WhyNotCertifiable -> String
$cshowList :: [WhyNotCertifiable] -> ShowS
showList :: [WhyNotCertifiable] -> ShowS
Show, (forall x. WhyNotCertifiable -> Rep WhyNotCertifiable x)
-> (forall x. Rep WhyNotCertifiable x -> WhyNotCertifiable)
-> Generic WhyNotCertifiable
forall x. Rep WhyNotCertifiable x -> WhyNotCertifiable
forall x. WhyNotCertifiable -> Rep WhyNotCertifiable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. WhyNotCertifiable -> Rep WhyNotCertifiable x
from :: forall x. WhyNotCertifiable -> Rep WhyNotCertifiable x
$cto :: forall x. Rep WhyNotCertifiable x -> WhyNotCertifiable
to :: forall x. Rep WhyNotCertifiable x -> WhyNotCertifiable
Generic)
  deriving anyclass Context -> WhyNotCertifiable -> IO (Maybe ThunkInfo)
Proxy WhyNotCertifiable -> String
(Context -> WhyNotCertifiable -> IO (Maybe ThunkInfo))
-> (Context -> WhyNotCertifiable -> IO (Maybe ThunkInfo))
-> (Proxy WhyNotCertifiable -> String)
-> NoThunks WhyNotCertifiable
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> WhyNotCertifiable -> IO (Maybe ThunkInfo)
noThunks :: Context -> WhyNotCertifiable -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> WhyNotCertifiable -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> WhyNotCertifiable -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy WhyNotCertifiable -> String
showTypeOf :: Proxy WhyNotCertifiable -> String
NoThunks

-- | Keeps the more specific reason: 'NothingAnnounced', then
-- 'AnnouncedInPreviousEra', then 'AnnouncedInPreviousEpoch'.
--
-- An era boundary is also an epoch boundary, and either may be crossed first,
-- so neither may trample the other's more specific reason.
instance Semigroup WhyNotCertifiable where
  <> :: WhyNotCertifiable -> WhyNotCertifiable -> WhyNotCertifiable
(<>) = (WhyNotCertifiable -> Word)
-> WhyNotCertifiable -> WhyNotCertifiable -> WhyNotCertifiable
forall {a} {t}. Ord a => (t -> a) -> t -> t -> t
minBy WhyNotCertifiable -> Word
specificityRank
   where
    minBy :: (t -> a) -> t -> t -> t
minBy t -> a
f t
a t
b = if t -> a
f t
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> t -> a
f t
b then t
b else t
a

    specificityRank :: WhyNotCertifiable -> Word
specificityRank = \case
      WhyNotCertifiable
NothingAnnounced -> Word
0 :: Word -- most specific
      WhyNotCertifiable
AnnouncedInPreviousEra -> Word
1
      WhyNotCertifiable
AnnouncedInPreviousEpoch -> Word
2 -- least specific

-- | What the next header may certify after crossing a boundary that rules out
-- certifying the pending announcement, for this reason.
markUncertifiable ::
  WhyNotCertifiable ->
  Strict.Either WhyNotCertifiable LeiosAnnouncement ->
  Strict.Either WhyNotCertifiable LeiosAnnouncement
markUncertifiable :: WhyNotCertifiable
-> Either WhyNotCertifiable LeiosAnnouncement
-> Either WhyNotCertifiable LeiosAnnouncement
markUncertifiable WhyNotCertifiable
why = WhyNotCertifiable -> Either WhyNotCertifiable LeiosAnnouncement
forall a b. a -> Either a b
Strict.Left (WhyNotCertifiable -> Either WhyNotCertifiable LeiosAnnouncement)
-> (Either WhyNotCertifiable LeiosAnnouncement
    -> WhyNotCertifiable)
-> Either WhyNotCertifiable LeiosAnnouncement
-> Either WhyNotCertifiable LeiosAnnouncement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WhyNotCertifiable -> WhyNotCertifiable)
-> (LeiosAnnouncement -> WhyNotCertifiable)
-> Either WhyNotCertifiable LeiosAnnouncement
-> WhyNotCertifiable
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
Strict.either (WhyNotCertifiable -> WhyNotCertifiable -> WhyNotCertifiable
forall a. Semigroup a => a -> a -> a
<> WhyNotCertifiable
why) (\LeiosAnnouncement
_ann -> WhyNotCertifiable
why)

encodeCertifiable :: Strict.Either WhyNotCertifiable LeiosAnnouncement -> CBOR.Encoding
encodeCertifiable :: Either WhyNotCertifiable LeiosAnnouncement -> Encoding
encodeCertifiable = \case
  Strict.Left WhyNotCertifiable
NothingAnnounced -> Word -> Encoding
CBOR.encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
0
  Strict.Left WhyNotCertifiable
AnnouncedInPreviousEra -> Word -> Encoding
CBOR.encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
1
  Strict.Left WhyNotCertifiable
AnnouncedInPreviousEpoch -> Word -> Encoding
CBOR.encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
3
  Strict.Right LeiosAnnouncement
ann -> Word -> Encoding
CBOR.encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> LeiosAnnouncement -> Encoding
encodeLeiosAnnouncement LeiosAnnouncement
ann

decodeCertifiable :: CBOR.Decoder s (Strict.Either WhyNotCertifiable LeiosAnnouncement)
decodeCertifiable :: forall s. Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
decodeCertifiable = do
  n <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
  tag <- CBOR.decodeWord
  case (n, tag) of
    (Int
1, Word
0) -> Either WhyNotCertifiable LeiosAnnouncement
-> Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WhyNotCertifiable LeiosAnnouncement
 -> Decoder s (Either WhyNotCertifiable LeiosAnnouncement))
-> Either WhyNotCertifiable LeiosAnnouncement
-> Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
forall a b. (a -> b) -> a -> b
$ WhyNotCertifiable -> Either WhyNotCertifiable LeiosAnnouncement
forall a b. a -> Either a b
Strict.Left WhyNotCertifiable
NothingAnnounced
    (Int
1, Word
1) -> Either WhyNotCertifiable LeiosAnnouncement
-> Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WhyNotCertifiable LeiosAnnouncement
 -> Decoder s (Either WhyNotCertifiable LeiosAnnouncement))
-> Either WhyNotCertifiable LeiosAnnouncement
-> Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
forall a b. (a -> b) -> a -> b
$ WhyNotCertifiable -> Either WhyNotCertifiable LeiosAnnouncement
forall a b. a -> Either a b
Strict.Left WhyNotCertifiable
AnnouncedInPreviousEra
    (Int
2, Word
2) -> LeiosAnnouncement -> Either WhyNotCertifiable LeiosAnnouncement
forall a b. b -> Either a b
Strict.Right (LeiosAnnouncement -> Either WhyNotCertifiable LeiosAnnouncement)
-> Decoder s LeiosAnnouncement
-> Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s LeiosAnnouncement
forall s. Decoder s LeiosAnnouncement
decodeLeiosAnnouncement
    (Int
1, Word
3) -> Either WhyNotCertifiable LeiosAnnouncement
-> Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WhyNotCertifiable LeiosAnnouncement
 -> Decoder s (Either WhyNotCertifiable LeiosAnnouncement))
-> Either WhyNotCertifiable LeiosAnnouncement
-> Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
forall a b. (a -> b) -> a -> b
$ WhyNotCertifiable -> Either WhyNotCertifiable LeiosAnnouncement
forall a b. a -> Either a b
Strict.Left WhyNotCertifiable
AnnouncedInPreviousEpoch
    (Int, Word)
_ -> String -> Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
forall a. HasCallStack => String -> Decoder s a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail (String -> Decoder s (Either WhyNotCertifiable LeiosAnnouncement))
-> String -> Decoder s (Either WhyNotCertifiable LeiosAnnouncement)
forall a b. (a -> b) -> a -> b
$ String
"WhyNotCertifiable: unknown tag " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
tag String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" of length " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n

data instance Ticked (PolyPraosState proto) = TickedPraosState
  { forall proto. Ticked (PolyPraosState proto) -> PolyPraosState proto
tickedPraosStateChainDepState :: PolyPraosState proto
  , forall proto.
Ticked (PolyPraosState proto) -> PolyPraosLedgerView proto
tickedPraosStateLedgerView :: Views.PolyPraosLedgerView proto
  }

-- | Errors which we might encounter
data PolyPraosValidationErr proto c
  = VRFKeyUnknown
      !(KeyHash SL.StakePool) -- unknown VRF keyhash (not registered)
  | VRFKeyWrongVRFKey
      !(KeyHash SL.StakePool) -- KeyHash of block issuer
      !(Hash.Hash HASH (VRF.VerKeyVRF (VRF c))) -- VRF KeyHash registered with stake pool
      !(Hash.Hash HASH (VRF.VerKeyVRF (VRF c))) -- VRF KeyHash from Header
  | VRFKeyBadProof
      !SlotNo -- Slot used for VRF calculation
      !Nonce -- Epoch nonce used for VRF calculation
      !(VRF.CertifiedVRF (VRF c) InputVRF) -- VRF calculated nonce value
  | VRFLeaderValueTooBig Natural Rational ActiveSlotCoeff
  | KESBeforeStartOCERT
      !KESPeriod -- OCert Start KES Period
      !KESPeriod -- Current KES Period
  | KESAfterEndOCERT
      !KESPeriod -- Current KES Period
      !KESPeriod -- OCert Start KES Period
      !Word64 -- Max KES Key Evolutions
  | CounterTooSmallOCERT
      !Word64 -- last KES counter used
      !Word64 -- current KES counter
  | -- | The KES counter has been incremented by more than 1
    CounterOverIncrementedOCERT
      !Word64 -- last KES counter used
      !Word64 -- current KES counter
  | InvalidSignatureOCERT
      !Word64 -- OCert counter
      !KESPeriod -- OCert KES period
      !String -- DSIGN error message
  | InvalidKesSignatureOCERT
      !Word -- current KES Period
      !Word -- KES start period
      !Word -- expected KES evolutions
      !Word64 -- max KES evolutions
      !String -- error message given by Consensus Layer
  | NoCounterForKeyHashOCERT
      !(KeyHash SL.BlockIssuer) -- stake pool key hash
  | -- | The header sets its cert bit, but there is no announcement for the
    -- certificate to certify.
    LeiosCertWithoutAnnouncement
      !(VoidUnlessLeios proto ())
      !WhyNotCertifiable
      !(WithOrigin SlotNo) -- Slot of its predecessor
      !SlotNo -- Slot of this header
  | -- | The header sets its cert bit too soon after its predecessor's
    -- announcement: the announcement, voting and diffusion periods have not all
    -- elapsed.
    LeiosCertTooYoung
      !(VoidUnlessLeios proto ())
      !SlotNo -- Slot of the announcing block
      !SlotNo -- Slot of this header
      !SlotNo -- Earliest slot in which this header could have certified
  | -- | The header announces an endorser block larger than the protocol
    -- parameters allow.
    LeiosEbTooBig
      !(VoidUnlessLeios proto ())
      !Word32 -- Announced size
      !Word32 -- Maximum size
  deriving (forall x.
 PolyPraosValidationErr proto c
 -> Rep (PolyPraosValidationErr proto c) x)
-> (forall x.
    Rep (PolyPraosValidationErr proto c) x
    -> PolyPraosValidationErr proto c)
-> Generic (PolyPraosValidationErr proto c)
forall x.
Rep (PolyPraosValidationErr proto c) x
-> PolyPraosValidationErr proto c
forall x.
PolyPraosValidationErr proto c
-> Rep (PolyPraosValidationErr proto c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto c x.
Rep (PolyPraosValidationErr proto c) x
-> PolyPraosValidationErr proto c
forall proto c x.
PolyPraosValidationErr proto c
-> Rep (PolyPraosValidationErr proto c) x
$cfrom :: forall proto c x.
PolyPraosValidationErr proto c
-> Rep (PolyPraosValidationErr proto c) x
from :: forall x.
PolyPraosValidationErr proto c
-> Rep (PolyPraosValidationErr proto c) x
$cto :: forall proto c x.
Rep (PolyPraosValidationErr proto c) x
-> PolyPraosValidationErr proto c
to :: forall x.
Rep (PolyPraosValidationErr proto c) x
-> PolyPraosValidationErr proto c
Generic

deriving instance
  (Crypto c, Eq (VoidUnlessLeios proto ())) =>
  Eq (PolyPraosValidationErr proto c)

deriving instance
  (Typeable proto, Crypto c, NoThunks (VoidUnlessLeios proto ())) =>
  NoThunks (PolyPraosValidationErr proto c)

deriving instance
  (Crypto c, Show (VoidUnlessLeios proto ())) =>
  Show (PolyPraosValidationErr proto c)

instance ChainDepStateSupportsPeras (PolyPraosState proto) where
  getEpochNonce :: PolyPraosState proto -> Nonce
getEpochNonce = PolyPraosState proto -> Nonce
forall proto. PolyPraosState proto -> Nonce
praosStateEpochNonce

instance ChainDepStateSupportsPeras (Ticked (PolyPraosState proto)) where
  getEpochNonce :: Ticked (PolyPraosState proto) -> Nonce
getEpochNonce = PolyPraosState proto -> Nonce
forall proto. PolyPraosState proto -> Nonce
praosStateEpochNonce (PolyPraosState proto -> Nonce)
-> (Ticked (PolyPraosState proto) -> PolyPraosState proto)
-> Ticked (PolyPraosState proto)
-> Nonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (PolyPraosState proto) -> PolyPraosState proto
forall proto. Ticked (PolyPraosState proto) -> PolyPraosState proto
tickedPraosStateChainDepState

-- | 'checkIsLeader' for every Praos.
checkIsLeaderPolyPraos ::
  forall proto c.
  PolyPraosCrypto proto c =>
  PraosParams ->
  PraosCanBeLeader c ->
  SlotNo ->
  Ticked (PolyPraosState proto) ->
  Maybe (PraosIsLeader c)
checkIsLeaderPolyPraos :: forall proto c.
PolyPraosCrypto proto c =>
PraosParams
-> PraosCanBeLeader c
-> SlotNo
-> Ticked (PolyPraosState proto)
-> Maybe (PraosIsLeader c)
checkIsLeaderPolyPraos
  PraosParams
prms
  PraosCanBeLeader
    { SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF :: forall c. PraosCanBeLeader c -> SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF :: SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF
    , VKey BlockIssuer
praosCanBeLeaderColdVerKey :: forall c. PraosCanBeLeader c -> VKey BlockIssuer
praosCanBeLeaderColdVerKey :: VKey BlockIssuer
praosCanBeLeaderColdVerKey
    }
  SlotNo
slot
  Ticked (PolyPraosState proto)
cs =
    if Proxy c
-> PraosParams
-> PolyPraosLedgerView proto
-> KeyHash StakePool
-> CertifiedVRF (VRF c) InputVRF
-> Bool
forall (proxy :: * -> *) proto c.
proxy c
-> PraosParams
-> PolyPraosLedgerView proto
-> KeyHash StakePool
-> CertifiedVRF (VRF c) InputVRF
-> Bool
meetsLeaderThreshold (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c) PraosParams
prms PolyPraosLedgerView proto
lv (KeyHash BlockIssuer -> KeyHash StakePool
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
SL.coerceKeyRole KeyHash BlockIssuer
vkhCold) CertifiedVRF (VRF c) InputVRF
rho
      then
        PraosIsLeader c -> Maybe (PraosIsLeader c)
forall a. a -> Maybe a
Just
          PraosIsLeader
            { praosIsLeaderVrfRes :: CertifiedVRF (VRF c) InputVRF
praosIsLeaderVrfRes = CertifiedVRF (VRF c) InputVRF -> CertifiedVRF (VRF c) InputVRF
forall a b. Coercible a b => a -> b
coerce CertifiedVRF (VRF c) InputVRF
rho
            }
      else Maybe (PraosIsLeader c)
forall a. Maybe a
Nothing
   where
    chainState :: PolyPraosState proto
chainState = Ticked (PolyPraosState proto) -> PolyPraosState proto
forall proto. Ticked (PolyPraosState proto) -> PolyPraosState proto
tickedPraosStateChainDepState Ticked (PolyPraosState proto)
cs
    lv :: PolyPraosLedgerView proto
lv = Ticked (PolyPraosState proto) -> PolyPraosLedgerView proto
forall proto.
Ticked (PolyPraosState proto) -> PolyPraosLedgerView proto
tickedPraosStateLedgerView Ticked (PolyPraosState proto)
cs
    eta0 :: Nonce
eta0 = PolyPraosState proto -> Nonce
forall proto. PolyPraosState proto -> Nonce
praosStateEpochNonce PolyPraosState proto
chainState
    vkhCold :: KeyHash BlockIssuer
vkhCold = VKey BlockIssuer -> KeyHash BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
SL.hashKey VKey BlockIssuer
praosCanBeLeaderColdVerKey
    rho' :: InputVRF
rho' = SlotNo -> Nonce -> InputVRF
mkInputVRF SlotNo
slot Nonce
eta0

    rho :: CertifiedVRF (VRF c) InputVRF
rho = ContextVRF (VRF c)
-> InputVRF -> SignKeyVRF (VRF c) -> CertifiedVRF (VRF c) InputVRF
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified () InputVRF
rho' SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF

-- | 'tickChainDepState' for every Praos.
--
-- Updating the chain dependent state for Praos.
--
-- If we are not in a new epoch, then nothing happens. If we are in a new
-- epoch, we do four things:
-- - Store the existing current epoch nonce as the "previous epoch" nonce.
--   This is needed to validate Peras certificates when they appear in blocks.
-- - Update the epoch nonce to the combination of the candidate nonce and the
--   nonce derived from the last block of the previous epoch.
-- - Update the "last block of previous epoch" nonce to the nonce derived
--   from the last applied block.
-- - Mark the pending announcement as no longer certifiable, since an endorser
--   block may not be certified across an epoch boundary.
tickChainDepStatePolyPraos ::
  Functor (WhenLeios proto) =>
  EpochInfo (Except History.PastHorizonException) ->
  Views.PolyPraosLedgerView proto ->
  SlotNo ->
  PolyPraosState proto ->
  Ticked (PolyPraosState proto)
tickChainDepStatePolyPraos :: forall proto.
Functor (WhenLeios proto) =>
EpochInfo (Except PastHorizonException)
-> PolyPraosLedgerView proto
-> SlotNo
-> PolyPraosState proto
-> Ticked (PolyPraosState proto)
tickChainDepStatePolyPraos
  EpochInfo (Except PastHorizonException)
praosEpochInfo
  PolyPraosLedgerView proto
lv
  SlotNo
slot
  PolyPraosState proto
st =
    TickedPraosState
      { tickedPraosStateChainDepState :: PolyPraosState proto
tickedPraosStateChainDepState = PolyPraosState proto
st'
      , tickedPraosStateLedgerView :: PolyPraosLedgerView proto
tickedPraosStateLedgerView = PolyPraosLedgerView proto
lv
      }
   where
    newEpoch :: Bool
newEpoch =
      EpochInfo Identity -> WithOrigin SlotNo -> SlotNo -> Bool
isNewEpoch
        (EpochInfo (Except PastHorizonException) -> EpochInfo Identity
History.toPureEpochInfo EpochInfo (Except PastHorizonException)
praosEpochInfo)
        (PolyPraosState proto -> WithOrigin SlotNo
forall proto. PolyPraosState proto -> WithOrigin SlotNo
praosStateLastSlot PolyPraosState proto
st)
        SlotNo
slot
    st' :: PolyPraosState proto
st' =
      if Bool
newEpoch
        then
          PolyPraosState proto
st
            { praosStateEpochNonce =
                praosStateCandidateNonce st
                  ⭒ praosStateLastEpochBlockNonce st
            , praosStatePreviousEpochNonce =
                praosStateEpochNonce st
            , praosStateLastEpochBlockNonce =
                praosStateLabNonce st
            , praosStateLeiosAnnouncement =
                markUncertifiable AnnouncedInPreviousEpoch
                  <$> praosStateLeiosAnnouncement st
            }
        else PolyPraosState proto
st

-- | 'updateChainDepState' for every Praos.
--
-- Validate and update the chain dependent state as a result of processing a
-- new header.
--
-- This consists of:
-- - Validate the VRF checks
-- - Validate the KES checks
-- - Call 'reupdateChainDepState'
updateChainDepStatePolyPraos ::
  ( PolyPraosCrypto proto c
  , Applicative (WhenLeios proto)
  , Foldable (WhenLeios proto)
  , TypeSwitch (LeiosOnly proto)
  ) =>
  PraosParams ->
  EpochInfo (Except History.PastHorizonException) ->
  Views.PolyPraosValidateView proto c ->
  SlotNo ->
  Ticked (PolyPraosState proto) ->
  Except (PolyPraosValidationErr proto c) (PolyPraosState proto)
updateChainDepStatePolyPraos :: forall proto c.
(PolyPraosCrypto proto c, Applicative (WhenLeios proto),
 Foldable (WhenLeios proto), TypeSwitch (LeiosOnly proto)) =>
PraosParams
-> EpochInfo (Except PastHorizonException)
-> PolyPraosValidateView proto c
-> SlotNo
-> Ticked (PolyPraosState proto)
-> Except (PolyPraosValidationErr proto c) (PolyPraosState proto)
updateChainDepStatePolyPraos
  prms :: PraosParams
prms@PraosParams{ActiveSlotCoeff
praosLeaderF :: PraosParams -> ActiveSlotCoeff
praosLeaderF :: ActiveSlotCoeff
praosLeaderF}
  EpochInfo (Except PastHorizonException)
ei
  PolyPraosValidateView proto c
b
  SlotNo
slot
  Ticked (PolyPraosState proto)
tcs = do
    -- The Leios header checks are cheap, so they run first.
    EpochInfo (Except PastHorizonException)
-> PolyPraosLedgerView proto
-> PolyPraosValidateView proto c
-> SlotNo
-> PolyPraosState proto
-> Except (PolyPraosValidationErr proto c) ()
forall proto c.
(Applicative (WhenLeios proto), Foldable (WhenLeios proto),
 TypeSwitch (LeiosOnly proto)) =>
EpochInfo (Except PastHorizonException)
-> PolyPraosLedgerView proto
-> PolyPraosValidateView proto c
-> SlotNo
-> PolyPraosState proto
-> Except (PolyPraosValidationErr proto c) ()
leiosHeaderChecks EpochInfo (Except PastHorizonException)
ei PolyPraosLedgerView proto
lv PolyPraosValidateView proto c
b SlotNo
slot PolyPraosState proto
cs
    -- First, we check the KES signature, which validates that the issuer is
    -- in fact who they say they are.
    PraosParams
-> PolyPraosLedgerView proto
-> Map (KeyHash BlockIssuer) Word64
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
forall proto c.
PolyPraosCrypto proto c =>
PraosParams
-> PolyPraosLedgerView proto
-> Map (KeyHash BlockIssuer) Word64
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
validateKESSignature PraosParams
prms PolyPraosLedgerView proto
lv (PolyPraosState proto -> Map (KeyHash BlockIssuer) Word64
forall proto.
PolyPraosState proto -> Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters PolyPraosState proto
cs) PolyPraosValidateView proto c
b
    -- Then we examing the VRF proof, which confirms that they have the
    -- right to issue in this slot.
    Nonce
-> PolyPraosLedgerView proto
-> ActiveSlotCoeff
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
forall proto c.
PolyPraosCrypto proto c =>
Nonce
-> PolyPraosLedgerView proto
-> ActiveSlotCoeff
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
validateVRFSignature (PolyPraosState proto -> Nonce
forall proto. PolyPraosState proto -> Nonce
praosStateEpochNonce PolyPraosState proto
cs) PolyPraosLedgerView proto
lv ActiveSlotCoeff
praosLeaderF PolyPraosValidateView proto c
b
    -- Finally, we apply the changes from this header to the chain state.
    PolyPraosState proto
-> ExceptT
     (PolyPraosValidationErr proto c) Identity (PolyPraosState proto)
forall a. a -> ExceptT (PolyPraosValidationErr proto c) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PolyPraosState proto
 -> ExceptT
      (PolyPraosValidationErr proto c) Identity (PolyPraosState proto))
-> PolyPraosState proto
-> ExceptT
     (PolyPraosValidationErr proto c) Identity (PolyPraosState proto)
forall a b. (a -> b) -> a -> b
$ PraosParams
-> EpochInfo (Except PastHorizonException)
-> PolyPraosValidateView proto c
-> SlotNo
-> Ticked (PolyPraosState proto)
-> PolyPraosState proto
forall proto c.
Functor (WhenLeios proto) =>
PraosParams
-> EpochInfo (Except PastHorizonException)
-> PolyPraosValidateView proto c
-> SlotNo
-> Ticked (PolyPraosState proto)
-> PolyPraosState proto
reupdateChainDepStatePolyPraos PraosParams
prms EpochInfo (Except PastHorizonException)
ei PolyPraosValidateView proto c
b SlotNo
slot Ticked (PolyPraosState proto)
tcs
   where
    lv :: PolyPraosLedgerView proto
lv = Ticked (PolyPraosState proto) -> PolyPraosLedgerView proto
forall proto.
Ticked (PolyPraosState proto) -> PolyPraosLedgerView proto
tickedPraosStateLedgerView Ticked (PolyPraosState proto)
tcs
    cs :: PolyPraosState proto
cs = Ticked (PolyPraosState proto) -> PolyPraosState proto
forall proto. Ticked (PolyPraosState proto) -> PolyPraosState proto
tickedPraosStateChainDepState Ticked (PolyPraosState proto)
tcs

-- | 'reupdateChainDepState' for every Praos.
--
-- Re-update the chain dependent state as a result of processing a header.
--
-- This consists of:
-- - Update the last applied block hash.
-- - Update the evolving and (potentially) candidate nonces based on the
--   position in the epoch.
-- - Update the operational certificate counter.
-- - Record the header's announcement, if any, replacing the previous one.
reupdateChainDepStatePolyPraos ::
  forall proto c.
  Functor (WhenLeios proto) =>
  PraosParams ->
  EpochInfo (Except History.PastHorizonException) ->
  Views.PolyPraosValidateView proto c ->
  SlotNo ->
  Ticked (PolyPraosState proto) ->
  PolyPraosState proto
reupdateChainDepStatePolyPraos :: forall proto c.
Functor (WhenLeios proto) =>
PraosParams
-> EpochInfo (Except PastHorizonException)
-> PolyPraosValidateView proto c
-> SlotNo
-> Ticked (PolyPraosState proto)
-> PolyPraosState proto
reupdateChainDepStatePolyPraos
  PraosParams{Word64
praosRandomnessStabilisationWindow :: PraosParams -> Word64
praosRandomnessStabilisationWindow :: Word64
praosRandomnessStabilisationWindow}
  EpochInfo (Except PastHorizonException)
ei
  PolyPraosValidateView proto c
b
  SlotNo
slot
  Ticked (PolyPraosState proto)
tcs =
    PolyPraosState proto
cs
      { praosStateLastSlot = NotOrigin slot
      , praosStateLabNonce = prevHashToNonce (Views.hvPrevHash b)
      , praosStateEvolvingNonce = newEvolvingNonce
      , praosStateCandidateNonce =
          if slot +* Duration praosRandomnessStabilisationWindow < firstSlotNextEpoch
            then newEvolvingNonce
            else praosStateCandidateNonce cs
      , praosStateOCertCounters =
          Map.insert hk n $ praosStateOCertCounters cs
      , praosStateLeiosAnnouncement =
          fmap
            ( \(Bool
_containsCert, StrictMaybe EbReferencesAnnouncement
mbAnn) ->
                Either WhyNotCertifiable LeiosAnnouncement
-> (EbReferencesAnnouncement
    -> Either WhyNotCertifiable LeiosAnnouncement)
-> StrictMaybe EbReferencesAnnouncement
-> Either WhyNotCertifiable LeiosAnnouncement
forall a b. a -> (b -> a) -> StrictMaybe b -> a
strictMaybe
                  (WhyNotCertifiable -> Either WhyNotCertifiable LeiosAnnouncement
forall a b. a -> Either a b
Strict.Left WhyNotCertifiable
NothingAnnounced)
                  (LeiosAnnouncement -> Either WhyNotCertifiable LeiosAnnouncement
forall a b. b -> Either a b
Strict.Right (LeiosAnnouncement -> Either WhyNotCertifiable LeiosAnnouncement)
-> (EbReferencesAnnouncement -> LeiosAnnouncement)
-> EbReferencesAnnouncement
-> Either WhyNotCertifiable LeiosAnnouncement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash BlockIssuer
-> EbReferencesAnnouncement -> LeiosAnnouncement
mkLeiosAnnouncement KeyHash BlockIssuer
hk)
                  StrictMaybe EbReferencesAnnouncement
mbAnn
            )
            (Views.hvLeios b)
      }
   where
    epochInfoWithErr :: EpochInfo Identity
epochInfoWithErr =
      (forall a. Except PastHorizonException a -> Identity a)
-> EpochInfo (Except PastHorizonException) -> EpochInfo Identity
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo
        ((PastHorizonException -> Identity a)
-> (a -> Identity a) -> Either PastHorizonException a -> Identity a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PastHorizonException -> Identity a
forall a e. (HasCallStack, Exception e) => e -> a
throw a -> Identity a
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PastHorizonException a -> Identity a)
-> (Except PastHorizonException a -> Either PastHorizonException a)
-> Except PastHorizonException a
-> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except PastHorizonException a -> Either PastHorizonException a
forall e a. Except e a -> Either e a
runExcept)
        EpochInfo (Except PastHorizonException)
ei
    firstSlotNextEpoch :: SlotNo
firstSlotNextEpoch = Identity SlotNo -> SlotNo
forall a. Identity a -> a
runIdentity (Identity SlotNo -> SlotNo) -> Identity SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ do
      EpochNo currentEpochNo <- EpochInfo Identity -> SlotNo -> Identity EpochNo
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m EpochNo
epochInfoEpoch EpochInfo Identity
epochInfoWithErr SlotNo
slot
      let nextEpoch = Word64 -> EpochNo
EpochNo (Word64 -> EpochNo) -> Word64 -> EpochNo
forall a b. (a -> b) -> a -> b
$ Word64
currentEpochNo Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
      epochInfoFirst epochInfoWithErr nextEpoch
    cs :: PolyPraosState proto
cs = Ticked (PolyPraosState proto) -> PolyPraosState proto
forall proto. Ticked (PolyPraosState proto) -> PolyPraosState proto
tickedPraosStateChainDepState Ticked (PolyPraosState proto)
tcs
    eta :: Nonce
eta = Proxy c -> CertifiedVRF (VRF c) InputVRF -> Nonce
forall (proxy :: * -> *) c.
proxy c -> CertifiedVRF (VRF c) InputVRF -> Nonce
vrfNonceValue (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c) (CertifiedVRF (VRF c) InputVRF -> Nonce)
-> CertifiedVRF (VRF c) InputVRF -> Nonce
forall a b. (a -> b) -> a -> b
$ PolyPraosValidateView proto c -> CertifiedVRF (VRF c) InputVRF
forall proto crypto.
PolyPraosValidateView proto crypto
-> CertifiedVRF (VRF crypto) InputVRF
Views.hvVrfRes PolyPraosValidateView proto c
b
    newEvolvingNonce :: Nonce
newEvolvingNonce = PolyPraosState proto -> Nonce
forall proto. PolyPraosState proto -> Nonce
praosStateEvolvingNonce PolyPraosState proto
cs Nonce -> Nonce -> Nonce
⭒ Nonce
eta
    OCert VerKeyKES (KES c)
_ Word64
n KESPeriod
_ SignedDSIGN DSIGN (OCertSignable c)
_ = PolyPraosValidateView proto c -> OCert c
forall proto crypto.
PolyPraosValidateView proto crypto -> OCert crypto
Views.hvOCert PolyPraosValidateView proto c
b
    hk :: KeyHash BlockIssuer
hk = VKey BlockIssuer -> KeyHash BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey BlockIssuer -> KeyHash BlockIssuer)
-> VKey BlockIssuer -> KeyHash BlockIssuer
forall a b. (a -> b) -> a -> b
$ PolyPraosValidateView proto c -> VKey BlockIssuer
forall proto crypto.
PolyPraosValidateView proto crypto -> VKey BlockIssuer
Views.hvVK PolyPraosValidateView proto c
b

-- | The Leios header checks that read only the header and the ledger view.
--
-- Sound out of context: the bound they check is forecast for the header's own
-- slot, so any path that validates the header reads the same value.
--
-- They run only for protocols with Leios, which are the ones that fill
-- 'typeSwitchR'.
leiosContextFreeHeaderChecks ::
  ( Applicative (WhenLeios proto)
  , Foldable (WhenLeios proto)
  , TypeSwitch (LeiosOnly proto)
  ) =>
  Views.PolyPraosLedgerView proto ->
  Views.PolyPraosValidateView proto c ->
  Except (PolyPraosValidationErr proto c) ()
leiosContextFreeHeaderChecks :: forall proto c.
(Applicative (WhenLeios proto), Foldable (WhenLeios proto),
 TypeSwitch (LeiosOnly proto)) =>
PolyPraosLedgerView proto
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
leiosContextFreeHeaderChecks PolyPraosLedgerView proto
lv PolyPraosValidateView proto c
b =
  ((LeiosOnly proto Void (),
  (Bool, StrictMaybe EbReferencesAnnouncement), Word32)
 -> ExceptT (PolyPraosValidationErr proto c) Identity ())
-> LeiosOnly
     proto
     ()
     (LeiosOnly proto Void (),
      (Bool, StrictMaybe EbReferencesAnnouncement), Word32)
-> ExceptT (PolyPraosValidationErr proto c) Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (LeiosOnly proto Void (),
 (Bool, StrictMaybe EbReferencesAnnouncement), Word32)
-> ExceptT (PolyPraosValidationErr proto c) Identity ()
forall {f :: * -> *} {proto} {c} {a}.
MonadError (PolyPraosValidationErr proto c) f =>
(LeiosOnly proto Void (),
 (a, StrictMaybe EbReferencesAnnouncement), Word32)
-> f ()
check (LeiosOnly
   proto
   ()
   (LeiosOnly proto Void (),
    (Bool, StrictMaybe EbReferencesAnnouncement), Word32)
 -> ExceptT (PolyPraosValidationErr proto c) Identity ())
-> LeiosOnly
     proto
     ()
     (LeiosOnly proto Void (),
      (Bool, StrictMaybe EbReferencesAnnouncement), Word32)
-> ExceptT (PolyPraosValidationErr proto c) Identity ()
forall a b. (a -> b) -> a -> b
$
    (,,) (LeiosOnly proto Void ()
 -> (Bool, StrictMaybe EbReferencesAnnouncement)
 -> Word32
 -> (LeiosOnly proto Void (),
     (Bool, StrictMaybe EbReferencesAnnouncement), Word32))
-> LeiosOnly proto () (LeiosOnly proto Void ())
-> LeiosOnly
     proto
     ()
     ((Bool, StrictMaybe EbReferencesAnnouncement)
      -> Word32
      -> (LeiosOnly proto Void (),
          (Bool, StrictMaybe EbReferencesAnnouncement), Word32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LeiosOnly proto () (LeiosOnly proto Void ())
forall (ff :: * -> * -> *). TypeSwitch ff => ff () (ff Void ())
typeSwitchR LeiosOnly
  proto
  ()
  ((Bool, StrictMaybe EbReferencesAnnouncement)
   -> Word32
   -> (LeiosOnly proto Void (),
       (Bool, StrictMaybe EbReferencesAnnouncement), Word32))
-> LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement)
-> LeiosOnly
     proto
     ()
     (Word32
      -> (LeiosOnly proto Void (),
          (Bool, StrictMaybe EbReferencesAnnouncement), Word32))
forall a b.
LeiosOnly proto () (a -> b)
-> LeiosOnly proto () a -> LeiosOnly proto () b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PolyPraosValidateView proto c
-> LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement)
forall proto crypto.
PolyPraosValidateView proto crypto
-> WhenLeios proto (Bool, StrictMaybe EbReferencesAnnouncement)
Views.hvLeios PolyPraosValidateView proto c
b LeiosOnly
  proto
  ()
  (Word32
   -> (LeiosOnly proto Void (),
       (Bool, StrictMaybe EbReferencesAnnouncement), Word32))
-> LeiosOnly proto () Word32
-> LeiosOnly
     proto
     ()
     (LeiosOnly proto Void (),
      (Bool, StrictMaybe EbReferencesAnnouncement), Word32)
forall a b.
LeiosOnly proto () (a -> b)
-> LeiosOnly proto () a -> LeiosOnly proto () b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LeiosLedgerView -> Word32
llvMaxEbBodySize (LeiosLedgerView -> Word32)
-> LeiosOnly proto () LeiosLedgerView -> LeiosOnly proto () Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PolyPraosLedgerView proto -> LeiosOnly proto () LeiosLedgerView
forall proto.
PolyPraosLedgerView proto -> WhenLeios proto LeiosLedgerView
Views.plvLeios PolyPraosLedgerView proto
lv)
 where
  check :: (LeiosOnly proto Void (),
 (a, StrictMaybe EbReferencesAnnouncement), Word32)
-> f ()
check (LeiosOnly proto Void ()
err, (a
_containsCert, StrictMaybe EbReferencesAnnouncement
mbAnn), Word32
maxEbBodySize) =
    case StrictMaybe EbReferencesAnnouncement
mbAnn of
      StrictMaybe EbReferencesAnnouncement
SNothing -> () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      SJust EbReferencesAnnouncement
ann -> do
        let announced :: Word32
announced = EbReferencesAnnouncement -> Word32
ebReferencesAnnouncementSize EbReferencesAnnouncement
ann
        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
announced Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
maxEbBodySize) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
          PolyPraosValidationErr proto c -> f ()
forall a. PolyPraosValidationErr proto c -> f a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PolyPraosValidationErr proto c -> f ())
-> PolyPraosValidationErr proto c -> f ()
forall a b. (a -> b) -> a -> b
$
            LeiosOnly proto Void ()
-> Word32 -> Word32 -> PolyPraosValidationErr proto c
forall proto c.
VoidUnlessLeios proto ()
-> Word32 -> Word32 -> PolyPraosValidationErr proto c
LeiosEbTooBig LeiosOnly proto Void ()
err Word32
announced Word32
maxEbBodySize

-- | 'getLeiosAnnouncement' for every Praos.
getLeiosAnnouncementPolyPraos ::
  Foldable (WhenLeios proto) =>
  Views.PolyPraosValidateView proto c ->
  Maybe LeiosAnnouncement
getLeiosAnnouncementPolyPraos :: forall proto c.
Foldable (WhenLeios proto) =>
PolyPraosValidateView proto c -> Maybe LeiosAnnouncement
getLeiosAnnouncementPolyPraos PolyPraosValidateView proto c
b =
  ((Bool, StrictMaybe EbReferencesAnnouncement)
 -> Maybe LeiosAnnouncement -> Maybe LeiosAnnouncement)
-> Maybe LeiosAnnouncement
-> LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement)
-> Maybe LeiosAnnouncement
forall a b. (a -> b -> b) -> b -> LeiosOnly proto () a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    ( \(Bool
_containsCert, StrictMaybe EbReferencesAnnouncement
mbAnn) Maybe LeiosAnnouncement
_ -> KeyHash BlockIssuer
-> EbReferencesAnnouncement -> LeiosAnnouncement
mkLeiosAnnouncement (VKey BlockIssuer -> KeyHash BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (PolyPraosValidateView proto c -> VKey BlockIssuer
forall proto crypto.
PolyPraosValidateView proto crypto -> VKey BlockIssuer
Views.hvVK PolyPraosValidateView proto c
b)) (EbReferencesAnnouncement -> LeiosAnnouncement)
-> Maybe EbReferencesAnnouncement -> Maybe LeiosAnnouncement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe EbReferencesAnnouncement
-> Maybe EbReferencesAnnouncement
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe StrictMaybe EbReferencesAnnouncement
mbAnn
    )
    Maybe LeiosAnnouncement
forall a. Maybe a
Nothing
    (PolyPraosValidateView proto c
-> LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement)
forall proto crypto.
PolyPraosValidateView proto crypto
-> WhenLeios proto (Bool, StrictMaybe EbReferencesAnnouncement)
Views.hvLeios PolyPraosValidateView proto c
b)

-- | The announcement a header carries, given its issuer.
mkLeiosAnnouncement :: KeyHash SL.BlockIssuer -> EbReferencesAnnouncement -> LeiosAnnouncement
mkLeiosAnnouncement :: KeyHash BlockIssuer
-> EbReferencesAnnouncement -> LeiosAnnouncement
mkLeiosAnnouncement KeyHash BlockIssuer
issuer EbReferencesAnnouncement
ann =
  MkLeiosAnnouncement
    { announcementElectee :: KeyHash BlockIssuer
announcementElectee = KeyHash BlockIssuer
issuer
    , announcementEbHash :: EbHash
announcementEbHash =
        ByteString -> EbHash
Leios.MkEbHash (ByteString -> EbHash) -> ByteString -> EbHash
forall a b. (a -> b) -> a -> b
$ Hash HASH EraIndependentEbReferences -> ByteString
forall h a. Hash h a -> ByteString
Hash.hashToBytes (Hash HASH EraIndependentEbReferences -> ByteString)
-> Hash HASH EraIndependentEbReferences -> ByteString
forall a b. (a -> b) -> a -> b
$ SafeHash EraIndependentEbReferences
-> Hash HASH EraIndependentEbReferences
forall i. SafeHash i -> Hash HASH i
extractHash (SafeHash EraIndependentEbReferences
 -> Hash HASH EraIndependentEbReferences)
-> SafeHash EraIndependentEbReferences
-> Hash HASH EraIndependentEbReferences
forall a b. (a -> b) -> a -> b
$ EbReferencesAnnouncement -> SafeHash EraIndependentEbReferences
ebReferencesAnnouncementHash EbReferencesAnnouncement
ann
    , announcementEbSize :: Word32
announcementEbSize = EbReferencesAnnouncement -> Word32
ebReferencesAnnouncementSize EbReferencesAnnouncement
ann
    }

-- | 'getLeiosLedgerView' for every Praos.
getLeiosLedgerViewPolyPraos ::
  Foldable (WhenLeios proto) =>
  Views.PolyPraosLedgerView proto ->
  Maybe LeiosLedgerView
getLeiosLedgerViewPolyPraos :: forall proto.
Foldable (WhenLeios proto) =>
PolyPraosLedgerView proto -> Maybe LeiosLedgerView
getLeiosLedgerViewPolyPraos PolyPraosLedgerView proto
lv =
  (LeiosLedgerView -> Maybe LeiosLedgerView -> Maybe LeiosLedgerView)
-> Maybe LeiosLedgerView
-> LeiosOnly proto () LeiosLedgerView
-> Maybe LeiosLedgerView
forall a b. (a -> b -> b) -> b -> LeiosOnly proto () a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\LeiosLedgerView
llv Maybe LeiosLedgerView
_ -> LeiosLedgerView -> Maybe LeiosLedgerView
forall a. a -> Maybe a
Just LeiosLedgerView
llv) Maybe LeiosLedgerView
forall a. Maybe a
Nothing (PolyPraosLedgerView proto -> LeiosOnly proto () LeiosLedgerView
forall proto.
PolyPraosLedgerView proto -> WhenLeios proto LeiosLedgerView
Views.plvLeios PolyPraosLedgerView proto
lv)

-- | 'validateLeiosAnnouncement' for every Praos.
--
-- The election proof (VRF) and the signature (KES and operational certificate)
-- are checked in full. The operational certificate counter is not upper
-- bounded, since a counter ahead of our immutable tip's record is honest lag.
-- A counter below that record, or no record at all, yields 'StaleOCIN' rather
-- than a rejection, since that lag can explain either too. The certification
-- gap check is skipped: it needs the header's predecessor, and an
-- announcement is checked without one.
validateLeiosAnnouncementPolyPraos ::
  ( PolyPraosCrypto proto c
  , Applicative (WhenLeios proto)
  , Foldable (WhenLeios proto)
  , TypeSwitch (LeiosOnly proto)
  ) =>
  PraosParams ->
  Views.PolyPraosValidateView proto c ->
  Ticked (PolyPraosState proto) ->
  Except (PolyPraosValidationErr proto c) OCINStaleness
validateLeiosAnnouncementPolyPraos :: forall proto c.
(PolyPraosCrypto proto c, Applicative (WhenLeios proto),
 Foldable (WhenLeios proto), TypeSwitch (LeiosOnly proto)) =>
PraosParams
-> PolyPraosValidateView proto c
-> Ticked (PolyPraosState proto)
-> Except (PolyPraosValidationErr proto c) OCINStaleness
validateLeiosAnnouncementPolyPraos
  PraosParams{ActiveSlotCoeff
praosLeaderF :: PraosParams -> ActiveSlotCoeff
praosLeaderF :: ActiveSlotCoeff
praosLeaderF, Word64
praosMaxKESEvo :: PraosParams -> Word64
praosMaxKESEvo :: Word64
praosMaxKESEvo, Word64
praosSlotsPerKESPeriod :: PraosParams -> Word64
praosSlotsPerKESPeriod :: Word64
praosSlotsPerKESPeriod}
  PolyPraosValidateView proto c
b
  Ticked (PolyPraosState proto)
tcs = do
    PolyPraosLedgerView proto
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
forall proto c.
(Applicative (WhenLeios proto), Foldable (WhenLeios proto),
 TypeSwitch (LeiosOnly proto)) =>
PolyPraosLedgerView proto
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
leiosContextFreeHeaderChecks PolyPraosLedgerView proto
lv PolyPraosValidateView proto c
b
    Nonce
-> PolyPraosLedgerView proto
-> ActiveSlotCoeff
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
forall proto c.
PolyPraosCrypto proto c =>
Nonce
-> PolyPraosLedgerView proto
-> ActiveSlotCoeff
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
validateVRFSignature (PolyPraosState proto -> Nonce
forall proto. PolyPraosState proto -> Nonce
praosStateEpochNonce PolyPraosState proto
cs) PolyPraosLedgerView proto
lv ActiveSlotCoeff
praosLeaderF PolyPraosValidateView proto c
b
    ExceptT (PolyPraosValidationErr proto c) Identity OCINStaleness
authenticate ExceptT (PolyPraosValidationErr proto c) Identity OCINStaleness
-> (PolyPraosValidationErr proto c
    -> ExceptT (PolyPraosValidationErr proto c) Identity OCINStaleness)
-> ExceptT (PolyPraosValidationErr proto c) Identity OCINStaleness
forall a.
ExceptT (PolyPraosValidationErr proto c) Identity a
-> (PolyPraosValidationErr proto c
    -> ExceptT (PolyPraosValidationErr proto c) Identity a)
-> ExceptT (PolyPraosValidationErr proto c) Identity a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \case
      CounterTooSmallOCERT{} -> OCINStaleness
-> ExceptT (PolyPraosValidationErr proto c) Identity OCINStaleness
forall a. a -> ExceptT (PolyPraosValidationErr proto c) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OCINStaleness
StaleOCIN
      NoCounterForKeyHashOCERT{} -> OCINStaleness
-> ExceptT (PolyPraosValidationErr proto c) Identity OCINStaleness
forall a. a -> ExceptT (PolyPraosValidationErr proto c) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OCINStaleness
StaleOCIN
      PolyPraosValidationErr proto c
err -> PolyPraosValidationErr proto c
-> ExceptT (PolyPraosValidationErr proto c) Identity OCINStaleness
forall a.
PolyPraosValidationErr proto c
-> ExceptT (PolyPraosValidationErr proto c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PolyPraosValidationErr proto c
err
   where
    lv :: PolyPraosLedgerView proto
lv = Ticked (PolyPraosState proto) -> PolyPraosLedgerView proto
forall proto.
Ticked (PolyPraosState proto) -> PolyPraosLedgerView proto
tickedPraosStateLedgerView Ticked (PolyPraosState proto)
tcs
    cs :: PolyPraosState proto
cs = Ticked (PolyPraosState proto) -> PolyPraosState proto
forall proto. Ticked (PolyPraosState proto) -> PolyPraosState proto
tickedPraosStateChainDepState Ticked (PolyPraosState proto)
tcs
    SL.PoolDistr Map (KeyHash StakePool) IndividualPoolStake
pd NonZero Coin
_totalActiveStake = PolyPraosLedgerView proto -> PoolDistr
forall proto. PolyPraosLedgerView proto -> PoolDistr
Views.plvPoolDistr PolyPraosLedgerView proto
lv
    authenticate :: ExceptT (PolyPraosValidationErr proto c) Identity OCINStaleness
authenticate =
      OCINStaleness
FreshOCIN
        OCINStaleness
-> Except (PolyPraosValidationErr proto c) ()
-> ExceptT (PolyPraosValidationErr proto c) Identity OCINStaleness
forall a b.
a
-> ExceptT (PolyPraosValidationErr proto c) Identity b
-> ExceptT (PolyPraosValidationErr proto c) Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ WhetherToUpperBoundOCERT
-> Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
forall proto c.
PolyPraosCrypto proto c =>
WhetherToUpperBoundOCERT
-> Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
doValidateKESSignature'
          WhetherToUpperBoundOCERT
DoNotUpperBoundOCERT
          Word64
praosMaxKESEvo
          Word64
praosSlotsPerKESPeriod
          Map (KeyHash StakePool) IndividualPoolStake
pd
          (PolyPraosState proto -> Map (KeyHash BlockIssuer) Word64
forall proto.
PolyPraosState proto -> Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters PolyPraosState proto
cs)
          PolyPraosValidateView proto c
b

-- | The Leios-specific checks on a header, called by 'updateChainDepState'.
--
-- 'leiosContextFreeHeaderChecks' plus the one check that needs the header's
-- immediate predecessor: a block may not certify an announcement younger than
-- the certification gap, and only the predecessor's state says which
-- announcement that is.
leiosHeaderChecks ::
  ( Applicative (WhenLeios proto)
  , Foldable (WhenLeios proto)
  , TypeSwitch (LeiosOnly proto)
  ) =>
  EpochInfo (Except History.PastHorizonException) ->
  Views.PolyPraosLedgerView proto ->
  Views.PolyPraosValidateView proto c ->
  SlotNo ->
  PolyPraosState proto ->
  Except (PolyPraosValidationErr proto c) ()
leiosHeaderChecks :: forall proto c.
(Applicative (WhenLeios proto), Foldable (WhenLeios proto),
 TypeSwitch (LeiosOnly proto)) =>
EpochInfo (Except PastHorizonException)
-> PolyPraosLedgerView proto
-> PolyPraosValidateView proto c
-> SlotNo
-> PolyPraosState proto
-> Except (PolyPraosValidationErr proto c) ()
leiosHeaderChecks EpochInfo (Except PastHorizonException)
praosEpochInfo PolyPraosLedgerView proto
lv PolyPraosValidateView proto c
b SlotNo
slot PolyPraosState proto
cs = do
  PolyPraosLedgerView proto
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
forall proto c.
(Applicative (WhenLeios proto), Foldable (WhenLeios proto),
 TypeSwitch (LeiosOnly proto)) =>
PolyPraosLedgerView proto
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
leiosContextFreeHeaderChecks PolyPraosLedgerView proto
lv PolyPraosValidateView proto c
b
  ((LeiosOnly proto Void (),
  (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
  Either WhyNotCertifiable LeiosAnnouncement)
 -> Except (PolyPraosValidationErr proto c) ())
-> LeiosOnly
     proto
     ()
     (LeiosOnly proto Void (),
      (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
      Either WhyNotCertifiable LeiosAnnouncement)
-> Except (PolyPraosValidationErr proto c) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (LeiosOnly proto Void (),
 (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
 Either WhyNotCertifiable LeiosAnnouncement)
-> Except (PolyPraosValidationErr proto c) ()
check (LeiosOnly
   proto
   ()
   (LeiosOnly proto Void (),
    (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
    Either WhyNotCertifiable LeiosAnnouncement)
 -> Except (PolyPraosValidationErr proto c) ())
-> LeiosOnly
     proto
     ()
     (LeiosOnly proto Void (),
      (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
      Either WhyNotCertifiable LeiosAnnouncement)
-> Except (PolyPraosValidationErr proto c) ()
forall a b. (a -> b) -> a -> b
$
    (,,,)
      (LeiosOnly proto Void ()
 -> (Bool, StrictMaybe EbReferencesAnnouncement)
 -> LeiosLedgerView
 -> Either WhyNotCertifiable LeiosAnnouncement
 -> (LeiosOnly proto Void (),
     (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
     Either WhyNotCertifiable LeiosAnnouncement))
-> LeiosOnly proto () (LeiosOnly proto Void ())
-> LeiosOnly
     proto
     ()
     ((Bool, StrictMaybe EbReferencesAnnouncement)
      -> LeiosLedgerView
      -> Either WhyNotCertifiable LeiosAnnouncement
      -> (LeiosOnly proto Void (),
          (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
          Either WhyNotCertifiable LeiosAnnouncement))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LeiosOnly proto () (LeiosOnly proto Void ())
forall (ff :: * -> * -> *). TypeSwitch ff => ff () (ff Void ())
typeSwitchR
      LeiosOnly
  proto
  ()
  ((Bool, StrictMaybe EbReferencesAnnouncement)
   -> LeiosLedgerView
   -> Either WhyNotCertifiable LeiosAnnouncement
   -> (LeiosOnly proto Void (),
       (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
       Either WhyNotCertifiable LeiosAnnouncement))
-> LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement)
-> LeiosOnly
     proto
     ()
     (LeiosLedgerView
      -> Either WhyNotCertifiable LeiosAnnouncement
      -> (LeiosOnly proto Void (),
          (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
          Either WhyNotCertifiable LeiosAnnouncement))
forall a b.
LeiosOnly proto () (a -> b)
-> LeiosOnly proto () a -> LeiosOnly proto () b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PolyPraosValidateView proto c
-> LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement)
forall proto crypto.
PolyPraosValidateView proto crypto
-> WhenLeios proto (Bool, StrictMaybe EbReferencesAnnouncement)
Views.hvLeios PolyPraosValidateView proto c
b
      LeiosOnly
  proto
  ()
  (LeiosLedgerView
   -> Either WhyNotCertifiable LeiosAnnouncement
   -> (LeiosOnly proto Void (),
       (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
       Either WhyNotCertifiable LeiosAnnouncement))
-> LeiosOnly proto () LeiosLedgerView
-> LeiosOnly
     proto
     ()
     (Either WhyNotCertifiable LeiosAnnouncement
      -> (LeiosOnly proto Void (),
          (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
          Either WhyNotCertifiable LeiosAnnouncement))
forall a b.
LeiosOnly proto () (a -> b)
-> LeiosOnly proto () a -> LeiosOnly proto () b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PolyPraosLedgerView proto -> LeiosOnly proto () LeiosLedgerView
forall proto.
PolyPraosLedgerView proto -> WhenLeios proto LeiosLedgerView
Views.plvLeios PolyPraosLedgerView proto
lv
      LeiosOnly
  proto
  ()
  (Either WhyNotCertifiable LeiosAnnouncement
   -> (LeiosOnly proto Void (),
       (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
       Either WhyNotCertifiable LeiosAnnouncement))
-> LeiosOnly proto () (Either WhyNotCertifiable LeiosAnnouncement)
-> LeiosOnly
     proto
     ()
     (LeiosOnly proto Void (),
      (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
      Either WhyNotCertifiable LeiosAnnouncement)
forall a b.
LeiosOnly proto () (a -> b)
-> LeiosOnly proto () a -> LeiosOnly proto () b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PolyPraosState proto
-> LeiosOnly proto () (Either WhyNotCertifiable LeiosAnnouncement)
forall proto.
PolyPraosState proto
-> WhenLeios proto (Either WhyNotCertifiable LeiosAnnouncement)
praosStateLeiosAnnouncement PolyPraosState proto
cs
 where
  check :: (LeiosOnly proto Void (),
 (Bool, StrictMaybe EbReferencesAnnouncement), LeiosLedgerView,
 Either WhyNotCertifiable LeiosAnnouncement)
-> Except (PolyPraosValidationErr proto c) ()
check
    ( LeiosOnly proto Void ()
err
      , (Bool
containsCert, StrictMaybe EbReferencesAnnouncement
_mbAnn)
      , MkLeiosLedgerView
          { llvAnnouncementPeriod :: LeiosLedgerView -> Milliseconds32
llvAnnouncementPeriod = Milliseconds32
announcementPeriod
          , llvVotePeriod :: LeiosLedgerView -> Milliseconds32
llvVotePeriod = Milliseconds32
votePeriod
          , llvDiffusionPeriod :: LeiosLedgerView -> Milliseconds32
llvDiffusionPeriod = Milliseconds32
diffusionPeriod
          }
      , Either WhyNotCertifiable LeiosAnnouncement
announcedByPredecessor
      ) =
      Bool
-> Except (PolyPraosValidationErr proto c) ()
-> Except (PolyPraosValidationErr proto c) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
containsCert (Except (PolyPraosValidationErr proto c) ()
 -> Except (PolyPraosValidationErr proto c) ())
-> Except (PolyPraosValidationErr proto c) ()
-> Except (PolyPraosValidationErr proto c) ()
forall a b. (a -> b) -> a -> b
$
        case (Either WhyNotCertifiable LeiosAnnouncement
announcedByPredecessor, PolyPraosState proto -> WithOrigin SlotNo
forall proto. PolyPraosState proto -> WithOrigin SlotNo
praosStateLastSlot PolyPraosState proto
cs) of
          -- A state that announced an endorser block has necessarily applied a
          -- header, so 'Origin' is the same situation as announcing nothing.
          (Either WhyNotCertifiable LeiosAnnouncement
_, WithOrigin SlotNo
Origin) ->
            PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall a.
PolyPraosValidationErr proto c
-> ExceptT (PolyPraosValidationErr proto c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PolyPraosValidationErr proto c
 -> Except (PolyPraosValidationErr proto c) ())
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall a b. (a -> b) -> a -> b
$
              LeiosOnly proto Void ()
-> WhyNotCertifiable
-> WithOrigin SlotNo
-> SlotNo
-> PolyPraosValidationErr proto c
forall proto c.
VoidUnlessLeios proto ()
-> WhyNotCertifiable
-> WithOrigin SlotNo
-> SlotNo
-> PolyPraosValidationErr proto c
LeiosCertWithoutAnnouncement LeiosOnly proto Void ()
err WhyNotCertifiable
NothingAnnounced WithOrigin SlotNo
forall t. WithOrigin t
Origin SlotNo
slot
          (Strict.Left WhyNotCertifiable
why, NotOrigin SlotNo
predecessorSlot) ->
            PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall a.
PolyPraosValidationErr proto c
-> ExceptT (PolyPraosValidationErr proto c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PolyPraosValidationErr proto c
 -> Except (PolyPraosValidationErr proto c) ())
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall a b. (a -> b) -> a -> b
$
              LeiosOnly proto Void ()
-> WhyNotCertifiable
-> WithOrigin SlotNo
-> SlotNo
-> PolyPraosValidationErr proto c
forall proto c.
VoidUnlessLeios proto ()
-> WhyNotCertifiable
-> WithOrigin SlotNo
-> SlotNo
-> PolyPraosValidationErr proto c
LeiosCertWithoutAnnouncement LeiosOnly proto Void ()
err WhyNotCertifiable
why (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
predecessorSlot) SlotNo
slot
          (Strict.Right{}, NotOrigin SlotNo
announcingSlot) -> do
            let earliestAllowed :: SlotNo
earliestAllowed =
                  SlotLength
-> Milliseconds32
-> Milliseconds32
-> Milliseconds32
-> SlotNo
-> SlotNo
Leios.minCertificationSlot
                    ( Identity SlotLength -> SlotLength
forall a. Identity a -> a
runIdentity (Identity SlotLength -> SlotLength)
-> Identity SlotLength -> SlotLength
forall a b. (a -> b) -> a -> b
$
                        EpochInfo Identity -> SlotNo -> Identity SlotLength
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m SlotLength
epochInfoSlotLength
                          (EpochInfo (Except PastHorizonException) -> EpochInfo Identity
History.toPureEpochInfo EpochInfo (Except PastHorizonException)
praosEpochInfo)
                          SlotNo
slot
                    )
                    Milliseconds32
announcementPeriod
                    Milliseconds32
votePeriod
                    Milliseconds32
diffusionPeriod
                    SlotNo
announcingSlot
            Bool
-> Except (PolyPraosValidationErr proto c) ()
-> Except (PolyPraosValidationErr proto c) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SlotNo
slot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
earliestAllowed) (Except (PolyPraosValidationErr proto c) ()
 -> Except (PolyPraosValidationErr proto c) ())
-> Except (PolyPraosValidationErr proto c) ()
-> Except (PolyPraosValidationErr proto c) ()
forall a b. (a -> b) -> a -> b
$
              PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall a.
PolyPraosValidationErr proto c
-> ExceptT (PolyPraosValidationErr proto c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PolyPraosValidationErr proto c
 -> Except (PolyPraosValidationErr proto c) ())
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall a b. (a -> b) -> a -> b
$
                LeiosOnly proto Void ()
-> SlotNo -> SlotNo -> SlotNo -> PolyPraosValidationErr proto c
forall proto c.
VoidUnlessLeios proto ()
-> SlotNo -> SlotNo -> SlotNo -> PolyPraosValidationErr proto c
LeiosCertTooYoung LeiosOnly proto Void ()
err SlotNo
announcingSlot SlotNo
slot SlotNo
earliestAllowed

-- | Check whether this node meets the leader threshold to issue a block.
meetsLeaderThreshold ::
  forall proxy proto c.
  proxy c ->
  PraosParams ->
  Views.PolyPraosLedgerView proto ->
  SL.KeyHash SL.StakePool ->
  VRF.CertifiedVRF (VRF c) InputVRF ->
  Bool
meetsLeaderThreshold :: forall (proxy :: * -> *) proto c.
proxy c
-> PraosParams
-> PolyPraosLedgerView proto
-> KeyHash StakePool
-> CertifiedVRF (VRF c) InputVRF
-> Bool
meetsLeaderThreshold
  proxy c
_prx
  PraosParams
praosParams
  Views.PraosLedgerView{PoolDistr
plvPoolDistr :: forall proto. PolyPraosLedgerView proto -> PoolDistr
plvPoolDistr :: PoolDistr
Views.plvPoolDistr}
  KeyHash StakePool
keyHash
  CertifiedVRF (VRF c) InputVRF
rho =
    BoundedNatural -> Ratio Integer -> ActiveSlotCoeff -> Bool
checkLeaderNatValue
      (Proxy c -> CertifiedVRF (VRF c) InputVRF -> BoundedNatural
forall (proxy :: * -> *) c.
proxy c -> CertifiedVRF (VRF c) InputVRF -> BoundedNatural
vrfLeaderValue (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c) CertifiedVRF (VRF c) InputVRF
rho)
      Ratio Integer
r
      (PraosParams -> ActiveSlotCoeff
praosLeaderF PraosParams
praosParams)
   where
    SL.PoolDistr Map (KeyHash StakePool) IndividualPoolStake
poolDistr NonZero Coin
_totalActiveStake = PoolDistr
plvPoolDistr
    r :: Ratio Integer
r =
      Ratio Integer
-> (IndividualPoolStake -> Ratio Integer)
-> Maybe IndividualPoolStake
-> Ratio Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Ratio Integer
0 IndividualPoolStake -> Ratio Integer
SL.individualPoolStake (Maybe IndividualPoolStake -> Ratio Integer)
-> Maybe IndividualPoolStake -> Ratio Integer
forall a b. (a -> b) -> a -> b
$
        KeyHash StakePool
-> Map (KeyHash StakePool) IndividualPoolStake
-> Maybe IndividualPoolStake
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash StakePool
keyHash Map (KeyHash StakePool) IndividualPoolStake
poolDistr

validateVRFSignature ::
  forall proto c.
  PolyPraosCrypto proto c =>
  Nonce ->
  Views.PolyPraosLedgerView proto ->
  ActiveSlotCoeff ->
  Views.PolyPraosValidateView proto c ->
  Except (PolyPraosValidationErr proto c) ()
validateVRFSignature :: forall proto c.
PolyPraosCrypto proto c =>
Nonce
-> PolyPraosLedgerView proto
-> ActiveSlotCoeff
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
validateVRFSignature Nonce
eta0 (PolyPraosLedgerView proto -> PoolDistr
forall proto. PolyPraosLedgerView proto -> PoolDistr
Views.plvPoolDistr -> SL.PoolDistr Map (KeyHash StakePool) IndividualPoolStake
pd NonZero Coin
_) =
  Nonce
-> Map (KeyHash StakePool) IndividualPoolStake
-> ActiveSlotCoeff
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
forall proto c.
PolyPraosCrypto proto c =>
Nonce
-> Map (KeyHash StakePool) IndividualPoolStake
-> ActiveSlotCoeff
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
doValidateVRFSignature Nonce
eta0 Map (KeyHash StakePool) IndividualPoolStake
pd

-- NOTE: this function is much easier to test than 'validateVRFSignature' because we don't need
-- to construct a 'PraosConfig' nor 'LedgerView' to test it.
doValidateVRFSignature ::
  forall proto c.
  PolyPraosCrypto proto c =>
  Nonce ->
  Map (KeyHash SL.StakePool) SL.IndividualPoolStake ->
  ActiveSlotCoeff ->
  Views.PolyPraosValidateView proto c ->
  Except (PolyPraosValidationErr proto c) ()
doValidateVRFSignature :: forall proto c.
PolyPraosCrypto proto c =>
Nonce
-> Map (KeyHash StakePool) IndividualPoolStake
-> ActiveSlotCoeff
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
doValidateVRFSignature Nonce
eta0 Map (KeyHash StakePool) IndividualPoolStake
pd ActiveSlotCoeff
f PolyPraosValidateView proto c
b = do
  case KeyHash StakePool
-> Map (KeyHash StakePool) IndividualPoolStake
-> Maybe IndividualPoolStake
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash StakePool
hk Map (KeyHash StakePool) IndividualPoolStake
pd of
    Maybe IndividualPoolStake
Nothing -> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall a.
PolyPraosValidationErr proto c
-> ExceptT (PolyPraosValidationErr proto c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PolyPraosValidationErr proto c
 -> Except (PolyPraosValidationErr proto c) ())
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool -> PolyPraosValidationErr proto c
forall proto c. KeyHash StakePool -> PolyPraosValidationErr proto c
VRFKeyUnknown KeyHash StakePool
hk
    Just (SL.IndividualPoolStake{individualPoolStake :: IndividualPoolStake -> Ratio Integer
SL.individualPoolStake = Ratio Integer
sigma, individualPoolStakeVrf :: IndividualPoolStake -> VRFVerKeyHash StakePoolVRF
SL.individualPoolStakeVrf = VRFVerKeyHash StakePoolVRF
vrfHK}) -> do
      let vrfHKStake :: Hash HASH (VerKeyVRF (VRF c))
vrfHKStake = VRFVerKeyHash StakePoolVRF -> Hash HASH (VerKeyVRF (VRF c))
forall (r :: KeyRoleVRF) v.
VRFVerKeyHash r -> Hash HASH (VerKeyVRF v)
SL.fromVRFVerKeyHash VRFVerKeyHash StakePoolVRF
vrfHK
          vrfHKBlock :: Hash HASH (VerKeyVRF (VRF c))
vrfHKBlock = VerKeyVRF (VRF c) -> Hash HASH (VerKeyVRF (VRF c))
forall h.
HashAlgorithm h =>
VerKeyVRF (VRF c) -> Hash h (VerKeyVRF (VRF c))
forall v h.
(VRFAlgorithm v, HashAlgorithm h) =>
VerKeyVRF v -> Hash h (VerKeyVRF v)
VRF.hashVerKeyVRF VerKeyVRF (VRF c)
vrfK
      Hash HASH (VerKeyVRF (VRF c))
vrfHKStake
        Hash HASH (VerKeyVRF (VRF c))
-> Hash HASH (VerKeyVRF (VRF c)) -> Bool
forall a. Eq a => a -> a -> Bool
== Hash HASH (VerKeyVRF (VRF c))
vrfHKBlock
          Bool
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall e. Bool -> e -> Except e ()
?! KeyHash StakePool
-> Hash HASH (VerKeyVRF (VRF c))
-> Hash HASH (VerKeyVRF (VRF c))
-> PolyPraosValidationErr proto c
forall proto c.
KeyHash StakePool
-> Hash HASH (VerKeyVRF (VRF c))
-> Hash HASH (VerKeyVRF (VRF c))
-> PolyPraosValidationErr proto c
VRFKeyWrongVRFKey KeyHash StakePool
hk Hash HASH (VerKeyVRF (VRF c))
vrfHKStake Hash HASH (VerKeyVRF (VRF c))
vrfHKBlock
      ContextVRF (VRF c)
-> VerKeyVRF (VRF c)
-> InputVRF
-> CertifiedVRF (VRF c) InputVRF
-> Bool
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> VerKeyVRF v -> a -> CertifiedVRF v a -> Bool
VRF.verifyCertified
        ()
        VerKeyVRF (VRF c)
vrfK
        (SlotNo -> Nonce -> InputVRF
mkInputVRF SlotNo
slot Nonce
eta0)
        CertifiedVRF (VRF c) InputVRF
vrfCert
        Bool
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall e. Bool -> e -> Except e ()
?! SlotNo
-> Nonce
-> CertifiedVRF (VRF c) InputVRF
-> PolyPraosValidationErr proto c
forall proto c.
SlotNo
-> Nonce
-> CertifiedVRF (VRF c) InputVRF
-> PolyPraosValidationErr proto c
VRFKeyBadProof SlotNo
slot Nonce
eta0 CertifiedVRF (VRF c) InputVRF
vrfCert
      BoundedNatural -> Ratio Integer -> ActiveSlotCoeff -> Bool
checkLeaderNatValue BoundedNatural
vrfLeaderVal Ratio Integer
sigma ActiveSlotCoeff
f
        Bool
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall e. Bool -> e -> Except e ()
?! Natural
-> Ratio Integer
-> ActiveSlotCoeff
-> PolyPraosValidationErr proto c
forall proto c.
Natural
-> Ratio Integer
-> ActiveSlotCoeff
-> PolyPraosValidationErr proto c
VRFLeaderValueTooBig (BoundedNatural -> Natural
bvValue BoundedNatural
vrfLeaderVal) Ratio Integer
sigma ActiveSlotCoeff
f
 where
  hk :: KeyHash StakePool
hk = KeyHash BlockIssuer -> KeyHash StakePool
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole (KeyHash BlockIssuer -> KeyHash StakePool)
-> (PolyPraosValidateView proto c -> KeyHash BlockIssuer)
-> PolyPraosValidateView proto c
-> KeyHash StakePool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey BlockIssuer -> KeyHash BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey BlockIssuer -> KeyHash BlockIssuer)
-> (PolyPraosValidateView proto c -> VKey BlockIssuer)
-> PolyPraosValidateView proto c
-> KeyHash BlockIssuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyPraosValidateView proto c -> VKey BlockIssuer
forall proto crypto.
PolyPraosValidateView proto crypto -> VKey BlockIssuer
Views.hvVK (PolyPraosValidateView proto c -> KeyHash StakePool)
-> PolyPraosValidateView proto c -> KeyHash StakePool
forall a b. (a -> b) -> a -> b
$ PolyPraosValidateView proto c
b
  vrfK :: VerKeyVRF (VRF c)
vrfK = PolyPraosValidateView proto c -> VerKeyVRF (VRF c)
forall proto crypto.
PolyPraosValidateView proto crypto -> VerKeyVRF (VRF crypto)
Views.hvVrfVK PolyPraosValidateView proto c
b
  vrfCert :: CertifiedVRF (VRF c) InputVRF
vrfCert = PolyPraosValidateView proto c -> CertifiedVRF (VRF c) InputVRF
forall proto crypto.
PolyPraosValidateView proto crypto
-> CertifiedVRF (VRF crypto) InputVRF
Views.hvVrfRes PolyPraosValidateView proto c
b
  vrfLeaderVal :: BoundedNatural
vrfLeaderVal = Proxy c -> CertifiedVRF (VRF c) InputVRF -> BoundedNatural
forall (proxy :: * -> *) c.
proxy c -> CertifiedVRF (VRF c) InputVRF -> BoundedNatural
vrfLeaderValue (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c) CertifiedVRF (VRF c) InputVRF
vrfCert
  slot :: SlotNo
slot = PolyPraosValidateView proto c -> SlotNo
forall proto crypto. PolyPraosValidateView proto crypto -> SlotNo
Views.hvSlotNo PolyPraosValidateView proto c
b

validateKESSignature ::
  PolyPraosCrypto proto c =>
  PraosParams ->
  Views.PolyPraosLedgerView proto ->
  Map (KeyHash SL.BlockIssuer) Word64 ->
  Views.PolyPraosValidateView proto c ->
  Except (PolyPraosValidationErr proto c) ()
validateKESSignature :: forall proto c.
PolyPraosCrypto proto c =>
PraosParams
-> PolyPraosLedgerView proto
-> Map (KeyHash BlockIssuer) Word64
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
validateKESSignature
  PraosParams{Word64
praosMaxKESEvo :: PraosParams -> Word64
praosMaxKESEvo :: Word64
praosMaxKESEvo, Word64
praosSlotsPerKESPeriod :: PraosParams -> Word64
praosSlotsPerKESPeriod :: Word64
praosSlotsPerKESPeriod}
  Views.PraosLedgerView{plvPoolDistr :: forall proto. PolyPraosLedgerView proto -> PoolDistr
Views.plvPoolDistr = SL.PoolDistr Map (KeyHash StakePool) IndividualPoolStake
plvPoolDistr NonZero Coin
_totalActiveStake}
  Map (KeyHash BlockIssuer) Word64
ocertCounters =
    Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
forall proto c.
PolyPraosCrypto proto c =>
Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
doValidateKESSignature Word64
praosMaxKESEvo Word64
praosSlotsPerKESPeriod Map (KeyHash StakePool) IndividualPoolStake
plvPoolDistr Map (KeyHash BlockIssuer) Word64
ocertCounters

-- | Whether 'doValidateKESSignature'' enforces the OCERT counter's /upper/
-- bound, i.e. rejects (with 'CounterOverIncrementedOCERT') a counter more than
-- one greater than the one we have recorded for this issuer.
--
-- Normal header validation enforces it ('UpperBoundOCERT'). Validating a
-- relayed Leios announcement out-of-context against a (possibly lagging)
-- immutable tip legitimately sees counters that have run ahead of our recorded
-- view, so that path skips it ('DoNotUpperBoundOCERT'). The counter's /lower/
-- bound ('CounterTooSmallOCERT', a revoked key) is enforced either way.
data WhetherToUpperBoundOCERT
  = UpperBoundOCERT
  | DoNotUpperBoundOCERT
  deriving (WhetherToUpperBoundOCERT -> WhetherToUpperBoundOCERT -> Bool
(WhetherToUpperBoundOCERT -> WhetherToUpperBoundOCERT -> Bool)
-> (WhetherToUpperBoundOCERT -> WhetherToUpperBoundOCERT -> Bool)
-> Eq WhetherToUpperBoundOCERT
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WhetherToUpperBoundOCERT -> WhetherToUpperBoundOCERT -> Bool
== :: WhetherToUpperBoundOCERT -> WhetherToUpperBoundOCERT -> Bool
$c/= :: WhetherToUpperBoundOCERT -> WhetherToUpperBoundOCERT -> Bool
/= :: WhetherToUpperBoundOCERT -> WhetherToUpperBoundOCERT -> Bool
Eq, Int -> WhetherToUpperBoundOCERT -> ShowS
[WhetherToUpperBoundOCERT] -> ShowS
WhetherToUpperBoundOCERT -> String
(Int -> WhetherToUpperBoundOCERT -> ShowS)
-> (WhetherToUpperBoundOCERT -> String)
-> ([WhetherToUpperBoundOCERT] -> ShowS)
-> Show WhetherToUpperBoundOCERT
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WhetherToUpperBoundOCERT -> ShowS
showsPrec :: Int -> WhetherToUpperBoundOCERT -> ShowS
$cshow :: WhetherToUpperBoundOCERT -> String
show :: WhetherToUpperBoundOCERT -> String
$cshowList :: [WhetherToUpperBoundOCERT] -> ShowS
showList :: [WhetherToUpperBoundOCERT] -> ShowS
Show)

-- NOTE: This function is much easier to test than 'validateKESSignature' because we don't need to
-- construct a 'PraosConfig' nor 'LedgerView' to test it.
doValidateKESSignature ::
  PolyPraosCrypto proto c =>
  Word64 ->
  Word64 ->
  Map (KeyHash SL.StakePool) SL.IndividualPoolStake ->
  Map (KeyHash SL.BlockIssuer) Word64 ->
  Views.PolyPraosValidateView proto c ->
  Except (PolyPraosValidationErr proto c) ()
doValidateKESSignature :: forall proto c.
PolyPraosCrypto proto c =>
Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
doValidateKESSignature = WhetherToUpperBoundOCERT
-> Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
forall proto c.
PolyPraosCrypto proto c =>
WhetherToUpperBoundOCERT
-> Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
doValidateKESSignature' WhetherToUpperBoundOCERT
UpperBoundOCERT

-- | 'doValidateKESSignature', parameterized by whether to
-- enforce the OCERT counter's upper bound (see 'WhetherToUpperBoundOCERT').
doValidateKESSignature' ::
  PolyPraosCrypto proto c =>
  WhetherToUpperBoundOCERT ->
  Word64 ->
  Word64 ->
  Map (KeyHash SL.StakePool) SL.IndividualPoolStake ->
  Map (KeyHash SL.BlockIssuer) Word64 ->
  Views.PolyPraosValidateView proto c ->
  Except (PolyPraosValidationErr proto c) ()
doValidateKESSignature' :: forall proto c.
PolyPraosCrypto proto c =>
WhetherToUpperBoundOCERT
-> Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> PolyPraosValidateView proto c
-> Except (PolyPraosValidationErr proto c) ()
doValidateKESSignature' WhetherToUpperBoundOCERT
whetherToUpperBound Word64
praosMaxKESEvo Word64
praosSlotsPerKESPeriod Map (KeyHash StakePool) IndividualPoolStake
stakeDistribution Map (KeyHash BlockIssuer) Word64
ocertCounters PolyPraosValidateView proto c
b =
  do
    KESPeriod
c0 KESPeriod -> KESPeriod -> Bool
forall a. Ord a => a -> a -> Bool
<= KESPeriod
kp Bool
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall e. Bool -> e -> Except e ()
?! KESPeriod -> KESPeriod -> PolyPraosValidationErr proto c
forall proto c.
KESPeriod -> KESPeriod -> PolyPraosValidationErr proto c
KESBeforeStartOCERT KESPeriod
c0 KESPeriod
kp
    Word
kp_ Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
c0_ Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
praosMaxKESEvo Bool
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall e. Bool -> e -> Except e ()
?! KESPeriod -> KESPeriod -> Word64 -> PolyPraosValidationErr proto c
forall proto c.
KESPeriod -> KESPeriod -> Word64 -> PolyPraosValidationErr proto c
KESAfterEndOCERT KESPeriod
kp KESPeriod
c0 Word64
praosMaxKESEvo

    let t :: Word
t = if Word
kp_ Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Word
c0_ then Word
kp_ Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
c0_ else Word
0
    -- this is required to prevent an arithmetic underflow, in the case of kp_ <
    -- c0_ we get the above `KESBeforeStartOCERT` failure in the transition.

    ContextDSIGN DSIGN
-> VerKeyDSIGN DSIGN
-> OCertSignable c
-> SignedDSIGN DSIGN (OCertSignable c)
-> Either String ()
forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v
-> VerKeyDSIGN v -> a -> SignedDSIGN v a -> Either String ()
DSIGN.verifySignedDSIGN () VerKeyDSIGN DSIGN
vkcold (OCert c -> OCertSignable c
forall c. OCert c -> OCertSignable c
OCert.ocertToSignable OCert c
oc) SignedDSIGN DSIGN (OCertSignable c)
tau
      Either String ()
-> (String -> PolyPraosValidationErr proto c)
-> Except (PolyPraosValidationErr proto c) ()
forall e1 a e2. Either e1 a -> (e1 -> e2) -> Except e2 ()
?!: Word64 -> KESPeriod -> String -> PolyPraosValidationErr proto c
forall proto c.
Word64 -> KESPeriod -> String -> PolyPraosValidationErr proto c
InvalidSignatureOCERT Word64
n KESPeriod
c0
    ContextKES (KES c)
-> VerKeyKES (KES c)
-> Word
-> Signed (ShelleyProtocolHeader proto)
-> SignedKES (KES c) (Signed (ShelleyProtocolHeader proto))
-> Either String ()
forall v a.
(KESAlgorithm v, Signable v a) =>
ContextKES v
-> VerKeyKES v -> Word -> a -> SignedKES v a -> Either String ()
KES.verifySignedKES () VerKeyKES (KES c)
vk_hot Word
t (PolyPraosValidateView proto c
-> Signed (ShelleyProtocolHeader proto)
forall proto crypto.
PolyPraosValidateView proto crypto
-> Signed (ShelleyProtocolHeader proto)
Views.hvSigned PolyPraosValidateView proto c
b) (PolyPraosValidateView proto c
-> SignedKES (KES c) (Signed (ShelleyProtocolHeader proto))
forall proto crypto.
PolyPraosValidateView proto crypto
-> SignedKES (KES crypto) (Signed (ShelleyProtocolHeader proto))
Views.hvSignature PolyPraosValidateView proto c
b)
      Either String ()
-> (String -> PolyPraosValidationErr proto c)
-> Except (PolyPraosValidationErr proto c) ()
forall e1 a e2. Either e1 a -> (e1 -> e2) -> Except e2 ()
?!: Word
-> Word
-> Word
-> Word64
-> String
-> PolyPraosValidationErr proto c
forall proto c.
Word
-> Word
-> Word
-> Word64
-> String
-> PolyPraosValidationErr proto c
InvalidKesSignatureOCERT Word
kp_ Word
c0_ Word
t Word64
praosMaxKESEvo

    case Maybe Word64
currentIssueNo of
      Maybe Word64
Nothing -> do
        PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall a.
PolyPraosValidationErr proto c
-> ExceptT (PolyPraosValidationErr proto c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PolyPraosValidationErr proto c
 -> Except (PolyPraosValidationErr proto c) ())
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall a b. (a -> b) -> a -> b
$ KeyHash BlockIssuer -> PolyPraosValidationErr proto c
forall proto c.
KeyHash BlockIssuer -> PolyPraosValidationErr proto c
NoCounterForKeyHashOCERT KeyHash BlockIssuer
hk
      Just Word64
m -> do
        Word64
m Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
n Bool
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall e. Bool -> e -> Except e ()
?! Word64 -> Word64 -> PolyPraosValidationErr proto c
forall proto c. Word64 -> Word64 -> PolyPraosValidationErr proto c
CounterTooSmallOCERT Word64
m Word64
n
        case WhetherToUpperBoundOCERT
whetherToUpperBound of
          WhetherToUpperBoundOCERT
UpperBoundOCERT -> Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
m Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1 Bool
-> PolyPraosValidationErr proto c
-> Except (PolyPraosValidationErr proto c) ()
forall e. Bool -> e -> Except e ()
?! Word64 -> Word64 -> PolyPraosValidationErr proto c
forall proto c. Word64 -> Word64 -> PolyPraosValidationErr proto c
CounterOverIncrementedOCERT Word64
m Word64
n
          WhetherToUpperBoundOCERT
DoNotUpperBoundOCERT -> () -> Except (PolyPraosValidationErr proto c) ()
forall a. a -> ExceptT (PolyPraosValidationErr proto c) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  oc :: OCert c
oc@(OCert VerKeyKES (KES c)
vk_hot Word64
n c0 :: KESPeriod
c0@(KESPeriod Word
c0_) SignedDSIGN DSIGN (OCertSignable c)
tau) = PolyPraosValidateView proto c -> OCert c
forall proto crypto.
PolyPraosValidateView proto crypto -> OCert crypto
Views.hvOCert PolyPraosValidateView proto c
b
  (VKey VerKeyDSIGN DSIGN
vkcold) = PolyPraosValidateView proto c -> VKey BlockIssuer
forall proto crypto.
PolyPraosValidateView proto crypto -> VKey BlockIssuer
Views.hvVK PolyPraosValidateView proto c
b
  SlotNo Word64
s = PolyPraosValidateView proto c -> SlotNo
forall proto crypto. PolyPraosValidateView proto crypto -> SlotNo
Views.hvSlotNo PolyPraosValidateView proto c
b
  hk :: KeyHash BlockIssuer
hk = VKey BlockIssuer -> KeyHash BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey BlockIssuer -> KeyHash BlockIssuer)
-> VKey BlockIssuer -> KeyHash BlockIssuer
forall a b. (a -> b) -> a -> b
$ PolyPraosValidateView proto c -> VKey BlockIssuer
forall proto crypto.
PolyPraosValidateView proto crypto -> VKey BlockIssuer
Views.hvVK PolyPraosValidateView proto c
b
  kp :: KESPeriod
kp@(KESPeriod Word
kp_) =
    if Word64
praosSlotsPerKESPeriod Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
      then String -> KESPeriod
forall a. HasCallStack => String -> a
error String
"kesPeriod: slots per KES period was set to zero"
      else Word -> KESPeriod
KESPeriod (Word -> KESPeriod) -> (Word64 -> Word) -> Word64 -> KESPeriod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> KESPeriod) -> Word64 -> KESPeriod
forall a b. (a -> b) -> a -> b
$ Word64
s Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
praosSlotsPerKESPeriod

  currentIssueNo :: Maybe Word64
  currentIssueNo :: Maybe Word64
currentIssueNo
    | r :: Maybe Word64
r@Just{} <- KeyHash BlockIssuer
-> Map (KeyHash BlockIssuer) Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash BlockIssuer
hk Map (KeyHash BlockIssuer) Word64
ocertCounters =
        Maybe Word64
r
    | KeyHash StakePool
-> Map (KeyHash StakePool) IndividualPoolStake -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (KeyHash BlockIssuer -> KeyHash StakePool
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash BlockIssuer
hk) Map (KeyHash StakePool) IndividualPoolStake
stakeDistribution =
        Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    | Bool
otherwise =
        Maybe Word64
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  CannotForge
-------------------------------------------------------------------------------}

-- | Expresses that, whilst we believe ourselves to be a leader for this slot,
-- we are nonetheless unable to forge a block.
data PraosCannotForge c
  = -- | The KES key in our operational certificate can't be used because the
    -- current (wall clock) period is before the start period of the key.
    -- current KES period.
    --
    -- Note: the opposite case, i.e., the wall clock period being after the
    -- end period of the key, is caught when trying to update the key in
    -- 'updateForgeState'.
    PraosCannotForgeKeyNotUsableYet
      -- | Current KES period according to the wallclock slot, i.e., the KES
      -- period in which we want to use the key.
      !OCert.KESPeriod
      -- | Start KES period of the KES key.
      !OCert.KESPeriod
  deriving (forall x. PraosCannotForge c -> Rep (PraosCannotForge c) x)
-> (forall x. Rep (PraosCannotForge c) x -> PraosCannotForge c)
-> Generic (PraosCannotForge c)
forall x. Rep (PraosCannotForge c) x -> PraosCannotForge c
forall x. PraosCannotForge c -> Rep (PraosCannotForge c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PraosCannotForge c) x -> PraosCannotForge c
forall c x. PraosCannotForge c -> Rep (PraosCannotForge c) x
$cfrom :: forall c x. PraosCannotForge c -> Rep (PraosCannotForge c) x
from :: forall x. PraosCannotForge c -> Rep (PraosCannotForge c) x
$cto :: forall c x. Rep (PraosCannotForge c) x -> PraosCannotForge c
to :: forall x. Rep (PraosCannotForge c) x -> PraosCannotForge c
Generic

deriving instance Crypto c => Show (PraosCannotForge c)

praosCheckCanForge ::
  PraosParams ->
  SlotNo ->
  HotKey.KESInfo ->
  Either (PraosCannotForge c) ()
praosCheckCanForge :: forall c.
PraosParams -> SlotNo -> KESInfo -> Either (PraosCannotForge c) ()
praosCheckCanForge
  PraosParams
praosParams
  SlotNo
curSlot
  KESInfo
kesInfo
    | let startPeriod :: KESPeriod
startPeriod = KESInfo -> KESPeriod
HotKey.kesStartPeriod KESInfo
kesInfo
    , KESPeriod
startPeriod KESPeriod -> KESPeriod -> Bool
forall a. Ord a => a -> a -> Bool
> KESPeriod
wallclockPeriod =
        PraosCannotForge c -> Either (PraosCannotForge c) ()
forall a. PraosCannotForge c -> Either (PraosCannotForge c) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PraosCannotForge c -> Either (PraosCannotForge c) ())
-> PraosCannotForge c -> Either (PraosCannotForge c) ()
forall a b. (a -> b) -> a -> b
$ KESPeriod -> KESPeriod -> PraosCannotForge c
forall c. KESPeriod -> KESPeriod -> PraosCannotForge c
PraosCannotForgeKeyNotUsableYet KESPeriod
wallclockPeriod KESPeriod
startPeriod
    | Bool
otherwise =
        () -> Either (PraosCannotForge c) ()
forall a. a -> Either (PraosCannotForge c) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   where
    -- The current wallclock KES period
    wallclockPeriod :: OCert.KESPeriod
    wallclockPeriod :: KESPeriod
wallclockPeriod =
      Word -> KESPeriod
OCert.KESPeriod (Word -> KESPeriod) -> Word -> KESPeriod
forall a b. (a -> b) -> a -> b
$
        Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word) -> Word64 -> Word
forall a b. (a -> b) -> a -> b
$
          SlotNo -> Word64
unSlotNo SlotNo
curSlot Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` PraosParams -> Word64
praosSlotsPerKESPeriod PraosParams
praosParams

-- | 'getPraosNonces' for every Praos.
getPraosNoncesPolyPraos :: PolyPraosState proto -> PraosNonces
getPraosNoncesPolyPraos :: forall proto. PolyPraosState proto -> PraosNonces
getPraosNoncesPolyPraos PolyPraosState proto
cdst =
  PraosNonces
    { candidateNonce :: Nonce
candidateNonce = Nonce
praosStateCandidateNonce
    , epochNonce :: Nonce
epochNonce = Nonce
praosStateEpochNonce
    , evolvingNonce :: Nonce
evolvingNonce = Nonce
praosStateEvolvingNonce
    , labNonce :: Nonce
labNonce = Nonce
praosStateLabNonce
    , previousLabNonce :: Nonce
previousLabNonce = Nonce
praosStateLastEpochBlockNonce
    }
 where
  PraosState
    { Nonce
praosStateCandidateNonce :: forall proto. PolyPraosState proto -> Nonce
praosStateCandidateNonce :: Nonce
praosStateCandidateNonce
    , Nonce
praosStateEpochNonce :: forall proto. PolyPraosState proto -> Nonce
praosStateEpochNonce :: Nonce
praosStateEpochNonce
    , Nonce
praosStateEvolvingNonce :: forall proto. PolyPraosState proto -> Nonce
praosStateEvolvingNonce :: Nonce
praosStateEvolvingNonce
    , Nonce
praosStateLabNonce :: forall proto. PolyPraosState proto -> Nonce
praosStateLabNonce :: Nonce
praosStateLabNonce
    , Nonce
praosStateLastEpochBlockNonce :: forall proto. PolyPraosState proto -> Nonce
praosStateLastEpochBlockNonce :: Nonce
praosStateLastEpochBlockNonce
    } = PolyPraosState proto
cdst

-- | 'getOpCertCounters' for every Praos.
getOpCertCountersPolyPraos ::
  PolyPraosState proto -> Map (KeyHash SL.BlockIssuer) Word64
getOpCertCountersPolyPraos :: forall proto.
PolyPraosState proto -> Map (KeyHash BlockIssuer) Word64
getOpCertCountersPolyPraos PolyPraosState proto
cdst =
  Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters
 where
  PraosState
    { Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters :: forall proto.
PolyPraosState proto -> Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters :: Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters
    } = PolyPraosState proto
cdst

{-------------------------------------------------------------------------------
  Util
-------------------------------------------------------------------------------}

-- | Check value and raise error if it is false.
(?!) :: Bool -> e -> Except e ()
Bool
a ?! :: forall e. Bool -> e -> Except e ()
?! e
b = Bool -> ExceptT e Identity () -> ExceptT e Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
a (ExceptT e Identity () -> ExceptT e Identity ())
-> ExceptT e Identity () -> ExceptT e Identity ()
forall a b. (a -> b) -> a -> b
$ e -> ExceptT e Identity ()
forall a. e -> ExceptT e Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
b

infix 1 ?!

(?!:) :: Either e1 a -> (e1 -> e2) -> Except e2 ()
(Right a
_) ?!: :: forall e1 a e2. Either e1 a -> (e1 -> e2) -> Except e2 ()
?!: e1 -> e2
_ = () -> ExceptT e2 Identity ()
forall a. a -> ExceptT e2 Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Left e1
e1) ?!: e1 -> e2
f = e2 -> ExceptT e2 Identity ()
forall a. e2 -> ExceptT e2 Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e2 -> ExceptT e2 Identity ()) -> e2 -> ExceptT e2 Identity ()
forall a b. (a -> b) -> a -> b
$ e1 -> e2
f e1
e1

infix 1 ?!: