{-# 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.VRF as VRF
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           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 c toSign
tpraosSignature :: SL.SignedKES 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 c
tpraosToSignIssuerVK :: SL.VKey 'SL.BlockIssuer c
    , forall c. TPraosToSign c -> VerKeyVRF c
tpraosToSignVrfVK    :: SL.VerKeyVRF c
      -- | Verifiable result containing the updated nonce value.
    , forall c. 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.)
    , forall c. TPraosToSign c -> CertifiedVRF c Natural
tpraosToSignLeader   :: SL.CertifiedVRF 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
     , SL.KESignable 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, 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
hotKey PraosCanBeLeader{SignKeyVRF c
VKey 'BlockIssuer c
OCert c
praosCanBeLeaderOpCert :: OCert c
praosCanBeLeaderColdVerKey :: VKey 'BlockIssuer c
praosCanBeLeaderSignKeyVRF :: SignKeyVRF c
praosCanBeLeaderOpCert :: forall c. PraosCanBeLeader c -> OCert c
praosCanBeLeaderColdVerKey :: forall c. PraosCanBeLeader c -> VKey 'BlockIssuer c
praosCanBeLeaderSignKeyVRF :: forall c. PraosCanBeLeader c -> SignKeyVRF c
..} TPraosIsLeader{Maybe (Hash c (VerKeyVRF c))
CertifiedVRF c Natural
CertifiedVRF c Nonce
tpraosIsLeaderEta :: CertifiedVRF c Nonce
tpraosIsLeaderProof :: CertifiedVRF c Natural
tpraosIsLeaderGenVRFHash :: Maybe (Hash c (VerKeyVRF c))
tpraosIsLeaderEta :: forall c. TPraosIsLeader c -> CertifiedVRF c Nonce
tpraosIsLeaderProof :: forall c. TPraosIsLeader c -> CertifiedVRF c Natural
tpraosIsLeaderGenVRFHash :: forall c. TPraosIsLeader c -> Maybe (Hash c (VerKeyVRF c))
..} 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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 {
        tpraosToSignIssuerVK :: VKey 'BlockIssuer c
tpraosToSignIssuerVK = VKey 'BlockIssuer c
praosCanBeLeaderColdVerKey
      , tpraosToSignVrfVK :: VerKeyVRF c
tpraosToSignVrfVK    = SignKeyVRF c -> VerKeyVRF c
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
VRF.deriveVerKeyVRF SignKeyVRF 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
$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 era
  -> TPraosParams
mkTPraosParams :: forall era.
MaxMajorProtVer -> Nonce -> ShelleyGenesis era -> TPraosParams
mkTPraosParams MaxMajorProtVer
maxMajorPV Nonce
initialNonce ShelleyGenesis era
genesis = TPraosParams {
      tpraosSlotsPerKESPeriod :: Word64
tpraosSlotsPerKESPeriod = ShelleyGenesis era -> Word64
forall c. ShelleyGenesis c -> Word64
SL.sgSlotsPerKESPeriod ShelleyGenesis era
genesis
    , tpraosLeaderF :: ActiveSlotCoeff
tpraosLeaderF           = ShelleyGenesis era -> ActiveSlotCoeff
forall c. ShelleyGenesis c -> ActiveSlotCoeff
SL.sgActiveSlotCoeff   ShelleyGenesis era
genesis
    , tpraosMaxKESEvo :: Word64
tpraosMaxKESEvo         = ShelleyGenesis era -> Word64
forall c. ShelleyGenesis c -> Word64
SL.sgMaxKESEvolutions  ShelleyGenesis era
genesis
    , tpraosQuorum :: Word64
tpraosQuorum            = ShelleyGenesis era -> Word64
forall c. ShelleyGenesis c -> Word64
SL.sgUpdateQuorum      ShelleyGenesis era
genesis
    , tpraosMaxLovelaceSupply :: Word64
tpraosMaxLovelaceSupply = ShelleyGenesis era -> Word64
forall c. ShelleyGenesis c -> Word64
SL.sgMaxLovelaceSupply ShelleyGenesis era
genesis
    , tpraosNetworkId :: Network
tpraosNetworkId         = ShelleyGenesis era -> Network
forall c. ShelleyGenesis c -> 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 c. ShelleyGenesis c -> 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 c. ShelleyGenesis c -> 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 {
      forall c. TPraosIsLeader c -> CertifiedVRF c Nonce
tpraosIsLeaderEta        :: SL.CertifiedVRF c SL.Nonce
    , forall c. 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
    , forall c. 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
$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 c = TPraosState {
      forall c. TPraosState c -> WithOrigin SlotNo
tpraosStateLastSlot      :: !(WithOrigin SlotNo)
    , forall c. 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
$cfrom :: forall c x. TPraosState c -> Rep (TPraosState c) x
from :: forall x. TPraosState c -> Rep (TPraosState c) x
$cto :: forall c x. Rep (TPraosState c) x -> TPraosState c
to :: forall x. Rep (TPraosState c) x -> TPraosState c
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
$cshowsPrec :: forall c. Int -> TPraosState c -> ShowS
showsPrec :: Int -> TPraosState c -> ShowS
$cshow :: forall c. TPraosState c -> String
show :: TPraosState c -> String
$cshowList :: forall c. [TPraosState c] -> ShowS
showList :: [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
$c== :: forall c. TPraosState c -> TPraosState c -> Bool
== :: TPraosState c -> TPraosState c -> Bool
$c/= :: forall c. TPraosState c -> TPraosState c -> Bool
/= :: 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 :: forall s. Decoder s (TPraosState c)
fromCBOR = Decoder s (TPraosState c)
forall s. 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 :: forall s. 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 Decoder s (TPraosState c)
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 s. 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 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 c)
forall s. Decoder s (ChainDepState c)
forall a s. FromCBOR a => Decoder s a
fromCBOR

data instance Ticked (TPraosState c) = TickedChainDepState {
      forall c. Ticked (TPraosState c) -> ChainDepState c
tickedTPraosStateChainDepState :: SL.ChainDepState c
    , forall c. Ticked (TPraosState c) -> LedgerView (TPraos c)
tickedTPraosStateLedgerView    :: 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 :: HasCallStack =>
ConsensusConfig (TPraos c)
-> CanBeLeader (TPraos c)
-> SlotNo
-> Ticked (ChainDepState (TPraos c))
-> Maybe (IsLeader (TPraos c))
checkIsLeader ConsensusConfig (TPraos c)
cfg PraosCanBeLeader{SignKeyVRF c
VKey 'BlockIssuer c
OCert c
praosCanBeLeaderOpCert :: forall c. PraosCanBeLeader c -> OCert c
praosCanBeLeaderColdVerKey :: forall c. PraosCanBeLeader c -> VKey 'BlockIssuer c
praosCanBeLeaderSignKeyVRF :: forall c. PraosCanBeLeader c -> SignKeyVRF c
praosCanBeLeaderOpCert :: OCert c
praosCanBeLeaderColdVerKey :: VKey 'BlockIssuer c
praosCanBeLeaderSignKeyVRF :: SignKeyVRF c
..} 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 c.
SlotNo
-> Set (KeyHash 'Genesis c)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe (OBftSlot c)
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 (VRF 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 (TPraos c)
lv (KeyHash 'BlockIssuer c -> KeyHash 'StakePool c
forall (r :: KeyRole) c (r' :: KeyRole).
KeyHash r c -> KeyHash r' c
forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
SL.coerceKeyRole KeyHash 'BlockIssuer c
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 c (VerKeyVRF c))
tpraosIsLeaderGenVRFHash = Maybe (Hash c (VerKeyVRF 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 c
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 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 (r :: KeyRole) c (r' :: KeyRole).
KeyHash r c -> KeyHash r' c
forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
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 {
                     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 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))
Maybe (TPraosIsLeader 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 (TPraos c)
lv         = Ticked (TPraosState c) -> LedgerView (TPraos c)
forall c. Ticked (TPraosState c) -> LedgerView (TPraos c)
tickedTPraosStateLedgerView    Ticked (ChainDepState (TPraos c))
Ticked (TPraosState c)
cs
      d :: UnitInterval
d          = LedgerView c -> UnitInterval
forall c. LedgerView c -> UnitInterval
SL.lvD LedgerView c
LedgerView (TPraos 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
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 c. ChainDepState c -> TicknState
SL.csTickn ChainDepState c
chainState
      vkhCold :: KeyHash 'BlockIssuer c
vkhCold    = VKey 'BlockIssuer c -> KeyHash 'BlockIssuer c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
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 (VRF c) Seed
rho = ContextVRF (VRF c)
-> Seed -> SignKeyVRF 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 c
praosCanBeLeaderSignKeyVRF
      y :: CertifiedVRF (VRF c) Seed
y   = ContextVRF (VRF c)
-> Seed -> SignKeyVRF 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 c
praosCanBeLeaderSignKeyVRF

      SL.GenDelegs Map (KeyHash 'Genesis c) (GenDelegPair c)
dlgMap = LedgerView c -> GenDelegs c
forall c. LedgerView c -> GenDelegs c
SL.lvGenDelegs LedgerView c
LedgerView (TPraos c)
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 c
st) =
      TickedChainDepState {
          tickedTPraosStateChainDepState :: ChainDepState c
tickedTPraosStateChainDepState = ChainDepState c
st'
        , tickedTPraosStateLedgerView :: LedgerView (TPraos c)
tickedTPraosStateLedgerView    = LedgerView (TPraos c)
lv
        }
    where
      st' :: ChainDepState c
st' = Globals
-> LedgerView c -> Bool -> ChainDepState c -> ChainDepState c
forall c.
Globals
-> LedgerView c -> Bool -> ChainDepState c -> ChainDepState c
SL.tickChainDepState
              (ConsensusConfig (TPraos c) -> Globals
forall c. ConsensusConfig (TPraos c) -> Globals
mkShelleyGlobals ConsensusConfig (TPraos c)
cfg)
              LedgerView c
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 c
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 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 c (m :: * -> *).
(PraosCrypto c, MonadError (ChainTransitionError c) m) =>
Globals
-> LedgerView c
-> BHeader c
-> ChainDepState c
-> m (ChainDepState c)
SL.updateChainDepState
          (ConsensusConfig (TPraos c) -> Globals
forall c. ConsensusConfig (TPraos c) -> Globals
mkShelleyGlobals ConsensusConfig (TPraos c)
cfg)
          (Ticked (TPraosState c) -> LedgerView (TPraos c)
forall c. Ticked (TPraosState c) -> LedgerView (TPraos c)
tickedTPraosStateLedgerView Ticked (ChainDepState (TPraos c))
Ticked (TPraosState c)
cs)
          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)

  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 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 c.
PraosCrypto c =>
Globals
-> LedgerView c -> BHeader c -> ChainDepState c -> ChainDepState c
SL.reupdateChainDepState
          (ConsensusConfig (TPraos c) -> Globals
forall c. ConsensusConfig (TPraos c) -> Globals
mkShelleyGlobals ConsensusConfig (TPraos c)
cfg)
          (Ticked (TPraosState c) -> LedgerView (TPraos c)
forall c. Ticked (TPraosState c) -> LedgerView (TPraos c)
tickedTPraosStateLedgerView Ticked (ChainDepState (TPraos c))
Ticked (TPraosState c)
cs)
          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)

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 :: Word64
securityParameter             = Word64
k
    , 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
    SecurityParam Word64
k  = 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 c
  -> SL.CertifiedVRF c SL.Seed
  -> Bool
meetsLeaderThreshold :: forall c.
PraosCrypto c =>
ConsensusConfig (TPraos c)
-> LedgerView (TPraos c)
-> KeyHash 'StakePool c
-> CertifiedVRF c Seed
-> Bool
meetsLeaderThreshold TPraosConfig { TPraosParams
tpraosParams :: forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams :: TPraosParams
tpraosParams }
                     SL.LedgerView { PoolDistr c
lvPoolDistr :: PoolDistr c
lvPoolDistr :: forall c. LedgerView c -> PoolDistr c
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 CompactForm Coin
_totalActiveStake = 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 c. IndividualPoolStake c -> 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
$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)
  -> SL.Hash c (SL.VerKeyVRF c)
     -- ^ Precomputed hash of the VRF verification key
  -> SlotNo
  -> IsLeader (TPraos c)
  -> HotKey.KESInfo
  -> Either (TPraosCannotForge c) ()
tpraosCheckCanForge :: forall c.
ConsensusConfig (TPraos c)
-> Hash c (VerKeyVRF c)
-> SlotNo
-> IsLeader (TPraos c)
-> KESInfo
-> Either (TPraosCannotForge c) ()
tpraosCheckCanForge TPraosConfig { TPraosParams
tpraosParams :: forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams :: TPraosParams
tpraosParams }
                    Hash (HASH c) (VerKeyVRF (VRF c))
forgingVRFHash
                    SlotNo
curSlot
                    TPraosIsLeader { Maybe (Hash (HASH c) (VerKeyVRF (VRF c)))
tpraosIsLeaderGenVRFHash :: forall c. TPraosIsLeader c -> Maybe (Hash c (VerKeyVRF c))
tpraosIsLeaderGenVRFHash :: Maybe (Hash (HASH c) (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 c) (VerKeyVRF (VRF c))
genVRFHash <- Maybe (Hash (HASH c) (VerKeyVRF (VRF c)))
tpraosIsLeaderGenVRFHash
  , Hash (HASH c) (VerKeyVRF (VRF c))
genVRFHash Hash (HASH c) (VerKeyVRF (VRF c))
-> Hash (HASH c) (VerKeyVRF (VRF c)) -> Bool
forall a. Eq a => a -> a -> Bool
/= Hash (HASH c) (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 c) (VerKeyVRF (VRF c))
-> Hash (HASH c) (VerKeyVRF (VRF c)) -> TPraosCannotForge c
forall c.
Hash c (VerKeyVRF c) -> Hash c (VerKeyVRF c) -> TPraosCannotForge c
TPraosCannotForgeWrongVRF Hash (HASH c) (VerKeyVRF (VRF c))
genVRFHash Hash (HASH c) (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 c
tpraosStateChainDepState :: forall c. TPraosState c -> ChainDepState c
tpraosStateChainDepState :: ChainDepState c
tpraosStateChainDepState } = ChainDepState (TPraos c)
cdst
      SL.ChainDepState {
          Nonce
csLabNonce :: Nonce
csLabNonce :: forall c. ChainDepState c -> Nonce
SL.csLabNonce
        , PrtclState c
csProtocol :: PrtclState c
csProtocol :: forall c. ChainDepState c -> PrtclState c
SL.csProtocol
        , TicknState
csTickn :: forall c. ChainDepState c -> TicknState
csTickn :: 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 :: 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 (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 :: forall c. TPraosState c -> ChainDepState c
tpraosStateChainDepState :: ChainDepState c
tpraosStateChainDepState } = ChainDepState (TPraos c)
cdst
      SL.ChainDepState {
        PrtclState c
csProtocol :: forall c. ChainDepState c -> PrtclState c
csProtocol :: PrtclState c
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