{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

-- | Proof of concept implementation of Praos
module Ouroboros.Consensus.Mock.Protocol.Praos
  ( HotKey (..)
  , HotKeyEvolutionError (..)
  , Praos
  , PraosChainDepState (..)
  , PraosEvolvingStake (..)
  , PraosExtraFields (..)
  , PraosFields (..)
  , PraosParams (..)
  , emptyPraosEvolvingStake
  , evolveKey
  , forgePraosFields

    -- * Tags
  , PraosCrypto (..)
  , PraosMockCrypto
  , PraosStandardCrypto
  , PraosValidateView (..)
  , PraosValidationError (..)
  , praosValidateView

    -- * Type instances
  , BlockInfo (..)
  , ConsensusConfig (..)
  , Ticked (..)
  ) where

import Cardano.Binary (FromCBOR (..), ToCBOR (..), serialize')
import Cardano.Crypto.DSIGN.Ed25519 (Ed25519DSIGN)
import Cardano.Crypto.Hash.Class
  ( HashAlgorithm (..)
  , hashToBytes
  , hashWithSerialiser
  , sizeHash
  )
import Cardano.Crypto.Hash.SHA256 (SHA256)
import Cardano.Crypto.KES.Class
import Cardano.Crypto.KES.Mock
import Cardano.Crypto.KES.Simple
import Cardano.Crypto.Util
import Cardano.Crypto.VRF.Class
import Cardano.Crypto.VRF.Mock (MockVRF)
import Cardano.Crypto.VRF.Simple (SimpleVRF)
import Cardano.Slotting.EpochInfo
import Codec.CBOR.Decoding (decodeListLenOf)
import Codec.CBOR.Encoding (encodeListLen)
import Codec.Serialise (Serialise (..))
import Control.Monad (unless)
import Control.Monad.Except (throwError)
import Data.Kind (Type)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Typeable
import Data.Word (Word64)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import NoThunks.Class (NoThunks (..))
import Numeric.Natural
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Mock.Ledger.Stake
import Ouroboros.Consensus.NodeId (CoreNodeId (..))
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Protocol.Signed
import Ouroboros.Consensus.Util.Condense
import Test.Cardano.Slotting.Numeric ()

-- The Praos paper can be located at https://ia.cr/2017/573
--
-- A block as defined in Praos (section 3, definition 2, then extended in Fig 9)
-- consist of a tuple:
--
-- > B = (slⱼ, st, d, B_πj, ρ, σⱼ)
--
-- where
-- - slⱼ: the slot at which the block was generated.
--        Named 'simpleSlotNo' in the 'SimpleStdHeader' block header.
--        As far as consensus is concerned this will be accessed through
--        'biSlot' in each block in the 'ChainDepState'.
--
-- - st: state, a string ∈ {0,1}^λ, which holds the hash of the previous block.
--       Named 'simplePrev' in the 'SimpleStdHeader' block header.
--
-- - d: data (transaction data in most cases).
--      Named 'simpleBody' inside 'SimpleBlock'.
--
-- - B_πj: block proof consisting of (Uᵢ, y, π).
--         Named 'praosY' inside 'PraosExtraFields'.
--      - y: a VRF output used to confirm that Uᵢ was the slot leader.
--      - π: the VRF proof of the above value.
--
--      > (y, π) ≜ VRF_evalProve(η, slⱼ, TEST) see Fig 9
--
-- - ρ: the block nonce consisting of (ρ_y, ρ_π), to capture entropy from the
--      block forging process.
--      Named 'praosRho' inside 'PraosExtraFields'.
--      - ρ_y: a VRF output used to confirm this block captured all the previous
--             entropy.
--      - ρ_π: the VRF proof of the above value.
--
--      > (ρ_y, ρ_π) ≜ VRF_evalProve(η, slⱼ, NONCE) see Fig 9
--
-- - σⱼ: a signature on (st, d, slⱼ, B_πj, ρ) with the signing key
--       for the slot slⱼ for the stakeholder Uᵢ.
--       Named 'praosSignature' in 'PraosFields'.
--
-- Protocol parameters:
-- - k: maximum number of blocks we can rollback.
--      Named 'praosSecurityParam' in 'PraosParams'.
-- - R: number of slots per epoch.
--      Named 'praosSlotsPerEpoch' in 'PraosParams'.
-- - f: the active slots coefficient, specifies roughly the proportion of
--      occupied slots per epoch.
--      Named 'praosLeaderF' in 'PraosParams'.
--
-- Some values you will encounter:
-- - η: The epoch's nonce. Captures entropy from the block chain. See Fig 8 in
--      praos paper for where it is used and Fig 10 for how it is defined.
--      Defined as the hash of the η from the previous epoch, this epoch number
--      and the ρ of the first 2/3 of the blocks in the previous epoch.
--      Commonly named through the code as 'eta'.
--
--      > η_e ≜ HASH(η_{e-1} || e || ρ_{e-1,0} ... ρ_{e-1, 2R/3})
--
-- - Tᵢ: the leader threshold for a specific stakeholder considering its
--       relative stake (therefore depending on the slot). Defined in the Praos
--       paper in Figure 4 using the definition for ϕ_f(αᵢ) from section 3.3.
--       Named 't' in the code but essentially computed by 'leaderThreshold' in
--       'rhoYT'.
--
--       > Tᵢ ≜ 2^(l_VRF) * pᵢ
--       > pᵢ = ϕ_f(αᵢ) ≜ 1 - (1 - f)^(αᵢ)

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

-- | The fields that Praos required in the header
data PraosFields crypto typeBeingSigned = PraosFields
  { forall crypto typeBeingSigned.
PraosFields crypto typeBeingSigned
-> SignedKES (PraosKES crypto) typeBeingSigned
praosSignature :: SignedKES (PraosKES crypto) typeBeingSigned
  , forall crypto typeBeingSigned.
PraosFields crypto typeBeingSigned -> PraosExtraFields crypto
praosExtraFields :: PraosExtraFields crypto
  }
  deriving (forall x.
 PraosFields crypto typeBeingSigned
 -> Rep (PraosFields crypto typeBeingSigned) x)
-> (forall x.
    Rep (PraosFields crypto typeBeingSigned) x
    -> PraosFields crypto typeBeingSigned)
-> Generic (PraosFields crypto typeBeingSigned)
forall x.
Rep (PraosFields crypto typeBeingSigned) x
-> PraosFields crypto typeBeingSigned
forall x.
PraosFields crypto typeBeingSigned
-> Rep (PraosFields crypto typeBeingSigned) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto typeBeingSigned x.
Rep (PraosFields crypto typeBeingSigned) x
-> PraosFields crypto typeBeingSigned
forall crypto typeBeingSigned x.
PraosFields crypto typeBeingSigned
-> Rep (PraosFields crypto typeBeingSigned) x
$cfrom :: forall crypto typeBeingSigned x.
PraosFields crypto typeBeingSigned
-> Rep (PraosFields crypto typeBeingSigned) x
from :: forall x.
PraosFields crypto typeBeingSigned
-> Rep (PraosFields crypto typeBeingSigned) x
$cto :: forall crypto typeBeingSigned x.
Rep (PraosFields crypto typeBeingSigned) x
-> PraosFields crypto typeBeingSigned
to :: forall x.
Rep (PraosFields crypto typeBeingSigned) x
-> PraosFields crypto typeBeingSigned
Generic

instance (PraosCrypto c, Typeable toSign) => NoThunks (PraosFields c toSign)

deriving instance PraosCrypto c => Show (PraosFields c toSign)
deriving instance PraosCrypto c => Eq (PraosFields c toSign)

-- | Fields that should be included in the signature
data PraosExtraFields c = PraosExtraFields
  { forall c. PraosExtraFields c -> CoreNodeId
praosCreator :: CoreNodeId
  , forall c.
PraosExtraFields c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
  , forall c.
PraosExtraFields c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosY :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
  }
  deriving (forall x. PraosExtraFields c -> Rep (PraosExtraFields c) x)
-> (forall x. Rep (PraosExtraFields c) x -> PraosExtraFields c)
-> Generic (PraosExtraFields c)
forall x. Rep (PraosExtraFields c) x -> PraosExtraFields c
forall x. PraosExtraFields c -> Rep (PraosExtraFields c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PraosExtraFields c) x -> PraosExtraFields c
forall c x. PraosExtraFields c -> Rep (PraosExtraFields c) x
$cfrom :: forall c x. PraosExtraFields c -> Rep (PraosExtraFields c) x
from :: forall x. PraosExtraFields c -> Rep (PraosExtraFields c) x
$cto :: forall c x. Rep (PraosExtraFields c) x -> PraosExtraFields c
to :: forall x. Rep (PraosExtraFields c) x -> PraosExtraFields c
Generic

instance PraosCrypto c => NoThunks (PraosExtraFields c)

deriving instance PraosCrypto c => Show (PraosExtraFields c)
deriving instance PraosCrypto c => Eq (PraosExtraFields c)

-- | A validate view is an association from the (@signed@) value to the
-- @PraosFields@ that contains the signature that sign it.
--
-- In this mock implementation, this could have been simplified to use
-- @SignedSimplePraos@ but from the consensus point of view, it is not relevant
-- which actual value is being signed, that's why we use the existential.
data PraosValidateView c
  = forall signed.
    Cardano.Crypto.KES.Class.Signable (PraosKES c) signed =>
    PraosValidateView (PraosFields c signed) signed

-- | Convenience constructor for 'PraosValidateView'
praosValidateView ::
  ( SignedHeader hdr
  , Cardano.Crypto.KES.Class.Signable (PraosKES c) (Signed hdr)
  ) =>
  (hdr -> PraosFields c (Signed hdr)) ->
  (hdr -> PraosValidateView c)
praosValidateView :: forall hdr c.
(SignedHeader hdr, Signable (PraosKES c) (Signed hdr)) =>
(hdr -> PraosFields c (Signed hdr)) -> hdr -> PraosValidateView c
praosValidateView hdr -> PraosFields c (Signed hdr)
getFields hdr
hdr =
  PraosFields c (Signed hdr) -> Signed hdr -> PraosValidateView c
forall c signed.
Signable (PraosKES c) signed =>
PraosFields c signed -> signed -> PraosValidateView c
PraosValidateView (hdr -> PraosFields c (Signed hdr)
getFields hdr
hdr) (hdr -> Signed hdr
forall hdr. SignedHeader hdr => hdr -> Signed hdr
headerSigned hdr
hdr)

{-------------------------------------------------------------------------------
  Forging
-------------------------------------------------------------------------------}

-- | The key used for the given period or a stub Poisoned value.
--
-- A key will be poisoned if it failed to evolve by @updateKES@, and will remain
-- poisoned forever after that.
data HotKey c
  = HotKey
      -- | Absolute period of the KES key
      !Period
      !(UnsoundPureSignKeyKES (PraosKES c))
  | HotKeyPoisoned
  deriving (forall x. HotKey c -> Rep (HotKey c) x)
-> (forall x. Rep (HotKey c) x -> HotKey c) -> Generic (HotKey c)
forall x. Rep (HotKey c) x -> HotKey c
forall x. HotKey c -> Rep (HotKey c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (HotKey c) x -> HotKey c
forall c x. HotKey c -> Rep (HotKey c) x
$cfrom :: forall c x. HotKey c -> Rep (HotKey c) x
from :: forall x. HotKey c -> Rep (HotKey c) x
$cto :: forall c x. Rep (HotKey c) x -> HotKey c
to :: forall x. Rep (HotKey c) x -> HotKey c
Generic

instance PraosCrypto c => NoThunks (HotKey c)
instance PraosCrypto c => Show (HotKey c) where
  show :: HotKey c -> String
show (HotKey Period
p UnsoundPureSignKeyKES (PraosKES c)
_) = String
"HotKey " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Period -> String
forall a. Show a => a -> String
show Period
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" <SignKeyKES: hidden>"
  show HotKey c
HotKeyPoisoned = String
"HotKeyPoisoned"

-- | The 'HotKey' could not be evolved to the given 'Period'.
newtype HotKeyEvolutionError = HotKeyEvolutionError Period
  deriving Int -> HotKeyEvolutionError -> ShowS
[HotKeyEvolutionError] -> ShowS
HotKeyEvolutionError -> String
(Int -> HotKeyEvolutionError -> ShowS)
-> (HotKeyEvolutionError -> String)
-> ([HotKeyEvolutionError] -> ShowS)
-> Show HotKeyEvolutionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HotKeyEvolutionError -> ShowS
showsPrec :: Int -> HotKeyEvolutionError -> ShowS
$cshow :: HotKeyEvolutionError -> String
show :: HotKeyEvolutionError -> String
$cshowList :: [HotKeyEvolutionError] -> ShowS
showList :: [HotKeyEvolutionError] -> ShowS
Show

-- | To be used in conjunction with, e.g., 'modifyMVar'.
--
-- NOTE: when the key's period is after the target period, we shouldn't use
-- it, but we currently do. In real TPraos we check this in
-- 'tpraosCheckCanForge'.
evolveKey ::
  PraosCrypto c =>
  SlotNo ->
  HotKey c ->
  (HotKey c, UpdateInfo (HotKey c) HotKeyEvolutionError)
evolveKey :: forall c.
PraosCrypto c =>
SlotNo
-> HotKey c
-> (HotKey c, UpdateInfo (HotKey c) HotKeyEvolutionError)
evolveKey SlotNo
slotNo HotKey c
hotKey = case HotKey c
hotKey of
  HotKey Period
keyPeriod UnsoundPureSignKeyKES (PraosKES c)
oldKey
    | Period
keyPeriod Period -> Period -> Bool
forall a. Ord a => a -> a -> Bool
>= Period
targetPeriod ->
        (HotKey c
hotKey, HotKey c -> UpdateInfo (HotKey c) HotKeyEvolutionError
forall updated failed. updated -> UpdateInfo updated failed
Updated HotKey c
hotKey)
    | Bool
otherwise ->
        case ContextKES (PraosKES c)
-> UnsoundPureSignKeyKES (PraosKES c)
-> Period
-> Maybe (UnsoundPureSignKeyKES (PraosKES c))
forall v.
UnsoundPureKESAlgorithm v =>
ContextKES v
-> UnsoundPureSignKeyKES v
-> Period
-> Maybe (UnsoundPureSignKeyKES v)
unsoundPureUpdateKES () UnsoundPureSignKeyKES (PraosKES c)
oldKey Period
keyPeriod of
          Maybe (UnsoundPureSignKeyKES (PraosKES c))
Nothing ->
            (HotKey c
forall c. HotKey c
HotKeyPoisoned, HotKeyEvolutionError -> UpdateInfo (HotKey c) HotKeyEvolutionError
forall updated failed. failed -> UpdateInfo updated failed
UpdateFailed (HotKeyEvolutionError
 -> UpdateInfo (HotKey c) HotKeyEvolutionError)
-> HotKeyEvolutionError
-> UpdateInfo (HotKey c) HotKeyEvolutionError
forall a b. (a -> b) -> a -> b
$ Period -> HotKeyEvolutionError
HotKeyEvolutionError Period
targetPeriod)
          Just UnsoundPureSignKeyKES (PraosKES c)
newKey ->
            SlotNo
-> HotKey c
-> (HotKey c, UpdateInfo (HotKey c) HotKeyEvolutionError)
forall c.
PraosCrypto c =>
SlotNo
-> HotKey c
-> (HotKey c, UpdateInfo (HotKey c) HotKeyEvolutionError)
evolveKey SlotNo
slotNo (Period -> UnsoundPureSignKeyKES (PraosKES c) -> HotKey c
forall c. Period -> UnsoundPureSignKeyKES (PraosKES c) -> HotKey c
HotKey (Period
keyPeriod Period -> Period -> Period
forall a. Num a => a -> a -> a
+ Period
1) UnsoundPureSignKeyKES (PraosKES c)
newKey)
  HotKey c
HotKeyPoisoned ->
    (HotKey c
forall c. HotKey c
HotKeyPoisoned, HotKeyEvolutionError -> UpdateInfo (HotKey c) HotKeyEvolutionError
forall updated failed. failed -> UpdateInfo updated failed
UpdateFailed (HotKeyEvolutionError
 -> UpdateInfo (HotKey c) HotKeyEvolutionError)
-> HotKeyEvolutionError
-> UpdateInfo (HotKey c) HotKeyEvolutionError
forall a b. (a -> b) -> a -> b
$ Period -> HotKeyEvolutionError
HotKeyEvolutionError Period
targetPeriod)
 where
  targetPeriod :: Period
  targetPeriod :: Period
targetPeriod = Word64 -> Period
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Period) -> Word64 -> Period
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slotNo

-- | Create a PraosFields using a proof, a key and the data to be signed.
--
-- It is done by signing whatever is extracted from the extra fields by @mkToSign@
-- and storing the signature and the extra fields on a @PraosFields@.
forgePraosFields ::
  ( PraosCrypto c
  , Cardano.Crypto.KES.Class.Signable (PraosKES c) toSign
  , HasCallStack
  ) =>
  PraosProof c ->
  HotKey c ->
  (PraosExtraFields c -> toSign) ->
  PraosFields c toSign
forgePraosFields :: forall c toSign.
(PraosCrypto c, Signable (PraosKES c) toSign, HasCallStack) =>
PraosProof c
-> HotKey c
-> (PraosExtraFields c -> toSign)
-> PraosFields c toSign
forgePraosFields PraosProof{CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
CoreNodeId
praosProofRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosProofY :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosLeader :: CoreNodeId
praosLeader :: forall c. PraosProof c -> CoreNodeId
praosProofY :: forall c.
PraosProof c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosProofRho :: forall c.
PraosProof c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
..} HotKey c
hotKey PraosExtraFields c -> toSign
mkToSign =
  case HotKey c
hotKey of
    HotKey Period
kesPeriod UnsoundPureSignKeyKES (PraosKES c)
key ->
      PraosFields
        { praosSignature :: SignedKES (PraosKES c) toSign
praosSignature = ContextKES (PraosKES c)
-> Period
-> toSign
-> UnsoundPureSignKeyKES (PraosKES c)
-> SignedKES (PraosKES c) toSign
forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v
-> Period -> a -> UnsoundPureSignKeyKES v -> SignedKES v a
unsoundPureSignedKES () Period
kesPeriod (PraosExtraFields c -> toSign
mkToSign PraosExtraFields c
fieldsToSign) UnsoundPureSignKeyKES (PraosKES c)
key
        , praosExtraFields :: PraosExtraFields c
praosExtraFields = PraosExtraFields c
fieldsToSign
        }
    HotKey c
HotKeyPoisoned -> String -> PraosFields c toSign
forall a. HasCallStack => String -> a
error String
"trying to sign with a poisoned key"
 where
  fieldsToSign :: PraosExtraFields c
fieldsToSign =
    PraosExtraFields
      { praosCreator :: CoreNodeId
praosCreator = CoreNodeId
praosLeader
      , praosRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosRho = CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosProofRho
      , praosY :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosY = CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosProofY
      }

{-------------------------------------------------------------------------------
  Mock stake distribution
-------------------------------------------------------------------------------}

-- | An association from epoch to stake distributions.
--
-- Should be used when checking if someone is the leader of a particular slot.
-- This is sufficiently good for a mock protocol as far as consensus is
-- concerned. It is not strictly necessary that the stake distribution is
-- computed from previous epochs, as we just need to consider that:
--
-- 1) an attacker cannot influence it.
-- 2) all the nodes agree on the same value for each Slot.
--
-- Each pair stores the stake distribution established by the end of the epoch
-- in the first item of the pair. See 'latestEvolvedStakeDistAsOfEpoch' for the
-- intended interface.
--
-- If no value is returned, that means we are checking the stake before any
-- changes have happened so we should consult instead the 'praosInitialStake'.
newtype PraosEvolvingStake = PraosEvolvingStake (Map EpochNo StakeDist)
  deriving stock Int -> PraosEvolvingStake -> ShowS
[PraosEvolvingStake] -> ShowS
PraosEvolvingStake -> String
(Int -> PraosEvolvingStake -> ShowS)
-> (PraosEvolvingStake -> String)
-> ([PraosEvolvingStake] -> ShowS)
-> Show PraosEvolvingStake
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PraosEvolvingStake -> ShowS
showsPrec :: Int -> PraosEvolvingStake -> ShowS
$cshow :: PraosEvolvingStake -> String
show :: PraosEvolvingStake -> String
$cshowList :: [PraosEvolvingStake] -> ShowS
showList :: [PraosEvolvingStake] -> ShowS
Show
  deriving newtype Context -> PraosEvolvingStake -> IO (Maybe ThunkInfo)
Proxy PraosEvolvingStake -> String
(Context -> PraosEvolvingStake -> IO (Maybe ThunkInfo))
-> (Context -> PraosEvolvingStake -> IO (Maybe ThunkInfo))
-> (Proxy PraosEvolvingStake -> String)
-> NoThunks PraosEvolvingStake
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PraosEvolvingStake -> IO (Maybe ThunkInfo)
noThunks :: Context -> PraosEvolvingStake -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PraosEvolvingStake -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PraosEvolvingStake -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PraosEvolvingStake -> String
showTypeOf :: Proxy PraosEvolvingStake -> String
NoThunks

emptyPraosEvolvingStake :: PraosEvolvingStake
emptyPraosEvolvingStake :: PraosEvolvingStake
emptyPraosEvolvingStake = Map EpochNo StakeDist -> PraosEvolvingStake
PraosEvolvingStake Map EpochNo StakeDist
forall k a. Map k a
Map.empty

latestEvolvedStakeDistAsOfEpoch :: PraosEvolvingStake -> EpochNo -> Maybe StakeDist
latestEvolvedStakeDistAsOfEpoch :: PraosEvolvingStake -> EpochNo -> Maybe StakeDist
latestEvolvedStakeDistAsOfEpoch (PraosEvolvingStake Map EpochNo StakeDist
x) EpochNo
e =
  ((EpochNo, StakeDist) -> StakeDist)
-> Maybe (EpochNo, StakeDist) -> Maybe StakeDist
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EpochNo, StakeDist) -> StakeDist
forall a b. (a, b) -> b
snd (Maybe (EpochNo, StakeDist) -> Maybe StakeDist)
-> ((Map EpochNo StakeDist, Map EpochNo StakeDist)
    -> Maybe (EpochNo, StakeDist))
-> (Map EpochNo StakeDist, Map EpochNo StakeDist)
-> Maybe StakeDist
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map EpochNo StakeDist -> Maybe (EpochNo, StakeDist)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax (Map EpochNo StakeDist -> Maybe (EpochNo, StakeDist))
-> ((Map EpochNo StakeDist, Map EpochNo StakeDist)
    -> Map EpochNo StakeDist)
-> (Map EpochNo StakeDist, Map EpochNo StakeDist)
-> Maybe (EpochNo, StakeDist)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map EpochNo StakeDist, Map EpochNo StakeDist)
-> Map EpochNo StakeDist
forall a b. (a, b) -> a
fst ((Map EpochNo StakeDist, Map EpochNo StakeDist) -> Maybe StakeDist)
-> (Map EpochNo StakeDist, Map EpochNo StakeDist)
-> Maybe StakeDist
forall a b. (a -> b) -> a -> b
$ EpochNo
-> Map EpochNo StakeDist
-> (Map EpochNo StakeDist, Map EpochNo StakeDist)
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split EpochNo
e Map EpochNo StakeDist
x

{-------------------------------------------------------------------------------
  Praos specific types
-------------------------------------------------------------------------------}

-- | The two VRF invocation modes, NONCE (rho) and TEST (y). See the comment at
--  the top of the module for an explanation of these.
data VRFType = NONCE | TEST
  deriving (Int -> VRFType -> ShowS
[VRFType] -> ShowS
VRFType -> String
(Int -> VRFType -> ShowS)
-> (VRFType -> String) -> ([VRFType] -> ShowS) -> Show VRFType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VRFType -> ShowS
showsPrec :: Int -> VRFType -> ShowS
$cshow :: VRFType -> String
show :: VRFType -> String
$cshowList :: [VRFType] -> ShowS
showList :: [VRFType] -> ShowS
Show, VRFType -> VRFType -> Bool
(VRFType -> VRFType -> Bool)
-> (VRFType -> VRFType -> Bool) -> Eq VRFType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VRFType -> VRFType -> Bool
== :: VRFType -> VRFType -> Bool
$c/= :: VRFType -> VRFType -> Bool
/= :: VRFType -> VRFType -> Bool
Eq, Eq VRFType
Eq VRFType =>
(VRFType -> VRFType -> Ordering)
-> (VRFType -> VRFType -> Bool)
-> (VRFType -> VRFType -> Bool)
-> (VRFType -> VRFType -> Bool)
-> (VRFType -> VRFType -> Bool)
-> (VRFType -> VRFType -> VRFType)
-> (VRFType -> VRFType -> VRFType)
-> Ord VRFType
VRFType -> VRFType -> Bool
VRFType -> VRFType -> Ordering
VRFType -> VRFType -> VRFType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: VRFType -> VRFType -> Ordering
compare :: VRFType -> VRFType -> Ordering
$c< :: VRFType -> VRFType -> Bool
< :: VRFType -> VRFType -> Bool
$c<= :: VRFType -> VRFType -> Bool
<= :: VRFType -> VRFType -> Bool
$c> :: VRFType -> VRFType -> Bool
> :: VRFType -> VRFType -> Bool
$c>= :: VRFType -> VRFType -> Bool
>= :: VRFType -> VRFType -> Bool
$cmax :: VRFType -> VRFType -> VRFType
max :: VRFType -> VRFType -> VRFType
$cmin :: VRFType -> VRFType -> VRFType
min :: VRFType -> VRFType -> VRFType
Ord, (forall x. VRFType -> Rep VRFType x)
-> (forall x. Rep VRFType x -> VRFType) -> Generic VRFType
forall x. Rep VRFType x -> VRFType
forall x. VRFType -> Rep VRFType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. VRFType -> Rep VRFType x
from :: forall x. VRFType -> Rep VRFType x
$cto :: forall x. Rep VRFType x -> VRFType
to :: forall x. Rep VRFType x -> VRFType
Generic, Context -> VRFType -> IO (Maybe ThunkInfo)
Proxy VRFType -> String
(Context -> VRFType -> IO (Maybe ThunkInfo))
-> (Context -> VRFType -> IO (Maybe ThunkInfo))
-> (Proxy VRFType -> String)
-> NoThunks VRFType
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> VRFType -> IO (Maybe ThunkInfo)
noThunks :: Context -> VRFType -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> VRFType -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> VRFType -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy VRFType -> String
showTypeOf :: Proxy VRFType -> String
NoThunks)

instance Serialise VRFType

instance ToCBOR VRFType where
  -- This is a cheat, and at some point we probably want to decide on Serialise/ToCBOR
  toCBOR :: VRFType -> Encoding
toCBOR = VRFType -> Encoding
forall a. Serialise a => a -> Encoding
encode

-- | Proofs certifying ρ and y for a given slot and eta.
data PraosProof c = PraosProof
  { forall c.
PraosProof c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosProofRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
  , forall c.
PraosProof c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosProofY :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
  , forall c. PraosProof c -> CoreNodeId
praosLeader :: CoreNodeId
  }

-- | An error that can arise during validation
data PraosValidationError c
  = PraosInvalidSlot SlotNo SlotNo
  | PraosUnknownCoreId CoreNodeId
  | PraosInvalidSig String (VerKeyKES (PraosKES c)) Natural (SigKES (PraosKES c))
  | PraosInvalidCert (VerKeyVRF (PraosVRF c)) (Natural, SlotNo, VRFType) Natural (CertVRF (PraosVRF c))
  | PraosInsufficientStake Double Natural
  deriving (forall x.
 PraosValidationError c -> Rep (PraosValidationError c) x)
-> (forall x.
    Rep (PraosValidationError c) x -> PraosValidationError c)
-> Generic (PraosValidationError c)
forall x. Rep (PraosValidationError c) x -> PraosValidationError c
forall x. PraosValidationError c -> Rep (PraosValidationError c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (PraosValidationError c) x -> PraosValidationError c
forall c x.
PraosValidationError c -> Rep (PraosValidationError c) x
$cfrom :: forall c x.
PraosValidationError c -> Rep (PraosValidationError c) x
from :: forall x. PraosValidationError c -> Rep (PraosValidationError c) x
$cto :: forall c x.
Rep (PraosValidationError c) x -> PraosValidationError c
to :: forall x. Rep (PraosValidationError c) x -> PraosValidationError c
Generic

-- We override 'showTypeOf' to make sure to show @c@
instance PraosCrypto c => NoThunks (PraosValidationError c) where
  showTypeOf :: Proxy (PraosValidationError c) -> String
showTypeOf Proxy (PraosValidationError c)
_ = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy (PraosValidationError c) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(PraosValidationError c))

deriving instance PraosCrypto c => Show (PraosValidationError c)
deriving instance PraosCrypto c => Eq (PraosValidationError c)

data BlockInfo c = BlockInfo
  { forall c. BlockInfo c -> SlotNo
biSlot :: !SlotNo
  , forall c.
BlockInfo c -> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
biRho :: !(CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType))
  }
  deriving (forall x. BlockInfo c -> Rep (BlockInfo c) x)
-> (forall x. Rep (BlockInfo c) x -> BlockInfo c)
-> Generic (BlockInfo c)
forall x. Rep (BlockInfo c) x -> BlockInfo c
forall x. BlockInfo c -> Rep (BlockInfo c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (BlockInfo c) x -> BlockInfo c
forall c x. BlockInfo c -> Rep (BlockInfo c) x
$cfrom :: forall c x. BlockInfo c -> Rep (BlockInfo c) x
from :: forall x. BlockInfo c -> Rep (BlockInfo c) x
$cto :: forall c x. Rep (BlockInfo c) x -> BlockInfo c
to :: forall x. Rep (BlockInfo c) x -> BlockInfo c
Generic

deriving instance PraosCrypto c => Show (BlockInfo c)
deriving instance PraosCrypto c => Eq (BlockInfo c)
deriving instance PraosCrypto c => NoThunks (BlockInfo c)

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

-- | An uninhabited type representing the Praos protocol.
data Praos c

-- | Praos parameters that are node independent
data PraosParams = PraosParams
  { PraosParams -> Double
praosLeaderF :: !Double
  -- ^ f, the active slots coefficient, defined in 3.3 in the Praos paper.
  , PraosParams -> SecurityParam
praosSecurityParam :: !SecurityParam
  -- ^ k, maximum number of blocks we can rollback
  , PraosParams -> Word64
praosSlotsPerEpoch :: !Word64
  -- ^ R, slots in each epoch, defined in section 3 in the Praos paper.
  }
  deriving ((forall x. PraosParams -> Rep PraosParams x)
-> (forall x. Rep PraosParams x -> PraosParams)
-> Generic PraosParams
forall x. Rep PraosParams x -> PraosParams
forall x. PraosParams -> Rep PraosParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PraosParams -> Rep PraosParams x
from :: forall x. PraosParams -> Rep PraosParams x
$cto :: forall x. Rep PraosParams x -> PraosParams
to :: forall x. Rep PraosParams x -> PraosParams
Generic, Context -> PraosParams -> IO (Maybe ThunkInfo)
Proxy PraosParams -> String
(Context -> PraosParams -> IO (Maybe ThunkInfo))
-> (Context -> PraosParams -> IO (Maybe ThunkInfo))
-> (Proxy PraosParams -> String)
-> NoThunks PraosParams
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PraosParams -> IO (Maybe ThunkInfo)
noThunks :: Context -> PraosParams -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PraosParams -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PraosParams -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PraosParams -> String
showTypeOf :: Proxy PraosParams -> String
NoThunks)

-- | The configuration that will be provided to every node when running the
-- MockPraos protocol.
data instance ConsensusConfig (Praos c) = PraosConfig
  { forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams :: !PraosParams
  , forall c. ConsensusConfig (Praos c) -> Natural
praosInitialEta :: !Natural
  , forall c. ConsensusConfig (Praos c) -> StakeDist
praosInitialStake :: !StakeDist
  , forall c. ConsensusConfig (Praos c) -> PraosEvolvingStake
praosEvolvingStake :: !PraosEvolvingStake
  , forall c. ConsensusConfig (Praos c) -> SignKeyVRF (PraosVRF c)
praosSignKeyVRF :: !(SignKeyVRF (PraosVRF c))
  , forall c.
ConsensusConfig (Praos c)
-> Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
praosVerKeys :: !(Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c)))
  }
  deriving (forall x.
 ConsensusConfig (Praos c) -> Rep (ConsensusConfig (Praos c)) x)
-> (forall x.
    Rep (ConsensusConfig (Praos c)) x -> ConsensusConfig (Praos c))
-> Generic (ConsensusConfig (Praos c))
forall x.
Rep (ConsensusConfig (Praos c)) x -> ConsensusConfig (Praos c)
forall x.
ConsensusConfig (Praos c) -> Rep (ConsensusConfig (Praos c)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (ConsensusConfig (Praos c)) x -> ConsensusConfig (Praos c)
forall c x.
ConsensusConfig (Praos c) -> Rep (ConsensusConfig (Praos c)) x
$cfrom :: forall c x.
ConsensusConfig (Praos c) -> Rep (ConsensusConfig (Praos c)) x
from :: forall x.
ConsensusConfig (Praos c) -> Rep (ConsensusConfig (Praos c)) x
$cto :: forall c x.
Rep (ConsensusConfig (Praos c)) x -> ConsensusConfig (Praos c)
to :: forall x.
Rep (ConsensusConfig (Praos c)) x -> ConsensusConfig (Praos c)
Generic

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

slotEpoch :: ConsensusConfig (Praos c) -> SlotNo -> EpochNo
slotEpoch :: forall c. ConsensusConfig (Praos c) -> SlotNo -> EpochNo
slotEpoch PraosConfig{Natural
Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
SignKeyVRF (PraosVRF c)
StakeDist
PraosParams
PraosEvolvingStake
praosInitialStake :: forall c. ConsensusConfig (Praos c) -> StakeDist
praosParams :: forall c. ConsensusConfig (Praos c) -> PraosParams
praosInitialEta :: forall c. ConsensusConfig (Praos c) -> Natural
praosEvolvingStake :: forall c. ConsensusConfig (Praos c) -> PraosEvolvingStake
praosSignKeyVRF :: forall c. ConsensusConfig (Praos c) -> SignKeyVRF (PraosVRF c)
praosVerKeys :: forall c.
ConsensusConfig (Praos c)
-> Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
praosParams :: PraosParams
praosInitialEta :: Natural
praosInitialStake :: StakeDist
praosEvolvingStake :: PraosEvolvingStake
praosSignKeyVRF :: SignKeyVRF (PraosVRF c)
praosVerKeys :: Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
..} SlotNo
s =
  EpochSize -> SlotNo -> EpochNo
fixedEpochInfoEpoch (Word64 -> EpochSize
EpochSize Word64
praosSlotsPerEpoch) SlotNo
s
 where
  PraosParams{Double
Word64
SecurityParam
praosLeaderF :: PraosParams -> Double
praosSecurityParam :: PraosParams -> SecurityParam
praosSlotsPerEpoch :: PraosParams -> Word64
praosSlotsPerEpoch :: Word64
praosLeaderF :: Double
praosSecurityParam :: SecurityParam
..} = PraosParams
praosParams

epochFirst :: ConsensusConfig (Praos c) -> EpochNo -> SlotNo
epochFirst :: forall c. ConsensusConfig (Praos c) -> EpochNo -> SlotNo
epochFirst PraosConfig{Natural
Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
SignKeyVRF (PraosVRF c)
StakeDist
PraosParams
PraosEvolvingStake
praosInitialStake :: forall c. ConsensusConfig (Praos c) -> StakeDist
praosParams :: forall c. ConsensusConfig (Praos c) -> PraosParams
praosInitialEta :: forall c. ConsensusConfig (Praos c) -> Natural
praosEvolvingStake :: forall c. ConsensusConfig (Praos c) -> PraosEvolvingStake
praosSignKeyVRF :: forall c. ConsensusConfig (Praos c) -> SignKeyVRF (PraosVRF c)
praosVerKeys :: forall c.
ConsensusConfig (Praos c)
-> Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
praosParams :: PraosParams
praosInitialEta :: Natural
praosInitialStake :: StakeDist
praosEvolvingStake :: PraosEvolvingStake
praosSignKeyVRF :: SignKeyVRF (PraosVRF c)
praosVerKeys :: Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
..} EpochNo
e =
  EpochSize -> EpochNo -> SlotNo
fixedEpochInfoFirst (Word64 -> EpochSize
EpochSize Word64
praosSlotsPerEpoch) EpochNo
e
 where
  PraosParams{Double
Word64
SecurityParam
praosLeaderF :: PraosParams -> Double
praosSecurityParam :: PraosParams -> SecurityParam
praosSlotsPerEpoch :: PraosParams -> Word64
praosSlotsPerEpoch :: Word64
praosLeaderF :: Double
praosSecurityParam :: SecurityParam
..} = PraosParams
praosParams

-- | The chain dependent state, in this case as it is a mock, we just will store
--  a list of BlockInfos that allow us to look into the past.
newtype PraosChainDepState c = PraosChainDepState
  { forall c. PraosChainDepState c -> [BlockInfo c]
praosHistory :: [BlockInfo c]
  }
  deriving stock (PraosChainDepState c -> PraosChainDepState c -> Bool
(PraosChainDepState c -> PraosChainDepState c -> Bool)
-> (PraosChainDepState c -> PraosChainDepState c -> Bool)
-> Eq (PraosChainDepState c)
forall c.
PraosCrypto c =>
PraosChainDepState c -> PraosChainDepState c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c.
PraosCrypto c =>
PraosChainDepState c -> PraosChainDepState c -> Bool
== :: PraosChainDepState c -> PraosChainDepState c -> Bool
$c/= :: forall c.
PraosCrypto c =>
PraosChainDepState c -> PraosChainDepState c -> Bool
/= :: PraosChainDepState c -> PraosChainDepState c -> Bool
Eq, Int -> PraosChainDepState c -> ShowS
[PraosChainDepState c] -> ShowS
PraosChainDepState c -> String
(Int -> PraosChainDepState c -> ShowS)
-> (PraosChainDepState c -> String)
-> ([PraosChainDepState c] -> ShowS)
-> Show (PraosChainDepState c)
forall c. PraosCrypto c => Int -> PraosChainDepState c -> ShowS
forall c. PraosCrypto c => [PraosChainDepState c] -> ShowS
forall c. PraosCrypto c => PraosChainDepState c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. PraosCrypto c => Int -> PraosChainDepState c -> ShowS
showsPrec :: Int -> PraosChainDepState c -> ShowS
$cshow :: forall c. PraosCrypto c => PraosChainDepState c -> String
show :: PraosChainDepState c -> String
$cshowList :: forall c. PraosCrypto c => [PraosChainDepState c] -> ShowS
showList :: [PraosChainDepState c] -> ShowS
Show)
  deriving newtype (Context -> PraosChainDepState c -> IO (Maybe ThunkInfo)
Proxy (PraosChainDepState c) -> String
(Context -> PraosChainDepState c -> IO (Maybe ThunkInfo))
-> (Context -> PraosChainDepState c -> IO (Maybe ThunkInfo))
-> (Proxy (PraosChainDepState c) -> String)
-> NoThunks (PraosChainDepState c)
forall c.
PraosCrypto c =>
Context -> PraosChainDepState c -> IO (Maybe ThunkInfo)
forall c. PraosCrypto c => Proxy (PraosChainDepState c) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall c.
PraosCrypto c =>
Context -> PraosChainDepState c -> IO (Maybe ThunkInfo)
noThunks :: Context -> PraosChainDepState c -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall c.
PraosCrypto c =>
Context -> PraosChainDepState c -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PraosChainDepState c -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall c. PraosCrypto c => Proxy (PraosChainDepState c) -> String
showTypeOf :: Proxy (PraosChainDepState c) -> String
NoThunks, [PraosChainDepState c] -> Encoding
PraosChainDepState c -> Encoding
(PraosChainDepState c -> Encoding)
-> (forall s. Decoder s (PraosChainDepState c))
-> ([PraosChainDepState c] -> Encoding)
-> (forall s. Decoder s [PraosChainDepState c])
-> Serialise (PraosChainDepState c)
forall s. Decoder s [PraosChainDepState c]
forall s. Decoder s (PraosChainDepState c)
forall c. PraosCrypto c => [PraosChainDepState c] -> Encoding
forall c. PraosCrypto c => PraosChainDepState c -> Encoding
forall c s. PraosCrypto c => Decoder s [PraosChainDepState c]
forall c s. PraosCrypto c => Decoder s (PraosChainDepState c)
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: forall c. PraosCrypto c => PraosChainDepState c -> Encoding
encode :: PraosChainDepState c -> Encoding
$cdecode :: forall c s. PraosCrypto c => Decoder s (PraosChainDepState c)
decode :: forall s. Decoder s (PraosChainDepState c)
$cencodeList :: forall c. PraosCrypto c => [PraosChainDepState c] -> Encoding
encodeList :: [PraosChainDepState c] -> Encoding
$cdecodeList :: forall c s. PraosCrypto c => Decoder s [PraosChainDepState c]
decodeList :: forall s. Decoder s [PraosChainDepState c]
Serialise)

infosSlice :: SlotNo -> SlotNo -> [BlockInfo c] -> [BlockInfo c]
infosSlice :: forall c. SlotNo -> SlotNo -> [BlockInfo c] -> [BlockInfo c]
infosSlice SlotNo
from SlotNo
to [BlockInfo c]
xs =
  (BlockInfo c -> Bool) -> [BlockInfo c] -> [BlockInfo c]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\BlockInfo c
b -> BlockInfo c -> SlotNo
forall c. BlockInfo c -> SlotNo
biSlot BlockInfo c
b SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
from) ([BlockInfo c] -> [BlockInfo c]) -> [BlockInfo c] -> [BlockInfo c]
forall a b. (a -> b) -> a -> b
$
    (BlockInfo c -> Bool) -> [BlockInfo c] -> [BlockInfo c]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\BlockInfo c
b -> BlockInfo c -> SlotNo
forall c. BlockInfo c -> SlotNo
biSlot BlockInfo c
b SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
to) [BlockInfo c]
xs

infosEta ::
  forall c.
  PraosCrypto c =>
  ConsensusConfig (Praos c) ->
  [BlockInfo c] ->
  EpochNo ->
  Natural
infosEta :: forall c.
PraosCrypto c =>
ConsensusConfig (Praos c) -> [BlockInfo c] -> EpochNo -> Natural
infosEta ConsensusConfig (Praos c)
l [BlockInfo c]
_ EpochNo
0 =
  ConsensusConfig (Praos c) -> Natural
forall c. ConsensusConfig (Praos c) -> Natural
praosInitialEta ConsensusConfig (Praos c)
l
infosEta l :: ConsensusConfig (Praos c)
l@PraosConfig{praosParams :: forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams = PraosParams{Double
Word64
SecurityParam
praosLeaderF :: PraosParams -> Double
praosSecurityParam :: PraosParams -> SecurityParam
praosSlotsPerEpoch :: PraosParams -> Word64
praosLeaderF :: Double
praosSecurityParam :: SecurityParam
praosSlotsPerEpoch :: Word64
..}} [BlockInfo c]
xs EpochNo
e =
  let e' :: EpochNo
e' = EpochNo
e EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
- EpochNo
1
      -- the η from the previous epoch
      eta' :: Natural
eta' = ConsensusConfig (Praos c) -> [BlockInfo c] -> EpochNo -> Natural
forall c.
PraosCrypto c =>
ConsensusConfig (Praos c) -> [BlockInfo c] -> EpochNo -> Natural
infosEta ConsensusConfig (Praos c)
l [BlockInfo c]
xs EpochNo
e'
      -- the first slot in previous epoch
      from :: SlotNo
from = ConsensusConfig (Praos c) -> EpochNo -> SlotNo
forall c. ConsensusConfig (Praos c) -> EpochNo -> SlotNo
epochFirst ConsensusConfig (Praos c)
l EpochNo
e'
      -- 2/3 of the slots per epoch
      n :: Word64
n = Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
div (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
praosSlotsPerEpoch) Word64
3
      -- the last of the 2/3 of slots in this epoch
      to :: SlotNo
to = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
from Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
n
      -- the list of rhos from the first block in this epoch until the one at
      -- 2/3 of the slots. Note it is reversed, i.e. start at the oldest.
      rhos :: [CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)]
rhos = [CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)]
-> [CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)]
forall a. [a] -> [a]
reverse [BlockInfo c -> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
forall c.
BlockInfo c -> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
biRho BlockInfo c
b | BlockInfo c
b <- SlotNo -> SlotNo -> [BlockInfo c] -> [BlockInfo c]
forall c. SlotNo -> SlotNo -> [BlockInfo c] -> [BlockInfo c]
infosSlice SlotNo
from SlotNo
to [BlockInfo c]
xs]
   in ByteString -> Natural
bytesToNatural
        (ByteString -> Natural)
-> (Hash
      (PraosHash c)
      (Natural, EpochNo,
       [CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)])
    -> ByteString)
-> Hash
     (PraosHash c)
     (Natural, EpochNo,
      [CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)])
-> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash
  (PraosHash c)
  (Natural, EpochNo,
   [CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)])
-> ByteString
forall h a. Hash h a -> ByteString
hashToBytes
        (Hash
   (PraosHash c)
   (Natural, EpochNo,
    [CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)])
 -> Natural)
-> Hash
     (PraosHash c)
     (Natural, EpochNo,
      [CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)])
-> Natural
forall a b. (a -> b) -> a -> b
$ forall h a. HashAlgorithm h => (a -> Encoding) -> a -> Hash h a
hashWithSerialiser @(PraosHash c) (Natural, EpochNo,
 [CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)])
-> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Natural
eta', EpochNo
e, [CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)]
rhos)

-- | Ticking the Praos chain dep state has no effect
--
-- For the real Praos implementation, ticking is crucial, as it determines the
-- point where the "nonce under construction" is swapped out for the "active"
-- nonce. However, for the mock implementation, we keep the full history, and
-- choose the right nonce from that; this means that ticking has no effect.
--
-- We do however need access to the ticked stake distribution.
data instance Ticked (PraosChainDepState c) = TickedPraosChainDepState
  { forall c. Ticked (PraosChainDepState c) -> LedgerView (Praos c)
praosLedgerView :: LedgerView (Praos c)
  , forall c. Ticked (PraosChainDepState c) -> PraosChainDepState c
untickedPraosChainDepState :: PraosChainDepState c
  -- ^ The unticked chain dependent state, containing the full history.
  }

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

  type LedgerView (Praos c) = ()
  type IsLeader (Praos c) = PraosProof c
  type ValidationErr (Praos c) = PraosValidationError c
  type ValidateView (Praos c) = PraosValidateView c
  type ChainDepState (Praos c) = PraosChainDepState c
  type CanBeLeader (Praos c) = CoreNodeId

  checkIsLeader :: HasCallStack =>
ConsensusConfig (Praos c)
-> CanBeLeader (Praos c)
-> SlotNo
-> Ticked (ChainDepState (Praos c))
-> Maybe (IsLeader (Praos c))
checkIsLeader cfg :: ConsensusConfig (Praos c)
cfg@PraosConfig{Natural
Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
SignKeyVRF (PraosVRF c)
StakeDist
PraosParams
PraosEvolvingStake
praosInitialStake :: forall c. ConsensusConfig (Praos c) -> StakeDist
praosParams :: forall c. ConsensusConfig (Praos c) -> PraosParams
praosInitialEta :: forall c. ConsensusConfig (Praos c) -> Natural
praosEvolvingStake :: forall c. ConsensusConfig (Praos c) -> PraosEvolvingStake
praosSignKeyVRF :: forall c. ConsensusConfig (Praos c) -> SignKeyVRF (PraosVRF c)
praosVerKeys :: forall c.
ConsensusConfig (Praos c)
-> Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
praosParams :: PraosParams
praosInitialEta :: Natural
praosInitialStake :: StakeDist
praosEvolvingStake :: PraosEvolvingStake
praosSignKeyVRF :: SignKeyVRF (PraosVRF c)
praosVerKeys :: Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
..} CanBeLeader (Praos c)
nid SlotNo
slot (TickedPraosChainDepState LedgerView (Praos c)
_u PraosChainDepState c
cds) =
    -- See Figure 4 of the Praos paper.
    -- In order to be leader, y must be < Tᵢ
    if Natural -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (OutputVRF (PraosVRF c) -> Natural
forall v. OutputVRF v -> Natural
getOutputVRFNatural (CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
-> OutputVRF (PraosVRF c)
forall v a. CertifiedVRF v a -> OutputVRF v
certifiedOutput CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
y)) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t
      then
        PraosProof c -> Maybe (PraosProof c)
forall a. a -> Maybe a
Just
          PraosProof
            { praosProofRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosProofRho = CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
rho
            , praosProofY :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosProofY = CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
y
            , praosLeader :: CoreNodeId
praosLeader = CoreNodeId
CanBeLeader (Praos c)
nid
            }
      else Maybe (IsLeader (Praos c))
Maybe (PraosProof c)
forall a. Maybe a
Nothing
   where
    ((Natural, SlotNo, VRFType)
rho', (Natural, SlotNo, VRFType)
y', Double
t) = ConsensusConfig (Praos c)
-> [BlockInfo c]
-> SlotNo
-> CoreNodeId
-> ((Natural, SlotNo, VRFType), (Natural, SlotNo, VRFType), Double)
forall c.
PraosCrypto c =>
ConsensusConfig (Praos c)
-> [BlockInfo c]
-> SlotNo
-> CoreNodeId
-> ((Natural, SlotNo, VRFType), (Natural, SlotNo, VRFType), Double)
rhoYT ConsensusConfig (Praos c)
cfg (PraosChainDepState c -> [BlockInfo c]
forall c. PraosChainDepState c -> [BlockInfo c]
praosHistory PraosChainDepState c
cds) SlotNo
slot CoreNodeId
CanBeLeader (Praos c)
nid
    rho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
rho = ContextVRF (PraosVRF c)
-> (Natural, SlotNo, VRFType)
-> SignKeyVRF (PraosVRF c)
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
evalCertified () (Natural, SlotNo, VRFType)
rho' SignKeyVRF (PraosVRF c)
praosSignKeyVRF
    y :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
y = ContextVRF (PraosVRF c)
-> (Natural, SlotNo, VRFType)
-> SignKeyVRF (PraosVRF c)
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
evalCertified () (Natural, SlotNo, VRFType)
y' SignKeyVRF (PraosVRF c)
praosSignKeyVRF

  tickChainDepState :: ConsensusConfig (Praos c)
-> LedgerView (Praos c)
-> SlotNo
-> ChainDepState (Praos c)
-> Ticked (ChainDepState (Praos c))
tickChainDepState ConsensusConfig (Praos c)
_ LedgerView (Praos c)
lv SlotNo
_ = LedgerView (Praos c)
-> PraosChainDepState c -> Ticked (PraosChainDepState c)
forall c.
LedgerView (Praos c)
-> PraosChainDepState c -> Ticked (PraosChainDepState c)
TickedPraosChainDepState LedgerView (Praos c)
lv

  updateChainDepState :: HasCallStack =>
ConsensusConfig (Praos c)
-> ValidateView (Praos c)
-> SlotNo
-> Ticked (ChainDepState (Praos c))
-> Except (ValidationErr (Praos c)) (ChainDepState (Praos c))
updateChainDepState
    cfg :: ConsensusConfig (Praos c)
cfg@PraosConfig{Natural
Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
SignKeyVRF (PraosVRF c)
StakeDist
PraosParams
PraosEvolvingStake
praosInitialStake :: forall c. ConsensusConfig (Praos c) -> StakeDist
praosParams :: forall c. ConsensusConfig (Praos c) -> PraosParams
praosInitialEta :: forall c. ConsensusConfig (Praos c) -> Natural
praosEvolvingStake :: forall c. ConsensusConfig (Praos c) -> PraosEvolvingStake
praosSignKeyVRF :: forall c. ConsensusConfig (Praos c) -> SignKeyVRF (PraosVRF c)
praosVerKeys :: forall c.
ConsensusConfig (Praos c)
-> Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
praosParams :: PraosParams
praosInitialEta :: Natural
praosInitialStake :: StakeDist
praosEvolvingStake :: PraosEvolvingStake
praosSignKeyVRF :: SignKeyVRF (PraosVRF c)
praosVerKeys :: Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
..}
    (PraosValidateView PraosFields{SignedKES (PraosKES c) signed
PraosExtraFields c
praosSignature :: forall crypto typeBeingSigned.
PraosFields crypto typeBeingSigned
-> SignedKES (PraosKES crypto) typeBeingSigned
praosExtraFields :: forall crypto typeBeingSigned.
PraosFields crypto typeBeingSigned -> PraosExtraFields crypto
praosSignature :: SignedKES (PraosKES c) signed
praosExtraFields :: PraosExtraFields c
..} signed
toSign)
    SlotNo
slot
    (TickedPraosChainDepState () PraosChainDepState c
cds) = do
      let PraosExtraFields{CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
CoreNodeId
praosCreator :: forall c. PraosExtraFields c -> CoreNodeId
praosRho :: forall c.
PraosExtraFields c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosY :: forall c.
PraosExtraFields c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosCreator :: CoreNodeId
praosRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosY :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
..} = PraosExtraFields c
praosExtraFields
          nid :: CoreNodeId
nid = CoreNodeId
praosCreator

      -- check that the new block advances time
      case PraosChainDepState c -> [BlockInfo c]
forall c. PraosChainDepState c -> [BlockInfo c]
praosHistory PraosChainDepState c
cds of
        (BlockInfo c
c : [BlockInfo c]
_)
          | BlockInfo c -> SlotNo
forall c. BlockInfo c -> SlotNo
biSlot BlockInfo c
c SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
slot -> PraosValidationError c
-> ExceptT (PraosValidationError c) Identity ()
forall a.
PraosValidationError c
-> ExceptT (PraosValidationError c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PraosValidationError c
 -> ExceptT (PraosValidationError c) Identity ())
-> PraosValidationError c
-> ExceptT (PraosValidationError c) Identity ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> PraosValidationError c
forall c. SlotNo -> SlotNo -> PraosValidationError c
PraosInvalidSlot SlotNo
slot (BlockInfo c -> SlotNo
forall c. BlockInfo c -> SlotNo
biSlot BlockInfo c
c)
        [BlockInfo c]
_ -> () -> ExceptT (PraosValidationError c) Identity ()
forall a. a -> ExceptT (PraosValidationError c) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- check that block creator is a known core node
      (vkKES, vkVRF) <- case CoreNodeId
-> Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
-> Maybe (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CoreNodeId
nid Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
praosVerKeys of
        Maybe (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
Nothing -> PraosValidationError c
-> ExceptT
     (PraosValidationError c)
     Identity
     (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
forall a.
PraosValidationError c
-> ExceptT (PraosValidationError c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PraosValidationError c
 -> ExceptT
      (PraosValidationError c)
      Identity
      (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c)))
-> PraosValidationError c
-> ExceptT
     (PraosValidationError c)
     Identity
     (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
forall a b. (a -> b) -> a -> b
$ CoreNodeId -> PraosValidationError c
forall c. CoreNodeId -> PraosValidationError c
PraosUnknownCoreId CoreNodeId
nid
        Just (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
vks -> (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
-> ExceptT
     (PraosValidationError c)
     Identity
     (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
forall a. a -> ExceptT (PraosValidationError c) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
vks

      -- verify block signature
      case verifySignedKES
        ()
        vkKES
        (fromIntegral $ unSlotNo slot)
        toSign
        praosSignature of
        Right () -> () -> ExceptT (PraosValidationError c) Identity ()
forall a. a -> ExceptT (PraosValidationError c) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Left String
err ->
          PraosValidationError c
-> ExceptT (PraosValidationError c) Identity ()
forall a.
PraosValidationError c
-> ExceptT (PraosValidationError c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PraosValidationError c
 -> ExceptT (PraosValidationError c) Identity ())
-> PraosValidationError c
-> ExceptT (PraosValidationError c) Identity ()
forall a b. (a -> b) -> a -> b
$
            String
-> VerKeyKES (PraosKES c)
-> Natural
-> SigKES (PraosKES c)
-> PraosValidationError c
forall c.
String
-> VerKeyKES (PraosKES c)
-> Natural
-> SigKES (PraosKES c)
-> PraosValidationError c
PraosInvalidSig
              String
err
              VerKeyKES (PraosKES c)
vkKES
              (Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Natural) -> Word64 -> Natural
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)
              (SignedKES (PraosKES c) signed -> SigKES (PraosKES c)
forall v a. SignedKES v a -> SigKES v
getSig SignedKES (PraosKES c) signed
praosSignature)

      let (rho', y', t) = rhoYT cfg (praosHistory cds) slot nid

      -- verify rho proof
      unless (verifyCertified () vkVRF rho' praosRho) $
        throwError $
          PraosInvalidCert
            vkVRF
            rho'
            (getOutputVRFNatural (certifiedOutput praosRho))
            (certifiedProof praosRho)

      -- verify y proof
      unless (verifyCertified () vkVRF y' praosY) $
        throwError $
          PraosInvalidCert
            vkVRF
            y'
            (getOutputVRFNatural (certifiedOutput praosY))
            (certifiedProof praosY)

      -- verify stake
      unless (fromIntegral (getOutputVRFNatural (certifiedOutput praosY)) < t) $
        throwError $
          PraosInsufficientStake t $
            getOutputVRFNatural (certifiedOutput praosY)

      -- "store" a block by adding it to the chain dependent state
      let !bi =
            BlockInfo
              { biSlot :: SlotNo
biSlot = SlotNo
slot
              , biRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
biRho = CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosRho
              }

      return $ PraosChainDepState $ bi : praosHistory cds

  reupdateChainDepState :: HasCallStack =>
ConsensusConfig (Praos c)
-> ValidateView (Praos c)
-> SlotNo
-> Ticked (ChainDepState (Praos c))
-> ChainDepState (Praos c)
reupdateChainDepState
    ConsensusConfig (Praos c)
_
    (PraosValidateView PraosFields{SignedKES (PraosKES c) signed
PraosExtraFields c
praosSignature :: forall crypto typeBeingSigned.
PraosFields crypto typeBeingSigned
-> SignedKES (PraosKES crypto) typeBeingSigned
praosExtraFields :: forall crypto typeBeingSigned.
PraosFields crypto typeBeingSigned -> PraosExtraFields crypto
praosSignature :: SignedKES (PraosKES c) signed
praosExtraFields :: PraosExtraFields c
..} signed
_)
    SlotNo
slot
    (TickedPraosChainDepState () PraosChainDepState c
cds) =
      let PraosExtraFields{CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
CoreNodeId
praosCreator :: forall c. PraosExtraFields c -> CoreNodeId
praosRho :: forall c.
PraosExtraFields c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosY :: forall c.
PraosExtraFields c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosCreator :: CoreNodeId
praosRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosY :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
..} = PraosExtraFields c
praosExtraFields
          !bi :: BlockInfo c
bi =
            BlockInfo
              { biSlot :: SlotNo
biSlot = SlotNo
slot
              , biRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
biRho = CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosRho
              }
       in [BlockInfo c] -> PraosChainDepState c
forall c. [BlockInfo c] -> PraosChainDepState c
PraosChainDepState ([BlockInfo c] -> PraosChainDepState c)
-> [BlockInfo c] -> PraosChainDepState c
forall a b. (a -> b) -> a -> b
$ BlockInfo c
bi BlockInfo c -> [BlockInfo c] -> [BlockInfo c]
forall a. a -> [a] -> [a]
: PraosChainDepState c -> [BlockInfo c]
forall c. PraosChainDepState c -> [BlockInfo c]
praosHistory PraosChainDepState c
cds

-- (Standard) Praos uses the standard chain selection rule, so no need to
-- override (though see note regarding clock skew).

-- | Probability for stakeholder Uᵢ to be elected in slot
-- slⱼ considering its relative stake αᵢ.
phi :: ConsensusConfig (Praos c) -> Rational -> Double
phi :: forall c. ConsensusConfig (Praos c) -> Rational -> Double
phi PraosConfig{Natural
Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
SignKeyVRF (PraosVRF c)
StakeDist
PraosParams
PraosEvolvingStake
praosInitialStake :: forall c. ConsensusConfig (Praos c) -> StakeDist
praosParams :: forall c. ConsensusConfig (Praos c) -> PraosParams
praosInitialEta :: forall c. ConsensusConfig (Praos c) -> Natural
praosEvolvingStake :: forall c. ConsensusConfig (Praos c) -> PraosEvolvingStake
praosSignKeyVRF :: forall c. ConsensusConfig (Praos c) -> SignKeyVRF (PraosVRF c)
praosVerKeys :: forall c.
ConsensusConfig (Praos c)
-> Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
praosParams :: PraosParams
praosInitialEta :: Natural
praosInitialStake :: StakeDist
praosEvolvingStake :: PraosEvolvingStake
praosSignKeyVRF :: SignKeyVRF (PraosVRF c)
praosVerKeys :: Map CoreNodeId (VerKeyKES (PraosKES c), VerKeyVRF (PraosVRF c))
..} Rational
alpha = Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
praosLeaderF) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
alpha
 where
  PraosParams{Double
Word64
SecurityParam
praosLeaderF :: PraosParams -> Double
praosSecurityParam :: PraosParams -> SecurityParam
praosSlotsPerEpoch :: PraosParams -> Word64
praosLeaderF :: Double
praosSecurityParam :: SecurityParam
praosSlotsPerEpoch :: Word64
..} = PraosParams
praosParams

-- | Compute Tᵢ for a given stakeholder @n@ at a @SlotNo@. Will be computed from
-- 'praosEvolvingStake' (or taken from 'praosInitialStake' if checking epoch 0).
leaderThreshold ::
  forall c.
  PraosCrypto c =>
  ConsensusConfig (Praos c) ->
  [BlockInfo c] ->
  SlotNo ->
  CoreNodeId ->
  Double
leaderThreshold :: forall c.
PraosCrypto c =>
ConsensusConfig (Praos c)
-> [BlockInfo c] -> SlotNo -> CoreNodeId -> Double
leaderThreshold ConsensusConfig (Praos c)
config [BlockInfo c]
_blockInfos SlotNo
s CoreNodeId
n =
  let
    alpha :: Rational
alpha =
      Rational -> CoreNodeId -> StakeDist -> Rational
stakeWithDefault Rational
0 CoreNodeId
n (StakeDist -> Rational) -> StakeDist -> Rational
forall a b. (a -> b) -> a -> b
$
        StakeDist -> Maybe StakeDist -> StakeDist
forall a. a -> Maybe a -> a
fromMaybe (ConsensusConfig (Praos c) -> StakeDist
forall c. ConsensusConfig (Praos c) -> StakeDist
praosInitialStake ConsensusConfig (Praos c)
config) (Maybe StakeDist -> StakeDist) -> Maybe StakeDist -> StakeDist
forall a b. (a -> b) -> a -> b
$
          PraosEvolvingStake -> EpochNo -> Maybe StakeDist
latestEvolvedStakeDistAsOfEpoch (ConsensusConfig (Praos c) -> PraosEvolvingStake
forall c. ConsensusConfig (Praos c) -> PraosEvolvingStake
praosEvolvingStake ConsensusConfig (Praos c)
config) (ConsensusConfig (Praos c) -> SlotNo -> EpochNo
forall c. ConsensusConfig (Praos c) -> SlotNo -> EpochNo
slotEpoch ConsensusConfig (Praos c)
config SlotNo
s)
   in
    -- 2^(l_VRF * 8) * ϕ_f(αᵢ)
    -- the 8 factor converts from bytes to bits.
    Double
2 Double -> Period -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ (Proxy (PraosHash c) -> Period
forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Period
sizeHash (Proxy (PraosHash c)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (PraosHash c)) Period -> Period -> Period
forall a. Num a => a -> a -> a
* Period
8) Double -> Double -> Double
forall a. Num a => a -> a -> a
* ConsensusConfig (Praos c) -> Rational -> Double
forall c. ConsensusConfig (Praos c) -> Rational -> Double
phi ConsensusConfig (Praos c)
config Rational
alpha

-- | Compute the rho, y and Tᵢ parameters for a given slot.
rhoYT ::
  PraosCrypto c =>
  ConsensusConfig (Praos c) ->
  [BlockInfo c] ->
  SlotNo ->
  CoreNodeId ->
  ( (Natural, SlotNo, VRFType)
  , (Natural, SlotNo, VRFType)
  , Double
  )
rhoYT :: forall c.
PraosCrypto c =>
ConsensusConfig (Praos c)
-> [BlockInfo c]
-> SlotNo
-> CoreNodeId
-> ((Natural, SlotNo, VRFType), (Natural, SlotNo, VRFType), Double)
rhoYT ConsensusConfig (Praos c)
st [BlockInfo c]
xs SlotNo
s CoreNodeId
nid =
  let e :: EpochNo
e = ConsensusConfig (Praos c) -> SlotNo -> EpochNo
forall c. ConsensusConfig (Praos c) -> SlotNo -> EpochNo
slotEpoch ConsensusConfig (Praos c)
st SlotNo
s
      eta :: Natural
eta = ConsensusConfig (Praos c) -> [BlockInfo c] -> EpochNo -> Natural
forall c.
PraosCrypto c =>
ConsensusConfig (Praos c) -> [BlockInfo c] -> EpochNo -> Natural
infosEta ConsensusConfig (Praos c)
st [BlockInfo c]
xs EpochNo
e
      rho :: (Natural, SlotNo, VRFType)
rho = (Natural
eta, SlotNo
s, VRFType
NONCE)
      y :: (Natural, SlotNo, VRFType)
y = (Natural
eta, SlotNo
s, VRFType
TEST)
      t :: Double
t = ConsensusConfig (Praos c)
-> [BlockInfo c] -> SlotNo -> CoreNodeId -> Double
forall c.
PraosCrypto c =>
ConsensusConfig (Praos c)
-> [BlockInfo c] -> SlotNo -> CoreNodeId -> Double
leaderThreshold ConsensusConfig (Praos c)
st [BlockInfo c]
xs SlotNo
s CoreNodeId
nid
   in ((Natural, SlotNo, VRFType)
rho, (Natural, SlotNo, VRFType)
y, Double
t)

{-------------------------------------------------------------------------------
  Crypto models
-------------------------------------------------------------------------------}

class
  ( UnsoundPureKESAlgorithm (PraosKES c)
  , VRFAlgorithm (PraosVRF c)
  , HashAlgorithm (PraosHash c)
  , Typeable c
  , Typeable (PraosVRF c)
  , Condense (SigKES (PraosKES c))
  , Cardano.Crypto.VRF.Class.Signable (PraosVRF c) (Natural, SlotNo, VRFType)
  , ContextKES (PraosKES c) ~ ()
  , ContextVRF (PraosVRF c) ~ ()
  ) =>
  PraosCrypto (c :: Type)
  where
  type PraosKES c :: Type
  type PraosVRF c :: Type
  type PraosHash c :: Type

data PraosStandardCrypto
data PraosMockCrypto

instance PraosCrypto PraosStandardCrypto where
  type PraosKES PraosStandardCrypto = SimpleKES Ed25519DSIGN 1000
  type PraosVRF PraosStandardCrypto = SimpleVRF
  type PraosHash PraosStandardCrypto = SHA256

instance PraosCrypto PraosMockCrypto where
  type PraosKES PraosMockCrypto = MockKES 10000
  type PraosVRF PraosMockCrypto = MockVRF
  type PraosHash PraosMockCrypto = SHA256

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

instance PraosCrypto c => Condense (PraosFields c toSign) where
  condense :: PraosFields c toSign -> String
condense PraosFields{SignedKES (PraosKES c) toSign
PraosExtraFields c
praosSignature :: forall crypto typeBeingSigned.
PraosFields crypto typeBeingSigned
-> SignedKES (PraosKES crypto) typeBeingSigned
praosExtraFields :: forall crypto typeBeingSigned.
PraosFields crypto typeBeingSigned -> PraosExtraFields crypto
praosSignature :: SignedKES (PraosKES c) toSign
praosExtraFields :: PraosExtraFields c
..} = SignedKES (PraosKES c) toSign -> String
forall a. Condense a => a -> String
condense SignedKES (PraosKES c) toSign
praosSignature

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

instance PraosCrypto c => Serialise (BlockInfo c) where
  encode :: BlockInfo c -> Encoding
encode BlockInfo{CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
SlotNo
biSlot :: forall c. BlockInfo c -> SlotNo
biRho :: forall c.
BlockInfo c -> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
biSlot :: SlotNo
biRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
..} =
    [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
      [ Period -> Encoding
encodeListLen Period
2
      , SlotNo -> Encoding
forall a. Serialise a => a -> Encoding
encode SlotNo
biSlot
      , CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
biRho
      ]
  decode :: forall s. Decoder s (BlockInfo c)
decode = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
    biSlot <- Decoder s SlotNo
forall s. Decoder s SlotNo
forall a s. Serialise a => Decoder s a
decode
    biRho <- fromCBOR
    return BlockInfo{..}

instance SignableRepresentation (Natural, SlotNo, VRFType) where
  getSignableRepresentation :: (Natural, SlotNo, VRFType) -> ByteString
getSignableRepresentation = Encoding -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' (Encoding -> ByteString)
-> ((Natural, SlotNo, VRFType) -> Encoding)
-> (Natural, SlotNo, VRFType)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural, SlotNo, VRFType) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR