{-# 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 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           Cardano.Binary (FromCBOR (..), ToCBOR (..), enforceSize)
import qualified Cardano.Crypto.VRF as VRF
import           Cardano.Slotting.EpochInfo
import           Cardano.Slotting.Time (SystemStart (..))

import           Ouroboros.Consensus.Block
import qualified Ouroboros.Consensus.HardFork.History as History
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Ticked
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.Versioned

import qualified Cardano.Ledger.BaseTypes as SL (ActiveSlotCoeff, Seed)
import           Cardano.Ledger.Crypto (StandardCrypto)
import qualified Cardano.Ledger.Keys as SL
import qualified Cardano.Ledger.Shelley.API as SL
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           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

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

data TPraosFields c toSign = TPraosFields {
      TPraosFields c toSign -> SignedKES c toSign
tpraosSignature :: SL.SignedKES 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
$cto :: forall c toSign x.
Rep (TPraosFields c toSign) x -> TPraosFields c toSign
$cfrom :: forall c toSign x.
TPraosFields c toSign -> Rep (TPraosFields c toSign) x
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.
      TPraosToSign c -> VKey 'BlockIssuer c
tpraosToSignIssuerVK :: SL.VKey 'SL.BlockIssuer c
    , TPraosToSign c -> VerKeyVRF c
tpraosToSignVrfVK    :: SL.VerKeyVRF c
      -- | Verifiable result containing the updated nonce value.
    , TPraosToSign c -> CertifiedVRF c Nonce
tpraosToSignEta      :: SL.CertifiedVRF 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.)
    , TPraosToSign c -> CertifiedVRF c Natural
tpraosToSignLeader   :: SL.CertifiedVRF c Natural
      -- | Lightweight delegation certificate mapping the cold (DSIGN) key to
      -- the online KES key.
    , 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
$cto :: forall c x. Rep (TPraosToSign c) x -> TPraosToSign c
$cfrom :: forall c x. TPraosToSign c -> Rep (TPraosToSign c) x
Generic)

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

forgeTPraosFields ::
     ( SL.PraosCrypto c
     , SL.KESignable c toSign
     , Monad m
     )
  => HotKey c m
  -> CanBeLeader (TPraos c)
  -> IsLeader (TPraos c)
  -> (TPraosToSign c -> toSign)
  -> m (TPraosFields c toSign)
forgeTPraosFields :: HotKey c m
-> CanBeLeader (TPraos c)
-> IsLeader (TPraos c)
-> (TPraosToSign c -> toSign)
-> m (TPraosFields c toSign)
forgeTPraosFields HotKey c m
hotKey PraosCanBeLeader{..} TPraosIsLeader{..} TPraosToSign c -> toSign
mkToSign = do
    SignedKES (KES c) toSign
signature <- HotKey c m -> toSign -> m (SignedKES (KES c) toSign)
forall c toSign (m :: * -> *).
(KESignable c toSign, HasCallStack) =>
HotKey c m -> toSign -> m (SignedKES c toSign)
HotKey.sign HotKey c m
hotKey toSign
toSign
    TPraosFields c toSign -> m (TPraosFields c toSign)
forall (m :: * -> *) a. Monad m => a -> m a
return TPraosFields :: forall c toSign.
SignedKES c toSign -> toSign -> TPraosFields c toSign
TPraosFields {
        tpraosSignature :: SignedKES (KES c) toSign
tpraosSignature = SignedKES (KES c) toSign
signature
      , tpraosToSign :: toSign
tpraosToSign    = toSign
toSign
      }
  where
    toSign :: toSign
toSign = TPraosToSign c -> toSign
mkToSign TPraosToSign c
signedFields

    signedFields :: TPraosToSign c
signedFields = TPraosToSign :: forall c.
VKey 'BlockIssuer c
-> VerKeyVRF c
-> CertifiedVRF c Nonce
-> CertifiedVRF c Natural
-> OCert c
-> TPraosToSign c
TPraosToSign {
        tpraosToSignIssuerVK :: VKey 'BlockIssuer c
tpraosToSignIssuerVK = VKey 'BlockIssuer c
praosCanBeLeaderColdVerKey
      , tpraosToSignVrfVK :: VerKeyVRF c
tpraosToSignVrfVK    = SignKeyVRF (VRF c) -> VerKeyVRF c
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
VRF.deriveVerKeyVRF SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF
      , tpraosToSignEta :: CertifiedVRF c Nonce
tpraosToSignEta      = CertifiedVRF c Nonce
tpraosIsLeaderEta
      , tpraosToSignLeader :: CertifiedVRF c Natural
tpraosToSignLeader   = CertifiedVRF 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
$cto :: forall x. Rep TPraosParams x -> TPraosParams
$cfrom :: forall x. TPraosParams -> Rep TPraosParams x
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
showTypeOf :: Proxy TPraosParams -> String
$cshowTypeOf :: Proxy TPraosParams -> String
wNoThunks :: Context -> TPraosParams -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TPraosParams -> IO (Maybe ThunkInfo)
noThunks :: Context -> TPraosParams -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> TPraosParams -> IO (Maybe ThunkInfo)
NoThunks)

mkTPraosParams
  :: MaxMajorProtVer
  -> SL.Nonce  -- ^ Initial nonce
  -> SL.ShelleyGenesis era
  -> TPraosParams
mkTPraosParams :: MaxMajorProtVer -> Nonce -> ShelleyGenesis era -> TPraosParams
mkTPraosParams MaxMajorProtVer
maxMajorPV Nonce
initialNonce ShelleyGenesis era
genesis = TPraosParams :: Word64
-> ActiveSlotCoeff
-> SecurityParam
-> Word64
-> Word64
-> MaxMajorProtVer
-> Word64
-> Network
-> Nonce
-> SystemStart
-> TPraosParams
TPraosParams {
      tpraosSlotsPerKESPeriod :: Word64
tpraosSlotsPerKESPeriod = ShelleyGenesis era -> Word64
forall era. ShelleyGenesis era -> Word64
SL.sgSlotsPerKESPeriod ShelleyGenesis era
genesis
    , tpraosLeaderF :: ActiveSlotCoeff
tpraosLeaderF           = ShelleyGenesis era -> ActiveSlotCoeff
forall era. ShelleyGenesis era -> ActiveSlotCoeff
SL.sgActiveSlotCoeff   ShelleyGenesis era
genesis
    , tpraosMaxKESEvo :: Word64
tpraosMaxKESEvo         = ShelleyGenesis era -> Word64
forall era. ShelleyGenesis era -> Word64
SL.sgMaxKESEvolutions  ShelleyGenesis era
genesis
    , tpraosQuorum :: Word64
tpraosQuorum            = ShelleyGenesis era -> Word64
forall era. ShelleyGenesis era -> Word64
SL.sgUpdateQuorum      ShelleyGenesis era
genesis
    , tpraosMaxLovelaceSupply :: Word64
tpraosMaxLovelaceSupply = ShelleyGenesis era -> Word64
forall era. ShelleyGenesis era -> Word64
SL.sgMaxLovelaceSupply ShelleyGenesis era
genesis
    , tpraosNetworkId :: Network
tpraosNetworkId         = ShelleyGenesis era -> Network
forall era. ShelleyGenesis era -> Network
SL.sgNetworkId         ShelleyGenesis era
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 = Word64 -> SecurityParam
SecurityParam (Word64 -> SecurityParam) -> Word64 -> SecurityParam
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis era -> Word64
forall era. ShelleyGenesis era -> Word64
SL.sgSecurityParam ShelleyGenesis era
genesis
    systemStart :: SystemStart
systemStart   = UTCTime -> SystemStart
SystemStart   (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis era -> UTCTime
forall era. ShelleyGenesis era -> UTCTime
SL.sgSystemStart   ShelleyGenesis era
genesis

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

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

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

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

-- | Ledger view at a particular slot
newtype instance Ticked (SL.LedgerView c) = TickedPraosLedgerView {
      -- TODO: Perhaps it would be cleaner to define this as a separate type
      Ticked (LedgerView c) -> LedgerView c
getTickedPraosLedgerView :: SL.LedgerView 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 c = TPraosState {
      TPraosState c -> WithOrigin SlotNo
tpraosStateLastSlot      :: !(WithOrigin SlotNo)
    , TPraosState c -> ChainDepState c
tpraosStateChainDepState :: !(SL.ChainDepState c)
    }
  deriving ((forall x. TPraosState c -> Rep (TPraosState c) x)
-> (forall x. Rep (TPraosState c) x -> TPraosState c)
-> Generic (TPraosState c)
forall x. Rep (TPraosState c) x -> TPraosState c
forall x. TPraosState c -> Rep (TPraosState c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (TPraosState c) x -> TPraosState c
forall c x. TPraosState c -> Rep (TPraosState c) x
$cto :: forall c x. Rep (TPraosState c) x -> TPraosState c
$cfrom :: forall c x. TPraosState c -> Rep (TPraosState c) x
Generic, Int -> TPraosState c -> ShowS
[TPraosState c] -> ShowS
TPraosState c -> String
(Int -> TPraosState c -> ShowS)
-> (TPraosState c -> String)
-> ([TPraosState c] -> ShowS)
-> Show (TPraosState c)
forall c. Int -> TPraosState c -> ShowS
forall c. [TPraosState c] -> ShowS
forall c. TPraosState c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TPraosState c] -> ShowS
$cshowList :: forall c. [TPraosState c] -> ShowS
show :: TPraosState c -> String
$cshow :: forall c. TPraosState c -> String
showsPrec :: Int -> TPraosState c -> ShowS
$cshowsPrec :: forall c. Int -> TPraosState c -> ShowS
Show, TPraosState c -> TPraosState c -> Bool
(TPraosState c -> TPraosState c -> Bool)
-> (TPraosState c -> TPraosState c -> Bool) -> Eq (TPraosState c)
forall c. TPraosState c -> TPraosState c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TPraosState c -> TPraosState c -> Bool
$c/= :: forall c. TPraosState c -> TPraosState c -> Bool
== :: TPraosState c -> TPraosState c -> Bool
$c== :: forall c. TPraosState c -> TPraosState c -> Bool
Eq)

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

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

instance SL.PraosCrypto c => ToCBOR (TPraosState c) where
  toCBOR :: TPraosState c -> Encoding
toCBOR = TPraosState c -> Encoding
forall a. Serialise a => a -> Encoding
encode

instance SL.PraosCrypto c => FromCBOR (TPraosState c) where
  fromCBOR :: Decoder s (TPraosState c)
fromCBOR = Decoder s (TPraosState c)
forall a s. Serialise a => Decoder s a
decode

instance SL.PraosCrypto c => Serialise (TPraosState c) where
  encode :: TPraosState c -> Encoding
encode (TPraosState WithOrigin SlotNo
slot ChainDepState c
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 c -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR ChainDepState c
chainDepState
      ]

  decode :: Decoder s (TPraosState c)
decode = [(VersionNumber, VersionDecoder (TPraosState c))]
-> forall s. Decoder s (TPraosState c)
forall a.
[(VersionNumber, VersionDecoder a)] -> forall s. Decoder s a
decodeVersion
      [(VersionNumber
serialisationFormatVersion1, (forall s. Decoder s (TPraosState c))
-> VersionDecoder (TPraosState c)
forall a. (forall s. Decoder s a) -> VersionDecoder a
Decode forall s. Decoder s (TPraosState c)
decodeTPraosState1)]
    where
      decodeTPraosState1 :: Decoder s (TPraosState c)
decodeTPraosState1 = do
        Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"TPraosState" Int
2
        WithOrigin SlotNo -> ChainDepState c -> TPraosState c
forall c. WithOrigin SlotNo -> ChainDepState c -> TPraosState c
TPraosState (WithOrigin SlotNo -> ChainDepState c -> TPraosState c)
-> Decoder s (WithOrigin SlotNo)
-> Decoder s (ChainDepState c -> TPraosState c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (WithOrigin SlotNo)
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (ChainDepState c -> TPraosState c)
-> Decoder s (ChainDepState c) -> Decoder s (TPraosState c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (ChainDepState c)
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Ticked 'TPraosState'
data instance Ticked (TPraosState c) = TickedChainDepState {
      Ticked (TPraosState c) -> ChainDepState c
tickedTPraosStateChainDepState :: SL.ChainDepState c
    , Ticked (TPraosState c) -> Ticked (LedgerView (TPraos c))
tickedTPraosStateLedgerView    :: Ticked (LedgerView (TPraos c))
    }

instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where
  type ChainDepState (TPraos c) = TPraosState c
  type IsLeader      (TPraos c) = TPraosIsLeader c
  type CanBeLeader   (TPraos c) = PraosCanBeLeader c
  type SelectView    (TPraos c) = PraosChainSelectView c
  type LedgerView    (TPraos c) = SL.LedgerView c
  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 :: ConsensusConfig (TPraos c)
-> CanBeLeader (TPraos c)
-> SlotNo
-> Ticked (ChainDepState (TPraos c))
-> Maybe (IsLeader (TPraos c))
checkIsLeader ConsensusConfig (TPraos c)
cfg PraosCanBeLeader{..} SlotNo
slot Ticked (ChainDepState (TPraos c))
cs = do
      -- First, check whether we're in the overlay schedule
      case SlotNo
-> Set (KeyHash 'Genesis c)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe (OBftSlot c)
forall crypto.
SlotNo
-> Set (KeyHash 'Genesis crypto)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe (OBftSlot crypto)
SL.lookupInOverlaySchedule SlotNo
firstSlot Set (KeyHash 'Genesis c)
gkeys UnitInterval
d ActiveSlotCoeff
asc SlotNo
slot of
        -- Slot isn't in the overlay schedule, so we're in Praos
        Maybe (OBftSlot c)
Nothing
          | ConsensusConfig (TPraos c)
-> LedgerView (TPraos c)
-> KeyHash 'StakePool c
-> CertifiedVRF c Seed
-> Bool
forall c.
PraosCrypto c =>
ConsensusConfig (TPraos c)
-> LedgerView (TPraos c)
-> KeyHash 'StakePool c
-> CertifiedVRF c Seed
-> Bool
meetsLeaderThreshold ConsensusConfig (TPraos c)
cfg LedgerView c
LedgerView (TPraos c)
lv (KeyHash 'BlockIssuer c -> KeyHash 'StakePool c
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto
       (r' :: KeyRole).
HasKeyRole a =>
a r crypto -> a r' crypto
SL.coerceKeyRole KeyHash 'BlockIssuer c
vkhCold) CertifiedVRF c Seed
y
          -> TPraosIsLeader c -> Maybe (TPraosIsLeader c)
forall a. a -> Maybe a
Just TPraosIsLeader :: forall c.
CertifiedVRF c Nonce
-> CertifiedVRF c Natural
-> Maybe (Hash c (VerKeyVRF c))
-> TPraosIsLeader c
TPraosIsLeader {
                tpraosIsLeaderEta :: CertifiedVRF c Nonce
tpraosIsLeaderEta        = CertifiedVRF c Seed -> CertifiedVRF c Nonce
coerce CertifiedVRF c Seed
rho
              , tpraosIsLeaderProof :: CertifiedVRF c Natural
tpraosIsLeaderProof      = CertifiedVRF c Seed -> CertifiedVRF c Natural
coerce CertifiedVRF c Seed
y
              , tpraosIsLeaderGenVRFHash :: Maybe (Hash c (VerKeyVRF c))
tpraosIsLeaderGenVRFHash = Maybe (Hash c (VerKeyVRF c))
forall a. Maybe a
Nothing
              }
          | Bool
otherwise
          -> Maybe (IsLeader (TPraos c))
forall a. Maybe a
Nothing

       -- This is a non-active slot; nobody may produce a block
        Just OBftSlot c
SL.NonActiveSlot -> Maybe (IsLeader (TPraos 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 c
gkhash) -> case KeyHash 'Genesis c
-> Map (KeyHash 'Genesis c) (GenDelegPair c)
-> Maybe (GenDelegPair c)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'Genesis c
gkhash Map (KeyHash 'Genesis c) (GenDelegPair c)
dlgMap of
            Maybe (GenDelegPair c)
Nothing
              -> String -> Maybe (TPraosIsLeader c)
forall a. HasCallStack => String -> a
error String
"unknown genesis key in overlay schedule"
            Just (SL.GenDelegPair KeyHash 'GenesisDelegate c
dlgHash Hash c (VerKeyVRF c)
genDlgVRFHash)
              | KeyHash 'GenesisDelegate c -> KeyHash 'BlockIssuer c
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto
       (r' :: KeyRole).
HasKeyRole a =>
a r crypto -> a r' crypto
SL.coerceKeyRole KeyHash 'GenesisDelegate c
dlgHash KeyHash 'BlockIssuer c -> KeyHash 'BlockIssuer c -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash 'BlockIssuer c
vkhCold
              -> TPraosIsLeader c -> Maybe (TPraosIsLeader c)
forall a. a -> Maybe a
Just TPraosIsLeader :: forall c.
CertifiedVRF c Nonce
-> CertifiedVRF c Natural
-> Maybe (Hash c (VerKeyVRF c))
-> TPraosIsLeader c
TPraosIsLeader {
                     tpraosIsLeaderEta :: CertifiedVRF c Nonce
tpraosIsLeaderEta        = CertifiedVRF c Seed -> CertifiedVRF c Nonce
coerce CertifiedVRF 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 c Natural
tpraosIsLeaderProof      = CertifiedVRF c Seed -> CertifiedVRF c Natural
coerce CertifiedVRF c Seed
y
                   , tpraosIsLeaderGenVRFHash :: Maybe (Hash c (VerKeyVRF c))
tpraosIsLeaderGenVRFHash = Hash c (VerKeyVRF c) -> Maybe (Hash c (VerKeyVRF c))
forall a. a -> Maybe a
Just Hash c (VerKeyVRF c)
genDlgVRFHash
                   }
              | Bool
otherwise
              -> Maybe (IsLeader (TPraos c))
forall a. Maybe a
Nothing
    where
      chainState :: ChainDepState c
chainState = Ticked (TPraosState c) -> ChainDepState c
forall c. Ticked (TPraosState c) -> ChainDepState c
tickedTPraosStateChainDepState Ticked (ChainDepState (TPraos c))
Ticked (TPraosState c)
cs
      lv :: LedgerView c
lv         = Ticked (LedgerView c) -> LedgerView c
forall c. Ticked (LedgerView c) -> LedgerView c
getTickedPraosLedgerView (Ticked (LedgerView c) -> LedgerView c)
-> Ticked (LedgerView c) -> LedgerView c
forall a b. (a -> b) -> a -> b
$ Ticked (TPraosState c) -> Ticked (LedgerView (TPraos c))
forall c. Ticked (TPraosState c) -> Ticked (LedgerView (TPraos c))
tickedTPraosStateLedgerView Ticked (ChainDepState (TPraos c))
Ticked (TPraosState c)
cs
      d :: UnitInterval
d          = LedgerView c -> UnitInterval
forall crypto. LedgerView crypto -> UnitInterval
SL.lvD LedgerView c
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
forall (f :: * -> *).
Applicative f =>
EpochInfo (Except PastHorizonException) -> EpochInfo f
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 c)
gkeys      = Map (KeyHash 'Genesis c) (GenDelegPair c)
-> Set (KeyHash 'Genesis c)
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis c) (GenDelegPair c)
dlgMap
      eta0 :: Nonce
eta0       = TicknState -> Nonce
SL.ticknStateEpochNonce (TicknState -> Nonce) -> TicknState -> Nonce
forall a b. (a -> b) -> a -> b
$ ChainDepState c -> TicknState
forall crypto. ChainDepState crypto -> TicknState
SL.csTickn ChainDepState c
chainState
      vkhCold :: KeyHash 'BlockIssuer c
vkhCold    = VKey 'BlockIssuer c -> KeyHash 'BlockIssuer c
forall crypto (kd :: KeyRole).
Crypto crypto =>
VKey kd crypto -> KeyHash kd crypto
SL.hashKey VKey 'BlockIssuer c
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 c Seed
rho = ContextVRF (VRF c)
-> Seed -> SignKeyVRF (VRF c) -> CertifiedVRF 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 c Seed
y   = ContextVRF (VRF c)
-> Seed -> SignKeyVRF (VRF c) -> CertifiedVRF 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 c) (GenDelegPair c)
dlgMap = LedgerView c -> GenDelegs c
forall crypto. LedgerView crypto -> GenDelegs crypto
SL.lvGenDelegs LedgerView c
lv

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

  updateChainDepState :: 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 c -> TPraosState c
forall c. WithOrigin SlotNo -> ChainDepState c -> TPraosState c
TPraosState (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slot) (ChainDepState c -> TPraosState c)
-> ExceptT (ChainTransitionError c) Identity (ChainDepState c)
-> ExceptT (ChainTransitionError c) Identity (TPraosState c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Globals
-> LedgerView c
-> BHeader c
-> ChainDepState c
-> ExceptT (ChainTransitionError c) Identity (ChainDepState c)
forall crypto (m :: * -> *).
(PraosCrypto crypto, MonadError (ChainTransitionError crypto) m) =>
Globals
-> LedgerView crypto
-> BHeader crypto
-> ChainDepState crypto
-> m (ChainDepState crypto)
SL.updateChainDepState
          Globals
shelleyGlobals
          LedgerView c
lv
          BHeader c
ValidateView (TPraos c)
b
          (Ticked (TPraosState c) -> ChainDepState c
forall c. Ticked (TPraosState c) -> ChainDepState c
tickedTPraosStateChainDepState Ticked (ChainDepState (TPraos c))
Ticked (TPraosState c)
cs)
    where
      shelleyGlobals :: Globals
shelleyGlobals = ConsensusConfig (TPraos c) -> Globals
forall c. ConsensusConfig (TPraos c) -> Globals
mkShelleyGlobals ConsensusConfig (TPraos c)
cfg
      lv :: LedgerView c
lv = Ticked (LedgerView c) -> LedgerView c
forall c. Ticked (LedgerView c) -> LedgerView c
getTickedPraosLedgerView (Ticked (TPraosState c) -> Ticked (LedgerView (TPraos c))
forall c. Ticked (TPraosState c) -> Ticked (LedgerView (TPraos c))
tickedTPraosStateLedgerView Ticked (ChainDepState (TPraos c))
Ticked (TPraosState c)
cs)

  reupdateChainDepState :: 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 c -> TPraosState c
forall c. WithOrigin SlotNo -> ChainDepState c -> TPraosState c
TPraosState (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slot) (ChainDepState c -> TPraosState c)
-> ChainDepState c -> TPraosState c
forall a b. (a -> b) -> a -> b
$
        Globals
-> LedgerView c -> BHeader c -> ChainDepState c -> ChainDepState c
forall crypto.
PraosCrypto crypto =>
Globals
-> LedgerView crypto
-> BHeader crypto
-> ChainDepState crypto
-> ChainDepState crypto
SL.reupdateChainDepState
          Globals
shelleyGlobals
          LedgerView c
lv
          BHeader c
ValidateView (TPraos c)
b
          (Ticked (TPraosState c) -> ChainDepState c
forall c. Ticked (TPraosState c) -> ChainDepState c
tickedTPraosStateChainDepState Ticked (ChainDepState (TPraos c))
Ticked (TPraosState c)
cs)
    where
      shelleyGlobals :: Globals
shelleyGlobals = ConsensusConfig (TPraos c) -> Globals
forall c. ConsensusConfig (TPraos c) -> Globals
mkShelleyGlobals ConsensusConfig (TPraos c)
cfg
      lv :: LedgerView c
lv = Ticked (LedgerView c) -> LedgerView c
forall c. Ticked (LedgerView c) -> LedgerView c
getTickedPraosLedgerView (Ticked (TPraosState c) -> Ticked (LedgerView (TPraos c))
forall c. Ticked (TPraosState c) -> Ticked (LedgerView (TPraos c))
tickedTPraosStateLedgerView Ticked (ChainDepState (TPraos c))
Ticked (TPraosState c)
cs)

mkShelleyGlobals :: ConsensusConfig (TPraos c) -> SL.Globals
mkShelleyGlobals :: ConsensusConfig (TPraos c) -> Globals
mkShelleyGlobals TPraosConfig{..} = Globals :: EpochInfo (Either Text)
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Natural
-> Word64
-> ActiveSlotCoeff
-> Network
-> SystemStart
-> Globals
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)
-> (ExceptT PastHorizonException Identity a -> Except Text a)
-> ExceptT PastHorizonException Identity a
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PastHorizonException -> Text)
-> ExceptT PastHorizonException Identity 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 :: Word64
securityParameter             = Word64
k
    , maxKESEvo :: Word64
maxKESEvo                     = Word64
tpraosMaxKESEvo
    , quorum :: Word64
quorum                        = Word64
tpraosQuorum
    , maxMajorPV :: Natural
maxMajorPV                    = MaxMajorProtVer -> Natural
getMaxMajorProtVer MaxMajorProtVer
tpraosMaxMajorPV
    , maxLovelaceSupply :: Word64
maxLovelaceSupply             = Word64
tpraosMaxLovelaceSupply
    , activeSlotCoeff :: ActiveSlotCoeff
activeSlotCoeff               = ActiveSlotCoeff
tpraosLeaderF
    , networkId :: Network
networkId                     = Network
tpraosNetworkId
    , systemStart :: SystemStart
systemStart                   = SystemStart
tpraosSystemStart
    }
  where
    SecurityParam Word64
k  = SecurityParam
tpraosSecurityParam
    TPraosParams{Word64
Nonce
ActiveSlotCoeff
Network
SystemStart
SecurityParam
MaxMajorProtVer
tpraosInitialNonce :: Nonce
tpraosSecurityParam :: SecurityParam
tpraosSystemStart :: SystemStart
tpraosNetworkId :: Network
tpraosMaxLovelaceSupply :: Word64
tpraosMaxMajorPV :: MaxMajorProtVer
tpraosQuorum :: Word64
tpraosMaxKESEvo :: Word64
tpraosLeaderF :: ActiveSlotCoeff
tpraosSlotsPerKESPeriod :: Word64
tpraosSystemStart :: TPraosParams -> SystemStart
tpraosInitialNonce :: TPraosParams -> Nonce
tpraosNetworkId :: TPraosParams -> Network
tpraosMaxLovelaceSupply :: TPraosParams -> Word64
tpraosMaxMajorPV :: TPraosParams -> MaxMajorProtVer
tpraosQuorum :: TPraosParams -> Word64
tpraosMaxKESEvo :: TPraosParams -> Word64
tpraosSecurityParam :: TPraosParams -> SecurityParam
tpraosLeaderF :: TPraosParams -> ActiveSlotCoeff
tpraosSlotsPerKESPeriod :: TPraosParams -> Word64
..} = 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 c
  -> SL.CertifiedVRF c SL.Seed
  -> Bool
meetsLeaderThreshold :: ConsensusConfig (TPraos c)
-> LedgerView (TPraos c)
-> KeyHash 'StakePool c
-> CertifiedVRF c Seed
-> Bool
meetsLeaderThreshold TPraosConfig { tpraosParams }
                     SL.LedgerView { lvPoolDistr }
                     KeyHash 'StakePool c
keyHash
                     CertifiedVRF c Seed
certNat =
    OutputVRF (VRF c) -> Rational -> ActiveSlotCoeff -> Bool
forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
SL.checkLeaderValue
      (CertifiedVRF c Seed -> OutputVRF (VRF c)
forall v a. CertifiedVRF v a -> OutputVRF v
VRF.certifiedOutput CertifiedVRF c Seed
certNat)
      Rational
r
      (TPraosParams -> ActiveSlotCoeff
tpraosLeaderF TPraosParams
tpraosParams)
  where
    SL.PoolDistr Map (KeyHash 'StakePool c) (IndividualPoolStake c)
poolDistr = PoolDistr c
lvPoolDistr
    r :: Rational
r = Rational
-> (IndividualPoolStake c -> Rational)
-> Maybe (IndividualPoolStake c)
-> Rational
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rational
0 IndividualPoolStake c -> Rational
forall crypto. IndividualPoolStake crypto -> Rational
SL.individualPoolStake
        (Maybe (IndividualPoolStake c) -> Rational)
-> Maybe (IndividualPoolStake c) -> Rational
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool c
-> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> Maybe (IndividualPoolStake c)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool c
keyHash Map (KeyHash 'StakePool c) (IndividualPoolStake c)
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
      !(SL.Hash c (SL.VerKeyVRF c))
      !(SL.Hash c (SL.VerKeyVRF 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
$cto :: forall c x. Rep (TPraosCannotForge c) x -> TPraosCannotForge c
$cfrom :: forall c x. TPraosCannotForge c -> Rep (TPraosCannotForge c) x
Generic)

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

tpraosCheckCanForge ::
     ConsensusConfig (TPraos c)
  -> SL.Hash c (SL.VerKeyVRF c)
     -- ^ Precomputed hash of the VRF verification key
  -> SlotNo
  -> IsLeader (TPraos c)
  -> HotKey.KESInfo
  -> Either (TPraosCannotForge c) ()
tpraosCheckCanForge :: ConsensusConfig (TPraos c)
-> Hash c (VerKeyVRF c)
-> SlotNo
-> IsLeader (TPraos c)
-> KESInfo
-> Either (TPraosCannotForge c) ()
tpraosCheckCanForge TPraosConfig { tpraosParams }
                    Hash c (VerKeyVRF c)
forgingVRFHash
                    SlotNo
curSlot
                    TPraosIsLeader { 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 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 c (VerKeyVRF c)
genVRFHash <- Maybe (Hash c (VerKeyVRF c))
tpraosIsLeaderGenVRFHash
  , Hash c (VerKeyVRF c)
genVRFHash Hash c (VerKeyVRF c) -> Hash c (VerKeyVRF c) -> Bool
forall a. Eq a => a -> a -> Bool
/= Hash c (VerKeyVRF c)
forgingVRFHash
  = TPraosCannotForge c -> Either (TPraosCannotForge c) ()
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 c (VerKeyVRF c) -> Hash c (VerKeyVRF c) -> TPraosCannotForge c
forall c.
Hash c (VerKeyVRF c) -> Hash c (VerKeyVRF c) -> TPraosCannotForge c
TPraosCannotForgeWrongVRF Hash c (VerKeyVRF c)
genVRFHash Hash c (VerKeyVRF c)
forgingVRFHash
  | Bool
otherwise
  = () -> Either (TPraosCannotForge c) ()
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 :: proxy (TPraos c) -> ChainDepState (TPraos c) -> PraosNonces
getPraosNonces proxy (TPraos c)
_prx ChainDepState (TPraos c)
cdst =
      PraosNonces :: Nonce -> Nonce -> Nonce -> Nonce -> Nonce -> PraosNonces
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 c
tpraosStateChainDepState :: ChainDepState c
tpraosStateChainDepState :: forall c. TPraosState c -> ChainDepState c
tpraosStateChainDepState } = ChainDepState (TPraos c)
TPraosState c
cdst
      SL.ChainDepState {
          Nonce
csLabNonce :: forall crypto. ChainDepState crypto -> Nonce
csLabNonce :: Nonce
SL.csLabNonce
        , PrtclState c
csProtocol :: forall crypto. ChainDepState crypto -> PrtclState crypto
csProtocol :: PrtclState c
SL.csProtocol
        , TicknState
csTickn :: TicknState
csTickn :: forall crypto. ChainDepState crypto -> TicknState
SL.csTickn
        } = ChainDepState c
tpraosStateChainDepState
      SL.PrtclState
        Map (KeyHash 'BlockIssuer c) Word64
_opcertCounters
        Nonce
evolvingNonce
        Nonce
candidateNonce
          = PrtclState c
csProtocol
      SL.TicknState {
          Nonce
ticknStateEpochNonce :: Nonce
ticknStateEpochNonce :: TicknState -> Nonce
ticknStateEpochNonce
        , Nonce
ticknStatePrevHashNonce :: TicknState -> Nonce
ticknStatePrevHashNonce :: Nonce
ticknStatePrevHashNonce
        } = TicknState
csTickn

  getOpCertCounters :: proxy (TPraos c)
-> ChainDepState (TPraos c)
-> Map
     (KeyHash 'BlockIssuer (PraosProtocolSupportsNodeCrypto (TPraos c)))
     Word64
getOpCertCounters proxy (TPraos c)
_prx ChainDepState (TPraos c)
cdst = Map (KeyHash 'BlockIssuer c) Word64
Map
  (KeyHash 'BlockIssuer (PraosProtocolSupportsNodeCrypto (TPraos c)))
  Word64
opcertCounters
    where
      TPraosState { ChainDepState c
tpraosStateChainDepState :: ChainDepState c
tpraosStateChainDepState :: forall c. TPraosState c -> ChainDepState c
tpraosStateChainDepState } = ChainDepState (TPraos c)
TPraosState c
cdst
      SL.ChainDepState {
        PrtclState c
csProtocol :: PrtclState c
csProtocol :: forall crypto. ChainDepState crypto -> PrtclState crypto
SL.csProtocol
        } = ChainDepState c
tpraosStateChainDepState
      SL.PrtclState
        Map (KeyHash 'BlockIssuer c) Word64
opcertCounters
        Nonce
_evolvingNonce
        Nonce
_candidateNonce
          = PrtclState c
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