{-# 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.Crypto (VRF)
import Cardano.Ledger.Shelley.API hiding (vKey)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL)
import Cardano.Ledger.Slot (SlotNo (..))
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 (
  Mock,
 )
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
  , Mock (EraCrypto era)
  , GetLedgerView era
  , QC.HasTrace (EraRule "LEDGERS" era) (GenEnv era)
  , EraGen era
  ) =>
  GenEnv era ->
  ChainState era ->
  Gen (Block (BHeader (EraCrypto era)) era)
genBlock :: forall era.
(MinLEDGER_STS era, ApplyBlock era, Mock (EraCrypto era),
 GetLedgerView era, HasTrace (EraRule "LEDGERS" era) (GenEnv era),
 EraGen era) =>
GenEnv era
-> ChainState era -> Gen (Block (BHeader (EraCrypto era)) era)
genBlock GenEnv era
ge = forall era.
(Mock (EraCrypto era), GetLedgerView era, ApplyBlock era,
 EraGen era) =>
TxGen era
-> GenEnv era
-> ChainState era
-> Gen (Block (BHeader (EraCrypto era)) 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 -> PParams era -> AccountState -> ShelleyLedgersEnv era
LedgersEnv @era 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.
  ( Mock (EraCrypto era)
  , GetLedgerView era
  , ApplyBlock era
  , EraGen era
  ) =>
  TxGen era ->
  GenEnv era ->
  ChainState era ->
  Gen (Block (BHeader (EraCrypto era)) era)
genBlockWithTxGen :: forall era.
(Mock (EraCrypto era), GetLedgerView era, ApplyBlock era,
 EraGen era) =>
TxGen era
-> GenEnv era
-> ChainState era
-> Gen (Block (BHeader (EraCrypto era)) era)
genBlockWithTxGen
  TxGen era
genTxs
  ge :: GenEnv era
ge@(GenEnv KeySpace_ {[AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools :: forall era.
KeySpace era -> [AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools :: [AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools, Map
  (KeyHash 'GenesisDelegate (EraCrypto era))
  (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates :: forall era.
KeySpace era
-> Map
     (KeyHash 'GenesisDelegate (EraCrypto era))
     (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates :: Map
  (KeyHash 'GenesisDelegate (EraCrypto era))
  (AllIssuerKeys (EraCrypto era) '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 (EraCrypto era) 'BlockIssuer
issuerKeys) =
          forall a. a -> Maybe a -> a
fromMaybe
            (forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot find a slot to create a block in")
            forall a b. (a -> b) -> a -> b
$ forall era.
(Mock (EraCrypto era), EraGen era, GetLedgerView era,
 ApplyBlock era) =>
GenEnv era
-> ChainState era
-> SlotNo
-> Maybe
     (SlotNo, ChainState era,
      AllIssuerKeys (EraCrypto era) '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 (EraCrypto era)
_ BlocksMade (EraCrypto era)
_ EpochState era
es StrictMaybe (PulsingRewUpdate (EraCrypto era))
_ PoolDistr (EraCrypto era)
_ StashedAVVMAddresses era
_ = forall era. ChainState era -> NewEpochState era
chainNes ChainState era
chainSt
        EpochState AccountState
acnt LedgerState era
ls SnapShots (EraCrypto era)
_ NonMyopic (EraCrypto era)
_ = 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 (EraCrypto era)) Word64
cs = forall era.
ChainState era -> Map (KeyHash 'BlockIssuer (EraCrypto era)) Word64
chainOCertIssue ChainState era
chainSt
        m :: Integer
m = forall h (r :: KeyRole). AllIssuerKeys h r -> KESPeriod -> Integer
getKESPeriodRenewalNo AllIssuerKeys (EraCrypto era) 'BlockIssuer
issuerKeys KESPeriod
kp
        hotKeys :: NonEmpty (KESPeriod, KESKeyPair (EraCrypto era))
hotKeys =
          forall a. a -> Maybe a -> a
fromMaybe
            ( forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
                [Char]
"No more hot keys left. Tried dropping "
                  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
m
                  forall a. [a] -> [a] -> [a]
++ [Char]
" from: "
                  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall v (r :: KeyRole).
AllIssuerKeys v r -> NonEmpty (KESPeriod, KESKeyPair v)
aikHot AllIssuerKeys (EraCrypto era) '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 v (r :: KeyRole).
AllIssuerKeys v r -> NonEmpty (KESPeriod, KESKeyPair v)
aikHot AllIssuerKeys (EraCrypto era) 'BlockIssuer
issuerKeys))
        keys :: AllIssuerKeys (EraCrypto era) 'BlockIssuer
keys = AllIssuerKeys (EraCrypto era) 'BlockIssuer
issuerKeys {aikHot :: NonEmpty (KESPeriod, KESKeyPair (EraCrypto era))
aikHot = NonEmpty (KESPeriod, KESKeyPair (EraCrypto era))
hotKeys}

        -- And issue a new ocert
        n' :: Maybe Word64
n' =
          forall c.
OCertEnv c
-> Map (KeyHash 'BlockIssuer c) Word64
-> KeyHash 'BlockIssuer c
-> Maybe Word64
currentIssueNo
            ( forall c.
Set (KeyHash 'StakePool c)
-> Set (KeyHash 'GenesisDelegate c) -> OCertEnv c
OCertEnv
                (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AllIssuerKeys (EraCrypto era) '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 (EraCrypto era))
  (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates))
            )
            Map (KeyHash 'BlockIssuer (EraCrypto era)) Word64
cs
            (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall a b. (a -> b) -> a -> b
$ forall v (r :: KeyRole). AllIssuerKeys v r -> KeyPair r v
aikCold AllIssuerKeys (EraCrypto era) '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 => [Char] -> a
error [Char]
"no issue number available"
            else forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
m
        oCert :: OCert (EraCrypto era)
oCert = forall c (r :: KeyRole).
(Crypto c, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys (EraCrypto era) '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 (EraCrypto era))
hotKeys)
    Block (BHeader (EraCrypto era)) era
theBlock <-
      forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) Seed,
 Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> Word
-> Word
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlock
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure HashHeader (EraCrypto era)
hashheader
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure AllIssuerKeys (EraCrypto era) '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 (EraCrypto era)
oCert
    let hView :: BHeaderView (EraCrypto era)
hView = forall c. Crypto c => BHeader c -> BHeaderView c
makeHeaderView (forall h era. Block h era -> h
bheader Block (BHeader (EraCrypto era)) era
theBlock)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall c. BHeaderView c -> Word32
bhviewBSize BHeaderView (EraCrypto era)
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. [Char] -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$
        [Char]
"genBlockWithTxGen: bhviewBSize too large"
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall c. BHeaderView c -> Word32
bhviewBSize BHeaderView (EraCrypto era)
hView)
          forall a. Semigroup a => a -> a -> a
<> [Char]
" vs "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
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 (forall c. BHeaderView c -> Int
bhviewHSize BHeaderView (EraCrypto era)
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. [Char] -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$
        [Char]
"genBlockWithTxGen: bhviewHSize too large"
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall c. BHeaderView c -> Int
bhviewHSize BHeaderView (EraCrypto era)
hView)
          forall a. Semigroup a => a -> a -> a
<> [Char]
" vs "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
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 (EraCrypto era)) 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 (EraCrypto era)
hashheader) = case forall era.
ChainState era -> WithOrigin (LastAppliedBlock (EraCrypto era))
chainLastAppliedBlock ChainState era
origChainState of
        WithOrigin (LastAppliedBlock (EraCrypto era))
Origin -> forall a. HasCallStack => [Char] -> a
error [Char]
"block generator does not support from Origin"
        At (LastAppliedBlock BlockNo
b SlotNo
s HashHeader (EraCrypto era)
hh) -> (BlockNo
b, SlotNo
s, HashHeader (EraCrypto era)
hh)

selectNextSlotWithLeader ::
  forall era.
  ( Mock (EraCrypto era)
  , EraGen era
  , GetLedgerView era
  , ApplyBlock era
  ) =>
  GenEnv era ->
  ChainState era ->
  -- Starting slot
  SlotNo ->
  Maybe (SlotNo, ChainState era, AllIssuerKeys (EraCrypto era) 'BlockIssuer)
selectNextSlotWithLeader :: forall era.
(Mock (EraCrypto era), EraGen era, GetLedgerView era,
 ApplyBlock era) =>
GenEnv era
-> ChainState era
-> SlotNo
-> Maybe
     (SlotNo, ChainState era,
      AllIssuerKeys (EraCrypto era) 'BlockIssuer)
selectNextSlotWithLeader
  (GenEnv KeySpace_ {[AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools :: [AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools :: forall era.
KeySpace era -> [AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools, Map
  (KeyHash 'GenesisDelegate (EraCrypto era))
  (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates :: Map
  (KeyHash 'GenesisDelegate (EraCrypto era))
  (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates :: forall era.
KeySpace era
-> Map
     (KeyHash 'GenesisDelegate (EraCrypto era))
     (AllIssuerKeys (EraCrypto era) '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 (EraCrypto era) '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 (EraCrypto era) 'BlockIssuer)
      selectNextSlotWithLeaderThisEpoch :: SlotNo
-> Maybe
     (SlotNo, ChainState era,
      AllIssuerKeys (EraCrypto era) 'BlockIssuer)
selectNextSlotWithLeaderThisEpoch SlotNo
fromSlot =
        forall {a} {b} {c}. (a -> Maybe (b, c)) -> [a] -> Maybe (a, b, c)
findJust SlotNo
-> Maybe
     (ChainState era, AllIssuerKeys (EraCrypto era) '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 (EraCrypto era) 'BlockIssuer)
      selectLeaderForSlot :: SlotNo
-> Maybe
     (ChainState era, AllIssuerKeys (EraCrypto era) 'BlockIssuer)
selectLeaderForSlot SlotNo
slotNo =
        (ChainState era
chainSt,)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case forall c.
SlotNo
-> Set (KeyHash 'Genesis c)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe (OBftSlot c)
lookupInOverlaySchedule SlotNo
firstEpochSlot (forall k a. Map k a -> Set k
Map.keysSet Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
cores) UnitInterval
d ActiveSlotCoeff
f SlotNo
slotNo of
            Maybe (OBftSlot (EraCrypto era))
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 (EraCrypto era)
aikVrf :: forall v (r :: KeyRole). AllIssuerKeys v r -> VRFKeyPair v
aikVrf :: VRFKeyPair (EraCrypto era)
aikVrf, KeyHash 'StakePool (EraCrypto era)
aikColdKeyHash :: KeyHash 'StakePool (EraCrypto era)
aikColdKeyHash :: forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash}) ->
                      KeyHash 'StakePool (EraCrypto era)
-> SignKeyVRF (VRF (EraCrypto era)) -> Bool
isLeader KeyHash 'StakePool (EraCrypto era)
aikColdKeyHash (forall c. VRFKeyPair c -> SignKeyVRF c
vrfSignKey VRFKeyPair (EraCrypto era)
aikVrf)
                  )
                  [AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools
            Just (ActiveSlot KeyHash 'Genesis (EraCrypto era)
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 (EraCrypto era)
x Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
cores
                  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \GenDelegPair (EraCrypto era)
y -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall c. GenDelegPair c -> KeyHash 'GenesisDelegate c
genDelegKeyHash GenDelegPair (EraCrypto era)
y) Map
  (KeyHash 'GenesisDelegate (EraCrypto era))
  (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates
            Maybe (OBftSlot (EraCrypto era))
_ -> 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 (EraCrypto era))
  (IndividualPoolStake (EraCrypto era))
poolDistr = forall c.
PoolDistr c -> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
unPoolDistr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> PoolDistr (EraCrypto era)
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 (EraCrypto era)) (GenDelegPair (EraCrypto era))
cores) = (forall era. DState era -> GenDelegs (EraCrypto era)
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 (EraCrypto era)
-> SignKeyVRF (VRF (EraCrypto era)) -> Bool
isLeader KeyHash 'StakePool (EraCrypto era)
poolHash SignKeyVRF (VRF (EraCrypto era))
vrfKey =
            let y :: CertifiedVRF (VRF (EraCrypto era)) Seed
y = forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified @(VRF (EraCrypto era)) () (Nonce -> SlotNo -> Nonce -> Seed
mkSeed Nonce
seedL SlotNo
slotNo Nonce
epochNonce) SignKeyVRF (VRF (EraCrypto era))
vrfKey
                stake :: Rational
stake = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rational
0 forall c. IndividualPoolStake c -> Rational
individualPoolStake forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool (EraCrypto era)
poolHash Map
  (KeyHash 'StakePool (EraCrypto era))
  (IndividualPoolStake (EraCrypto era))
poolDistr
             in case forall c.
SlotNo
-> Set (KeyHash 'Genesis c)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe (OBftSlot c)
lookupInOverlaySchedule SlotNo
firstEpochSlot (forall k a. Map k a -> Set k
Map.keysSet Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
cores) UnitInterval
d ActiveSlotCoeff
f SlotNo
slotNo of
                  Maybe (OBftSlot (EraCrypto era))
Nothing -> forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderValue (forall v a. CertifiedVRF v a -> OutputVRF v
VRF.certifiedOutput CertifiedVRF (VRF (EraCrypto era)) Seed
y) Rational
stake ActiveSlotCoeff
f
                  Just (ActiveSlot KeyHash 'Genesis (EraCrypto era)
x) | forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole KeyHash 'Genesis (EraCrypto era)
x forall a. Eq a => a -> a -> Bool
== KeyHash 'StakePool (EraCrypto era)
poolHash -> Bool
True
                  Maybe (OBftSlot (EraCrypto era))
_ -> 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 (EraCrypto era)) Word64
chainOCertIssue :: Map (KeyHash 'BlockIssuer (EraCrypto era)) Word64
chainOCertIssue :: forall era.
ChainState era -> Map (KeyHash 'BlockIssuer (EraCrypto era)) 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 (EraCrypto era))
chainLastAppliedBlock :: WithOrigin (LastAppliedBlock (EraCrypto era))
chainLastAppliedBlock :: forall era.
ChainState era -> WithOrigin (LastAppliedBlock (EraCrypto era))
chainLastAppliedBlock
    } =
    let cds :: ChainDepState (EraCrypto era)
cds =
          ChainDepState
            { csProtocol :: PrtclState (EraCrypto era)
csProtocol = forall c.
Map (KeyHash 'BlockIssuer c) Word64
-> Nonce -> Nonce -> PrtclState c
PrtclState Map (KeyHash 'BlockIssuer (EraCrypto era)) Word64
chainOCertIssue Nonce
chainEvolvingNonce Nonce
chainCandidateNonce
            , csTickn :: TicknState
csTickn = Nonce -> Nonce -> TicknState
TicknState Nonce
chainEpochNonce Nonce
chainPrevEpochNonce
            , csLabNonce :: Nonce
csLabNonce = case WithOrigin (LastAppliedBlock (EraCrypto era))
chainLastAppliedBlock of
                WithOrigin (LastAppliedBlock (EraCrypto era))
Origin -> Nonce
NeutralNonce
                At (LastAppliedBlock {HashHeader (EraCrypto era)
labHash :: forall c. LastAppliedBlock c -> HashHeader c
labHash :: HashHeader (EraCrypto era)
labHash}) -> forall c. HashHeader c -> Nonce
hashHeaderToNonce HashHeader (EraCrypto era)
labHash
            }
        lv :: LedgerView (EraCrypto era)
lv = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
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 (EraCrypto era))
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 (EraCrypto era)
csProtocol :: PrtclState (EraCrypto era)
csProtocol :: forall c. ChainDepState c -> PrtclState c
csProtocol, TicknState
csTickn :: TicknState
csTickn :: forall c. ChainDepState c -> TicknState
csTickn} =
          forall c.
Globals
-> LedgerView c -> Bool -> ChainDepState c -> ChainDepState c
tickChainDepState Globals
testGlobals LedgerView (EraCrypto era)
lv Bool
isNewEpoch ChainDepState (EraCrypto era)
cds
        PrtclState Map (KeyHash 'BlockIssuer (EraCrypto era)) Word64
ocertIssue Nonce
evNonce Nonce
candNonce = PrtclState (EraCrypto era)
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 (EraCrypto era)) Word64
chainOCertIssue = Map (KeyHash 'BlockIssuer (EraCrypto era)) 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 (EraCrypto era))
chainLastAppliedBlock = WithOrigin (LastAppliedBlock (EraCrypto era))
chainLastAppliedBlock
          }