{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}

-- | Transitional Praos.
--
--   Transitional praos allows for the overlaying of Praos with an overlay
--   schedule determining slots to be produced by BFT
module Ouroboros.Consensus.Protocol.TPraos (
    MaxMajorProtVer (..)
  , PraosChainSelectView (..)
  , TPraos
  , TPraosFields (..)
  , TPraosIsLeader (..)
  , TPraosParams (..)
  , TPraosState (..)
  , TPraosToSign (..)
  , TPraosValidateView
  , forgeTPraosFields
  , mkShelleyGlobals
  , mkTPraosParams
    -- * Crypto
  , SL.PraosCrypto
  , StandardCrypto
    -- * CannotForge
  , TPraosCannotForge (..)
  , tpraosCheckCanForge
    -- * Type instances
  , ConsensusConfig (..)
  , Ticked (..)
  ) where

import           Cardano.Binary (FromCBOR (..), ToCBOR (..), enforceSize)
import qualified Cardano.Crypto.Hash as Hash
import qualified Cardano.Crypto.KES as KES
import qualified Cardano.Crypto.VRF as VRF
import qualified Cardano.Ledger.BaseTypes as SL (ActiveSlotCoeff, Seed)
import           Cardano.Ledger.BaseTypes.NonZero (nonZeroOr, unNonZero)
import           Cardano.Ledger.Hashes (HASH)
import qualified Cardano.Ledger.Keys as SL
import qualified Cardano.Ledger.Shelley.API as SL
import           Cardano.Protocol.Crypto (KES, StandardCrypto, VRF)
import qualified Cardano.Protocol.TPraos.API as SL
import qualified Cardano.Protocol.TPraos.BHeader as SL
import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..))
import qualified Cardano.Protocol.TPraos.OCert as SL
import qualified Cardano.Protocol.TPraos.Rules.Overlay as SL
import qualified Cardano.Protocol.TPraos.Rules.Prtcl as SL
import qualified Cardano.Protocol.TPraos.Rules.Tickn as SL
import           Cardano.Slotting.EpochInfo
import           Cardano.Slotting.Time (SystemStart (..))
import qualified Codec.CBOR.Encoding as CBOR
import           Codec.Serialise (Serialise (..))
import           Control.Monad.Except (Except, runExcept, throwError,
                     withExceptT)
import           Data.Coerce (coerce)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T (pack)
import           Data.Word (Word64)
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks (..))
import           Numeric.Natural (Natural)
import           Ouroboros.Consensus.Block
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
import           Ouroboros.Consensus.Protocol.Praos.Common
import           Ouroboros.Consensus.Ticked
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.Versioned

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

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

deriving instance (NoThunks toSign, SL.PraosCrypto c)
  => NoThunks (TPraosFields c toSign)
deriving instance (Show toSign, SL.PraosCrypto c)
  => Show (TPraosFields c toSign)

-- | Fields arising from transitional praos execution which must be included in
-- the block signature.
data TPraosToSign c = TPraosToSign {
      -- | Verification key for the issuer of this block.
      --
      -- Note that unlike in Classic/BFT where we have a key for the genesis
      -- delegate on whose behalf we are issuing this block, this key
      -- corresponds to the stake pool/core node actually forging the block.
      forall c. TPraosToSign c -> VKey 'BlockIssuer
tpraosToSignIssuerVK :: SL.VKey 'SL.BlockIssuer
    , forall c. TPraosToSign c -> VerKeyVRF (VRF c)
tpraosToSignVrfVK    :: VRF.VerKeyVRF (VRF c)
      -- | Verifiable result containing the updated nonce value.
    , forall c. TPraosToSign c -> CertifiedVRF (VRF c) Nonce
tpraosToSignEta      :: VRF.CertifiedVRF (VRF c) SL.Nonce
      -- | Verifiable proof of the leader value, used to determine whether the
      -- node has the right to issue a block in this slot.
      --
      -- We include a value here even for blocks forged under the BFT
      -- schedule. It is not required that such a value be verifiable (though
      -- by default it will be verifiably correct, but unused.)
    , forall c. TPraosToSign c -> CertifiedVRF (VRF c) Natural
tpraosToSignLeader   :: VRF.CertifiedVRF (VRF c) Natural
      -- | Lightweight delegation certificate mapping the cold (DSIGN) key to
      -- the online KES key.
    , forall c. TPraosToSign c -> OCert c
tpraosToSignOCert    :: SL.OCert c
    }
  deriving ((forall x. TPraosToSign c -> Rep (TPraosToSign c) x)
-> (forall x. Rep (TPraosToSign c) x -> TPraosToSign c)
-> Generic (TPraosToSign c)
forall x. Rep (TPraosToSign c) x -> TPraosToSign c
forall x. TPraosToSign c -> Rep (TPraosToSign c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (TPraosToSign c) x -> TPraosToSign c
forall c x. TPraosToSign c -> Rep (TPraosToSign c) x
$cfrom :: forall c x. TPraosToSign c -> Rep (TPraosToSign c) x
from :: forall x. TPraosToSign c -> Rep (TPraosToSign c) x
$cto :: forall c x. Rep (TPraosToSign c) x -> TPraosToSign c
to :: forall x. Rep (TPraosToSign c) x -> TPraosToSign c
Generic)

instance SL.PraosCrypto c => NoThunks (TPraosToSign c)
deriving instance SL.PraosCrypto c => Show (TPraosToSign c)

forgeTPraosFields ::
     ( SL.PraosCrypto c
     , KES.Signable (KES c) toSign
     , Monad m
     )
  => HotKey c m
  -> CanBeLeader (TPraos c)
  -> IsLeader (TPraos c)
  -> (TPraosToSign c -> toSign)
  -> m (TPraosFields c toSign)
forgeTPraosFields :: forall c toSign (m :: * -> *).
(PraosCrypto c, Signable (KES c) toSign, Monad m) =>
HotKey c m
-> CanBeLeader (TPraos c)
-> IsLeader (TPraos c)
-> (TPraosToSign c -> toSign)
-> m (TPraosFields c toSign)
forgeTPraosFields HotKey c m
hotKey PraosCanBeLeader{SignKeyVRF (VRF c)
VKey 'BlockIssuer
OCert c
praosCanBeLeaderOpCert :: OCert c
praosCanBeLeaderColdVerKey :: VKey 'BlockIssuer
praosCanBeLeaderSignKeyVRF :: SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF :: forall c. PraosCanBeLeader c -> SignKeyVRF (VRF c)
praosCanBeLeaderColdVerKey :: forall c. PraosCanBeLeader c -> VKey 'BlockIssuer
praosCanBeLeaderOpCert :: forall c. PraosCanBeLeader c -> OCert c
..} TPraosIsLeader{Maybe (Hash HASH (VerKeyVRF (VRF c)))
CertifiedVRF (VRF c) Natural
CertifiedVRF (VRF c) Nonce
tpraosIsLeaderEta :: CertifiedVRF (VRF c) Nonce
tpraosIsLeaderProof :: CertifiedVRF (VRF c) Natural
tpraosIsLeaderGenVRFHash :: Maybe (Hash HASH (VerKeyVRF (VRF c)))
tpraosIsLeaderGenVRFHash :: forall c. TPraosIsLeader c -> Maybe (Hash HASH (VerKeyVRF (VRF c)))
tpraosIsLeaderProof :: forall c. TPraosIsLeader c -> CertifiedVRF (VRF c) Natural
tpraosIsLeaderEta :: forall c. TPraosIsLeader c -> CertifiedVRF (VRF c) Nonce
..} TPraosToSign c -> toSign
mkToSign = do
    signature <- HotKey c m -> toSign -> m (SignedKES (KES c) toSign)
forall c toSign (m :: * -> *).
(Signable (KES c) toSign, HasCallStack) =>
HotKey c m -> toSign -> m (SignedKES (KES c) toSign)
HotKey.sign HotKey c m
hotKey toSign
toSign
    return TPraosFields {
        tpraosSignature = signature
      , tpraosToSign    = toSign
      }
  where
    toSign :: toSign
toSign = TPraosToSign c -> toSign
mkToSign TPraosToSign c
signedFields

    signedFields :: TPraosToSign c
signedFields = TPraosToSign {
        tpraosToSignIssuerVK :: VKey 'BlockIssuer
tpraosToSignIssuerVK = VKey 'BlockIssuer
praosCanBeLeaderColdVerKey
      , tpraosToSignVrfVK :: VerKeyVRF (VRF c)
tpraosToSignVrfVK    = SignKeyVRF (VRF c) -> VerKeyVRF (VRF c)
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
VRF.deriveVerKeyVRF SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF
      , tpraosToSignEta :: CertifiedVRF (VRF c) Nonce
tpraosToSignEta      = CertifiedVRF (VRF c) Nonce
tpraosIsLeaderEta
      , tpraosToSignLeader :: CertifiedVRF (VRF c) Natural
tpraosToSignLeader   = CertifiedVRF (VRF c) Natural
tpraosIsLeaderProof
      , tpraosToSignOCert :: OCert c
tpraosToSignOCert    = OCert c
praosCanBeLeaderOpCert
      }

-- | Because we are using the executable spec, rather than implementing the
-- protocol directly here, we have a fixed header type rather than an
-- abstraction. So our validate view is fixed to this.
type TPraosValidateView c = SL.BHeader c

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

data TPraos c

-- | TPraos parameters that are node independent
data TPraosParams = TPraosParams {
      -- | See 'Globals.slotsPerKESPeriod'.
      TPraosParams -> Word64
tpraosSlotsPerKESPeriod :: !Word64
      -- | 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.
    , TPraosParams -> ActiveSlotCoeff
tpraosLeaderF           :: !SL.ActiveSlotCoeff
      -- | See 'Globals.securityParameter'.
    , TPraosParams -> SecurityParam
tpraosSecurityParam     :: !SecurityParam
      -- | Maximum number of KES iterations, see 'Globals.maxKESEvo'.
    , TPraosParams -> Word64
tpraosMaxKESEvo         :: !Word64
      -- | Quorum for update system votes and MIR certificates, see
      -- 'Globals.quorum'.
    , TPraosParams -> Word64
tpraosQuorum            :: !Word64
      -- | All blocks invalid after this protocol version, see
      -- 'Globals.maxMajorPV'.
    , TPraosParams -> MaxMajorProtVer
tpraosMaxMajorPV        :: !MaxMajorProtVer
      -- | Maximum number of lovelace in the system, see
      -- 'Globals.maxLovelaceSupply'.
    , TPraosParams -> Word64
tpraosMaxLovelaceSupply :: !Word64
      -- | Testnet or mainnet?
    , TPraosParams -> Network
tpraosNetworkId         :: !SL.Network
      -- | Initial nonce used for the TPraos protocol state. Typically this is
      -- derived from the hash of the Shelley genesis config JSON file, but
      -- different values may be used for testing purposes.
      --
      -- NOTE: this is only used when translating the Byron 'ChainDepState' to
      -- the Shelley 'ChainDepState', at which point we'll need access to the
      -- initial nonce at runtime. TODO #2326.
    , TPraosParams -> Nonce
tpraosInitialNonce      :: !SL.Nonce
      -- | The system start, as projected from the chain's genesis block.
    , TPraosParams -> SystemStart
tpraosSystemStart       :: !SystemStart
    }
  deriving ((forall x. TPraosParams -> Rep TPraosParams x)
-> (forall x. Rep TPraosParams x -> TPraosParams)
-> Generic TPraosParams
forall x. Rep TPraosParams x -> TPraosParams
forall x. TPraosParams -> Rep TPraosParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TPraosParams -> Rep TPraosParams x
from :: forall x. TPraosParams -> Rep TPraosParams x
$cto :: forall x. Rep TPraosParams x -> TPraosParams
to :: forall x. Rep TPraosParams x -> TPraosParams
Generic, Context -> TPraosParams -> IO (Maybe ThunkInfo)
Proxy TPraosParams -> String
(Context -> TPraosParams -> IO (Maybe ThunkInfo))
-> (Context -> TPraosParams -> IO (Maybe ThunkInfo))
-> (Proxy TPraosParams -> String)
-> NoThunks TPraosParams
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TPraosParams -> IO (Maybe ThunkInfo)
noThunks :: Context -> TPraosParams -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TPraosParams -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TPraosParams -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TPraosParams -> String
showTypeOf :: Proxy TPraosParams -> String
NoThunks)

mkTPraosParams ::
     MaxMajorProtVer
  -> SL.Nonce  -- ^ Initial nonce
  -> SL.ShelleyGenesis
  -> TPraosParams
mkTPraosParams :: MaxMajorProtVer -> Nonce -> ShelleyGenesis -> TPraosParams
mkTPraosParams MaxMajorProtVer
maxMajorPV Nonce
initialNonce ShelleyGenesis
genesis = TPraosParams {
      tpraosSlotsPerKESPeriod :: Word64
tpraosSlotsPerKESPeriod = ShelleyGenesis -> Word64
SL.sgSlotsPerKESPeriod ShelleyGenesis
genesis
    , tpraosLeaderF :: ActiveSlotCoeff
tpraosLeaderF           = ShelleyGenesis -> ActiveSlotCoeff
SL.sgActiveSlotCoeff   ShelleyGenesis
genesis
    , tpraosMaxKESEvo :: Word64
tpraosMaxKESEvo         = ShelleyGenesis -> Word64
SL.sgMaxKESEvolutions  ShelleyGenesis
genesis
    , tpraosQuorum :: Word64
tpraosQuorum            = ShelleyGenesis -> Word64
SL.sgUpdateQuorum      ShelleyGenesis
genesis
    , tpraosMaxLovelaceSupply :: Word64
tpraosMaxLovelaceSupply = ShelleyGenesis -> Word64
SL.sgMaxLovelaceSupply ShelleyGenesis
genesis
    , tpraosNetworkId :: Network
tpraosNetworkId         = ShelleyGenesis -> Network
SL.sgNetworkId         ShelleyGenesis
genesis
    , tpraosSecurityParam :: SecurityParam
tpraosSecurityParam     = SecurityParam
securityParam
    , tpraosMaxMajorPV :: MaxMajorProtVer
tpraosMaxMajorPV        = MaxMajorProtVer
maxMajorPV
    , tpraosInitialNonce :: Nonce
tpraosInitialNonce      = Nonce
initialNonce
    , tpraosSystemStart :: SystemStart
tpraosSystemStart       = SystemStart
systemStart
    }
  where
    securityParam :: SecurityParam
securityParam = NonZero Word64 -> SecurityParam
SecurityParam (NonZero Word64 -> SecurityParam)
-> NonZero Word64 -> SecurityParam
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> NonZero Word64
SL.sgSecurityParam ShelleyGenesis
genesis
    systemStart :: SystemStart
systemStart   = UTCTime -> SystemStart
SystemStart   (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> UTCTime
SL.sgSystemStart   ShelleyGenesis
genesis

-- | Assembled proof that the issuer has the right to issue a block in the
-- selected slot.
data TPraosIsLeader c = TPraosIsLeader {
      forall c. TPraosIsLeader c -> CertifiedVRF (VRF c) Nonce
tpraosIsLeaderEta        :: VRF.CertifiedVRF (VRF c) SL.Nonce
    , forall c. TPraosIsLeader c -> CertifiedVRF (VRF c) Natural
tpraosIsLeaderProof      :: VRF.CertifiedVRF (VRF c) Natural
      -- | When in the overlay schedule (otherwise 'Nothing'), return the hash
      -- of the VRF verification key in the overlay schedule
    , forall c. TPraosIsLeader c -> Maybe (Hash HASH (VerKeyVRF (VRF c)))
tpraosIsLeaderGenVRFHash :: Maybe (Hash.Hash HASH (VRF.VerKeyVRF (VRF c)))
    }
  deriving ((forall x. TPraosIsLeader c -> Rep (TPraosIsLeader c) x)
-> (forall x. Rep (TPraosIsLeader c) x -> TPraosIsLeader c)
-> Generic (TPraosIsLeader c)
forall x. Rep (TPraosIsLeader c) x -> TPraosIsLeader c
forall x. TPraosIsLeader c -> Rep (TPraosIsLeader c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (TPraosIsLeader c) x -> TPraosIsLeader c
forall c x. TPraosIsLeader c -> Rep (TPraosIsLeader c) x
$cfrom :: forall c x. TPraosIsLeader c -> Rep (TPraosIsLeader c) x
from :: forall x. TPraosIsLeader c -> Rep (TPraosIsLeader c) x
$cto :: forall c x. Rep (TPraosIsLeader c) x -> TPraosIsLeader c
to :: forall x. Rep (TPraosIsLeader c) x -> TPraosIsLeader c
Generic)

instance SL.PraosCrypto c => NoThunks (TPraosIsLeader c)

-- | Static configuration
data instance ConsensusConfig (TPraos c) = TPraosConfig {
      forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams    :: !TPraosParams
    , forall c.
ConsensusConfig (TPraos c)
-> EpochInfo (Except PastHorizonException)
tpraosEpochInfo :: !(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 (TPraos c) -> Rep (ConsensusConfig (TPraos c)) x)
-> (forall x.
    Rep (ConsensusConfig (TPraos c)) x -> ConsensusConfig (TPraos c))
-> Generic (ConsensusConfig (TPraos c))
forall x.
Rep (ConsensusConfig (TPraos c)) x -> ConsensusConfig (TPraos c)
forall x.
ConsensusConfig (TPraos c) -> Rep (ConsensusConfig (TPraos c)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (ConsensusConfig (TPraos c)) x -> ConsensusConfig (TPraos c)
forall c x.
ConsensusConfig (TPraos c) -> Rep (ConsensusConfig (TPraos c)) x
$cfrom :: forall c x.
ConsensusConfig (TPraos c) -> Rep (ConsensusConfig (TPraos c)) x
from :: forall x.
ConsensusConfig (TPraos c) -> Rep (ConsensusConfig (TPraos c)) x
$cto :: forall c x.
Rep (ConsensusConfig (TPraos c)) x -> ConsensusConfig (TPraos c)
to :: forall x.
Rep (ConsensusConfig (TPraos c)) x -> ConsensusConfig (TPraos c)
Generic)

instance SL.PraosCrypto c => NoThunks (ConsensusConfig (TPraos c))

-- | Transitional Praos consensus state.
--
-- In addition to the 'ChainDepState' provided by the ledger, we track the slot
-- number of the last applied header.
data TPraosState = TPraosState {
      TPraosState -> WithOrigin SlotNo
tpraosStateLastSlot      :: !(WithOrigin SlotNo)
    , TPraosState -> ChainDepState
tpraosStateChainDepState :: !SL.ChainDepState
    }
  deriving ((forall x. TPraosState -> Rep TPraosState x)
-> (forall x. Rep TPraosState x -> TPraosState)
-> Generic TPraosState
forall x. Rep TPraosState x -> TPraosState
forall x. TPraosState -> Rep TPraosState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TPraosState -> Rep TPraosState x
from :: forall x. TPraosState -> Rep TPraosState x
$cto :: forall x. Rep TPraosState x -> TPraosState
to :: forall x. Rep TPraosState x -> TPraosState
Generic, Int -> TPraosState -> ShowS
[TPraosState] -> ShowS
TPraosState -> String
(Int -> TPraosState -> ShowS)
-> (TPraosState -> String)
-> ([TPraosState] -> ShowS)
-> Show TPraosState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TPraosState -> ShowS
showsPrec :: Int -> TPraosState -> ShowS
$cshow :: TPraosState -> String
show :: TPraosState -> String
$cshowList :: [TPraosState] -> ShowS
showList :: [TPraosState] -> ShowS
Show, TPraosState -> TPraosState -> Bool
(TPraosState -> TPraosState -> Bool)
-> (TPraosState -> TPraosState -> Bool) -> Eq TPraosState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TPraosState -> TPraosState -> Bool
== :: TPraosState -> TPraosState -> Bool
$c/= :: TPraosState -> TPraosState -> Bool
/= :: TPraosState -> TPraosState -> Bool
Eq)

instance NoThunks TPraosState

-- | Version 0 supported rollback, removed in #2575.
serialisationFormatVersion1 :: VersionNumber
serialisationFormatVersion1 :: VersionNumber
serialisationFormatVersion1 = VersionNumber
1

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

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

instance Serialise TPraosState where
  encode :: TPraosState -> Encoding
encode (TPraosState WithOrigin SlotNo
slot ChainDepState
chainDepState) =
    VersionNumber -> Encoding -> Encoding
encodeVersion VersionNumber
serialisationFormatVersion1 (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
2
      , WithOrigin SlotNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR WithOrigin SlotNo
slot
      , ChainDepState -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR ChainDepState
chainDepState
      ]

  decode :: forall s. Decoder s TPraosState
decode = [(VersionNumber, VersionDecoder TPraosState)]
-> forall s. Decoder s TPraosState
forall a.
[(VersionNumber, VersionDecoder a)] -> forall s. Decoder s a
decodeVersion
      [(VersionNumber
serialisationFormatVersion1, (forall s. Decoder s TPraosState) -> VersionDecoder TPraosState
forall a. (forall s. Decoder s a) -> VersionDecoder a
Decode Decoder s TPraosState
forall s. Decoder s TPraosState
decodeTPraosState1)]
    where
      decodeTPraosState1 :: Decoder s TPraosState
decodeTPraosState1 = do
        Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"TPraosState" Int
2
        WithOrigin SlotNo -> ChainDepState -> TPraosState
TPraosState (WithOrigin SlotNo -> ChainDepState -> TPraosState)
-> Decoder s (WithOrigin SlotNo)
-> Decoder s (ChainDepState -> TPraosState)
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 (ChainDepState -> TPraosState)
-> Decoder s ChainDepState -> Decoder s TPraosState
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 ChainDepState
forall s. Decoder s ChainDepState
forall a s. FromCBOR a => Decoder s a
fromCBOR

data instance Ticked TPraosState = TickedChainDepState {
      Ticked TPraosState -> ChainDepState
tickedTPraosStateChainDepState :: SL.ChainDepState
    , Ticked TPraosState -> LedgerView
tickedTPraosStateLedgerView    :: SL.LedgerView
    }

instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where
  type ChainDepState (TPraos c) = TPraosState
  type IsLeader      (TPraos c) = TPraosIsLeader c
  type CanBeLeader   (TPraos c) = PraosCanBeLeader c
  type SelectView    (TPraos c) = PraosChainSelectView c
  type LedgerView    (TPraos c) = SL.LedgerView
  type ValidationErr (TPraos c) = SL.ChainTransitionError c
  type ValidateView  (TPraos c) = TPraosValidateView c

  protocolSecurityParam :: ConsensusConfig (TPraos c) -> SecurityParam
protocolSecurityParam = TPraosParams -> SecurityParam
tpraosSecurityParam (TPraosParams -> SecurityParam)
-> (ConsensusConfig (TPraos c) -> TPraosParams)
-> ConsensusConfig (TPraos c)
-> SecurityParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsensusConfig (TPraos c) -> TPraosParams
forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams

  checkIsLeader :: HasCallStack =>
ConsensusConfig (TPraos c)
-> CanBeLeader (TPraos c)
-> SlotNo
-> Ticked (ChainDepState (TPraos c))
-> Maybe (IsLeader (TPraos c))
checkIsLeader ConsensusConfig (TPraos c)
cfg PraosCanBeLeader{SignKeyVRF (VRF c)
VKey 'BlockIssuer
OCert c
praosCanBeLeaderSignKeyVRF :: forall c. PraosCanBeLeader c -> SignKeyVRF (VRF c)
praosCanBeLeaderColdVerKey :: forall c. PraosCanBeLeader c -> VKey 'BlockIssuer
praosCanBeLeaderOpCert :: forall c. PraosCanBeLeader c -> OCert c
praosCanBeLeaderOpCert :: OCert c
praosCanBeLeaderColdVerKey :: VKey 'BlockIssuer
praosCanBeLeaderSignKeyVRF :: SignKeyVRF (VRF c)
..} SlotNo
slot Ticked (ChainDepState (TPraos c))
cs = do
      -- First, check whether we're in the overlay schedule
      case SlotNo
-> Set (KeyHash 'Genesis)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe OBftSlot
SL.lookupInOverlaySchedule SlotNo
firstSlot Set (KeyHash 'Genesis)
gkeys UnitInterval
d ActiveSlotCoeff
asc SlotNo
slot of
        -- Slot isn't in the overlay schedule, so we're in Praos
        Maybe OBftSlot
Nothing
          | ConsensusConfig (TPraos c)
-> LedgerView (TPraos c)
-> KeyHash 'StakePool
-> CertifiedVRF (VRF c) Seed
-> Bool
forall c.
PraosCrypto c =>
ConsensusConfig (TPraos c)
-> LedgerView (TPraos c)
-> KeyHash 'StakePool
-> CertifiedVRF (VRF c) Seed
-> Bool
meetsLeaderThreshold ConsensusConfig (TPraos c)
cfg LedgerView
LedgerView (TPraos c)
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) Seed
y
          -> TPraosIsLeader c -> Maybe (TPraosIsLeader c)
forall a. a -> Maybe a
Just TPraosIsLeader {
                tpraosIsLeaderEta :: CertifiedVRF (VRF c) Nonce
tpraosIsLeaderEta        = CertifiedVRF (VRF c) Seed -> CertifiedVRF (VRF c) Nonce
forall a b. Coercible a b => a -> b
coerce CertifiedVRF (VRF c) Seed
rho
              , tpraosIsLeaderProof :: CertifiedVRF (VRF c) Natural
tpraosIsLeaderProof      = CertifiedVRF (VRF c) Seed -> CertifiedVRF (VRF c) Natural
forall a b. Coercible a b => a -> b
coerce CertifiedVRF (VRF c) Seed
y
              , tpraosIsLeaderGenVRFHash :: Maybe (Hash HASH (VerKeyVRF (VRF c)))
tpraosIsLeaderGenVRFHash = Maybe (Hash HASH (VerKeyVRF (VRF c)))
forall a. Maybe a
Nothing
              }
          | Bool
otherwise
          -> Maybe (IsLeader (TPraos c))
Maybe (TPraosIsLeader c)
forall a. Maybe a
Nothing

       -- This is a non-active slot; nobody may produce a block
        Just OBftSlot
SL.NonActiveSlot -> Maybe (IsLeader (TPraos c))
Maybe (TPraosIsLeader c)
forall a. Maybe a
Nothing

       -- The given genesis key has authority to produce a block in this
        -- slot. Check whether we're its delegate.
        Just (SL.ActiveSlot KeyHash 'Genesis
gkhash) -> case KeyHash 'Genesis
-> Map (KeyHash 'Genesis) GenDelegPair -> Maybe GenDelegPair
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'Genesis
gkhash Map (KeyHash 'Genesis) GenDelegPair
dlgMap of
            Maybe GenDelegPair
Nothing
              -> String -> Maybe (TPraosIsLeader c)
forall a. HasCallStack => String -> a
error String
"unknown genesis key in overlay schedule"
            Just (SL.GenDelegPair KeyHash 'GenesisDelegate
dlgHash VRFVerKeyHash 'GenDelegVRF
genDlgVRFHash)
              | KeyHash 'GenesisDelegate -> KeyHash 'BlockIssuer
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 'GenesisDelegate
dlgHash KeyHash 'BlockIssuer -> KeyHash 'BlockIssuer -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash 'BlockIssuer
vkhCold
              -> TPraosIsLeader c -> Maybe (TPraosIsLeader c)
forall a. a -> Maybe a
Just TPraosIsLeader {
                     tpraosIsLeaderEta :: CertifiedVRF (VRF c) Nonce
tpraosIsLeaderEta        = CertifiedVRF (VRF c) Seed -> CertifiedVRF (VRF c) Nonce
forall a b. Coercible a b => a -> b
coerce CertifiedVRF (VRF c) Seed
rho
                     -- Note that this leader value is not checked for slots in
                     -- the overlay schedule, so we could set it to whatever we
                     -- want. We evaluate it as normal for simplicity's sake.
                   , tpraosIsLeaderProof :: CertifiedVRF (VRF c) Natural
tpraosIsLeaderProof      = CertifiedVRF (VRF c) Seed -> CertifiedVRF (VRF c) Natural
forall a b. Coercible a b => a -> b
coerce CertifiedVRF (VRF c) Seed
y
                   , tpraosIsLeaderGenVRFHash :: Maybe (Hash HASH (VerKeyVRF (VRF c)))
tpraosIsLeaderGenVRFHash = Hash HASH (VerKeyVRF (VRF c))
-> Maybe (Hash HASH (VerKeyVRF (VRF c)))
forall a. a -> Maybe a
Just (Hash HASH (VerKeyVRF (VRF c))
 -> Maybe (Hash HASH (VerKeyVRF (VRF c))))
-> Hash HASH (VerKeyVRF (VRF c))
-> Maybe (Hash HASH (VerKeyVRF (VRF c)))
forall a b. (a -> b) -> a -> b
$ VRFVerKeyHash 'GenDelegVRF -> Hash HASH (VerKeyVRF (VRF c))
forall (r :: KeyRoleVRF) v.
VRFVerKeyHash r -> Hash HASH (VerKeyVRF v)
SL.fromVRFVerKeyHash VRFVerKeyHash 'GenDelegVRF
genDlgVRFHash
                   }
              | Bool
otherwise
              -> Maybe (IsLeader (TPraos c))
Maybe (TPraosIsLeader c)
forall a. Maybe a
Nothing
    where
      chainState :: ChainDepState
chainState = Ticked TPraosState -> ChainDepState
tickedTPraosStateChainDepState Ticked (ChainDepState (TPraos c))
Ticked TPraosState
cs
      lv :: LedgerView
lv         = Ticked TPraosState -> LedgerView
tickedTPraosStateLedgerView    Ticked (ChainDepState (TPraos c))
Ticked TPraosState
cs
      d :: UnitInterval
d          = LedgerView -> UnitInterval
SL.lvD LedgerView
lv
      asc :: ActiveSlotCoeff
asc        = TPraosParams -> ActiveSlotCoeff
tpraosLeaderF (TPraosParams -> ActiveSlotCoeff)
-> TPraosParams -> ActiveSlotCoeff
forall a b. (a -> b) -> a -> b
$ ConsensusConfig (TPraos c) -> TPraosParams
forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams ConsensusConfig (TPraos c)
cfg
      firstSlot :: SlotNo
firstSlot  =
          EpochInfo Identity -> SlotNo -> SlotNo
firstSlotOfEpochOfSlot
            (EpochInfo (Except PastHorizonException) -> EpochInfo Identity
History.toPureEpochInfo (EpochInfo (Except PastHorizonException) -> EpochInfo Identity)
-> EpochInfo (Except PastHorizonException) -> EpochInfo Identity
forall a b. (a -> b) -> a -> b
$ ConsensusConfig (TPraos c)
-> EpochInfo (Except PastHorizonException)
forall c.
ConsensusConfig (TPraos c)
-> EpochInfo (Except PastHorizonException)
tpraosEpochInfo ConsensusConfig (TPraos c)
cfg)
            SlotNo
slot
      gkeys :: Set (KeyHash 'Genesis)
gkeys      = Map (KeyHash 'Genesis) GenDelegPair -> Set (KeyHash 'Genesis)
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis) GenDelegPair
dlgMap
      eta0 :: Nonce
eta0       = TicknState -> Nonce
SL.ticknStateEpochNonce (TicknState -> Nonce) -> TicknState -> Nonce
forall a b. (a -> b) -> a -> b
$ ChainDepState -> TicknState
SL.csTickn ChainDepState
chainState
      vkhCold :: KeyHash 'BlockIssuer
vkhCold    = VKey 'BlockIssuer -> KeyHash 'BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
SL.hashKey VKey 'BlockIssuer
praosCanBeLeaderColdVerKey
      rho' :: Seed
rho'       = Nonce -> SlotNo -> Nonce -> Seed
SL.mkSeed Nonce
SL.seedEta SlotNo
slot Nonce
eta0
      y' :: Seed
y'         = Nonce -> SlotNo -> Nonce -> Seed
SL.mkSeed Nonce
SL.seedL   SlotNo
slot Nonce
eta0

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

      SL.GenDelegs Map (KeyHash 'Genesis) GenDelegPair
dlgMap = LedgerView -> GenDelegs
SL.lvGenDelegs LedgerView
lv

  tickChainDepState :: ConsensusConfig (TPraos c)
-> LedgerView (TPraos c)
-> SlotNo
-> ChainDepState (TPraos c)
-> Ticked (ChainDepState (TPraos c))
tickChainDepState cfg :: ConsensusConfig (TPraos c)
cfg@TPraosConfig{EpochInfo (Except PastHorizonException)
TPraosParams
tpraosParams :: forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosEpochInfo :: forall c.
ConsensusConfig (TPraos c)
-> EpochInfo (Except PastHorizonException)
tpraosParams :: TPraosParams
tpraosEpochInfo :: EpochInfo (Except PastHorizonException)
..}
                    LedgerView (TPraos c)
lv
                    SlotNo
slot
                    (TPraosState WithOrigin SlotNo
lastSlot ChainDepState
st) =
      TickedChainDepState {
          tickedTPraosStateChainDepState :: ChainDepState
tickedTPraosStateChainDepState = ChainDepState
st'
        , tickedTPraosStateLedgerView :: LedgerView
tickedTPraosStateLedgerView    = LedgerView
LedgerView (TPraos c)
lv
        }
    where
      st' :: ChainDepState
st' = Globals -> LedgerView -> Bool -> ChainDepState -> ChainDepState
SL.tickChainDepState
              (ConsensusConfig (TPraos c) -> Globals
forall c. ConsensusConfig (TPraos c) -> Globals
mkShelleyGlobals ConsensusConfig (TPraos c)
cfg)
              LedgerView
LedgerView (TPraos c)
lv
              ( EpochInfo Identity -> WithOrigin SlotNo -> SlotNo -> Bool
isNewEpoch
                  (EpochInfo (Except PastHorizonException) -> EpochInfo Identity
History.toPureEpochInfo EpochInfo (Except PastHorizonException)
tpraosEpochInfo)
                  WithOrigin SlotNo
lastSlot
                  SlotNo
slot
              )
              ChainDepState
st

  updateChainDepState :: HasCallStack =>
ConsensusConfig (TPraos c)
-> ValidateView (TPraos c)
-> SlotNo
-> Ticked (ChainDepState (TPraos c))
-> Except (ValidationErr (TPraos c)) (ChainDepState (TPraos c))
updateChainDepState ConsensusConfig (TPraos c)
cfg ValidateView (TPraos c)
b SlotNo
slot Ticked (ChainDepState (TPraos c))
cs =
      WithOrigin SlotNo -> ChainDepState -> TPraosState
TPraosState (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slot) (ChainDepState -> TPraosState)
-> ExceptT (ChainTransitionError c) Identity ChainDepState
-> ExceptT (ChainTransitionError c) Identity TPraosState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Globals
-> LedgerView
-> BHeader c
-> ChainDepState
-> ExceptT (ChainTransitionError c) Identity ChainDepState
forall c (m :: * -> *).
(PraosCrypto c, MonadError (ChainTransitionError c) m) =>
Globals
-> LedgerView -> BHeader c -> ChainDepState -> m ChainDepState
SL.updateChainDepState
          (ConsensusConfig (TPraos c) -> Globals
forall c. ConsensusConfig (TPraos c) -> Globals
mkShelleyGlobals ConsensusConfig (TPraos c)
cfg)
          (Ticked TPraosState -> LedgerView
tickedTPraosStateLedgerView Ticked (ChainDepState (TPraos c))
Ticked TPraosState
cs)
          BHeader c
ValidateView (TPraos c)
b
          (Ticked TPraosState -> ChainDepState
tickedTPraosStateChainDepState Ticked (ChainDepState (TPraos c))
Ticked TPraosState
cs)

  reupdateChainDepState :: HasCallStack =>
ConsensusConfig (TPraos c)
-> ValidateView (TPraos c)
-> SlotNo
-> Ticked (ChainDepState (TPraos c))
-> ChainDepState (TPraos c)
reupdateChainDepState ConsensusConfig (TPraos c)
cfg ValidateView (TPraos c)
b SlotNo
slot Ticked (ChainDepState (TPraos c))
cs =
      WithOrigin SlotNo -> ChainDepState -> TPraosState
TPraosState (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slot) (ChainDepState -> TPraosState) -> ChainDepState -> TPraosState
forall a b. (a -> b) -> a -> b
$
        Globals
-> LedgerView -> BHeader c -> ChainDepState -> ChainDepState
forall c.
PraosCrypto c =>
Globals
-> LedgerView -> BHeader c -> ChainDepState -> ChainDepState
SL.reupdateChainDepState
          (ConsensusConfig (TPraos c) -> Globals
forall c. ConsensusConfig (TPraos c) -> Globals
mkShelleyGlobals ConsensusConfig (TPraos c)
cfg)
          (Ticked TPraosState -> LedgerView
tickedTPraosStateLedgerView Ticked (ChainDepState (TPraos c))
Ticked TPraosState
cs)
          BHeader c
ValidateView (TPraos c)
b
          (Ticked TPraosState -> ChainDepState
tickedTPraosStateChainDepState Ticked (ChainDepState (TPraos c))
Ticked TPraosState
cs)

mkShelleyGlobals :: ConsensusConfig (TPraos c) -> SL.Globals
mkShelleyGlobals :: forall c. ConsensusConfig (TPraos c) -> Globals
mkShelleyGlobals TPraosConfig{EpochInfo (Except PastHorizonException)
TPraosParams
tpraosParams :: forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosEpochInfo :: forall c.
ConsensusConfig (TPraos c)
-> EpochInfo (Except PastHorizonException)
tpraosParams :: TPraosParams
tpraosEpochInfo :: EpochInfo (Except PastHorizonException)
..} = SL.Globals {
      epochInfo :: EpochInfo (Either Text)
epochInfo                     =
        (forall a. Except PastHorizonException a -> Either Text a)
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either Text)
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo
          (Except Text a -> Either Text a
forall e a. Except e a -> Either e a
runExcept (Except Text a -> Either Text a)
-> (Except PastHorizonException a -> Except Text a)
-> Except PastHorizonException a
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PastHorizonException -> Text)
-> Except PastHorizonException a -> Except Text a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (String -> Text
T.pack (String -> Text)
-> (PastHorizonException -> String) -> PastHorizonException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PastHorizonException -> String
forall a. Show a => a -> String
show))
          EpochInfo (Except PastHorizonException)
tpraosEpochInfo
    , slotsPerKESPeriod :: Word64
slotsPerKESPeriod             = Word64
tpraosSlotsPerKESPeriod
    , stabilityWindow :: Word64
stabilityWindow               = Word64 -> ActiveSlotCoeff -> Word64
SL.computeStabilityWindow               Word64
k ActiveSlotCoeff
tpraosLeaderF
    , randomnessStabilisationWindow :: Word64
randomnessStabilisationWindow = Word64 -> ActiveSlotCoeff -> Word64
SL.computeRandomnessStabilisationWindow Word64
k ActiveSlotCoeff
tpraosLeaderF
    , securityParameter :: NonZero Word64
securityParameter             = Word64 -> NonZero Word64 -> NonZero Word64
forall a. HasZero a => a -> NonZero a -> NonZero a
nonZeroOr Word64
k (NonZero Word64 -> NonZero Word64)
-> NonZero Word64 -> NonZero Word64
forall a b. (a -> b) -> a -> b
$ String -> NonZero Word64
forall a. HasCallStack => String -> a
error String
"The security parameter cannot be zero."
    , maxKESEvo :: Word64
maxKESEvo                     = Word64
tpraosMaxKESEvo
    , quorum :: Word64
quorum                        = Word64
tpraosQuorum
    , maxLovelaceSupply :: Word64
maxLovelaceSupply             = Word64
tpraosMaxLovelaceSupply
    , activeSlotCoeff :: ActiveSlotCoeff
activeSlotCoeff               = ActiveSlotCoeff
tpraosLeaderF
    , networkId :: Network
networkId                     = Network
tpraosNetworkId
    , systemStart :: SystemStart
systemStart                   = SystemStart
tpraosSystemStart
    }
  where
    k :: Word64
k  = NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64) -> NonZero Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
tpraosSecurityParam
    TPraosParams{Word64
Network
ActiveSlotCoeff
Nonce
SystemStart
SecurityParam
MaxMajorProtVer
tpraosSlotsPerKESPeriod :: TPraosParams -> Word64
tpraosLeaderF :: TPraosParams -> ActiveSlotCoeff
tpraosSecurityParam :: TPraosParams -> SecurityParam
tpraosMaxKESEvo :: TPraosParams -> Word64
tpraosQuorum :: TPraosParams -> Word64
tpraosMaxMajorPV :: TPraosParams -> MaxMajorProtVer
tpraosMaxLovelaceSupply :: TPraosParams -> Word64
tpraosNetworkId :: TPraosParams -> Network
tpraosInitialNonce :: TPraosParams -> Nonce
tpraosSystemStart :: TPraosParams -> SystemStart
tpraosSlotsPerKESPeriod :: Word64
tpraosLeaderF :: ActiveSlotCoeff
tpraosMaxKESEvo :: Word64
tpraosQuorum :: Word64
tpraosMaxLovelaceSupply :: Word64
tpraosNetworkId :: Network
tpraosSystemStart :: SystemStart
tpraosSecurityParam :: SecurityParam
tpraosMaxMajorPV :: MaxMajorProtVer
tpraosInitialNonce :: Nonce
..} = TPraosParams
tpraosParams

-- | Check whether this node meets the leader threshold to issue a block.
meetsLeaderThreshold ::
     forall c. SL.PraosCrypto c
  => ConsensusConfig (TPraos c)
  -> LedgerView (TPraos c)
  -> SL.KeyHash 'SL.StakePool
  -> VRF.CertifiedVRF (VRF c) SL.Seed
  -> Bool
meetsLeaderThreshold :: forall c.
PraosCrypto c =>
ConsensusConfig (TPraos c)
-> LedgerView (TPraos c)
-> KeyHash 'StakePool
-> CertifiedVRF (VRF c) Seed
-> Bool
meetsLeaderThreshold TPraosConfig { TPraosParams
tpraosParams :: forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams :: TPraosParams
tpraosParams }
                     SL.LedgerView { PoolDistr
lvPoolDistr :: PoolDistr
lvPoolDistr :: LedgerView -> PoolDistr
lvPoolDistr }
                     KeyHash 'StakePool
keyHash
                     CertifiedVRF (VRF c) Seed
certNat =
    OutputVRF (VRF c) -> Rational -> ActiveSlotCoeff -> Bool
forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
SL.checkLeaderValue
      (CertifiedVRF (VRF c) Seed -> OutputVRF (VRF c)
forall v a. CertifiedVRF v a -> OutputVRF v
VRF.certifiedOutput CertifiedVRF (VRF c) Seed
certNat)
      Rational
r
      (TPraosParams -> ActiveSlotCoeff
tpraosLeaderF TPraosParams
tpraosParams)
  where
    SL.PoolDistr Map (KeyHash 'StakePool) IndividualPoolStake
poolDistr CompactForm 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

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

-- | Expresses that, whilst we believe ourselves to be a leader for this slot,
-- we are nonetheless unable to forge a block.
data TPraosCannotForge 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'.
    TPraosCannotForgeKeyNotUsableYet
      !Absolute.KESPeriod
      -- ^ Current KES period according to the wallclock slot, i.e., the KES
      -- period in which we want to use the key.
      !Absolute.KESPeriod
      -- ^ Start KES period of the KES key.

    -- | We are a genesis delegate, but our VRF key (second argument) does not
    -- match the registered key for that delegate (first argument).
  | TPraosCannotForgeWrongVRF
      !(Hash.Hash HASH (VRF.VerKeyVRF (VRF c)))
      !(Hash.Hash HASH (VRF.VerKeyVRF (VRF c)))
  deriving ((forall x. TPraosCannotForge c -> Rep (TPraosCannotForge c) x)
-> (forall x. Rep (TPraosCannotForge c) x -> TPraosCannotForge c)
-> Generic (TPraosCannotForge c)
forall x. Rep (TPraosCannotForge c) x -> TPraosCannotForge c
forall x. TPraosCannotForge c -> Rep (TPraosCannotForge c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (TPraosCannotForge c) x -> TPraosCannotForge c
forall c x. TPraosCannotForge c -> Rep (TPraosCannotForge c) x
$cfrom :: forall c x. TPraosCannotForge c -> Rep (TPraosCannotForge c) x
from :: forall x. TPraosCannotForge c -> Rep (TPraosCannotForge c) x
$cto :: forall c x. Rep (TPraosCannotForge c) x -> TPraosCannotForge c
to :: forall x. Rep (TPraosCannotForge c) x -> TPraosCannotForge c
Generic)

deriving instance SL.PraosCrypto c => Show (TPraosCannotForge c)

tpraosCheckCanForge ::
     ConsensusConfig (TPraos c)
  -> Hash.Hash HASH (VRF.VerKeyVRF (VRF c))
     -- ^ Precomputed hash of the VRF verification key
  -> SlotNo
  -> IsLeader (TPraos c)
  -> HotKey.KESInfo
  -> Either (TPraosCannotForge c) ()
tpraosCheckCanForge :: forall c.
ConsensusConfig (TPraos c)
-> Hash HASH (VerKeyVRF (VRF c))
-> SlotNo
-> IsLeader (TPraos c)
-> KESInfo
-> Either (TPraosCannotForge c) ()
tpraosCheckCanForge TPraosConfig { TPraosParams
tpraosParams :: forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams :: TPraosParams
tpraosParams }
                    Hash HASH (VerKeyVRF (VRF c))
forgingVRFHash
                    SlotNo
curSlot
                    TPraosIsLeader { Maybe (Hash HASH (VerKeyVRF (VRF c)))
tpraosIsLeaderGenVRFHash :: forall c. TPraosIsLeader c -> Maybe (Hash HASH (VerKeyVRF (VRF c)))
tpraosIsLeaderGenVRFHash :: Maybe (Hash HASH (VerKeyVRF (VRF c)))
tpraosIsLeaderGenVRFHash }
                    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
  = TPraosCannotForge c -> Either (TPraosCannotForge c) ()
forall a. TPraosCannotForge c -> Either (TPraosCannotForge c) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TPraosCannotForge c -> Either (TPraosCannotForge c) ())
-> TPraosCannotForge c -> Either (TPraosCannotForge c) ()
forall a b. (a -> b) -> a -> b
$ KESPeriod -> KESPeriod -> TPraosCannotForge c
forall c. KESPeriod -> KESPeriod -> TPraosCannotForge c
TPraosCannotForgeKeyNotUsableYet KESPeriod
wallclockPeriod KESPeriod
startPeriod
  | Just Hash HASH (VerKeyVRF (VRF c))
genVRFHash <- Maybe (Hash HASH (VerKeyVRF (VRF c)))
tpraosIsLeaderGenVRFHash
  , Hash HASH (VerKeyVRF (VRF c))
genVRFHash Hash HASH (VerKeyVRF (VRF c))
-> Hash HASH (VerKeyVRF (VRF c)) -> Bool
forall a. Eq a => a -> a -> Bool
/= Hash HASH (VerKeyVRF (VRF c))
forgingVRFHash
  = TPraosCannotForge c -> Either (TPraosCannotForge c) ()
forall a. TPraosCannotForge c -> Either (TPraosCannotForge c) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TPraosCannotForge c -> Either (TPraosCannotForge c) ())
-> TPraosCannotForge c -> Either (TPraosCannotForge c) ()
forall a b. (a -> b) -> a -> b
$ Hash HASH (VerKeyVRF (VRF c))
-> Hash HASH (VerKeyVRF (VRF c)) -> TPraosCannotForge c
forall c.
Hash HASH (VerKeyVRF (VRF c))
-> Hash HASH (VerKeyVRF (VRF c)) -> TPraosCannotForge c
TPraosCannotForgeWrongVRF Hash HASH (VerKeyVRF (VRF c))
genVRFHash Hash HASH (VerKeyVRF (VRF c))
forgingVRFHash
  | Bool
otherwise
  = () -> Either (TPraosCannotForge c) ()
forall a. a -> Either (TPraosCannotForge c) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    -- The current wallclock KES period
    wallclockPeriod :: Absolute.KESPeriod
    wallclockPeriod :: KESPeriod
wallclockPeriod = Word -> KESPeriod
Absolute.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` TPraosParams -> Word64
tpraosSlotsPerKESPeriod TPraosParams
tpraosParams

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

instance SL.PraosCrypto c => PraosProtocolSupportsNode (TPraos c) where
  type PraosProtocolSupportsNodeCrypto (TPraos c) = c

  getPraosNonces :: forall (proxy :: * -> *).
proxy (TPraos c) -> ChainDepState (TPraos c) -> PraosNonces
getPraosNonces proxy (TPraos c)
_prx ChainDepState (TPraos c)
cdst =
      PraosNonces {
          Nonce
candidateNonce :: Nonce
candidateNonce :: Nonce
candidateNonce
        , epochNonce :: Nonce
epochNonce       = Nonce
ticknStateEpochNonce
        , Nonce
evolvingNonce :: Nonce
evolvingNonce :: Nonce
evolvingNonce
        , labNonce :: Nonce
labNonce         = Nonce
csLabNonce
        , previousLabNonce :: Nonce
previousLabNonce = Nonce
ticknStatePrevHashNonce
        }
    where
      TPraosState { ChainDepState
tpraosStateChainDepState :: TPraosState -> ChainDepState
tpraosStateChainDepState :: ChainDepState
tpraosStateChainDepState } = ChainDepState (TPraos c)
cdst
      SL.ChainDepState {
          Nonce
csLabNonce :: Nonce
csLabNonce :: ChainDepState -> Nonce
SL.csLabNonce
        , PrtclState
csProtocol :: PrtclState
csProtocol :: ChainDepState -> PrtclState
SL.csProtocol
        , TicknState
csTickn :: ChainDepState -> TicknState
csTickn :: TicknState
SL.csTickn
        } = ChainDepState
tpraosStateChainDepState
      SL.PrtclState
        Map (KeyHash 'BlockIssuer) Word64
_opcertCounters
        Nonce
evolvingNonce
        Nonce
candidateNonce
          = PrtclState
csProtocol
      SL.TicknState {
          Nonce
ticknStateEpochNonce :: TicknState -> Nonce
ticknStateEpochNonce :: Nonce
ticknStateEpochNonce
        , Nonce
ticknStatePrevHashNonce :: Nonce
ticknStatePrevHashNonce :: TicknState -> Nonce
ticknStatePrevHashNonce
        } = TicknState
csTickn

  getOpCertCounters :: forall (proxy :: * -> *).
proxy (TPraos c)
-> ChainDepState (TPraos c) -> Map (KeyHash 'BlockIssuer) Word64
getOpCertCounters proxy (TPraos c)
_prx ChainDepState (TPraos c)
cdst = Map (KeyHash 'BlockIssuer) Word64
opcertCounters
    where
      TPraosState { ChainDepState
tpraosStateChainDepState :: TPraosState -> ChainDepState
tpraosStateChainDepState :: ChainDepState
tpraosStateChainDepState } = ChainDepState (TPraos c)
cdst
      SL.ChainDepState {
        PrtclState
csProtocol :: ChainDepState -> PrtclState
csProtocol :: PrtclState
SL.csProtocol
        } = ChainDepState
tpraosStateChainDepState
      SL.PrtclState
        Map (KeyHash 'BlockIssuer) Word64
opcertCounters
        Nonce
_evolvingNonce
        Nonce
_candidateNonce
          = PrtclState
csProtocol

{-------------------------------------------------------------------------------
  Condense
-------------------------------------------------------------------------------}

instance (Condense toSign, SL.PraosCrypto c) => Condense (TPraosFields c toSign) where
  condense :: TPraosFields c toSign -> String
condense = toSign -> String
forall a. Condense a => a -> String
condense (toSign -> String)
-> (TPraosFields c toSign -> toSign)
-> TPraosFields c toSign
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TPraosFields c toSign -> toSign
forall c toSign. TPraosFields c toSign -> toSign
tpraosToSign