{-# 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.Ed448 (Ed448DSIGN)
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
      !Period  -- ^ Absolute period of the KES key
      !(SignKeyKES (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)
deriving instance PraosCrypto c => Show (HotKey c)

-- | 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 SignKeyKES (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)
-> SignKeyKES (PraosKES c)
-> Period
-> Maybe (SignKeyKES (PraosKES c))
forall v.
(KESAlgorithm v, HasCallStack) =>
ContextKES v -> SignKeyKES v -> Period -> Maybe (SignKeyKES v)
updateKES () SignKeyKES (PraosKES c)
oldKey Period
keyPeriod of
           Maybe (SignKeyKES (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 SignKeyKES (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 -> SignKeyKES (PraosKES c) -> HotKey c
forall c. Period -> SignKeyKES (PraosKES c) -> HotKey c
HotKey (Period
keyPeriod Period -> Period -> Period
forall a. Num a => a -> a -> a
+ Period
1) SignKeyKES (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
praosProofRho :: forall c.
PraosProof c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosProofY :: forall c.
PraosProof c
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosLeader :: forall c. PraosProof c -> CoreNodeId
..} HotKey c
hotKey PraosExtraFields c -> toSign
mkToSign =
    case HotKey c
hotKey of
      HotKey Period
kesPeriod SignKeyKES (PraosKES c)
key -> PraosFields {
          praosSignature :: SignedKES (PraosKES c) toSign
praosSignature   = ContextKES (PraosKES c)
-> Period
-> toSign
-> SignKeyKES (PraosKES c)
-> SignedKES (PraosKES c) toSign
forall v a.
(KESAlgorithm v, Signable v a) =>
ContextKES v -> Period -> a -> SignKeyKES v -> SignedKES v a
signedKES () Period
kesPeriod (PraosExtraFields c -> toSign
mkToSign PraosExtraFields c
fieldsToSign) SignKeyKES (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
    (VerKeyKES (PraosKES c)
vkKES, VerKeyVRF (PraosVRF c)
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 ContextKES (PraosKES c)
-> VerKeyKES (PraosKES c)
-> Period
-> signed
-> SignedKES (PraosKES c) signed
-> Either String ()
forall v a.
(KESAlgorithm v, Signable v a) =>
ContextKES v
-> VerKeyKES v -> Period -> a -> SignedKES v a -> Either String ()
verifySignedKES
           ()
           VerKeyKES (PraosKES c)
vkKES
           (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
slot)
           signed
toSign
           SignedKES (PraosKES c) signed
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 ((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
nid

    -- verify rho proof
    Bool
-> ExceptT (PraosValidationError c) Identity ()
-> ExceptT (PraosValidationError c) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ContextVRF (PraosVRF c)
-> VerKeyVRF (PraosVRF c)
-> (Natural, SlotNo, VRFType)
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
-> Bool
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> VerKeyVRF v -> a -> CertifiedVRF v a -> Bool
verifyCertified () VerKeyVRF (PraosVRF c)
vkVRF (Natural, SlotNo, VRFType)
rho' CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosRho) (ExceptT (PraosValidationError c) Identity ()
 -> ExceptT (PraosValidationError c) Identity ())
-> ExceptT (PraosValidationError c) Identity ()
-> ExceptT (PraosValidationError c) Identity ()
forall a b. (a -> b) -> a -> b
$
        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
$ VerKeyVRF (PraosVRF c)
-> (Natural, SlotNo, VRFType)
-> Natural
-> CertVRF (PraosVRF c)
-> PraosValidationError c
forall c.
VerKeyVRF (PraosVRF c)
-> (Natural, SlotNo, VRFType)
-> Natural
-> CertVRF (PraosVRF c)
-> PraosValidationError c
PraosInvalidCert
            VerKeyVRF (PraosVRF c)
vkVRF
            (Natural, SlotNo, VRFType)
rho'
            (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)
praosRho))
            (CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
-> CertVRF (PraosVRF c)
forall v a. CertifiedVRF v a -> CertVRF v
certifiedProof CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosRho)

    -- verify y proof
    Bool
-> ExceptT (PraosValidationError c) Identity ()
-> ExceptT (PraosValidationError c) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ContextVRF (PraosVRF c)
-> VerKeyVRF (PraosVRF c)
-> (Natural, SlotNo, VRFType)
-> CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
-> Bool
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> VerKeyVRF v -> a -> CertifiedVRF v a -> Bool
verifyCertified () VerKeyVRF (PraosVRF c)
vkVRF (Natural, SlotNo, VRFType)
y' CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosY) (ExceptT (PraosValidationError c) Identity ()
 -> ExceptT (PraosValidationError c) Identity ())
-> ExceptT (PraosValidationError c) Identity ()
-> ExceptT (PraosValidationError c) Identity ()
forall a b. (a -> b) -> a -> b
$
        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
$ VerKeyVRF (PraosVRF c)
-> (Natural, SlotNo, VRFType)
-> Natural
-> CertVRF (PraosVRF c)
-> PraosValidationError c
forall c.
VerKeyVRF (PraosVRF c)
-> (Natural, SlotNo, VRFType)
-> Natural
-> CertVRF (PraosVRF c)
-> PraosValidationError c
PraosInvalidCert
            VerKeyVRF (PraosVRF c)
vkVRF
            (Natural, SlotNo, VRFType)
y'
            (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)
praosY))
            (CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
-> CertVRF (PraosVRF c)
forall v a. CertifiedVRF v a -> CertVRF v
certifiedProof CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
praosY)

    -- verify stake
    Bool
-> ExceptT (PraosValidationError c) Identity ()
-> ExceptT (PraosValidationError c) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (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)
praosY)) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t) (ExceptT (PraosValidationError c) Identity ()
 -> ExceptT (PraosValidationError c) Identity ())
-> ExceptT (PraosValidationError c) Identity ()
-> ExceptT (PraosValidationError c) Identity ()
forall a b. (a -> b) -> a -> b
$
        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
$ Double -> Natural -> PraosValidationError c
forall c. Double -> Natural -> PraosValidationError c
PraosInsufficientStake Double
t (Natural -> PraosValidationError c)
-> Natural -> PraosValidationError c
forall a b. (a -> b) -> a -> b
$
                       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)
praosY)

    -- "store" a block by adding it to the chain dependent state
    let !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
            }

    PraosChainDepState c
-> ExceptT (PraosValidationError c) Identity (PraosChainDepState c)
forall a. a -> ExceptT (PraosValidationError c) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (PraosChainDepState c
 -> ExceptT
      (PraosValidationError c) Identity (PraosChainDepState c))
-> PraosChainDepState c
-> ExceptT (PraosValidationError c) Identity (PraosChainDepState c)
forall a b. (a -> b) -> a -> b
$ [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

  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 ( KESAlgorithm  (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 family PraosKES  c :: Type
  type family PraosVRF  c :: Type
  type family PraosHash c :: Type

data PraosStandardCrypto
data PraosMockCrypto

instance PraosCrypto PraosStandardCrypto where
  type PraosKES  PraosStandardCrypto = SimpleKES Ed448DSIGN 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
    SlotNo
biSlot  <- Decoder s SlotNo
forall s. Decoder s SlotNo
forall a s. Serialise a => Decoder s a
decode
    CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
biRho   <- Decoder s (CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType))
forall s.
Decoder s (CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType))
forall a s. FromCBOR a => Decoder s a
fromCBOR
    BlockInfo c -> Decoder s (BlockInfo c)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockInfo {CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
SlotNo
biSlot :: SlotNo
biRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
biSlot :: SlotNo
biRho :: CertifiedVRF (PraosVRF c) (Natural, SlotNo, VRFType)
..}

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