{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeApplications    #-}
{-# 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.Shelley.Protocol (
    TPraos
  , TPraosState (..)
  , TPraosChainSelectView (..)
  , SelfIssued (..)
  , TPraosFields (..)
  , forgeTPraosFields
  , TPraosToSign (..)
  , TPraosValidateView
  , TPraosParams (..)
  , mkTPraosParams
  , TPraosCanBeLeader (..)
  , TPraosIsLeader (..)
  , mkShelleyGlobals
  , MaxMajorProtVer (..)
    -- * Crypto
  , 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 (throwError)
import           Data.Coerce (coerce)
import           Data.Function (on)
import           Data.Functor.Identity (Identity)
import qualified Data.Map.Strict as Map
import           Data.Ord (Down (..))
import           Data.Word (Word64)
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks (..))
import           Numeric.Natural (Natural)

import           Cardano.Binary (enforceSize, fromCBOR, toCBOR)
import qualified Cardano.Crypto.VRF as VRF
import           Cardano.Slotting.EpochInfo

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Ticked
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.Versioned

import           Cardano.Ledger.Crypto (VRF)
import qualified Shelley.Spec.Ledger.API as SL
import qualified Shelley.Spec.Ledger.BaseTypes as SL (ActiveSlotCoeff, Seed)
import qualified Shelley.Spec.Ledger.BlockChain as SL (checkLeaderValue, mkSeed,
                     seedEta, seedL)
import qualified Shelley.Spec.Ledger.OCert as Absolute (KESPeriod (..))

import           Ouroboros.Consensus.Shelley.Protocol.Crypto
import           Ouroboros.Consensus.Shelley.Protocol.HotKey (HotKey)
import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey
import           Ouroboros.Consensus.Shelley.Protocol.Util

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

forgeTPraosFields ::
     ( 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 TPraosCanBeLeader{..} 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
tpraosCanBeLeaderColdVerKey
      , tpraosToSignVrfVK :: VerKeyVRF c
tpraosToSignVrfVK    = SignKeyVRF (VRF c) -> VerKeyVRF c
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
VRF.deriveVerKeyVRF SignKeyVRF (VRF c)
tpraosCanBeLeaderSignKeyVRF
      , tpraosToSignEta :: CertifiedVRF c Nonce
tpraosToSignEta      = CertifiedVRF c Nonce
tpraosIsLeaderEta
      , tpraosToSignLeader :: CertifiedVRF c Natural
tpraosToSignLeader   = CertifiedVRF c Natural
tpraosIsLeaderProof
      , tpraosToSignOCert :: OCert c
tpraosToSignOCert    = OCert c
tpraosCanBeLeaderOpCert
      }

-- | 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
-------------------------------------------------------------------------------}

-- | The maximum major protocol version.
--
-- Must be at least the current major protocol version. For Cardano mainnet, the
-- Shelley era has major protocol verison __2__.
newtype MaxMajorProtVer = MaxMajorProtVer {
      MaxMajorProtVer -> Natural
getMaxMajorProtVer :: Natural
    }
  deriving (MaxMajorProtVer -> MaxMajorProtVer -> Bool
(MaxMajorProtVer -> MaxMajorProtVer -> Bool)
-> (MaxMajorProtVer -> MaxMajorProtVer -> Bool)
-> Eq MaxMajorProtVer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MaxMajorProtVer -> MaxMajorProtVer -> Bool
$c/= :: MaxMajorProtVer -> MaxMajorProtVer -> Bool
== :: MaxMajorProtVer -> MaxMajorProtVer -> Bool
$c== :: MaxMajorProtVer -> MaxMajorProtVer -> Bool
Eq, Int -> MaxMajorProtVer -> ShowS
[MaxMajorProtVer] -> ShowS
MaxMajorProtVer -> String
(Int -> MaxMajorProtVer -> ShowS)
-> (MaxMajorProtVer -> String)
-> ([MaxMajorProtVer] -> ShowS)
-> Show MaxMajorProtVer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MaxMajorProtVer] -> ShowS
$cshowList :: [MaxMajorProtVer] -> ShowS
show :: MaxMajorProtVer -> String
$cshow :: MaxMajorProtVer -> String
showsPrec :: Int -> MaxMajorProtVer -> ShowS
$cshowsPrec :: Int -> MaxMajorProtVer -> ShowS
Show, (forall x. MaxMajorProtVer -> Rep MaxMajorProtVer x)
-> (forall x. Rep MaxMajorProtVer x -> MaxMajorProtVer)
-> Generic MaxMajorProtVer
forall x. Rep MaxMajorProtVer x -> MaxMajorProtVer
forall x. MaxMajorProtVer -> Rep MaxMajorProtVer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MaxMajorProtVer x -> MaxMajorProtVer
$cfrom :: forall x. MaxMajorProtVer -> Rep MaxMajorProtVer x
Generic, Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo)
Proxy MaxMajorProtVer -> String
(Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo))
-> (Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo))
-> (Proxy MaxMajorProtVer -> String)
-> NoThunks MaxMajorProtVer
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy MaxMajorProtVer -> String
$cshowTypeOf :: Proxy MaxMajorProtVer -> String
wNoThunks :: Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo)
noThunks :: Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> MaxMajorProtVer -> IO (Maybe ThunkInfo)
NoThunks)

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
    }
  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
-> 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
    }
  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

data TPraosCanBeLeader c = TPraosCanBeLeader {
      -- | Certificate delegating rights from the stake pool cold key (or
      -- genesis stakeholder delegate cold key) to the online KES key.
      TPraosCanBeLeader c -> OCert c
tpraosCanBeLeaderOpCert     :: !(SL.OCert c)
      -- | Stake pool cold key or genesis stakeholder delegate cold key.
    , TPraosCanBeLeader c -> VKey 'BlockIssuer c
tpraosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer c)
    , TPraosCanBeLeader c -> SignKeyVRF c
tpraosCanBeLeaderSignKeyVRF :: !(SL.SignKeyVRF c)
    }
  deriving ((forall x. TPraosCanBeLeader c -> Rep (TPraosCanBeLeader c) x)
-> (forall x. Rep (TPraosCanBeLeader c) x -> TPraosCanBeLeader c)
-> Generic (TPraosCanBeLeader c)
forall x. Rep (TPraosCanBeLeader c) x -> TPraosCanBeLeader c
forall x. TPraosCanBeLeader c -> Rep (TPraosCanBeLeader c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (TPraosCanBeLeader c) x -> TPraosCanBeLeader c
forall c x. TPraosCanBeLeader c -> Rep (TPraosCanBeLeader c) x
$cto :: forall c x. Rep (TPraosCanBeLeader c) x -> TPraosCanBeLeader c
$cfrom :: forall c x. TPraosCanBeLeader c -> Rep (TPraosCanBeLeader c) x
Generic)

instance PraosCrypto c => NoThunks (TPraosCanBeLeader c)

-- | 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 PraosCrypto c => NoThunks (TPraosIsLeader c)

-- | Static configuration
data instance ConsensusConfig (TPraos c) = TPraosConfig {
      ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams    :: !TPraosParams
    , ConsensusConfig (TPraos c) -> EpochInfo Identity
tpraosEpochInfo :: !(EpochInfo Identity)
    }
  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 PraosCrypto c => NoThunks (ConsensusConfig (TPraos c))

-- | Separate type instead of 'Bool' for the custom 'Ord' instance +
-- documentation.
data SelfIssued =
    -- | A block we produced ourself
    SelfIssued
    -- | A block produced by another node
  | NotSelfIssued
  deriving (Int -> SelfIssued -> ShowS
[SelfIssued] -> ShowS
SelfIssued -> String
(Int -> SelfIssued -> ShowS)
-> (SelfIssued -> String)
-> ([SelfIssued] -> ShowS)
-> Show SelfIssued
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SelfIssued] -> ShowS
$cshowList :: [SelfIssued] -> ShowS
show :: SelfIssued -> String
$cshow :: SelfIssued -> String
showsPrec :: Int -> SelfIssued -> ShowS
$cshowsPrec :: Int -> SelfIssued -> ShowS
Show, SelfIssued -> SelfIssued -> Bool
(SelfIssued -> SelfIssued -> Bool)
-> (SelfIssued -> SelfIssued -> Bool) -> Eq SelfIssued
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SelfIssued -> SelfIssued -> Bool
$c/= :: SelfIssued -> SelfIssued -> Bool
== :: SelfIssued -> SelfIssued -> Bool
$c== :: SelfIssued -> SelfIssued -> Bool
Eq)

instance Ord SelfIssued where
  compare :: SelfIssued -> SelfIssued -> Ordering
compare SelfIssued
SelfIssued    SelfIssued
SelfIssued    = Ordering
EQ
  compare SelfIssued
NotSelfIssued SelfIssued
NotSelfIssued = Ordering
EQ
  compare SelfIssued
SelfIssued    SelfIssued
NotSelfIssued = Ordering
GT
  compare SelfIssued
NotSelfIssued SelfIssued
SelfIssued    = Ordering
LT

-- | View of the ledger tip for chain selection.
--
-- We order between chains as follows:
--
-- 1. By chain length, with longer chains always preferred.
-- 2. If the tip of each chain has the same slot number, we prefer the one tip
--    that we produced ourselves.
-- 3. If the tip of each chain was issued by the same agent, then we prefer
--    the chain whose tip has the highest ocert issue number.
-- 4. By the leader value of the chain tip, with lower values preferred.
data TPraosChainSelectView c = TPraosChainSelectView {
    TPraosChainSelectView c -> BlockNo
csvChainLength :: BlockNo
  , TPraosChainSelectView c -> SlotNo
csvSlotNo      :: SlotNo
  , TPraosChainSelectView c -> SelfIssued
csvSelfIssued  :: SelfIssued
  , TPraosChainSelectView c -> VKey 'BlockIssuer c
csvIssuer      :: SL.VKey 'SL.BlockIssuer c
  , TPraosChainSelectView c -> Word64
csvIssueNo     :: Word64
  , TPraosChainSelectView c -> OutputVRF (VRF c)
csvLeaderVRF   :: VRF.OutputVRF (VRF c)
  } deriving (Int -> TPraosChainSelectView c -> ShowS
[TPraosChainSelectView c] -> ShowS
TPraosChainSelectView c -> String
(Int -> TPraosChainSelectView c -> ShowS)
-> (TPraosChainSelectView c -> String)
-> ([TPraosChainSelectView c] -> ShowS)
-> Show (TPraosChainSelectView c)
forall c. Crypto c => Int -> TPraosChainSelectView c -> ShowS
forall c. Crypto c => [TPraosChainSelectView c] -> ShowS
forall c. Crypto c => TPraosChainSelectView c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TPraosChainSelectView c] -> ShowS
$cshowList :: forall c. Crypto c => [TPraosChainSelectView c] -> ShowS
show :: TPraosChainSelectView c -> String
$cshow :: forall c. Crypto c => TPraosChainSelectView c -> String
showsPrec :: Int -> TPraosChainSelectView c -> ShowS
$cshowsPrec :: forall c. Crypto c => Int -> TPraosChainSelectView c -> ShowS
Show, TPraosChainSelectView c -> TPraosChainSelectView c -> Bool
(TPraosChainSelectView c -> TPraosChainSelectView c -> Bool)
-> (TPraosChainSelectView c -> TPraosChainSelectView c -> Bool)
-> Eq (TPraosChainSelectView c)
forall c.
Crypto c =>
TPraosChainSelectView c -> TPraosChainSelectView c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TPraosChainSelectView c -> TPraosChainSelectView c -> Bool
$c/= :: forall c.
Crypto c =>
TPraosChainSelectView c -> TPraosChainSelectView c -> Bool
== :: TPraosChainSelectView c -> TPraosChainSelectView c -> Bool
$c== :: forall c.
Crypto c =>
TPraosChainSelectView c -> TPraosChainSelectView c -> Bool
Eq)

instance PraosCrypto c => Ord (TPraosChainSelectView c) where
  compare :: TPraosChainSelectView c -> TPraosChainSelectView c -> Ordering
compare =
      [TPraosChainSelectView c -> TPraosChainSelectView c -> Ordering]
-> TPraosChainSelectView c -> TPraosChainSelectView c -> Ordering
forall a. Monoid a => [a] -> a
mconcat [
          BlockNo -> BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (BlockNo -> BlockNo -> Ordering)
-> (TPraosChainSelectView c -> BlockNo)
-> TPraosChainSelectView c
-> TPraosChainSelectView c
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TPraosChainSelectView c -> BlockNo
forall c. TPraosChainSelectView c -> BlockNo
csvChainLength
        , (TPraosChainSelectView c -> SlotNo)
-> (TPraosChainSelectView c -> TPraosChainSelectView c -> Ordering)
-> TPraosChainSelectView c
-> TPraosChainSelectView c
-> Ordering
forall a view.
Eq a =>
(view -> a)
-> (view -> view -> Ordering) -> view -> view -> Ordering
whenSame TPraosChainSelectView c -> SlotNo
forall c. TPraosChainSelectView c -> SlotNo
csvSlotNo (SelfIssued -> SelfIssued -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SelfIssued -> SelfIssued -> Ordering)
-> (TPraosChainSelectView c -> SelfIssued)
-> TPraosChainSelectView c
-> TPraosChainSelectView c
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TPraosChainSelectView c -> SelfIssued
forall c. TPraosChainSelectView c -> SelfIssued
csvSelfIssued)
        , (TPraosChainSelectView c -> VKey 'BlockIssuer c)
-> (TPraosChainSelectView c -> TPraosChainSelectView c -> Ordering)
-> TPraosChainSelectView c
-> TPraosChainSelectView c
-> Ordering
forall a view.
Eq a =>
(view -> a)
-> (view -> view -> Ordering) -> view -> view -> Ordering
whenSame TPraosChainSelectView c -> VKey 'BlockIssuer c
forall c. TPraosChainSelectView c -> VKey 'BlockIssuer c
csvIssuer (Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word64 -> Word64 -> Ordering)
-> (TPraosChainSelectView c -> Word64)
-> TPraosChainSelectView c
-> TPraosChainSelectView c
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TPraosChainSelectView c -> Word64
forall c. TPraosChainSelectView c -> Word64
csvIssueNo)
        , Down (OutputVRF (VRF c)) -> Down (OutputVRF (VRF c)) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Down (OutputVRF (VRF c)) -> Down (OutputVRF (VRF c)) -> Ordering)
-> (TPraosChainSelectView c -> Down (OutputVRF (VRF c)))
-> TPraosChainSelectView c
-> TPraosChainSelectView c
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` OutputVRF (VRF c) -> Down (OutputVRF (VRF c))
forall a. a -> Down a
Down (OutputVRF (VRF c) -> Down (OutputVRF (VRF c)))
-> (TPraosChainSelectView c -> OutputVRF (VRF c))
-> TPraosChainSelectView c
-> Down (OutputVRF (VRF c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TPraosChainSelectView c -> OutputVRF (VRF c)
forall c. TPraosChainSelectView c -> OutputVRF (VRF c)
csvLeaderVRF
        ]
    where
      -- | When the @a@s are equal, use the given comparison function,
      -- otherwise, no preference.
      whenSame ::
           Eq a
        => (view -> a)
        -> (view -> view -> Ordering)
        -> (view -> view -> Ordering)
      whenSame :: (view -> a)
-> (view -> view -> Ordering) -> view -> view -> Ordering
whenSame view -> a
f view -> view -> Ordering
comp view
v1 view
v2
        | view -> a
f view
v1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== view -> a
f view
v2
        = view -> view -> Ordering
comp view
v1 view
v2
        | Bool
otherwise
        = Ordering
EQ

instance PraosCrypto c => ChainSelection (TPraos c) where

  -- | Chain selection is done on the basis of the chain length first, and then
  -- operational certificate issue number.
  type SelectView (TPraos c) = TPraosChainSelectView 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 PraosCrypto c => NoThunks (TPraosState c)

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

instance 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 PraosCrypto c => ConsensusProtocol (TPraos c) where
  type ChainDepState (TPraos c) = TPraosState c
  type IsLeader      (TPraos c) = TPraosIsLeader c
  type CanBeLeader   (TPraos c) = TPraosCanBeLeader 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 TPraosCanBeLeader{..} 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 (TPraos c)
LedgerView 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 (ConsensusConfig (TPraos c) -> EpochInfo Identity
forall c. ConsensusConfig (TPraos c) -> EpochInfo Identity
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
tpraosCanBeLeaderColdVerKey
      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)
tpraosCanBeLeaderSignKeyVRF
      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)
tpraosCanBeLeaderSignKeyVRF

      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 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 Identity
tpraosEpochInfo WithOrigin SlotNo
lastSlot SlotNo
slot)
              ChainDepState c
st
      shelleyGlobals :: Globals
shelleyGlobals = EpochInfo Identity -> TPraosParams -> Globals
mkShelleyGlobals EpochInfo Identity
tpraosEpochInfo TPraosParams
tpraosParams

  updateChainDepState :: ConsensusConfig (TPraos c)
-> ValidateView (TPraos c)
-> SlotNo
-> Ticked (ChainDepState (TPraos c))
-> Except (ValidationErr (TPraos c)) (ChainDepState (TPraos c))
updateChainDepState TPraosConfig{..} 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
          ValidateView (TPraos c)
BHeader 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 = EpochInfo Identity -> TPraosParams -> Globals
mkShelleyGlobals EpochInfo Identity
tpraosEpochInfo TPraosParams
tpraosParams
      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 TPraosConfig{..} 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
          ValidateView (TPraos c)
BHeader 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 = EpochInfo Identity -> TPraosParams -> Globals
mkShelleyGlobals EpochInfo Identity
tpraosEpochInfo TPraosParams
tpraosParams
      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 :: EpochInfo Identity -> TPraosParams -> SL.Globals
mkShelleyGlobals :: EpochInfo Identity -> TPraosParams -> Globals
mkShelleyGlobals EpochInfo Identity
epochInfo TPraosParams {Word64
SecurityParam
Nonce
ActiveSlotCoeff
Network
MaxMajorProtVer
tpraosInitialNonce :: Nonce
tpraosNetworkId :: Network
tpraosMaxLovelaceSupply :: Word64
tpraosMaxMajorPV :: MaxMajorProtVer
tpraosQuorum :: Word64
tpraosMaxKESEvo :: Word64
tpraosSecurityParam :: SecurityParam
tpraosLeaderF :: ActiveSlotCoeff
tpraosSlotsPerKESPeriod :: Word64
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
..} = Globals :: EpochInfo Identity
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Natural
-> Word64
-> ActiveSlotCoeff
-> Network
-> Globals
SL.Globals {
      epochInfo :: EpochInfo Identity
epochInfo                     = EpochInfo Identity
epochInfo
    , 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
    }
  where
    SecurityParam Word64
k = SecurityParam
tpraosSecurityParam

-- | Check whether this node meets the leader threshold to issue a block.
meetsLeaderThreshold ::
     forall c. 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 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

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

instance (Condense toSign, 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