{-# 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 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 TopTx 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
      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
      genEraTweakBlock @era pp 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
    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 (nextSlot, chainSt, issuerKeys) =
          fromMaybe
            (error "Cannot find a slot to create a block in")
            $ selectNextSlotWithLeader ge origChainState firstConsideredSlot

    -- Now we need to compute the KES period and get the set of hot keys.
    let NewEpochState _ _ _ es _ _ _ = chainNes chainSt
        EpochState acnt ls _ _ = es
        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 kesPeriod_) = runShelleyBase $ kesPeriod nextSlot
        cs = ChainState era -> Map (KeyHash BlockIssuer) Word64
forall era. ChainState era -> Map (KeyHash BlockIssuer) Word64
chainOCertIssue ChainState era
chainSt
        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)
-> 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
issuerKeys {aikHot = hotKeys}

        -- And issue a new ocert
        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)
                (Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> Set (KeyHash GenesisDelegate)
forall k a. Map k a -> Set k
Map.keysSet 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 =
          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 = 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)
    theBlock <-
      mkBlock
        <$> pure hashheader
        <*> pure keys
        <*> toList
        <$> genTxs pp acnt ls nextSlot
        <*> pure nextSlot
        <*> pure (block + 1)
        <*> pure (chainEpochNonce chainSt)
        <*> pure 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.
        <*> pure (fromIntegral (m * fromIntegral maxKESIterations))
        <*> pure oCert
    let 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
blockHeader Block (BHeader c) era
theBlock)
    unless (bhviewBSize hView <= pp ^. ppMaxBBSizeL) $
      tracedDiscard $
        "genBlockWithTxGen: bhviewBSize too large"
          <> show (bhviewBSize hView)
          <> " vs "
          <> show (pp ^. ppMaxBBSizeL)
    unless (bhviewHSize hView <= fromIntegral (pp ^. ppMaxBHSizeL)) $
      tracedDiscard $
        "genBlockWithTxGen: bhviewHSize too large"
          <> show (bhviewHSize hView)
          <> " vs "
          <> show (pp ^. ppMaxBHSizeL)
    pure 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 GenesisRole)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe OBftSlot
lookupInOverlaySchedule SlotNo
firstEpochSlot (Map (KeyHash GenesisRole) GenDelegPair -> Set (KeyHash GenesisRole)
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash GenesisRole) 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 GenesisRole
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 GenesisRole
-> Map (KeyHash GenesisRole) GenDelegPair -> Maybe GenDelegPair
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash GenesisRole
x Map (KeyHash GenesisRole) 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 GenesisRole) 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 GenesisRole)
-> UnitInterval
-> ActiveSlotCoeff
-> SlotNo
-> Maybe OBftSlot
lookupInOverlaySchedule SlotNo
firstEpochSlot (Map (KeyHash GenesisRole) GenDelegPair -> Set (KeyHash GenesisRole)
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash GenesisRole) 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 GenesisRole
x) | KeyHash GenesisRole -> 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 GenesisRole
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
          }