{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Cardano.Ledger.Shelley.Generator.Block (
  genBlock,
  genBlockWithTxGen,
  tickChainState,
) where

import qualified Cardano.Crypto.VRF as VRF
import Cardano.Ledger.BHeaderView (bhviewBSize, bhviewHSize)
import Cardano.Ledger.BaseTypes (UnitInterval)
import Cardano.Ledger.Shelley.API
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, dsGenDelegsL)
import Cardano.Ledger.Slot (SlotNo (..))
import Cardano.Protocol.Crypto (VRF)
import Cardano.Protocol.TPraos.API
import Cardano.Protocol.TPraos.BHeader (
  BHeader (..),
  LastAppliedBlock (..),
  hashHeaderToNonce,
  makeHeaderView,
  mkSeed,
  seedL,
 )
import Cardano.Protocol.TPraos.OCert (KESPeriod (..), OCertEnv (..), currentIssueNo, kesPeriod)
import Cardano.Protocol.TPraos.Rules.Overlay (OBftSlot (..), lookupInOverlaySchedule)
import Cardano.Protocol.TPraos.Rules.Prtcl (PrtclState (..))
import Cardano.Protocol.TPraos.Rules.Tickn (TicknState (..))
import Cardano.Slotting.Slot (WithOrigin (..))
import Control.Monad (unless)
import Control.SetAlgebra (dom, eval)
import Data.Coerce (coerce)
import Data.Foldable (toList)
import qualified Data.List as List (find)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.Sequence (Seq)
import qualified Data.Set as Set
import Lens.Micro ((^.))
import Lens.Micro.Extras (view)
import Test.Cardano.Ledger.Common (tracedDiscard)
import Test.Cardano.Ledger.Core.KeyPair (vKey)
import Test.Cardano.Ledger.Shelley.Generator.Core (
  AllIssuerKeys (..),
  GenEnv (..),
  KeySpace (..),
  getKESPeriodRenewalNo,
  mkBlock,
  mkOCert,
 )
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..), MinLEDGER_STS)
import Test.Cardano.Ledger.Shelley.Generator.Trace.Ledger ()
import Test.Cardano.Ledger.Shelley.Rules.Chain (ChainState (..))
import Test.Cardano.Ledger.Shelley.Utils (
  epochFromSlotNo,
  maxKESIterations,
  runShelleyBase,
  slotFromEpoch,
  testGlobals,
 )
import Test.Cardano.Protocol.TPraos.Create (VRFKeyPair (..))
import Test.Control.State.Transition.Trace.Generator.QuickCheck (sigGen)
import qualified Test.Control.State.Transition.Trace.Generator.QuickCheck as QC
import Test.QuickCheck (Gen)
import qualified Test.QuickCheck as QC (choose)

-- ======================================================

-- | Type alias for a transaction generator
type TxGen era =
  PParams era ->
  ChainAccountState ->
  LedgerState era ->
  SlotNo ->
  Gen (Seq (Tx era))

-- | Generate a valid block.
genBlock ::
  forall era c.
  ( MinLEDGER_STS era
  , ApplyBlock era
  , GetLedgerView era
  , QC.HasTrace (EraRule "LEDGERS" era) (GenEnv c era)
  , EraGen era
  , PraosCrypto c
  ) =>
  GenEnv c era ->
  ChainState era ->
  Gen (Block (BHeader c) era)
genBlock :: forall era c.
(MinLEDGER_STS era, ApplyBlock era, GetLedgerView era,
 HasTrace (EraRule "LEDGERS" era) (GenEnv c era), EraGen era,
 PraosCrypto c) =>
GenEnv c era -> ChainState era -> Gen (Block (BHeader c) era)
genBlock GenEnv c era
ge = TxGen era
-> GenEnv c era -> ChainState era -> Gen (Block (BHeader c) era)
forall era c.
(GetLedgerView era, ApplyBlock era, EraGen era, PraosCrypto c) =>
TxGen era
-> GenEnv c era -> ChainState era -> Gen (Block (BHeader c) era)
genBlockWithTxGen TxGen era
genTxs GenEnv c era
ge
  where
    genTxs :: TxGen era
    genTxs :: TxGen era
genTxs PParams era
pp ChainAccountState
reserves LedgerState era
ls SlotNo
s = do
      let ledgerEnv :: ShelleyLedgersEnv era
ledgerEnv = forall era.
SlotNo
-> EpochNo
-> PParams era
-> ChainAccountState
-> ShelleyLedgersEnv era
LedgersEnv @era SlotNo
s (SlotNo -> EpochNo
epochFromSlotNo SlotNo
s) PParams era
pp ChainAccountState
reserves
      Seq (Tx era)
block <- forall sts traceGenEnv.
(HasTrace sts traceGenEnv, HasCallStack) =>
traceGenEnv -> Environment sts -> State sts -> Gen (Signal sts)
sigGen @(EraRule "LEDGERS" era) GenEnv c era
ge ShelleyLedgersEnv era
Environment (EraRule "LEDGERS" era)
ledgerEnv State (EraRule "LEDGERS" era)
LedgerState era
ls
      forall era.
EraGen era =>
PParams era -> Seq (Tx era) -> Gen (Seq (Tx era))
genEraTweakBlock @era PParams era
pp Seq (Tx era)
block

genBlockWithTxGen ::
  forall era c.
  ( GetLedgerView era
  , ApplyBlock era
  , EraGen era
  , PraosCrypto c
  ) =>
  TxGen era ->
  GenEnv c era ->
  ChainState era ->
  Gen (Block (BHeader c) era)
genBlockWithTxGen :: forall era c.
(GetLedgerView era, ApplyBlock era, EraGen era, PraosCrypto c) =>
TxGen era
-> GenEnv c era -> ChainState era -> Gen (Block (BHeader c) era)
genBlockWithTxGen
  TxGen era
genTxs
  ge :: GenEnv c era
ge@(GenEnv KeySpace_ {[AllIssuerKeys c 'StakePool]
ksStakePools :: [AllIssuerKeys c 'StakePool]
ksStakePools :: forall c era. KeySpace c era -> [AllIssuerKeys c 'StakePool]
ksStakePools, Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates :: Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates :: forall c era.
KeySpace c era
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates} ScriptSpace era
_scriptspace Constants
_)
  ChainState era
origChainState = do
    -- Firstly, we must choose a slot in which to lead.
    -- Caution: the number of slots we jump here will affect the number
    -- of epochs that a chain of blocks will span
    SlotNo
firstConsideredSlot <- (SlotNo
slot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+) (SlotNo -> SlotNo) -> (Word64 -> SlotNo) -> Word64 -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
QC.choose (Word64
5, Word64
10)
    let (SlotNo
nextSlot, ChainState era
chainSt, AllIssuerKeys c 'BlockIssuer
issuerKeys) =
          (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
-> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
-> (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
forall a. a -> Maybe a -> a
fromMaybe
            (String -> (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
forall a. HasCallStack => String -> a
error String
"Cannot find a slot to create a block in")
            (Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
 -> (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer))
-> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
-> (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
forall a b. (a -> b) -> a -> b
$ GenEnv c era
-> ChainState era
-> SlotNo
-> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
forall era c.
(EraGen era, GetLedgerView era, ApplyBlock era, PraosCrypto c) =>
GenEnv c era
-> ChainState era
-> SlotNo
-> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
selectNextSlotWithLeader GenEnv c era
ge ChainState era
origChainState SlotNo
firstConsideredSlot

    -- Now we need to compute the KES period and get the set of hot keys.
    let NewEpochState EpochNo
_ BlocksMade
_ BlocksMade
_ EpochState era
es StrictMaybe PulsingRewUpdate
_ PoolDistr
_ StashedAVVMAddresses era
_ = ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes ChainState era
chainSt
        EpochState ChainAccountState
acnt LedgerState era
ls SnapShots
_ NonMyopic
_ = EpochState era
es
        pp :: PParams era
pp = EpochState era
es EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
        kp :: KESPeriod
kp@(KESPeriod Word
kesPeriod_) = ShelleyBase KESPeriod -> KESPeriod
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase KESPeriod -> KESPeriod)
-> ShelleyBase KESPeriod -> KESPeriod
forall a b. (a -> b) -> a -> b
$ SlotNo -> ShelleyBase KESPeriod
kesPeriod SlotNo
nextSlot
        cs :: Map (KeyHash 'BlockIssuer) Word64
cs = ChainState era -> Map (KeyHash 'BlockIssuer) Word64
forall era. ChainState era -> Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue ChainState era
chainSt
        m :: Integer
m = AllIssuerKeys c 'BlockIssuer -> KESPeriod -> Integer
forall h (r :: KeyRole). AllIssuerKeys h r -> KESPeriod -> Integer
getKESPeriodRenewalNo AllIssuerKeys c 'BlockIssuer
issuerKeys KESPeriod
kp
        hotKeys :: NonEmpty (KESPeriod, KESKeyPair c)
hotKeys =
          NonEmpty (KESPeriod, KESKeyPair c)
-> Maybe (NonEmpty (KESPeriod, KESKeyPair c))
-> NonEmpty (KESPeriod, KESKeyPair c)
forall a. a -> Maybe a -> a
fromMaybe
            ( String -> NonEmpty (KESPeriod, KESKeyPair c)
forall a. HasCallStack => String -> a
error (String -> NonEmpty (KESPeriod, KESKeyPair c))
-> String -> NonEmpty (KESPeriod, KESKeyPair c)
forall a b. (a -> b) -> a -> b
$
                String
"No more hot keys left. Tried dropping "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
m
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from: "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty (KESPeriod, KESKeyPair c) -> String
forall a. Show a => a -> String
show (AllIssuerKeys c 'BlockIssuer -> NonEmpty (KESPeriod, KESKeyPair c)
forall c (r :: KeyRole).
AllIssuerKeys c r -> NonEmpty (KESPeriod, KESKeyPair c)
aikHot AllIssuerKeys c 'BlockIssuer
issuerKeys)
            )
            ([(KESPeriod, KESKeyPair c)]
-> Maybe (NonEmpty (KESPeriod, KESKeyPair c))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([(KESPeriod, KESKeyPair c)]
 -> Maybe (NonEmpty (KESPeriod, KESKeyPair c)))
-> [(KESPeriod, KESKeyPair c)]
-> Maybe (NonEmpty (KESPeriod, KESKeyPair c))
forall a b. (a -> b) -> a -> b
$ Int
-> NonEmpty (KESPeriod, KESKeyPair c)
-> [(KESPeriod, KESKeyPair c)]
forall a. Int -> NonEmpty a -> [a]
NE.drop (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
m) (AllIssuerKeys c 'BlockIssuer -> NonEmpty (KESPeriod, KESKeyPair c)
forall c (r :: KeyRole).
AllIssuerKeys c r -> NonEmpty (KESPeriod, KESKeyPair c)
aikHot AllIssuerKeys c 'BlockIssuer
issuerKeys))
        keys :: AllIssuerKeys c 'BlockIssuer
keys = AllIssuerKeys c 'BlockIssuer
issuerKeys {aikHot = hotKeys}

        -- And issue a new ocert
        n' :: Maybe Word64
n' =
          OCertEnv
-> Map (KeyHash 'BlockIssuer) Word64
-> KeyHash 'BlockIssuer
-> Maybe Word64
currentIssueNo
            ( Set (KeyHash 'StakePool)
-> Set (KeyHash 'GenesisDelegate) -> OCertEnv
OCertEnv
                ([KeyHash 'StakePool] -> Set (KeyHash 'StakePool)
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash 'StakePool] -> Set (KeyHash 'StakePool))
-> [KeyHash 'StakePool] -> Set (KeyHash 'StakePool)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c 'StakePool -> KeyHash 'StakePool
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash (AllIssuerKeys c 'StakePool -> KeyHash 'StakePool)
-> [AllIssuerKeys c 'StakePool] -> [KeyHash 'StakePool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AllIssuerKeys c 'StakePool]
ksStakePools)
                (Exp (Sett (KeyHash 'GenesisDelegate) ())
-> Set (KeyHash 'GenesisDelegate)
forall s t. Embed s t => Exp t -> s
eval (Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
-> Exp (Sett (KeyHash 'GenesisDelegate) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates))
            )
            Map (KeyHash 'BlockIssuer) Word64
cs
            (KeyHash 'BlockIssuer -> KeyHash 'BlockIssuer
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole (KeyHash 'BlockIssuer -> KeyHash 'BlockIssuer)
-> (KeyPair 'BlockIssuer -> KeyHash 'BlockIssuer)
-> KeyPair 'BlockIssuer
-> KeyHash 'BlockIssuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey 'BlockIssuer -> KeyHash 'BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey 'BlockIssuer -> KeyHash 'BlockIssuer)
-> (KeyPair 'BlockIssuer -> VKey 'BlockIssuer)
-> KeyPair 'BlockIssuer
-> KeyHash 'BlockIssuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair 'BlockIssuer -> VKey 'BlockIssuer
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair 'BlockIssuer -> KeyHash 'BlockIssuer)
-> KeyPair 'BlockIssuer -> KeyHash 'BlockIssuer
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c 'BlockIssuer -> KeyPair 'BlockIssuer
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys c 'BlockIssuer
issuerKeys)
        issueNumber :: Word64
issueNumber =
          if Maybe Word64
n' Maybe Word64 -> Maybe Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Word64
forall a. Maybe a
Nothing
            then String -> Word64
forall a. HasCallStack => String -> a
error String
"no issue number available"
            else Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
m
        oCert :: OCert c
oCert = AllIssuerKeys c 'BlockIssuer -> Word64 -> KESPeriod -> OCert c
forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys c 'BlockIssuer
keys Word64
issueNumber ((KESPeriod, KESKeyPair c) -> KESPeriod
forall a b. (a, b) -> a
fst ((KESPeriod, KESKeyPair c) -> KESPeriod)
-> (KESPeriod, KESKeyPair c) -> KESPeriod
forall a b. (a -> b) -> a -> b
$ NonEmpty (KESPeriod, KESKeyPair c) -> (KESPeriod, KESKeyPair c)
forall a. NonEmpty a -> a
NE.head NonEmpty (KESPeriod, KESKeyPair c)
hotKeys)
    Block (BHeader c) era
theBlock <-
      HashHeader
-> AllIssuerKeys c 'BlockIssuer
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) Seed,
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlock
        (HashHeader
 -> AllIssuerKeys c 'BlockIssuer
 -> [Tx era]
 -> SlotNo
 -> BlockNo
 -> Nonce
 -> Word
 -> Word
 -> OCert c
 -> Block (BHeader c) era)
-> (Seq (Tx era) -> HashHeader)
-> Seq (Tx era)
-> AllIssuerKeys c 'BlockIssuer
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashHeader -> Seq (Tx era) -> HashHeader
forall a. a -> Seq (Tx era) -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashHeader
hashheader
        (Seq (Tx era)
 -> AllIssuerKeys c 'BlockIssuer
 -> [Tx era]
 -> SlotNo
 -> BlockNo
 -> Nonce
 -> Word
 -> Word
 -> OCert c
 -> Block (BHeader c) era)
-> (Seq (Tx era) -> AllIssuerKeys c 'BlockIssuer)
-> Seq (Tx era)
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
forall a b.
(Seq (Tx era) -> a -> b)
-> (Seq (Tx era) -> a) -> Seq (Tx era) -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AllIssuerKeys c 'BlockIssuer
-> Seq (Tx era) -> AllIssuerKeys c 'BlockIssuer
forall a. a -> Seq (Tx era) -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AllIssuerKeys c 'BlockIssuer
keys
        (Seq (Tx era)
 -> [Tx era]
 -> SlotNo
 -> BlockNo
 -> Nonce
 -> Word
 -> Word
 -> OCert c
 -> Block (BHeader c) era)
-> (Seq (Tx era) -> [Tx era])
-> Seq (Tx era)
-> SlotNo
-> BlockNo
-> Nonce
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
forall a b.
(Seq (Tx era) -> a -> b)
-> (Seq (Tx era) -> a) -> Seq (Tx era) -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Seq (Tx era) -> [Tx era]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
        (Seq (Tx era)
 -> SlotNo
 -> BlockNo
 -> Nonce
 -> Word
 -> Word
 -> OCert c
 -> Block (BHeader c) era)
-> Gen (Seq (Tx era))
-> Gen
     (SlotNo
      -> BlockNo
      -> Nonce
      -> Word
      -> Word
      -> OCert c
      -> Block (BHeader c) era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxGen era
genTxs PParams era
pp ChainAccountState
acnt LedgerState era
ls SlotNo
nextSlot
        Gen
  (SlotNo
   -> BlockNo
   -> Nonce
   -> Word
   -> Word
   -> OCert c
   -> Block (BHeader c) era)
-> Gen SlotNo
-> Gen
     (BlockNo
      -> Nonce -> Word -> Word -> OCert c -> Block (BHeader c) era)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SlotNo -> Gen SlotNo
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SlotNo
nextSlot
        Gen
  (BlockNo
   -> Nonce -> Word -> Word -> OCert c -> Block (BHeader c) era)
-> Gen BlockNo
-> Gen (Nonce -> Word -> Word -> OCert c -> Block (BHeader c) era)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockNo -> Gen BlockNo
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockNo
block BlockNo -> BlockNo -> BlockNo
forall a. Num a => a -> a -> a
+ BlockNo
1)
        Gen (Nonce -> Word -> Word -> OCert c -> Block (BHeader c) era)
-> Gen Nonce
-> Gen (Word -> Word -> OCert c -> Block (BHeader c) era)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Nonce -> Gen Nonce
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainState era -> Nonce
forall era. ChainState era -> Nonce
chainEpochNonce ChainState era
chainSt)
        Gen (Word -> Word -> OCert c -> Block (BHeader c) era)
-> Gen Word -> Gen (Word -> OCert c -> Block (BHeader c) era)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
kesPeriod_
        -- This seems to be trying to work out the start of the KES "era",
        -- e.g. the KES period in which this key starts to be valid.
        Gen (Word -> OCert c -> Block (BHeader c) era)
-> Gen Word -> Gen (OCert c -> Block (BHeader c) era)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
m Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxKESIterations))
        Gen (OCert c -> Block (BHeader c) era)
-> Gen (OCert c) -> Gen (Block (BHeader c) era)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OCert c -> Gen (OCert c)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OCert c
oCert
    let hView :: BHeaderView
hView = BHeader c -> BHeaderView
forall c. Crypto c => BHeader c -> BHeaderView
makeHeaderView (Block (BHeader c) era -> BHeader c
forall h era. Block h era -> h
bheader Block (BHeader c) era
theBlock)
    Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView -> Word32
bhviewBSize BHeaderView
hView Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= PParams era
pp PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
ppMaxBBSizeL) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
      String -> Gen ()
forall a. String -> a
tracedDiscard (String -> Gen ()) -> String -> Gen ()
forall a b. (a -> b) -> a -> b
$
        String
"genBlockWithTxGen: bhviewBSize too large"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word32 -> String
forall a. Show a => a -> String
show (BHeaderView -> Word32
bhviewBSize BHeaderView
hView)
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" vs "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word32 -> String
forall a. Show a => a -> String
show (PParams era
pp PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
ppMaxBBSizeL)
    Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView -> Int
bhviewHSize BHeaderView
hView Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams era
pp PParams era -> Getting Word16 (PParams era) Word16 -> Word16
forall s a. s -> Getting a s a -> a
^. Getting Word16 (PParams era) Word16
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
ppMaxBHSizeL)) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
      String -> Gen ()
forall a. String -> a
tracedDiscard (String -> Gen ()) -> String -> Gen ()
forall a b. (a -> b) -> a -> b
$
        String
"genBlockWithTxGen: bhviewHSize too large"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (BHeaderView -> Int
bhviewHSize BHeaderView
hView)
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" vs "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word16 -> String
forall a. Show a => a -> String
show (PParams era
pp PParams era -> Getting Word16 (PParams era) Word16 -> Word16
forall s a. s -> Getting a s a -> a
^. Getting Word16 (PParams era) Word16
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
ppMaxBHSizeL)
    Block (BHeader c) era -> Gen (Block (BHeader c) era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block (BHeader c) era
theBlock
    where
      -- This is safe to take form the original chain state, since we only tick
      -- it forward; no new blocks will have been applied.
      (BlockNo
block, SlotNo
slot, HashHeader
hashheader) = case ChainState era -> WithOrigin LastAppliedBlock
forall era. ChainState era -> WithOrigin LastAppliedBlock
chainLastAppliedBlock ChainState era
origChainState of
        WithOrigin LastAppliedBlock
Origin -> String -> (BlockNo, SlotNo, HashHeader)
forall a. HasCallStack => String -> a
error String
"block generator does not support from Origin"
        At (LastAppliedBlock BlockNo
b SlotNo
s HashHeader
hh) -> (BlockNo
b, SlotNo
s, HashHeader
hh)

selectNextSlotWithLeader ::
  forall era c.
  ( EraGen era
  , GetLedgerView era
  , ApplyBlock era
  , PraosCrypto c
  ) =>
  GenEnv c era ->
  ChainState era ->
  -- Starting slot
  SlotNo ->
  Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
selectNextSlotWithLeader :: forall era c.
(EraGen era, GetLedgerView era, ApplyBlock era, PraosCrypto c) =>
GenEnv c era
-> ChainState era
-> SlotNo
-> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
selectNextSlotWithLeader
  (GenEnv KeySpace_ {[AllIssuerKeys c 'StakePool]
ksStakePools :: forall c era. KeySpace c era -> [AllIssuerKeys c 'StakePool]
ksStakePools :: [AllIssuerKeys c 'StakePool]
ksStakePools, Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates :: forall c era.
KeySpace c era
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates :: Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates} ScriptSpace era
_ Constants
_)
  ChainState era
origChainState
  SlotNo
startSlot =
    ((SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer) -> Bool)
-> [(SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)]
-> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Bool
-> (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer) -> Bool
forall a b. a -> b -> a
const Bool
True) ([(SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)]
 -> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer))
-> ([Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)]
    -> [(SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)])
-> [Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)]
-> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)]
-> [(SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)]
 -> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer))
-> [Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)]
-> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
forall a b. (a -> b) -> a -> b
$
      SlotNo
-> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
selectNextSlotWithLeaderThisEpoch
        (SlotNo
 -> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer))
-> [SlotNo]
-> [Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SlotNo
startSlot SlotNo -> [SlotNo] -> [SlotNo]
forall a. a -> [a] -> [a]
: [EpochNo -> SlotNo
slotFromEpoch EpochNo
x | EpochNo
x <- [EpochNo
startEpoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1 .. EpochNo
startEpoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
4]])
    where
      -- If we can't find a leader in the next N Epochs, some thing is wrong, N=4 should be large enough.

      startEpoch :: EpochNo
startEpoch = SlotNo -> EpochNo
epochFromSlotNo SlotNo
startSlot
      selectNextSlotWithLeaderThisEpoch ::
        -- Slot number whence we begin our search
        SlotNo ->
        Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
      selectNextSlotWithLeaderThisEpoch :: SlotNo
-> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
selectNextSlotWithLeaderThisEpoch SlotNo
fromSlot =
        (SlotNo -> Maybe (ChainState era, AllIssuerKeys c 'BlockIssuer))
-> [SlotNo]
-> Maybe (SlotNo, ChainState era, AllIssuerKeys c 'BlockIssuer)
forall {a} {b} {c}. (a -> Maybe (b, c)) -> [a] -> Maybe (a, b, c)
findJust SlotNo -> Maybe (ChainState era, AllIssuerKeys c 'BlockIssuer)
selectLeaderForSlot [SlotNo
fromSlot .. SlotNo
toSlot]
        where
          currentEpoch :: EpochNo
currentEpoch = SlotNo -> EpochNo
epochFromSlotNo SlotNo
fromSlot
          toSlot :: SlotNo
toSlot = EpochNo -> SlotNo
slotFromEpoch (EpochNo
currentEpoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1) SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
1

          findJust :: (a -> Maybe (b, c)) -> [a] -> Maybe (a, b, c)
findJust a -> Maybe (b, c)
_ [] = Maybe (a, b, c)
forall a. Maybe a
Nothing
          findJust a -> Maybe (b, c)
f (a
x : [a]
xs) = case a -> Maybe (b, c)
f a
x of
            Just (b
chainSt, c
y) -> (a, b, c) -> Maybe (a, b, c)
forall a. a -> Maybe a
Just (a
x, b
chainSt, c
y)
            Maybe (b, c)
Nothing -> (a -> Maybe (b, c)) -> [a] -> Maybe (a, b, c)
findJust a -> Maybe (b, c)
f [a]
xs

      -- Try to select a leader for the given slot
      selectLeaderForSlot ::
        SlotNo ->
        Maybe (ChainState era, AllIssuerKeys c 'BlockIssuer)
      selectLeaderForSlot :: SlotNo -> Maybe (ChainState era, AllIssuerKeys c 'BlockIssuer)
selectLeaderForSlot SlotNo
slotNo =
        (ChainState era
chainSt,)
          (AllIssuerKeys c 'BlockIssuer
 -> (ChainState era, AllIssuerKeys c 'BlockIssuer))
-> Maybe (AllIssuerKeys c 'BlockIssuer)
-> Maybe (ChainState era, AllIssuerKeys c 'BlockIssuer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case SlotNo
-> Set (KeyHash 'Genesis)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe OBftSlot
lookupInOverlaySchedule SlotNo
firstEpochSlot (Map (KeyHash 'Genesis) GenDelegPair -> Set (KeyHash 'Genesis)
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis) GenDelegPair
cores) UnitInterval
d ActiveSlotCoeff
f SlotNo
slotNo of
            Maybe OBftSlot
Nothing ->
              AllIssuerKeys c 'StakePool -> AllIssuerKeys c 'BlockIssuer
forall a b. Coercible a b => a -> b
coerce
                (AllIssuerKeys c 'StakePool -> AllIssuerKeys c 'BlockIssuer)
-> Maybe (AllIssuerKeys c 'StakePool)
-> Maybe (AllIssuerKeys c 'BlockIssuer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AllIssuerKeys c 'StakePool -> Bool)
-> [AllIssuerKeys c 'StakePool]
-> Maybe (AllIssuerKeys c 'StakePool)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find
                  ( \(AllIssuerKeys {VRFKeyPair c
aikVrf :: VRFKeyPair c
aikVrf :: forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf, KeyHash 'StakePool
aikColdKeyHash :: forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash :: KeyHash 'StakePool
aikColdKeyHash}) ->
                      KeyHash 'StakePool -> SignKeyVRF (VRF c) -> Bool
isLeader KeyHash 'StakePool
aikColdKeyHash (VRFKeyPair c -> SignKeyVRF (VRF c)
forall c. VRFKeyPair c -> SignKeyVRF (VRF c)
vrfSignKey VRFKeyPair c
aikVrf)
                  )
                  [AllIssuerKeys c 'StakePool]
ksStakePools
            Just (ActiveSlot KeyHash 'Genesis
x) ->
              Maybe (AllIssuerKeys c 'GenesisDelegate)
-> Maybe (AllIssuerKeys c 'BlockIssuer)
forall a b. Coercible a b => a -> b
coerce (Maybe (AllIssuerKeys c 'GenesisDelegate)
 -> Maybe (AllIssuerKeys c 'BlockIssuer))
-> Maybe (AllIssuerKeys c 'GenesisDelegate)
-> Maybe (AllIssuerKeys c 'BlockIssuer)
forall a b. (a -> b) -> a -> b
$
                KeyHash 'Genesis
-> Map (KeyHash 'Genesis) GenDelegPair -> Maybe GenDelegPair
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'Genesis
x Map (KeyHash 'Genesis) GenDelegPair
cores
                  Maybe GenDelegPair
-> (GenDelegPair -> Maybe (AllIssuerKeys c 'GenesisDelegate))
-> Maybe (AllIssuerKeys c 'GenesisDelegate)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \GenDelegPair
y -> KeyHash 'GenesisDelegate
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
-> Maybe (AllIssuerKeys c 'GenesisDelegate)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (GenDelegPair -> KeyHash 'GenesisDelegate
genDelegKeyHash GenDelegPair
y) Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates
            Maybe OBftSlot
_ -> Maybe (AllIssuerKeys c 'BlockIssuer)
forall a. Maybe a
Nothing
        where
          chainSt :: ChainState era
chainSt = SlotNo -> ChainState era -> ChainState era
forall era.
(GetLedgerView era, ApplyBlock era) =>
SlotNo -> ChainState era -> ChainState era
tickChainState SlotNo
slotNo ChainState era
origChainState
          epochNonce :: Nonce
epochNonce = ChainState era -> Nonce
forall era. ChainState era -> Nonce
chainEpochNonce ChainState era
chainSt
          poolDistr :: Map (KeyHash 'StakePool) IndividualPoolStake
poolDistr = PoolDistr -> Map (KeyHash 'StakePool) IndividualPoolStake
unPoolDistr (PoolDistr -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> (ChainState era -> PoolDistr)
-> ChainState era
-> Map (KeyHash 'StakePool) IndividualPoolStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> PoolDistr
forall era. NewEpochState era -> PoolDistr
nesPd (NewEpochState era -> PoolDistr)
-> (ChainState era -> NewEpochState era)
-> ChainState era
-> PoolDistr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes (ChainState era -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> ChainState era -> Map (KeyHash 'StakePool) IndividualPoolStake
forall a b. (a -> b) -> a -> b
$ ChainState era
chainSt
          dpstate :: CertState era
dpstate = (LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState (LedgerState era -> CertState era)
-> (ChainState era -> LedgerState era)
-> ChainState era
-> CertState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState (EpochState era -> LedgerState era)
-> (ChainState era -> EpochState era)
-> ChainState era
-> LedgerState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs (NewEpochState era -> EpochState era)
-> (ChainState era -> NewEpochState era)
-> ChainState era
-> EpochState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes) ChainState era
chainSt
          (GenDelegs Map (KeyHash 'Genesis) GenDelegPair
cores) = CertState era
dpstate CertState era
-> Getting GenDelegs (CertState era) GenDelegs -> GenDelegs
forall s a. s -> Getting a s a -> a
^. (DState era -> Const GenDelegs (DState era))
-> CertState era -> Const GenDelegs (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const GenDelegs (DState era))
 -> CertState era -> Const GenDelegs (CertState era))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> DState era -> Const GenDelegs (DState era))
-> Getting GenDelegs (CertState era) GenDelegs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenDelegs -> Const GenDelegs GenDelegs)
-> DState era -> Const GenDelegs (DState era)
forall era (f :: * -> *).
Functor f =>
(GenDelegs -> f GenDelegs) -> DState era -> f (DState era)
dsGenDelegsL
          firstEpochSlot :: SlotNo
firstEpochSlot = EpochNo -> SlotNo
slotFromEpoch (SlotNo -> EpochNo
epochFromSlotNo SlotNo
slotNo)
          f :: ActiveSlotCoeff
f = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
testGlobals
          getUnitInterval :: PParams era -> UnitInterval
          getUnitInterval :: PParams era -> UnitInterval
getUnitInterval PParams era
pp = PParams era
pp PParams era
-> Getting UnitInterval (PParams era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams era) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams era) UnitInterval
ppDG
          d :: UnitInterval
d = (PParams era -> UnitInterval
getUnitInterval (PParams era -> UnitInterval)
-> (ChainState era -> PParams era)
-> ChainState era
-> UnitInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (PParams era) (EpochState era) (PParams era)
-> EpochState era -> PParams era
forall a s. Getting a s a -> s -> a
view Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL (EpochState era -> PParams era)
-> (ChainState era -> EpochState era)
-> ChainState era
-> PParams era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs (NewEpochState era -> EpochState era)
-> (ChainState era -> NewEpochState era)
-> ChainState era
-> EpochState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes) ChainState era
chainSt

          isLeader :: KeyHash 'StakePool -> SignKeyVRF (VRF c) -> Bool
isLeader KeyHash 'StakePool
poolHash SignKeyVRF (VRF c)
vrfKey =
            let y :: CertifiedVRF (VRF c) Seed
y = forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified @(VRF c) () (Nonce -> SlotNo -> Nonce -> Seed
mkSeed Nonce
seedL SlotNo
slotNo Nonce
epochNonce) SignKeyVRF (VRF c)
vrfKey
                stake :: Rational
stake = Rational
-> (IndividualPoolStake -> Rational)
-> Maybe IndividualPoolStake
-> Rational
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rational
0 IndividualPoolStake -> Rational
individualPoolStake (Maybe IndividualPoolStake -> Rational)
-> Maybe IndividualPoolStake -> Rational
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> Maybe IndividualPoolStake
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
poolHash Map (KeyHash 'StakePool) IndividualPoolStake
poolDistr
             in case SlotNo
-> Set (KeyHash 'Genesis)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe OBftSlot
lookupInOverlaySchedule SlotNo
firstEpochSlot (Map (KeyHash 'Genesis) GenDelegPair -> Set (KeyHash 'Genesis)
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis) GenDelegPair
cores) UnitInterval
d ActiveSlotCoeff
f SlotNo
slotNo of
                  Maybe OBftSlot
Nothing -> OutputVRF (VRF c) -> Rational -> ActiveSlotCoeff -> Bool
forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderValue (CertifiedVRF (VRF c) Seed -> OutputVRF (VRF c)
forall v a. CertifiedVRF v a -> OutputVRF v
VRF.certifiedOutput CertifiedVRF (VRF c) Seed
y) Rational
stake ActiveSlotCoeff
f
                  Just (ActiveSlot KeyHash 'Genesis
x) | KeyHash 'Genesis -> KeyHash 'StakePool
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'Genesis
x KeyHash 'StakePool -> KeyHash 'StakePool -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash 'StakePool
poolHash -> Bool
True
                  Maybe OBftSlot
_ -> Bool
False

-- | The chain state is a composite of the new epoch state and the chain dep
-- state. We tick both.
tickChainState ::
  (GetLedgerView era, ApplyBlock era) =>
  SlotNo ->
  ChainState era ->
  ChainState era
tickChainState :: forall era.
(GetLedgerView era, ApplyBlock era) =>
SlotNo -> ChainState era -> ChainState era
tickChainState
  SlotNo
slotNo
  ChainState
    { NewEpochState era
chainNes :: forall era. ChainState era -> NewEpochState era
chainNes :: NewEpochState era
chainNes
    , Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue :: forall era. ChainState era -> Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue :: Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue
    , Nonce
chainEpochNonce :: forall era. ChainState era -> Nonce
chainEpochNonce :: Nonce
chainEpochNonce
    , Nonce
chainEvolvingNonce :: Nonce
chainEvolvingNonce :: forall era. ChainState era -> Nonce
chainEvolvingNonce
    , Nonce
chainCandidateNonce :: Nonce
chainCandidateNonce :: forall era. ChainState era -> Nonce
chainCandidateNonce
    , Nonce
chainPrevEpochNonce :: Nonce
chainPrevEpochNonce :: forall era. ChainState era -> Nonce
chainPrevEpochNonce
    , WithOrigin LastAppliedBlock
chainLastAppliedBlock :: forall era. ChainState era -> WithOrigin LastAppliedBlock
chainLastAppliedBlock :: WithOrigin LastAppliedBlock
chainLastAppliedBlock
    } =
    let cds :: ChainDepState
cds =
          ChainDepState
            { csProtocol :: PrtclState
csProtocol = Map (KeyHash 'BlockIssuer) Word64 -> Nonce -> Nonce -> PrtclState
PrtclState Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue Nonce
chainEvolvingNonce Nonce
chainCandidateNonce
            , csTickn :: TicknState
csTickn = Nonce -> Nonce -> TicknState
TicknState Nonce
chainEpochNonce Nonce
chainPrevEpochNonce
            , csLabNonce :: Nonce
csLabNonce = case WithOrigin LastAppliedBlock
chainLastAppliedBlock of
                WithOrigin LastAppliedBlock
Origin -> Nonce
NeutralNonce
                At (LastAppliedBlock {HashHeader
labHash :: HashHeader
labHash :: LastAppliedBlock -> HashHeader
labHash}) -> HashHeader -> Nonce
hashHeaderToNonce HashHeader
labHash
            }
        lv :: LedgerView
lv = (FutureLedgerViewError era -> LedgerView)
-> (LedgerView -> LedgerView)
-> Either (FutureLedgerViewError era) LedgerView
-> LedgerView
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> LedgerView
forall a. HasCallStack => String -> a
error (String -> LedgerView)
-> (FutureLedgerViewError era -> String)
-> FutureLedgerViewError era
-> LedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutureLedgerViewError era -> String
forall a. Show a => a -> String
show) LedgerView -> LedgerView
forall a. a -> a
id (Either (FutureLedgerViewError era) LedgerView -> LedgerView)
-> Either (FutureLedgerViewError era) LedgerView -> LedgerView
forall a b. (a -> b) -> a -> b
$ Globals
-> NewEpochState era
-> SlotNo
-> Either (FutureLedgerViewError era) LedgerView
forall era (m :: * -> *).
(GetLedgerView era, MonadError (FutureLedgerViewError era) m) =>
Globals -> NewEpochState era -> SlotNo -> m LedgerView
forall (m :: * -> *).
MonadError (FutureLedgerViewError era) m =>
Globals -> NewEpochState era -> SlotNo -> m LedgerView
futureLedgerView Globals
testGlobals NewEpochState era
chainNes SlotNo
slotNo
        isNewEpoch :: Bool
isNewEpoch = SlotNo -> EpochNo
epochFromSlotNo SlotNo
slotNo EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
/= NewEpochState era -> EpochNo
forall era. NewEpochState era -> EpochNo
nesEL NewEpochState era
chainNes
        ChainDepState {PrtclState
csProtocol :: ChainDepState -> PrtclState
csProtocol :: PrtclState
csProtocol, TicknState
csTickn :: ChainDepState -> TicknState
csTickn :: TicknState
csTickn} =
          Globals -> LedgerView -> Bool -> ChainDepState -> ChainDepState
tickChainDepState Globals
testGlobals LedgerView
lv Bool
isNewEpoch ChainDepState
cds
        PrtclState Map (KeyHash 'BlockIssuer) Word64
ocertIssue Nonce
evNonce Nonce
candNonce = PrtclState
csProtocol
        nes' :: NewEpochState era
nes' = Globals -> NewEpochState era -> SlotNo -> NewEpochState era
forall era.
ApplyBlock era =>
Globals -> NewEpochState era -> SlotNo -> NewEpochState era
applyTickNoEvents Globals
testGlobals NewEpochState era
chainNes SlotNo
slotNo
     in ChainState
          { chainNes :: NewEpochState era
chainNes = NewEpochState era
nes'
          , chainOCertIssue :: Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue = Map (KeyHash 'BlockIssuer) Word64
ocertIssue
          , chainEpochNonce :: Nonce
chainEpochNonce = TicknState -> Nonce
ticknStateEpochNonce TicknState
csTickn
          , chainEvolvingNonce :: Nonce
chainEvolvingNonce = Nonce
evNonce
          , chainCandidateNonce :: Nonce
chainCandidateNonce = Nonce
candNonce
          , chainPrevEpochNonce :: Nonce
chainPrevEpochNonce = TicknState -> Nonce
ticknStatePrevHashNonce TicknState
csTickn
          , chainLastAppliedBlock :: WithOrigin LastAppliedBlock
chainLastAppliedBlock = WithOrigin LastAppliedBlock
chainLastAppliedBlock
          }