{-# LANGUAGE BangPatterns #-}
{-# 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)
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.ConcreteCryptoTypes (MockCrypto)
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 ->
  AccountState ->
  LedgerState era ->
  SlotNo ->
  Gen (Seq (Tx era))

-- | Generate a valid block.
genBlock ::
  forall era.
  ( MinLEDGER_STS era
  , ApplyBlock era
  , GetLedgerView era
  , QC.HasTrace (EraRule "LEDGERS" era) (GenEnv era)
  , EraGen era
  ) =>
  GenEnv era ->
  ChainState era ->
  Gen (Block (BHeader MockCrypto) era)
genBlock :: forall era.
(MinLEDGER_STS era, ApplyBlock era, GetLedgerView era,
 HasTrace (EraRule "LEDGERS" era) (GenEnv era), EraGen era) =>
GenEnv era
-> ChainState era -> Gen (Block (BHeader MockCrypto) era)
genBlock GenEnv era
ge = forall era.
(GetLedgerView era, ApplyBlock era, EraGen era) =>
TxGen era
-> GenEnv era
-> ChainState era
-> Gen (Block (BHeader MockCrypto) era)
genBlockWithTxGen TxGen era
genTxs GenEnv era
ge
  where
    genTxs :: TxGen era
    genTxs :: TxGen era
genTxs PParams era
pp AccountState
reserves LedgerState era
ls SlotNo
s = do
      let ledgerEnv :: ShelleyLedgersEnv era
ledgerEnv = forall era.
SlotNo
-> EpochNo -> PParams era -> AccountState -> ShelleyLedgersEnv era
LedgersEnv @era SlotNo
s (SlotNo -> EpochNo
epochFromSlotNo SlotNo
s) PParams era
pp AccountState
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 era
ge ShelleyLedgersEnv era
ledgerEnv 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.
  ( GetLedgerView era
  , ApplyBlock era
  , EraGen era
  ) =>
  TxGen era ->
  GenEnv era ->
  ChainState era ->
  Gen (Block (BHeader MockCrypto) era)
genBlockWithTxGen :: forall era.
(GetLedgerView era, ApplyBlock era, EraGen era) =>
TxGen era
-> GenEnv era
-> ChainState era
-> Gen (Block (BHeader MockCrypto) era)
genBlockWithTxGen
  TxGen era
genTxs
  ge :: GenEnv era
ge@(GenEnv KeySpace_ {[AllIssuerKeys MockCrypto 'StakePool]
ksStakePools :: forall era. KeySpace era -> [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools :: [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools, Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates :: forall era.
KeySpace era
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates :: Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto '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 forall a. Num a => a -> a -> a
+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
QC.choose (Word64
5, Word64
10)
    let (SlotNo
nextSlot, ChainState era
chainSt, AllIssuerKeys MockCrypto 'BlockIssuer
issuerKeys) =
          forall a. a -> Maybe a -> a
fromMaybe
            (forall a. HasCallStack => String -> a
error String
"Cannot find a slot to create a block in")
            forall a b. (a -> b) -> a -> b
$ forall era.
(EraGen era, GetLedgerView era, ApplyBlock era) =>
GenEnv era
-> ChainState era
-> SlotNo
-> Maybe
     (SlotNo, ChainState era, AllIssuerKeys MockCrypto 'BlockIssuer)
selectNextSlotWithLeader GenEnv 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
_ = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
chainSt
        EpochState AccountState
acnt LedgerState era
ls SnapShots
_ NonMyopic
_ = EpochState era
es
        pp :: PParams era
pp = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
        kp :: KESPeriod
kp@(KESPeriod Word
kesPeriod_) = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ SlotNo -> ShelleyBase KESPeriod
kesPeriod SlotNo
nextSlot
        cs :: Map (KeyHash 'BlockIssuer) Word64
cs = forall era. ChainState era -> Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue ChainState era
chainSt
        m :: Integer
m = forall h (r :: KeyRole). AllIssuerKeys h r -> KESPeriod -> Integer
getKESPeriodRenewalNo AllIssuerKeys MockCrypto 'BlockIssuer
issuerKeys KESPeriod
kp
        hotKeys :: NonEmpty (KESPeriod, KESKeyPair MockCrypto)
hotKeys =
          forall a. a -> Maybe a -> a
fromMaybe
            ( forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
                String
"No more hot keys left. Tried dropping "
                  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
m
                  forall a. [a] -> [a] -> [a]
++ String
" from: "
                  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c (r :: KeyRole).
AllIssuerKeys c r -> NonEmpty (KESPeriod, KESKeyPair c)
aikHot AllIssuerKeys MockCrypto 'BlockIssuer
issuerKeys)
            )
            (forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty forall a b. (a -> b) -> a -> b
$ forall a. Int -> NonEmpty a -> [a]
NE.drop (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
m) (forall c (r :: KeyRole).
AllIssuerKeys c r -> NonEmpty (KESPeriod, KESKeyPair c)
aikHot AllIssuerKeys MockCrypto 'BlockIssuer
issuerKeys))
        keys :: AllIssuerKeys MockCrypto 'BlockIssuer
keys = AllIssuerKeys MockCrypto 'BlockIssuer
issuerKeys {aikHot :: NonEmpty (KESPeriod, KESKeyPair MockCrypto)
aikHot = NonEmpty (KESPeriod, KESKeyPair MockCrypto)
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
                (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools)
                (forall s t. Embed s t => Exp t -> s
eval (forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates))
            )
            Map (KeyHash 'BlockIssuer) Word64
cs
            (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey forall a b. (a -> b) -> a -> b
$ forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys MockCrypto 'BlockIssuer
issuerKeys)
        issueNumber :: Word64
issueNumber =
          if Maybe Word64
n' forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing
            then forall a. HasCallStack => String -> a
error String
"no issue number available"
            else forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
m
        oCert :: OCert MockCrypto
oCert = forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys MockCrypto 'BlockIssuer
keys Word64
issueNumber (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.head NonEmpty (KESPeriod, KESKeyPair MockCrypto)
hotKeys)
    Block (BHeader MockCrypto) era
theBlock <-
      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
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure HashHeader
hashheader
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure AllIssuerKeys MockCrypto 'BlockIssuer
keys
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxGen era
genTxs PParams era
pp AccountState
acnt LedgerState era
ls SlotNo
nextSlot
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SlotNo
nextSlot
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockNo
block forall a. Num a => a -> a -> a
+ BlockNo
1)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. ChainState era -> Nonce
chainEpochNonce ChainState era
chainSt)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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.
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
m forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxKESIterations))
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure OCert MockCrypto
oCert
    let hView :: BHeaderView
hView = forall c. BHeader c -> BHeaderView
makeHeaderView (forall h era. Block h era -> h
bheader Block (BHeader MockCrypto) era
theBlock)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView -> Word32
bhviewBSize BHeaderView
hView forall a. Ord a => a -> a -> Bool
<= PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxBBSizeL) forall a b. (a -> b) -> a -> b
$
      forall a. String -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$
        String
"genBlockWithTxGen: bhviewBSize too large"
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (BHeaderView -> Word32
bhviewBSize BHeaderView
hView)
          forall a. Semigroup a => a -> a -> a
<> String
" vs "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxBBSizeL)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView -> Int
bhviewHSize BHeaderView
hView forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Word16
ppMaxBHSizeL)) forall a b. (a -> b) -> a -> b
$
      forall a. String -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$
        String
"genBlockWithTxGen: bhviewHSize too large"
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (BHeaderView -> Int
bhviewHSize BHeaderView
hView)
          forall a. Semigroup a => a -> a -> a
<> String
" vs "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Word16
ppMaxBHSizeL)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Block (BHeader MockCrypto) 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 forall era. ChainState era -> WithOrigin LastAppliedBlock
chainLastAppliedBlock ChainState era
origChainState of
        WithOrigin LastAppliedBlock
Origin -> 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.
  ( EraGen era
  , GetLedgerView era
  , ApplyBlock era
  ) =>
  GenEnv era ->
  ChainState era ->
  -- Starting slot
  SlotNo ->
  Maybe (SlotNo, ChainState era, AllIssuerKeys MockCrypto 'BlockIssuer)
selectNextSlotWithLeader :: forall era.
(EraGen era, GetLedgerView era, ApplyBlock era) =>
GenEnv era
-> ChainState era
-> SlotNo
-> Maybe
     (SlotNo, ChainState era, AllIssuerKeys MockCrypto 'BlockIssuer)
selectNextSlotWithLeader
  (GenEnv KeySpace_ {[AllIssuerKeys MockCrypto 'StakePool]
ksStakePools :: [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools :: forall era. KeySpace era -> [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools, Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates :: Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates :: forall era.
KeySpace era
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates} ScriptSpace era
_ Constants
_)
  ChainState era
origChainState
  SlotNo
startSlot =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (forall a b. a -> b -> a
const Bool
True) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
      SlotNo
-> Maybe
     (SlotNo, ChainState era, AllIssuerKeys MockCrypto 'BlockIssuer)
selectNextSlotWithLeaderThisEpoch
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SlotNo
startSlot forall a. a -> [a] -> [a]
: [EpochNo -> SlotNo
slotFromEpoch EpochNo
x | EpochNo
x <- [EpochNo
startEpoch forall a. Num a => a -> a -> a
+ EpochNo
1 .. EpochNo
startEpoch 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 MockCrypto 'BlockIssuer)
      selectNextSlotWithLeaderThisEpoch :: SlotNo
-> Maybe
     (SlotNo, ChainState era, AllIssuerKeys MockCrypto 'BlockIssuer)
selectNextSlotWithLeaderThisEpoch SlotNo
fromSlot =
        forall {a} {b} {c}. (a -> Maybe (b, c)) -> [a] -> Maybe (a, b, c)
findJust SlotNo
-> Maybe (ChainState era, AllIssuerKeys MockCrypto 'BlockIssuer)
selectLeaderForSlot [SlotNo
fromSlot .. SlotNo
toSlot]
        where
          currentEpoch :: EpochNo
currentEpoch = SlotNo -> EpochNo
epochFromSlotNo SlotNo
fromSlot
          toSlot :: SlotNo
toSlot = EpochNo -> SlotNo
slotFromEpoch (EpochNo
currentEpoch forall a. Num a => a -> a -> a
+ EpochNo
1) forall a. Num a => a -> a -> a
- SlotNo
1

          findJust :: (a -> Maybe (b, c)) -> [a] -> Maybe (a, b, c)
findJust a -> Maybe (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) -> 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 MockCrypto 'BlockIssuer)
      selectLeaderForSlot :: SlotNo
-> Maybe (ChainState era, AllIssuerKeys MockCrypto 'BlockIssuer)
selectLeaderForSlot SlotNo
slotNo =
        (ChainState era
chainSt,)
          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 (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 ->
              coerce :: forall a b. Coercible a b => a -> b
coerce
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find
                  ( \(AllIssuerKeys {VRFKeyPair MockCrypto
aikVrf :: forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf :: VRFKeyPair MockCrypto
aikVrf, KeyHash 'StakePool
aikColdKeyHash :: KeyHash 'StakePool
aikColdKeyHash :: forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash}) ->
                      KeyHash 'StakePool -> SignKeyVRF FakeVRF -> Bool
isLeader KeyHash 'StakePool
aikColdKeyHash (forall c. VRFKeyPair c -> SignKeyVRF (VRF c)
vrfSignKey VRFKeyPair MockCrypto
aikVrf)
                  )
                  [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools
            Just (ActiveSlot KeyHash 'Genesis
x) ->
              coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$
                forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'Genesis
x Map (KeyHash 'Genesis) GenDelegPair
cores
                  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \GenDelegPair
y -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (GenDelegPair -> KeyHash 'GenesisDelegate
genDelegKeyHash GenDelegPair
y) Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates
            Maybe OBftSlot
_ -> forall a. Maybe a
Nothing
        where
          chainSt :: ChainState era
chainSt = forall era.
(GetLedgerView era, ApplyBlock era) =>
SlotNo -> ChainState era -> ChainState era
tickChainState SlotNo
slotNo ChainState era
origChainState
          epochNonce :: Nonce
epochNonce = forall era. ChainState era -> Nonce
chainEpochNonce ChainState era
chainSt
          poolDistr :: Map (KeyHash 'StakePool) IndividualPoolStake
poolDistr = PoolDistr -> Map (KeyHash 'StakePool) IndividualPoolStake
unPoolDistr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> PoolDistr
nesPd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ChainState era -> NewEpochState era
chainNes forall a b. (a -> b) -> a -> b
$ ChainState era
chainSt
          dpstate :: CertState era
dpstate = (forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ChainState era -> NewEpochState era
chainNes) ChainState era
chainSt
          (GenDelegs Map (KeyHash 'Genesis) GenDelegPair
cores) = (forall era. DState era -> GenDelegs
dsGenDelegs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> DState era
certDState) CertState era
dpstate
          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 forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG
          d :: UnitInterval
d = (PParams era -> UnitInterval
getUnitInterval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ChainState era -> NewEpochState era
chainNes) ChainState era
chainSt

          isLeader :: KeyHash 'StakePool -> SignKeyVRF FakeVRF -> Bool
isLeader KeyHash 'StakePool
poolHash SignKeyVRF FakeVRF
vrfKey =
            let y :: CertifiedVRF (VRF MockCrypto) Seed
y = forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified @(VRF MockCrypto) () (Nonce -> SlotNo -> Nonce -> Seed
mkSeed Nonce
seedL SlotNo
slotNo Nonce
epochNonce) SignKeyVRF FakeVRF
vrfKey
                stake :: Rational
stake = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rational
0 IndividualPoolStake -> Rational
individualPoolStake forall a b. (a -> b) -> a -> b
$ 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 (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 -> forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderValue (forall v a. CertifiedVRF v a -> OutputVRF v
VRF.certifiedOutput CertifiedVRF (VRF MockCrypto) Seed
y) Rational
stake ActiveSlotCoeff
f
                  Just (ActiveSlot KeyHash 'Genesis
x) | forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'Genesis
x 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 :: NewEpochState era
chainNes :: forall era. ChainState era -> NewEpochState era
chainNes
    , Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue :: Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue :: forall era. ChainState era -> Map (KeyHash 'BlockIssuer) Word64
chainOCertIssue
    , Nonce
chainEpochNonce :: Nonce
chainEpochNonce :: forall era. ChainState era -> Nonce
chainEpochNonce
    , Nonce
chainEvolvingNonce :: forall era. ChainState era -> Nonce
chainEvolvingNonce :: Nonce
chainEvolvingNonce
    , Nonce
chainCandidateNonce :: forall era. ChainState era -> Nonce
chainCandidateNonce :: Nonce
chainCandidateNonce
    , Nonce
chainPrevEpochNonce :: forall era. ChainState era -> Nonce
chainPrevEpochNonce :: Nonce
chainPrevEpochNonce
    , WithOrigin LastAppliedBlock
chainLastAppliedBlock :: WithOrigin LastAppliedBlock
chainLastAppliedBlock :: forall era. ChainState era -> 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 :: LastAppliedBlock -> HashHeader
labHash :: HashHeader
labHash}) -> HashHeader -> Nonce
hashHeaderToNonce HashHeader
labHash
            }
        lv :: LedgerView
lv = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall era (m :: * -> *).
(GetLedgerView era, 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 forall a. Eq a => a -> a -> Bool
/= forall era. NewEpochState era -> EpochNo
nesEL NewEpochState era
chainNes
        ChainDepState {PrtclState
csProtocol :: PrtclState
csProtocol :: ChainDepState -> PrtclState
csProtocol, TicknState
csTickn :: TicknState
csTickn :: ChainDepState -> 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' = forall era.
ApplyBlock era =>
Globals -> NewEpochState era -> SlotNo -> NewEpochState era
applyTick 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
          }