{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ViewPatterns #-}

module Ouroboros.Consensus.Protocol.Praos
  ( ConsensusConfig (..)
  , Praos
  , PraosCannotForge (..)
  , PraosCrypto
  , PraosFields (..)
  , PraosIsLeader (..)
  , PraosParams (..)
  , PraosState (..)
  , PraosToSign (..)
  , PraosValidationErr (..)
  , Ticked (..)
  , forgePraosFields
  , praosCheckCanForge

    -- * For testing purposes
  , doValidateKESSignature
  , 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, (⭒))
import qualified Cardano.Ledger.BaseTypes as SL
import qualified Cardano.Ledger.Chain as SL
import Cardano.Ledger.Hashes (HASH)
import Cardano.Ledger.Keys
  ( DSIGN
  , KeyHash
  , VKey (VKey)
  , coerceKeyRole
  , hashKey
  )
import qualified Cardano.Ledger.Keys as SL
import Cardano.Ledger.Slot (Duration (Duration), (+*))
import qualified Cardano.Ledger.State as SL
import Cardano.Protocol.Crypto (Crypto, KES, StandardCrypto, VRF)
import qualified Cardano.Protocol.TPraos.API as SL
import Cardano.Protocol.TPraos.BHeader
  ( BoundedNatural (bvValue)
  , checkLeaderNatValue
  , prevHashToNonce
  )
import Cardano.Protocol.TPraos.OCert
  ( KESPeriod (KESPeriod)
  , OCert (OCert)
  , OCertSignable
  )
import qualified Cardano.Protocol.TPraos.OCert as OCert
import qualified Cardano.Protocol.TPraos.Rules.Prtcl as SL
import qualified Cardano.Protocol.TPraos.Rules.Tickn as SL
import Cardano.Slotting.EpochInfo
  ( EpochInfo
  , epochInfoEpoch
  , epochInfoFirst
  , hoistEpochInfo
  )
import Cardano.Slotting.Slot
  ( EpochNo (EpochNo)
  , SlotNo (SlotNo)
  , WithOrigin
  , unSlotNo
  )
import qualified Codec.CBOR.Encoding as CBOR
import Codec.Serialise (Serialise (decode, encode))
import Control.Exception (throw)
import Control.Monad (unless)
import Control.Monad.Except (Except, runExcept, throwError)
import Data.Coerce (coerce)
import Data.Functor.Identity (runIdentity)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (Proxy))
import Data.Word (Word64)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Numeric.Natural (Natural)
import Ouroboros.Consensus.Block (WithOrigin (NotOrigin))
import qualified Ouroboros.Consensus.HardFork.History as History
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.Header (HeaderBody)
import Ouroboros.Consensus.Protocol.Praos.VRF
  ( InputVRF
  , mkInputVRF
  , vrfLeaderValue
  , vrfNonceValue
  )
import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views
import Ouroboros.Consensus.Protocol.TPraos
  ( ConsensusConfig (TPraosConfig, tpraosEpochInfo, tpraosParams)
  , TPraos
  , TPraosState (tpraosStateChainDepState, tpraosStateLastSlot)
  )
import Ouroboros.Consensus.Ticked (Ticked)
import Ouroboros.Consensus.Util.Versioned
  ( VersionDecoder (Decode)
  , decodeVersion
  , encodeVersion
  )

data Praos c

class
  ( Crypto c
  , DSIGN.Signable DSIGN (OCertSignable c)
  , KES.Signable (KES c) (HeaderBody c)
  , VRF.Signable (VRF c) InputVRF
  ) =>
  PraosCrypto c

instance PraosCrypto StandardCrypto

{-------------------------------------------------------------------------------
  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, PraosCrypto c) =>
  NoThunks (PraosFields c toSign)

deriving instance
  (Show toSign, PraosCrypto 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 PraosCrypto c => NoThunks (PraosToSign c)

deriving instance PraosCrypto c => Show (PraosToSign c)

forgePraosFields ::
  ( PraosCrypto c
  , KES.Signable (KES c) toSign
  , Monad m
  ) =>
  HotKey c m ->
  CanBeLeader (Praos c) ->
  IsLeader (Praos c) ->
  (PraosToSign c -> toSign) ->
  m (PraosFields c toSign)
forgePraosFields :: forall c toSign (m :: * -> *).
(PraosCrypto c, Signable (KES c) toSign, Monad m) =>
HotKey c m
-> CanBeLeader (Praos c)
-> IsLeader (Praos 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 PraosCrypto c => NoThunks (PraosIsLeader c)

-- | Static configuration
data instance ConsensusConfig (Praos c) = PraosConfig
  { forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams :: !PraosParams
  , forall c.
ConsensusConfig (Praos c)
-> EpochInfo (Except PastHorizonException)
praosEpochInfo :: !(EpochInfo (Except History.PastHorizonException))
  -- it's useful for this record to be EpochInfo and one other thing,
  -- because the one other thing can then be used as the
  -- PartialConsensConfig in the HFC instance.
  }
  deriving (forall x.
 ConsensusConfig (Praos c) -> Rep (ConsensusConfig (Praos c)) x)
-> (forall x.
    Rep (ConsensusConfig (Praos c)) x -> ConsensusConfig (Praos c))
-> Generic (ConsensusConfig (Praos c))
forall x.
Rep (ConsensusConfig (Praos c)) x -> ConsensusConfig (Praos c)
forall x.
ConsensusConfig (Praos c) -> Rep (ConsensusConfig (Praos c)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (ConsensusConfig (Praos c)) x -> ConsensusConfig (Praos c)
forall c x.
ConsensusConfig (Praos c) -> Rep (ConsensusConfig (Praos c)) x
$cfrom :: forall c x.
ConsensusConfig (Praos c) -> Rep (ConsensusConfig (Praos c)) x
from :: forall x.
ConsensusConfig (Praos c) -> Rep (ConsensusConfig (Praos c)) x
$cto :: forall c x.
Rep (ConsensusConfig (Praos c)) x -> ConsensusConfig (Praos c)
to :: forall x.
Rep (ConsensusConfig (Praos c)) x -> ConsensusConfig (Praos c)
Generic

instance PraosCrypto c => NoThunks (ConsensusConfig (Praos c))

type PraosValidateView c = Views.HeaderView c

instance HasMaxMajorProtVer (Praos c) where
  protoMaxMajorPV :: ConsensusConfig (Praos c) -> MaxMajorProtVer
protoMaxMajorPV = PraosParams -> MaxMajorProtVer
praosMaxMajorPV (PraosParams -> MaxMajorProtVer)
-> (ConsensusConfig (Praos c) -> PraosParams)
-> ConsensusConfig (Praos c)
-> MaxMajorProtVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsensusConfig (Praos c) -> PraosParams
forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams

{-------------------------------------------------------------------------------
  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 PraosState = PraosState
  { PraosState -> WithOrigin SlotNo
praosStateLastSlot :: !(WithOrigin SlotNo)
  , PraosState -> Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters :: !(Map (KeyHash SL.BlockIssuer) Word64)
  -- ^ Operation Certificate counters
  , PraosState -> Nonce
praosStateEvolvingNonce :: !Nonce
  -- ^ Evolving nonce
  , PraosState -> Nonce
praosStateCandidateNonce :: !Nonce
  -- ^ Candidate nonce
  , PraosState -> Nonce
praosStateEpochNonce :: !Nonce
  -- ^ Epoch nonce
  , PraosState -> Nonce
praosStateLabNonce :: !Nonce
  -- ^ Nonce constructed from the hash of the previous block
  , PraosState -> Nonce
praosStateLastEpochBlockNonce :: !Nonce
  -- ^ Nonce corresponding to the LAB nonce of the last block of the previous
  -- epoch
  }
  deriving ((forall x. PraosState -> Rep PraosState x)
-> (forall x. Rep PraosState x -> PraosState) -> Generic PraosState
forall x. Rep PraosState x -> PraosState
forall x. PraosState -> Rep PraosState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PraosState -> Rep PraosState x
from :: forall x. PraosState -> Rep PraosState x
$cto :: forall x. Rep PraosState x -> PraosState
to :: forall x. Rep PraosState x -> PraosState
Generic, Int -> PraosState -> ShowS
[PraosState] -> ShowS
PraosState -> String
(Int -> PraosState -> ShowS)
-> (PraosState -> String)
-> ([PraosState] -> ShowS)
-> Show PraosState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PraosState -> ShowS
showsPrec :: Int -> PraosState -> ShowS
$cshow :: PraosState -> String
show :: PraosState -> String
$cshowList :: [PraosState] -> ShowS
showList :: [PraosState] -> ShowS
Show, PraosState -> PraosState -> Bool
(PraosState -> PraosState -> Bool)
-> (PraosState -> PraosState -> Bool) -> Eq PraosState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PraosState -> PraosState -> Bool
== :: PraosState -> PraosState -> Bool
$c/= :: PraosState -> PraosState -> Bool
/= :: PraosState -> PraosState -> Bool
Eq)

instance NoThunks PraosState

instance ToCBOR PraosState where
  toCBOR :: PraosState -> Encoding
toCBOR = PraosState -> Encoding
forall a. Serialise a => a -> Encoding
encode

instance FromCBOR PraosState where
  fromCBOR :: forall s. Decoder s PraosState
fromCBOR = Decoder s PraosState
forall s. Decoder s PraosState
forall a s. Serialise a => Decoder s a
decode

instance Serialise PraosState where
  encode :: PraosState -> Encoding
encode
    PraosState
      { WithOrigin SlotNo
praosStateLastSlot :: PraosState -> WithOrigin SlotNo
praosStateLastSlot :: WithOrigin SlotNo
praosStateLastSlot
      , Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters :: PraosState -> Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters :: Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters
      , Nonce
praosStateEvolvingNonce :: PraosState -> Nonce
praosStateEvolvingNonce :: Nonce
praosStateEvolvingNonce
      , Nonce
praosStateCandidateNonce :: PraosState -> Nonce
praosStateCandidateNonce :: Nonce
praosStateCandidateNonce
      , Nonce
praosStateEpochNonce :: PraosState -> Nonce
praosStateEpochNonce :: Nonce
praosStateEpochNonce
      , Nonce
praosStateLabNonce :: PraosState -> Nonce
praosStateLabNonce :: Nonce
praosStateLabNonce
      , Nonce
praosStateLastEpochBlockNonce :: PraosState -> Nonce
praosStateLastEpochBlockNonce :: Nonce
praosStateLastEpochBlockNonce
      } =
      VersionNumber -> Encoding -> Encoding
encodeVersion VersionNumber
0 (Encoding -> Encoding) -> Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$
        [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
          [ Word -> Encoding
CBOR.encodeListLen Word
7
          , WithOrigin 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
          , Nonce -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Nonce
praosStateEvolvingNonce
          , Nonce -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Nonce
praosStateCandidateNonce
          , Nonce -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Nonce
praosStateEpochNonce
          , Nonce -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Nonce
praosStateLabNonce
          , Nonce -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Nonce
praosStateLastEpochBlockNonce
          ]

  decode :: forall s. Decoder s PraosState
decode =
    [(VersionNumber, VersionDecoder PraosState)]
-> forall s. Decoder s PraosState
forall a.
[(VersionNumber, VersionDecoder a)] -> forall s. Decoder s a
decodeVersion
      [(VersionNumber
0, (forall s. Decoder s PraosState) -> VersionDecoder PraosState
forall a. (forall s. Decoder s a) -> VersionDecoder a
Decode Decoder s PraosState
forall s. Decoder s PraosState
decodePraosState)]
   where
    decodePraosState :: Decoder s PraosState
decodePraosState = do
      Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"PraosState" Int
7
      WithOrigin SlotNo
-> Map (KeyHash BlockIssuer) Word64
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> PraosState
PraosState
        (WithOrigin SlotNo
 -> Map (KeyHash BlockIssuer) Word64
 -> Nonce
 -> Nonce
 -> Nonce
 -> Nonce
 -> Nonce
 -> PraosState)
-> Decoder s (WithOrigin SlotNo)
-> Decoder
     s
     (Map (KeyHash BlockIssuer) Word64
      -> Nonce -> Nonce -> Nonce -> Nonce -> Nonce -> PraosState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (WithOrigin SlotNo)
forall s. Decoder s (WithOrigin SlotNo)
forall a s. FromCBOR a => Decoder s a
fromCBOR
        Decoder
  s
  (Map (KeyHash BlockIssuer) Word64
   -> Nonce -> Nonce -> Nonce -> Nonce -> Nonce -> PraosState)
-> Decoder s (Map (KeyHash BlockIssuer) Word64)
-> Decoder
     s (Nonce -> Nonce -> Nonce -> Nonce -> Nonce -> PraosState)
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 -> PraosState)
-> Decoder s Nonce
-> Decoder s (Nonce -> Nonce -> Nonce -> Nonce -> PraosState)
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 Nonce
forall s. Decoder s Nonce
forall a s. FromCBOR a => Decoder s a
fromCBOR
        Decoder s (Nonce -> Nonce -> Nonce -> Nonce -> PraosState)
-> Decoder s Nonce
-> Decoder s (Nonce -> Nonce -> Nonce -> PraosState)
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 Nonce
forall s. Decoder s Nonce
forall a s. FromCBOR a => Decoder s a
fromCBOR
        Decoder s (Nonce -> Nonce -> Nonce -> PraosState)
-> Decoder s Nonce -> Decoder s (Nonce -> Nonce -> PraosState)
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 Nonce
forall s. Decoder s Nonce
forall a s. FromCBOR a => Decoder s a
fromCBOR
        Decoder s (Nonce -> Nonce -> PraosState)
-> Decoder s Nonce -> Decoder s (Nonce -> PraosState)
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 Nonce
forall s. Decoder s Nonce
forall a s. FromCBOR a => Decoder s a
fromCBOR
        Decoder s (Nonce -> PraosState)
-> Decoder s Nonce -> Decoder s PraosState
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 Nonce
forall s. Decoder s Nonce
forall a s. FromCBOR a => Decoder s a
fromCBOR

data instance Ticked PraosState = TickedPraosState
  { Ticked PraosState -> PraosState
tickedPraosStateChainDepState :: PraosState
  , Ticked PraosState -> LedgerView
tickedPraosStateLedgerView :: Views.LedgerView
  }

-- | Errors which we might encounter
data PraosValidationErr 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
  deriving (forall x. PraosValidationErr c -> Rep (PraosValidationErr c) x)
-> (forall x. Rep (PraosValidationErr c) x -> PraosValidationErr c)
-> Generic (PraosValidationErr c)
forall x. Rep (PraosValidationErr c) x -> PraosValidationErr c
forall x. PraosValidationErr c -> Rep (PraosValidationErr c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PraosValidationErr c) x -> PraosValidationErr c
forall c x. PraosValidationErr c -> Rep (PraosValidationErr c) x
$cfrom :: forall c x. PraosValidationErr c -> Rep (PraosValidationErr c) x
from :: forall x. PraosValidationErr c -> Rep (PraosValidationErr c) x
$cto :: forall c x. Rep (PraosValidationErr c) x -> PraosValidationErr c
to :: forall x. Rep (PraosValidationErr c) x -> PraosValidationErr c
Generic

deriving instance PraosCrypto c => Eq (PraosValidationErr c)

deriving instance PraosCrypto c => NoThunks (PraosValidationErr c)

deriving instance PraosCrypto c => Show (PraosValidationErr c)

instance PraosCrypto c => ConsensusProtocol (Praos c) where
  type ChainDepState (Praos c) = PraosState
  type IsLeader (Praos c) = PraosIsLeader c
  type CanBeLeader (Praos c) = PraosCanBeLeader c
  type TiebreakerView (Praos c) = PraosTiebreakerView c
  type LedgerView (Praos c) = Views.LedgerView
  type ValidationErr (Praos c) = PraosValidationErr c
  type ValidateView (Praos c) = PraosValidateView c

  protocolSecurityParam :: ConsensusConfig (Praos c) -> SecurityParam
protocolSecurityParam = PraosParams -> SecurityParam
praosSecurityParam (PraosParams -> SecurityParam)
-> (ConsensusConfig (Praos c) -> PraosParams)
-> ConsensusConfig (Praos c)
-> SecurityParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsensusConfig (Praos c) -> PraosParams
forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams

  checkIsLeader :: HasCallStack =>
ConsensusConfig (Praos c)
-> CanBeLeader (Praos c)
-> SlotNo
-> Ticked (ChainDepState (Praos c))
-> Maybe (IsLeader (Praos c))
checkIsLeader
    ConsensusConfig (Praos c)
cfg
    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 (ChainDepState (Praos c))
cs =
      if ConsensusConfig (Praos c)
-> LedgerView (Praos c)
-> KeyHash StakePool
-> CertifiedVRF (VRF c) InputVRF
-> Bool
forall c.
ConsensusConfig (Praos c)
-> LedgerView (Praos c)
-> KeyHash StakePool
-> CertifiedVRF (VRF c) InputVRF
-> Bool
meetsLeaderThreshold ConsensusConfig (Praos c)
cfg LedgerView (Praos c)
LedgerView
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 (IsLeader (Praos c))
Maybe (PraosIsLeader c)
forall a. Maybe a
Nothing
     where
      chainState :: PraosState
chainState = Ticked PraosState -> PraosState
tickedPraosStateChainDepState Ticked (ChainDepState (Praos c))
Ticked PraosState
cs
      lv :: LedgerView
lv = Ticked PraosState -> LedgerView
tickedPraosStateLedgerView Ticked (ChainDepState (Praos c))
Ticked PraosState
cs
      eta0 :: Nonce
eta0 = PraosState -> Nonce
praosStateEpochNonce PraosState
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

  -- 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 two things:
  -- - 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.
  tickChainDepState :: ConsensusConfig (Praos c)
-> LedgerView (Praos c)
-> SlotNo
-> ChainDepState (Praos c)
-> Ticked (ChainDepState (Praos c))
tickChainDepState
    PraosConfig{EpochInfo (Except PastHorizonException)
praosEpochInfo :: forall c.
ConsensusConfig (Praos c)
-> EpochInfo (Except PastHorizonException)
praosEpochInfo :: EpochInfo (Except PastHorizonException)
praosEpochInfo}
    LedgerView (Praos c)
lv
    SlotNo
slot
    ChainDepState (Praos c)
st =
      TickedPraosState
        { tickedPraosStateChainDepState :: PraosState
tickedPraosStateChainDepState = PraosState
st'
        , tickedPraosStateLedgerView :: LedgerView
tickedPraosStateLedgerView = LedgerView (Praos c)
LedgerView
lv
        }
     where
      newEpoch :: Bool
newEpoch =
        EpochInfo Identity -> WithOrigin SlotNo -> SlotNo -> Bool
isNewEpoch
          (EpochInfo (Except PastHorizonException) -> EpochInfo Identity
History.toPureEpochInfo EpochInfo (Except PastHorizonException)
praosEpochInfo)
          (PraosState -> WithOrigin SlotNo
praosStateLastSlot ChainDepState (Praos c)
PraosState
st)
          SlotNo
slot
      st' :: PraosState
st' =
        if Bool
newEpoch
          then
            ChainDepState (Praos c)
st
              { praosStateEpochNonce =
                  praosStateCandidateNonce st
                    ⭒ praosStateLastEpochBlockNonce st
              , praosStateLastEpochBlockNonce = praosStateLabNonce st
              }
          else ChainDepState (Praos c)
PraosState
st

  -- 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'
  --
  updateChainDepState :: HasCallStack =>
ConsensusConfig (Praos c)
-> ValidateView (Praos c)
-> SlotNo
-> Ticked (ChainDepState (Praos c))
-> Except (ValidationErr (Praos c)) (ChainDepState (Praos c))
updateChainDepState
    cfg :: ConsensusConfig (Praos c)
cfg@( PraosConfig
            PraosParams{ActiveSlotCoeff
praosLeaderF :: PraosParams -> ActiveSlotCoeff
praosLeaderF :: ActiveSlotCoeff
praosLeaderF}
            EpochInfo (Except PastHorizonException)
_
          )
    ValidateView (Praos c)
b
    SlotNo
slot
    Ticked (ChainDepState (Praos c))
tcs = do
      -- First, we check the KES signature, which validates that the issuer is
      -- in fact who they say they are.
      ConsensusConfig (Praos c)
-> LedgerView (Praos c)
-> Map (KeyHash BlockIssuer) Word64
-> HeaderView c
-> Except (PraosValidationErr c) ()
forall c.
PraosCrypto c =>
ConsensusConfig (Praos c)
-> LedgerView (Praos c)
-> Map (KeyHash BlockIssuer) Word64
-> HeaderView c
-> Except (PraosValidationErr c) ()
validateKESSignature ConsensusConfig (Praos c)
cfg LedgerView (Praos c)
LedgerView
lv (PraosState -> Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters PraosState
cs) ValidateView (Praos c)
HeaderView c
b
      -- Then we examing the VRF proof, which confirms that they have the
      -- right to issue in this slot.
      Nonce
-> LedgerView
-> ActiveSlotCoeff
-> HeaderView c
-> Except (PraosValidationErr c) ()
forall c.
PraosCrypto c =>
Nonce
-> LedgerView
-> ActiveSlotCoeff
-> HeaderView c
-> Except (PraosValidationErr c) ()
validateVRFSignature (PraosState -> Nonce
praosStateEpochNonce PraosState
cs) LedgerView
lv ActiveSlotCoeff
praosLeaderF ValidateView (Praos c)
HeaderView c
b
      -- Finally, we apply the changes from this header to the chain state.
      PraosState -> ExceptT (PraosValidationErr c) Identity PraosState
forall a. a -> ExceptT (PraosValidationErr c) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PraosState -> ExceptT (PraosValidationErr c) Identity PraosState)
-> PraosState -> ExceptT (PraosValidationErr c) Identity PraosState
forall a b. (a -> b) -> a -> b
$ ConsensusConfig (Praos c)
-> ValidateView (Praos c)
-> SlotNo
-> Ticked (ChainDepState (Praos c))
-> ChainDepState (Praos c)
forall p.
(ConsensusProtocol p, HasCallStack) =>
ConsensusConfig p
-> ValidateView p
-> SlotNo
-> Ticked (ChainDepState p)
-> ChainDepState p
reupdateChainDepState ConsensusConfig (Praos c)
cfg ValidateView (Praos c)
b SlotNo
slot Ticked (ChainDepState (Praos c))
tcs
     where
      lv :: LedgerView
lv = Ticked PraosState -> LedgerView
tickedPraosStateLedgerView Ticked (ChainDepState (Praos c))
Ticked PraosState
tcs
      cs :: PraosState
cs = Ticked PraosState -> PraosState
tickedPraosStateChainDepState Ticked (ChainDepState (Praos c))
Ticked PraosState
tcs

  -- 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.
  reupdateChainDepState :: HasCallStack =>
ConsensusConfig (Praos c)
-> ValidateView (Praos c)
-> SlotNo
-> Ticked (ChainDepState (Praos c))
-> ChainDepState (Praos c)
reupdateChainDepState
    _cfg :: ConsensusConfig (Praos c)
_cfg@( PraosConfig
             PraosParams{Word64
praosRandomnessStabilisationWindow :: PraosParams -> Word64
praosRandomnessStabilisationWindow :: Word64
praosRandomnessStabilisationWindow}
             EpochInfo (Except PastHorizonException)
ei
           )
    ValidateView (Praos c)
b
    SlotNo
slot
    Ticked (ChainDepState (Praos c))
tcs =
      PraosState
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
        }
     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 :: PraosState
cs = Ticked PraosState -> PraosState
tickedPraosStateChainDepState Ticked (ChainDepState (Praos c))
Ticked PraosState
tcs
      eta :: Nonce
eta = Proxy c -> CertifiedVRF (VRF c) InputVRF -> Nonce
forall c (proxy :: * -> *).
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
$ HeaderView c -> CertifiedVRF (VRF c) InputVRF
forall crypto.
HeaderView crypto -> CertifiedVRF (VRF crypto) InputVRF
Views.hvVrfRes ValidateView (Praos c)
HeaderView c
b
      newEvolvingNonce :: Nonce
newEvolvingNonce = PraosState -> Nonce
praosStateEvolvingNonce PraosState
cs Nonce -> Nonce -> Nonce
⭒ Nonce
eta
      OCert VerKeyKES (KES c)
_ Word64
n KESPeriod
_ SignedDSIGN DSIGN (OCertSignable c)
_ = HeaderView c -> OCert c
forall crypto. HeaderView crypto -> OCert crypto
Views.hvOCert ValidateView (Praos c)
HeaderView 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
$ HeaderView c -> VKey BlockIssuer
forall crypto. HeaderView crypto -> VKey BlockIssuer
Views.hvVK ValidateView (Praos c)
HeaderView c
b

-- | Check whether this node meets the leader threshold to issue a block.
meetsLeaderThreshold ::
  forall c.
  ConsensusConfig (Praos c) ->
  LedgerView (Praos c) ->
  SL.KeyHash SL.StakePool ->
  VRF.CertifiedVRF (VRF c) InputVRF ->
  Bool
meetsLeaderThreshold :: forall c.
ConsensusConfig (Praos c)
-> LedgerView (Praos c)
-> KeyHash StakePool
-> CertifiedVRF (VRF c) InputVRF
-> Bool
meetsLeaderThreshold
  PraosConfig{PraosParams
praosParams :: forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams :: PraosParams
praosParams}
  Views.LedgerView{PoolDistr
lvPoolDistr :: PoolDistr
lvPoolDistr :: LedgerView -> PoolDistr
Views.lvPoolDistr}
  KeyHash StakePool
keyHash
  CertifiedVRF (VRF c) InputVRF
rho =
    BoundedNatural -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderNatValue
      (Proxy c -> CertifiedVRF (VRF c) InputVRF -> BoundedNatural
forall c (proxy :: * -> *).
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)
      Rational
r
      (PraosParams -> ActiveSlotCoeff
praosLeaderF PraosParams
praosParams)
   where
    SL.PoolDistr Map (KeyHash StakePool) IndividualPoolStake
poolDistr NonZero Coin
_totalActiveStake = PoolDistr
lvPoolDistr
    r :: Rational
r =
      Rational
-> (IndividualPoolStake -> Rational)
-> Maybe IndividualPoolStake
-> Rational
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rational
0 IndividualPoolStake -> Rational
SL.individualPoolStake (Maybe IndividualPoolStake -> Rational)
-> Maybe IndividualPoolStake -> Rational
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 c.
  PraosCrypto c =>
  Nonce ->
  Views.LedgerView ->
  ActiveSlotCoeff ->
  Views.HeaderView c ->
  Except (PraosValidationErr c) ()
validateVRFSignature :: forall c.
PraosCrypto c =>
Nonce
-> LedgerView
-> ActiveSlotCoeff
-> HeaderView c
-> Except (PraosValidationErr c) ()
validateVRFSignature Nonce
eta0 (LedgerView -> PoolDistr
Views.lvPoolDistr -> SL.PoolDistr Map (KeyHash StakePool) IndividualPoolStake
pd NonZero Coin
_) =
  Nonce
-> Map (KeyHash StakePool) IndividualPoolStake
-> ActiveSlotCoeff
-> HeaderView c
-> Except (PraosValidationErr c) ()
forall c.
PraosCrypto c =>
Nonce
-> Map (KeyHash StakePool) IndividualPoolStake
-> ActiveSlotCoeff
-> HeaderView c
-> Except (PraosValidationErr 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 c.
  PraosCrypto c =>
  Nonce ->
  Map (KeyHash SL.StakePool) SL.IndividualPoolStake ->
  ActiveSlotCoeff ->
  Views.HeaderView c ->
  Except (PraosValidationErr c) ()
doValidateVRFSignature :: forall c.
PraosCrypto c =>
Nonce
-> Map (KeyHash StakePool) IndividualPoolStake
-> ActiveSlotCoeff
-> HeaderView c
-> Except (PraosValidationErr c) ()
doValidateVRFSignature Nonce
eta0 Map (KeyHash StakePool) IndividualPoolStake
pd ActiveSlotCoeff
f HeaderView 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 -> PraosValidationErr c -> Except (PraosValidationErr c) ()
forall a.
PraosValidationErr c -> ExceptT (PraosValidationErr c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PraosValidationErr c -> Except (PraosValidationErr c) ())
-> PraosValidationErr c -> Except (PraosValidationErr c) ()
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool -> PraosValidationErr c
forall c. KeyHash StakePool -> PraosValidationErr c
VRFKeyUnknown KeyHash StakePool
hk
    Just (SL.IndividualPoolStake Rational
sigma CompactForm Coin
_totalPoolStake 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 -> PraosValidationErr c -> Except (PraosValidationErr c) ()
forall e. Bool -> e -> Except e ()
?! KeyHash StakePool
-> Hash HASH (VerKeyVRF (VRF c))
-> Hash HASH (VerKeyVRF (VRF c))
-> PraosValidationErr c
forall c.
KeyHash StakePool
-> Hash HASH (VerKeyVRF (VRF c))
-> Hash HASH (VerKeyVRF (VRF c))
-> PraosValidationErr 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 -> PraosValidationErr c -> Except (PraosValidationErr c) ()
forall e. Bool -> e -> Except e ()
?! SlotNo
-> Nonce -> CertifiedVRF (VRF c) InputVRF -> PraosValidationErr c
forall c.
SlotNo
-> Nonce -> CertifiedVRF (VRF c) InputVRF -> PraosValidationErr c
VRFKeyBadProof SlotNo
slot Nonce
eta0 CertifiedVRF (VRF c) InputVRF
vrfCert
      BoundedNatural -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderNatValue BoundedNatural
vrfLeaderVal Rational
sigma ActiveSlotCoeff
f
        Bool -> PraosValidationErr c -> Except (PraosValidationErr c) ()
forall e. Bool -> e -> Except e ()
?! Natural -> Rational -> ActiveSlotCoeff -> PraosValidationErr c
forall c.
Natural -> Rational -> ActiveSlotCoeff -> PraosValidationErr c
VRFLeaderValueTooBig (BoundedNatural -> Natural
bvValue BoundedNatural
vrfLeaderVal) Rational
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)
-> (HeaderView c -> KeyHash BlockIssuer)
-> HeaderView 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)
-> (HeaderView c -> VKey BlockIssuer)
-> HeaderView c
-> KeyHash BlockIssuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderView c -> VKey BlockIssuer
forall crypto. HeaderView crypto -> VKey BlockIssuer
Views.hvVK (HeaderView c -> KeyHash StakePool)
-> HeaderView c -> KeyHash StakePool
forall a b. (a -> b) -> a -> b
$ HeaderView c
b
  vrfK :: VerKeyVRF (VRF c)
vrfK = HeaderView c -> VerKeyVRF (VRF c)
forall crypto. HeaderView crypto -> VerKeyVRF (VRF crypto)
Views.hvVrfVK HeaderView c
b
  vrfCert :: CertifiedVRF (VRF c) InputVRF
vrfCert = HeaderView c -> CertifiedVRF (VRF c) InputVRF
forall crypto.
HeaderView crypto -> CertifiedVRF (VRF crypto) InputVRF
Views.hvVrfRes HeaderView c
b
  vrfLeaderVal :: BoundedNatural
vrfLeaderVal = Proxy c -> CertifiedVRF (VRF c) InputVRF -> BoundedNatural
forall c (proxy :: * -> *).
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 = HeaderView c -> SlotNo
forall crypto. HeaderView crypto -> SlotNo
Views.hvSlotNo HeaderView c
b

validateKESSignature ::
  PraosCrypto c =>
  ConsensusConfig (Praos c) ->
  LedgerView (Praos c) ->
  Map (KeyHash SL.BlockIssuer) Word64 ->
  Views.HeaderView c ->
  Except (PraosValidationErr c) ()
validateKESSignature :: forall c.
PraosCrypto c =>
ConsensusConfig (Praos c)
-> LedgerView (Praos c)
-> Map (KeyHash BlockIssuer) Word64
-> HeaderView c
-> Except (PraosValidationErr c) ()
validateKESSignature
  _cfg :: ConsensusConfig (Praos c)
_cfg@( PraosConfig
           PraosParams{Word64
praosMaxKESEvo :: PraosParams -> Word64
praosMaxKESEvo :: Word64
praosMaxKESEvo, Word64
praosSlotsPerKESPeriod :: PraosParams -> Word64
praosSlotsPerKESPeriod :: Word64
praosSlotsPerKESPeriod}
           EpochInfo (Except PastHorizonException)
_ei
         )
  Views.LedgerView{lvPoolDistr :: LedgerView -> PoolDistr
Views.lvPoolDistr = SL.PoolDistr Map (KeyHash StakePool) IndividualPoolStake
lvPoolDistr NonZero Coin
_totalActiveStake}
  Map (KeyHash BlockIssuer) Word64
ocertCounters =
    Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> HeaderView c
-> Except (PraosValidationErr c) ()
forall c.
PraosCrypto c =>
Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> HeaderView c
-> Except (PraosValidationErr c) ()
doValidateKESSignature Word64
praosMaxKESEvo Word64
praosSlotsPerKESPeriod Map (KeyHash StakePool) IndividualPoolStake
lvPoolDistr Map (KeyHash BlockIssuer) Word64
ocertCounters

-- 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 ::
  PraosCrypto c =>
  Word64 ->
  Word64 ->
  Map (KeyHash SL.StakePool) SL.IndividualPoolStake ->
  Map (KeyHash SL.BlockIssuer) Word64 ->
  Views.HeaderView c ->
  Except (PraosValidationErr c) ()
doValidateKESSignature :: forall c.
PraosCrypto c =>
Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> HeaderView c
-> Except (PraosValidationErr c) ()
doValidateKESSignature Word64
praosMaxKESEvo Word64
praosSlotsPerKESPeriod Map (KeyHash StakePool) IndividualPoolStake
stakeDistribution Map (KeyHash BlockIssuer) Word64
ocertCounters HeaderView c
b =
  do
    KESPeriod
c0 KESPeriod -> KESPeriod -> Bool
forall a. Ord a => a -> a -> Bool
<= KESPeriod
kp Bool -> PraosValidationErr c -> Except (PraosValidationErr c) ()
forall e. Bool -> e -> Except e ()
?! KESPeriod -> KESPeriod -> PraosValidationErr c
forall c. KESPeriod -> KESPeriod -> PraosValidationErr 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 -> PraosValidationErr c -> Except (PraosValidationErr c) ()
forall e. Bool -> e -> Except e ()
?! KESPeriod -> KESPeriod -> Word64 -> PraosValidationErr c
forall c. KESPeriod -> KESPeriod -> Word64 -> PraosValidationErr 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 -> PraosValidationErr c)
-> Except (PraosValidationErr c) ()
forall e1 a e2. Either e1 a -> (e1 -> e2) -> Except e2 ()
?!: Word64 -> KESPeriod -> String -> PraosValidationErr c
forall c. Word64 -> KESPeriod -> String -> PraosValidationErr c
InvalidSignatureOCERT Word64
n KESPeriod
c0
    ContextKES (KES c)
-> VerKeyKES (KES c)
-> Word
-> HeaderBody c
-> SignedKES (KES c) (HeaderBody c)
-> 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 (HeaderView c -> HeaderBody c
forall crypto. HeaderView crypto -> HeaderBody crypto
Views.hvSigned HeaderView c
b) (HeaderView c -> SignedKES (KES c) (HeaderBody c)
forall crypto.
HeaderView crypto -> SignedKES (KES crypto) (HeaderBody crypto)
Views.hvSignature HeaderView c
b)
      Either String ()
-> (String -> PraosValidationErr c)
-> Except (PraosValidationErr c) ()
forall e1 a e2. Either e1 a -> (e1 -> e2) -> Except e2 ()
?!: Word -> Word -> Word -> Word64 -> String -> PraosValidationErr c
forall c.
Word -> Word -> Word -> Word64 -> String -> PraosValidationErr c
InvalidKesSignatureOCERT Word
kp_ Word
c0_ Word
t Word64
praosMaxKESEvo

    case Maybe Word64
currentIssueNo of
      Maybe Word64
Nothing -> do
        PraosValidationErr c -> Except (PraosValidationErr c) ()
forall a.
PraosValidationErr c -> ExceptT (PraosValidationErr c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PraosValidationErr c -> Except (PraosValidationErr c) ())
-> PraosValidationErr c -> Except (PraosValidationErr c) ()
forall a b. (a -> b) -> a -> b
$ KeyHash BlockIssuer -> PraosValidationErr c
forall c. KeyHash BlockIssuer -> PraosValidationErr c
NoCounterForKeyHashOCERT KeyHash BlockIssuer
hk
      Just Word64
m -> do
        Word64
m Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
n Bool -> PraosValidationErr c -> Except (PraosValidationErr c) ()
forall e. Bool -> e -> Except e ()
?! Word64 -> Word64 -> PraosValidationErr c
forall c. Word64 -> Word64 -> PraosValidationErr c
CounterTooSmallOCERT Word64
m Word64
n
        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 -> PraosValidationErr c -> Except (PraosValidationErr c) ()
forall e. Bool -> e -> Except e ()
?! Word64 -> Word64 -> PraosValidationErr c
forall c. Word64 -> Word64 -> PraosValidationErr c
CounterOverIncrementedOCERT Word64
m Word64
n
 where
  oc :: OCert c
oc@(OCert VerKeyKES (KES c)
vk_hot Word64
n c0 :: KESPeriod
c0@(KESPeriod Word
c0_) SignedDSIGN DSIGN (OCertSignable c)
tau) = HeaderView c -> OCert c
forall crypto. HeaderView crypto -> OCert crypto
Views.hvOCert HeaderView c
b
  (VKey VerKeyDSIGN DSIGN
vkcold) = HeaderView c -> VKey BlockIssuer
forall crypto. HeaderView crypto -> VKey BlockIssuer
Views.hvVK HeaderView c
b
  SlotNo Word64
s = HeaderView c -> SlotNo
forall crypto. HeaderView crypto -> SlotNo
Views.hvSlotNo HeaderView 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
$ HeaderView c -> VKey BlockIssuer
forall crypto. HeaderView crypto -> VKey BlockIssuer
Views.hvVK HeaderView 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 PraosCrypto c => Show (PraosCannotForge c)

praosCheckCanForge ::
  ConsensusConfig (Praos c) ->
  SlotNo ->
  HotKey.KESInfo ->
  Either (PraosCannotForge c) ()
praosCheckCanForge :: forall c.
ConsensusConfig (Praos c)
-> SlotNo -> KESInfo -> Either (PraosCannotForge c) ()
praosCheckCanForge
  PraosConfig{PraosParams
praosParams :: forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams :: 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

{-------------------------------------------------------------------------------
  PraosProtocolSupportsNode
-------------------------------------------------------------------------------}

instance PraosCrypto c => PraosProtocolSupportsNode (Praos c) where
  type PraosProtocolSupportsNodeCrypto (Praos c) = c

  getPraosNonces :: forall (proxy :: * -> *).
proxy (Praos c) -> ChainDepState (Praos c) -> PraosNonces
getPraosNonces proxy (Praos c)
_prx ChainDepState (Praos c)
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 :: PraosState -> Nonce
praosStateCandidateNonce :: Nonce
praosStateCandidateNonce
      , Nonce
praosStateEpochNonce :: PraosState -> Nonce
praosStateEpochNonce :: Nonce
praosStateEpochNonce
      , Nonce
praosStateEvolvingNonce :: PraosState -> Nonce
praosStateEvolvingNonce :: Nonce
praosStateEvolvingNonce
      , Nonce
praosStateLabNonce :: PraosState -> Nonce
praosStateLabNonce :: Nonce
praosStateLabNonce
      , Nonce
praosStateLastEpochBlockNonce :: PraosState -> Nonce
praosStateLastEpochBlockNonce :: Nonce
praosStateLastEpochBlockNonce
      } = ChainDepState (Praos c)
cdst

  getOpCertCounters :: forall (proxy :: * -> *).
proxy (Praos c)
-> ChainDepState (Praos c) -> Map (KeyHash BlockIssuer) Word64
getOpCertCounters proxy (Praos c)
_prx ChainDepState (Praos c)
cdst =
    Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters
   where
    PraosState
      { Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters :: PraosState -> Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters :: Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters
      } = ChainDepState (Praos c)
cdst

{-------------------------------------------------------------------------------
  Translation from transitional Praos
-------------------------------------------------------------------------------}

-- | We can translate between TPraos and Praos, provided:
--
-- - They share the same HASH algorithm
-- - They share the same ADDRHASH algorithm
-- - They share the same DSIGN verification keys
-- - They share the same VRF verification keys
instance TranslateProto (TPraos c) (Praos c) where
  translateLedgerView :: Proxy (TPraos c, Praos c)
-> LedgerView (TPraos c) -> LedgerView (Praos c)
translateLedgerView Proxy (TPraos c, Praos c)
_ SL.LedgerView{PoolDistr
lvPoolDistr :: PoolDistr
lvPoolDistr :: LedgerView -> PoolDistr
SL.lvPoolDistr, ChainChecksPParams
lvChainChecks :: ChainChecksPParams
lvChainChecks :: LedgerView -> ChainChecksPParams
SL.lvChainChecks} =
    Views.LedgerView
      { lvPoolDistr :: PoolDistr
Views.lvPoolDistr = PoolDistr
lvPoolDistr
      , lvMaxHeaderSize :: Word16
Views.lvMaxHeaderSize = ChainChecksPParams -> Word16
SL.ccMaxBHSize ChainChecksPParams
lvChainChecks
      , lvMaxBodySize :: Word32
Views.lvMaxBodySize = ChainChecksPParams -> Word32
SL.ccMaxBBSize ChainChecksPParams
lvChainChecks
      , lvProtocolVersion :: ProtVer
Views.lvProtocolVersion = ChainChecksPParams -> ProtVer
SL.ccProtocolVersion ChainChecksPParams
lvChainChecks
      }

  translateChainDepState :: Proxy (TPraos c, Praos c)
-> ChainDepState (TPraos c) -> ChainDepState (Praos c)
translateChainDepState Proxy (TPraos c, Praos c)
_ ChainDepState (TPraos c)
tpState =
    PraosState
      { praosStateLastSlot :: WithOrigin SlotNo
praosStateLastSlot = TPraosState -> WithOrigin SlotNo
tpraosStateLastSlot ChainDepState (TPraos c)
TPraosState
tpState
      , praosStateOCertCounters :: Map (KeyHash BlockIssuer) Word64
praosStateOCertCounters = (KeyHash BlockIssuer -> KeyHash BlockIssuer)
-> Map (KeyHash BlockIssuer) Word64
-> Map (KeyHash BlockIssuer) Word64
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic KeyHash BlockIssuer -> KeyHash BlockIssuer
forall a b. Coercible a b => a -> b
coerce Map (KeyHash BlockIssuer) Word64
certCounters
      , praosStateEvolvingNonce :: Nonce
praosStateEvolvingNonce = Nonce
evolvingNonce
      , praosStateCandidateNonce :: Nonce
praosStateCandidateNonce = Nonce
candidateNonce
      , praosStateEpochNonce :: Nonce
praosStateEpochNonce = TicknState -> Nonce
SL.ticknStateEpochNonce TicknState
csTickn
      , praosStateLabNonce :: Nonce
praosStateLabNonce = Nonce
csLabNonce
      , praosStateLastEpochBlockNonce :: Nonce
praosStateLastEpochBlockNonce = TicknState -> Nonce
SL.ticknStatePrevHashNonce TicknState
csTickn
      }
   where
    SL.ChainDepState{PrtclState
csProtocol :: PrtclState
csProtocol :: ChainDepState -> PrtclState
SL.csProtocol, TicknState
csTickn :: TicknState
csTickn :: ChainDepState -> TicknState
SL.csTickn, Nonce
csLabNonce :: Nonce
csLabNonce :: ChainDepState -> Nonce
SL.csLabNonce} =
      TPraosState -> ChainDepState
tpraosStateChainDepState ChainDepState (TPraos c)
TPraosState
tpState
    SL.PrtclState Map (KeyHash BlockIssuer) Word64
certCounters Nonce
evolvingNonce Nonce
candidateNonce =
      PrtclState
csProtocol

{-------------------------------------------------------------------------------
  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 ?!: