{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

module Test.Cardano.Ledger.Shelley.Generator.Update (
  genPParams,
  genUpdate,
  genShelleyPParamsUpdate,
  genM,
  genDecentralisationParam,
) where

import Cardano.Ledger.BaseTypes (
  BoundedRational,
  EpochInterval (..),
  NonNegativeInterval,
  NonZero,
  Nonce (NeutralNonce),
  ProtVer (..),
  StrictMaybe (..),
  UnitInterval,
  Version,
  getVersion64,
  mkNonceFromNumber,
  mkVersion,
  mkVersion64,
  succVersion,
  unsafeNonZero,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Keys (
  GenDelegPair (..),
  GenDelegs (..),
  KeyHash,
  KeyRole (..),
  asWitness,
  hashKey,
 )
import Cardano.Ledger.Shelley.API (
  ProposedPPUpdates,
  Update,
 )
import Cardano.Ledger.Shelley.LedgerState (
  CertState,
  DState (..),
  UTxOState (..),
  dsGenDelegsL,
 )
import Cardano.Ledger.Shelley.PParams
import Cardano.Ledger.Slot (EpochNo (EpochNo), SlotNo)
import Cardano.Ledger.State (EraCertState (..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes)
import Data.Ratio (Ratio, (%))
import Data.Typeable (Typeable)
import Data.Word (Word16, Word32, Word64)
import GHC.Records
import GHC.Stack (HasCallStack)
import Lens.Micro
import Numeric.Natural (Natural)
import Test.Cardano.Ledger.Binary.Arbitrary (genVersion)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair, vKey)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Generator.Core (
  AllIssuerKeys (aikCold),
  genInteger,
  genNatural,
  genWord64,
  increasingProbabilityAt,
  tooLateInEpoch,
 )
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..))
import Test.Cardano.Ledger.Shelley.Utils (
  GenesisKeyPair,
  epochFromSlotNo,
  unsafeBoundRational,
 )
import Test.QuickCheck (Gen, choose, frequency)
import qualified Test.QuickCheck as QC

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

genRationalInThousands :: HasCallStack => Integer -> Integer -> Gen Rational
genRationalInThousands :: HasCallStack => Integer -> Integer -> Gen Rational
genRationalInThousands Integer
lower Integer
upper =
  (Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1000) (Integer -> Rational) -> Gen Integer -> Gen Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen Integer
genInteger Integer
lower Integer
upper

genIntervalInThousands ::
  (Typeable a, BoundedRational a, HasCallStack) => Integer -> Integer -> Gen a
genIntervalInThousands :: forall a.
(Typeable a, BoundedRational a, HasCallStack) =>
Integer -> Integer -> Gen a
genIntervalInThousands Integer
lower Integer
upper =
  Rational -> a
forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational (Rational -> a) -> Gen Rational -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Integer -> Integer -> Gen Rational
Integer -> Integer -> Gen Rational
genRationalInThousands Integer
lower Integer
upper

genPParams ::
  forall era.
  (EraPParams era, AtMostEra "Mary" era, AtMostEra "Alonzo" era) =>
  Constants ->
  Gen (PParams era)
genPParams :: forall era.
(EraPParams era, AtMostEra "Mary" era, AtMostEra "Alonzo" era) =>
Constants -> Gen (PParams era)
genPParams c :: Constants
c@Constants {Coin
maxMinFeeA :: Coin
maxMinFeeA :: Constants -> Coin
maxMinFeeA, Coin
maxMinFeeB :: Coin
maxMinFeeB :: Constants -> Coin
maxMinFeeB} = do
  let lowMajorPV :: Version
lowMajorPV = forall era. Era era => Version
eraProtVerLow @era
      highMajorPV :: Version
highMajorPV = forall era. Era era => Version
eraProtVerHigh @era
  minFeeA <- Integer -> Integer -> Gen Integer
genInteger Integer
0 (Coin -> Integer
unCoin Coin
maxMinFeeA)
  minFeeB <- genInteger 0 (unCoin maxMinFeeB)
  (maxBBSize, maxTxSize, maxBHSize) <- szGen
  keyDeposit <- genKeyDeposit
  poolDeposit <- genPoolDeposit
  eMax <- genEMax c
  nOpt <- genNOpt
  a0 <- genA0
  rho <- genRho
  tau <- genTau
  d <- genDecentralisationParam
  extraEntropy <- genExtraEntropy
  protocolVersion <- genProtocolVersion lowMajorPV highMajorPV
  minUTxOValue <- genMinUTxOValue
  minPoolCost <- genMinPoolCost
  pure $
    emptyPParams
      & ppMinFeeAL .~ Coin minFeeA
      & ppMinFeeBL .~ Coin minFeeB
      & ppMaxBBSizeL .~ maxBBSize
      & ppMaxTxSizeL .~ maxTxSize
      & ppMaxBHSizeL .~ maxBHSize
      & ppKeyDepositL .~ keyDeposit
      & ppPoolDepositL .~ poolDeposit
      & ppEMaxL .~ eMax
      & ppNOptL .~ nOpt
      & ppA0L .~ a0
      & ppRhoL .~ rho
      & ppTauL .~ tau
      & ppDL .~ d
      & ppExtraEntropyL .~ extraEntropy
      & ppProtocolVersionL .~ protocolVersion
      & ppMinUTxOValueL .~ minUTxOValue
      & ppMinPoolCostL .~ minPoolCost
  where
    szGen :: Gen (Word32, Word32, Word16)
    szGen :: Gen (Word32, Word32, Word16)
szGen = do
      blockBodySize <- (Word32, Word32) -> Gen Word32
forall a. Random a => (a, a) -> Gen a
choose (Word32
low, Word32
hi)
      (blockBodySize,,)
        <$> choose (blockBodySize, blockBodySize `div` 2)
        <*> choose (25000, maxBound :: Word16) -- Must stay in the range of Word16, but can't be too small

-- Note: we keep the lower bound high enough so that we can more likely
-- generate valid transactions and blocks
low, hi :: Word32
low :: Word32
low = Word32
70000 -- Using the EraGen machinery, we have found that at least one block had a size of 59271
hi :: Word32
hi = Word32
200000 -- This caused a rare, but annoying failure, Since these are arbitrary we set `low` to 70000

-- poolDeposit
-- NOTE: we need to keep these deposits small, otherwise
-- when we generate sequences of transactions we will bleed too
-- much funds into the deposit pool (i.e. funds not available as utxo)
genPoolDeposit :: HasCallStack => Gen Coin
genPoolDeposit :: HasCallStack => Gen Coin
genPoolDeposit =
  Gen Coin -> (Coin, Coin) -> Gen Coin
forall a. Gen a -> (a, a) -> Gen a
increasingProbabilityAt
    (Integer -> Coin
Coin (Integer -> Coin) -> Gen Integer -> Gen Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen Integer
genInteger Integer
0 Integer
100)
    (Integer -> Coin
Coin Integer
0, Integer -> Coin
Coin Integer
100)

-- Generates a Neutral or actual Nonces with equal frequency
genExtraEntropy :: HasCallStack => Gen Nonce
genExtraEntropy :: HasCallStack => Gen Nonce
genExtraEntropy =
  [(Int, Gen Nonce)] -> Gen Nonce
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
    [ (Int
1, Nonce -> Gen Nonce
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nonce
NeutralNonce)
    , (Int
1, Word64 -> Nonce
mkNonceFromNumber (Word64 -> Nonce) -> Gen Word64 -> Gen Nonce
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> Word64 -> Gen Word64
genWord64 Word64
1 Word64
123)
    ]

-- eMax (for an epoch per 5 days, say, this is between a month and 7yrs)
genEMax ::
  HasCallStack =>
  Constants ->
  Gen EpochInterval
genEMax :: HasCallStack => Constants -> Gen EpochInterval
genEMax Constants {Word64
frequencyLowMaxEpoch :: Word64
frequencyLowMaxEpoch :: Constants -> Word64
frequencyLowMaxEpoch} =
  Word32 -> EpochInterval
EpochInterval (Word32 -> EpochInterval)
-> (Word64 -> Word32) -> Word64 -> EpochInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> EpochInterval) -> Gen Word64 -> Gen EpochInterval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> Word64 -> Gen Word64
genWord64 Word64
frequencyLowMaxEpoch Word64
500

-- | nOpt
genNOpt :: HasCallStack => Gen Word16
genNOpt :: HasCallStack => Gen Word16
genNOpt = Natural -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Word16) -> Gen Natural -> Gen Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Natural -> Gen Natural
genNatural Natural
1 Natural
100

-- | genKeyDeposit
-- NOTE: we need to keep these deposits small, otherwise
-- when we generate sequences of transactions we will bleed too
-- much funds into the deposit pool (i.e. funds not available as utxo)
genKeyDeposit :: HasCallStack => Gen Coin
genKeyDeposit :: HasCallStack => Gen Coin
genKeyDeposit =
  Gen Coin -> (Coin, Coin) -> Gen Coin
forall a. Gen a -> (a, a) -> Gen a
increasingProbabilityAt
    (Integer -> Coin
Coin (Integer -> Coin) -> Gen Integer -> Gen Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen Integer
genInteger Integer
0 Integer
20)
    (Integer -> Coin
Coin Integer
0, Integer -> Coin
Coin Integer
20)

-- | a0: 0.01-1.0
genA0 :: HasCallStack => Gen NonNegativeInterval
genA0 :: HasCallStack => Gen NonNegativeInterval
genA0 = Integer -> Integer -> Gen NonNegativeInterval
forall a.
(Typeable a, BoundedRational a, HasCallStack) =>
Integer -> Integer -> Gen a
genIntervalInThousands Integer
10 Integer
1000

-- | rho: 0.001-0.009
genRho :: HasCallStack => Gen UnitInterval
genRho :: HasCallStack => Gen UnitInterval
genRho = Integer -> Integer -> Gen UnitInterval
forall a.
(Typeable a, BoundedRational a, HasCallStack) =>
Integer -> Integer -> Gen a
genIntervalInThousands Integer
1 Integer
9

-- | tau: 0.1-0.3
genTau :: HasCallStack => Gen UnitInterval
genTau :: HasCallStack => Gen UnitInterval
genTau = Integer -> Integer -> Gen UnitInterval
forall a.
(Typeable a, BoundedRational a, HasCallStack) =>
Integer -> Integer -> Gen a
genIntervalInThousands Integer
100 Integer
300

genDecentralisationParam :: HasCallStack => Gen UnitInterval
genDecentralisationParam :: HasCallStack => Gen UnitInterval
genDecentralisationParam = Rational -> UnitInterval
forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational (Rational -> UnitInterval) -> Gen Rational -> Gen UnitInterval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Rational] -> Gen Rational
forall a. HasCallStack => [a] -> Gen a
QC.elements [Rational
0.1, Rational
0.2 .. Rational
1]
-- ^ ^ TODO jc - generating d=0 takes some care, if there are no registered
--  stake pools then d=0 deadlocks the system.

genProtocolVersion :: HasCallStack => Version -> Version -> Gen ProtVer
genProtocolVersion :: HasCallStack => Version -> Version -> Gen ProtVer
genProtocolVersion Version
minMajPV Version
maxMajPV =
  Version -> Natural -> ProtVer
ProtVer (Version -> Natural -> ProtVer)
-> Gen Version -> Gen (Natural -> ProtVer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Version -> Version -> Gen Version
Version -> Version -> Gen Version
genVersion Version
minMajPV Version
maxMajPV Gen (Natural -> ProtVer) -> Gen Natural -> Gen ProtVer
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Natural -> Natural -> Gen Natural
genNatural Natural
1 Natural
50

genMinUTxOValue :: HasCallStack => Gen Coin
genMinUTxOValue :: HasCallStack => Gen Coin
genMinUTxOValue = Integer -> Coin
Coin (Integer -> Coin) -> Gen Integer -> Gen Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen Integer
genInteger Integer
1 Integer
20

genMinPoolCost :: HasCallStack => Gen Coin
genMinPoolCost :: HasCallStack => Gen Coin
genMinPoolCost = Integer -> Coin
Coin (Integer -> Coin) -> Gen Integer -> Gen Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen Integer
genInteger Integer
10 Integer
50

-- | Generate a possible next Protocol version based on the previous version.
-- Increments the Major or Minor versions and possibly the Alt version.
genNextProtocolVersion :: EraPParams era => HasCallStack => PParams era -> Version -> Gen ProtVer
genNextProtocolVersion :: forall era.
(EraPParams era, HasCallStack) =>
PParams era -> Version -> Gen ProtVer
genNextProtocolVersion PParams era
pp Version
maxMajorPV = do
  [ProtVer] -> Gen ProtVer
forall a. HasCallStack => [a] -> Gen a
QC.elements ([ProtVer] -> Gen ProtVer) -> [ProtVer] -> Gen ProtVer
forall a b. (a -> b) -> a -> b
$ Version -> Natural -> ProtVer
ProtVer Version
m (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1) ProtVer -> [ProtVer] -> [ProtVer]
forall a. a -> [a] -> [a]
: [Version -> Natural -> ProtVer
ProtVer Version
m' Natural
0 | Just Version
m' <- [Version -> Maybe Version
forall (m :: * -> *). MonadFail m => Version -> m Version
succVersion Version
m], Version
m' Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
<= Version
maxMajorPV]
  where
    ProtVer Version
m Natural
n = PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL

genM :: Gen a -> Gen (StrictMaybe a)
genM :: forall a. Gen a -> Gen (StrictMaybe a)
genM Gen a
gen = [(Int, Gen (StrictMaybe a))] -> Gen (StrictMaybe a)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
1, a -> StrictMaybe a
forall a. a -> StrictMaybe a
SJust (a -> StrictMaybe a) -> Gen a -> Gen (StrictMaybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
gen), (Int
2, StrictMaybe a -> Gen (StrictMaybe a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe a
forall a. StrictMaybe a
SNothing)]

-- | This is only good in the Shelley Era, used to define the genShelleyEraPParamsUpdate method for (EraGen (ShelleyEra c))
genShelleyPParamsUpdate ::
  forall era.
  (AtMostEra "Mary" era, AtMostEra "Alonzo" era, AtMostEra "Babbage" era, EraPParams era) =>
  Constants ->
  PParams era ->
  Gen (PParamsUpdate era)
genShelleyPParamsUpdate :: forall era.
(AtMostEra "Mary" era, AtMostEra "Alonzo" era,
 AtMostEra "Babbage" era, EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate c :: Constants
c@Constants {Coin
maxMinFeeA :: Constants -> Coin
maxMinFeeA :: Coin
maxMinFeeA, Coin
maxMinFeeB :: Constants -> Coin
maxMinFeeB :: Coin
maxMinFeeB} PParams era
pp = do
  let highMajorPV :: Version
highMajorPV = Version -> Version
forall a. Enum a => a -> a
succ (forall era. Era era => Version
eraProtVerHigh @era)
  -- TODO generate Maybe types so not all updates are full
  minFeeA <- Gen Integer -> Gen (StrictMaybe Integer)
forall a. Gen a -> Gen (StrictMaybe a)
genM (Gen Integer -> Gen (StrictMaybe Integer))
-> Gen Integer -> Gen (StrictMaybe Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Gen Integer
genInteger Integer
0 (Coin -> Integer
unCoin Coin
maxMinFeeA)
  minFeeB <- genM $ genInteger 0 (unCoin maxMinFeeB)
  maxBBSize <- genM $ choose (low, hi)
  maxTxSize <- genM $ choose (low, hi)
  -- Must stay in the range of Word16, but can't be too small
  maxBHSize <- genM $ choose (25000, maxBound :: Word16)
  keyDeposit <- genM $ genKeyDeposit
  poolDeposit <- genM $ genPoolDeposit
  eMax <- genM $ genEMax c
  nOpt <- genM genNOpt
  a0 <- genM genA0
  rho <- genM genRho
  tau <- genM genTau
  d <- genM genDecentralisationParam
  extraEntropy <- genM genExtraEntropy
  protocolVersion <- genM $ genNextProtocolVersion pp highMajorPV
  minUTxOValue <- genM genMinUTxOValue
  minPoolCost <- genM genMinPoolCost
  pure $
    emptyPParamsUpdate
      & ppuMinFeeAL .~ fmap Coin minFeeA
      & ppuMinFeeBL .~ fmap Coin minFeeB
      & ppuMaxBBSizeL .~ maxBBSize
      & ppuMaxTxSizeL .~ maxTxSize
      & ppuMaxBHSizeL .~ maxBHSize
      & ppuKeyDepositL .~ keyDeposit
      & ppuPoolDepositL .~ poolDeposit
      & ppuEMaxL .~ eMax
      & ppuNOptL .~ nOpt
      & ppuA0L .~ a0
      & ppuRhoL .~ rho
      & ppuTauL .~ tau
      & ppuDL .~ d
      & ppuExtraEntropyL .~ extraEntropy
      & ppuProtocolVersionL .~ protocolVersion
      & ppuMinUTxOValueL .~ minUTxOValue
      & ppuMinPoolCostL .~ minPoolCost

-- | Generate a proposal for protocol parameter updates for all the given genesis keys.
-- Return an empty update if it is too late in the epoch for updates.
genPPUpdate ::
  forall era.
  EraGen era =>
  Constants ->
  PParams era ->
  [KeyHash GenesisRole] ->
  Gen (ProposedPPUpdates era)
genPPUpdate :: forall era.
EraGen era =>
Constants
-> PParams era
-> [KeyHash GenesisRole]
-> Gen (ProposedPPUpdates era)
genPPUpdate Constants
constants PParams era
pp [KeyHash GenesisRole]
genesisKeys = do
  pps <- forall era.
EraGen era =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genEraPParamsUpdate @era Constants
constants PParams era
pp
  let ppUpdate = [KeyHash GenesisRole]
-> [PParamsUpdate era]
-> [(KeyHash GenesisRole, PParamsUpdate era)]
forall a b. [a] -> [b] -> [(a, b)]
zip [KeyHash GenesisRole]
genesisKeys (PParamsUpdate era -> [PParamsUpdate era]
forall a. a -> [a]
repeat PParamsUpdate era
pps)
  pure $ ProposedPPUpdates . Map.fromList $ ppUpdate

-- | Generate an @Update (where all the given nodes participate)
genUpdateForNodes ::
  forall era.
  EraGen era =>
  Constants ->
  SlotNo ->
  EpochNo -> -- current epoch
  [KeyPair GenesisRole] ->
  PParams era ->
  Gen (Maybe (Update era))
genUpdateForNodes :: forall era.
EraGen era =>
Constants
-> SlotNo
-> EpochNo
-> [KeyPair GenesisRole]
-> PParams era
-> Gen (Maybe (Update era))
genUpdateForNodes Constants
c SlotNo
s EpochNo
e [KeyPair GenesisRole]
coreKeys PParams era
pp =
  Update era -> Maybe (Update era)
forall a. a -> Maybe a
Just (Update era -> Maybe (Update era))
-> Gen (Update era) -> Gen (Maybe (Update era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProposedPPUpdates era -> EpochNo -> Update era
forall era. ProposedPPUpdates era -> EpochNo -> Update era
Update (ProposedPPUpdates era -> EpochNo -> Update era)
-> Gen (ProposedPPUpdates era) -> Gen (EpochNo -> Update era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (ProposedPPUpdates era)
genPPUpdate_ Gen (EpochNo -> Update era) -> Gen EpochNo -> Gen (Update era)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EpochNo -> Gen EpochNo
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochNo
e')
  where
    genesisKeys :: [KeyHash GenesisRole]
genesisKeys = VKey GenesisRole -> KeyHash GenesisRole
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey GenesisRole -> KeyHash GenesisRole)
-> (KeyPair GenesisRole -> VKey GenesisRole)
-> KeyPair GenesisRole
-> KeyHash GenesisRole
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair GenesisRole -> VKey GenesisRole
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair GenesisRole -> KeyHash GenesisRole)
-> [KeyPair GenesisRole] -> [KeyHash GenesisRole]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyPair GenesisRole]
coreKeys
    genPPUpdate_ :: Gen (ProposedPPUpdates era)
genPPUpdate_ = Constants
-> PParams era
-> [KeyHash GenesisRole]
-> Gen (ProposedPPUpdates era)
forall era.
EraGen era =>
Constants
-> PParams era
-> [KeyHash GenesisRole]
-> Gen (ProposedPPUpdates era)
genPPUpdate Constants
c PParams era
pp [KeyHash GenesisRole]
genesisKeys
    e' :: EpochNo
e' = if SlotNo -> Bool
tooLateInEpoch SlotNo
s then EpochNo
e EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1 else EpochNo
e

-- | Occasionally generate an update and return with the witness keys
genUpdate ::
  EraGen era =>
  Constants ->
  SlotNo ->
  [(GenesisKeyPair c, AllIssuerKeys c GenesisDelegate)] ->
  Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate) ->
  PParams era ->
  (UTxOState era, CertState era) ->
  Gen (Maybe (Update era), [KeyPair Witness])
genUpdate :: forall era c.
EraGen era =>
Constants
-> SlotNo
-> [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> (UTxOState era, CertState era)
-> Gen (Maybe (Update era), [KeyPair Witness])
genUpdate
  c :: Constants
c@Constants {Int
frequencyTxUpdates :: Int
frequencyTxUpdates :: Constants -> Int
frequencyTxUpdates}
  SlotNo
s
  [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
coreNodes
  Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
genesisDelegatesByHash
  PParams era
pp
  (UTxOState era
_utxoSt, CertState era
delegPoolSt) =
    do
      nodes <- Int
-> [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
-> [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
forall a. Int -> [a] -> [a]
take Int
5 ([(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
 -> [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)])
-> Gen [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
-> Gen [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
-> Gen [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
forall a. [a] -> Gen [a]
QC.shuffle [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
coreNodes

      let e = SlotNo -> EpochNo
epochFromSlotNo SlotNo
s
          GenDelegs genDelegs = delegPoolSt ^. certDStateL . dsGenDelegsL
          genesisKeys = (KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)
-> KeyPair GenesisRole
forall a b. (a, b) -> a
fst ((KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)
 -> KeyPair GenesisRole)
-> [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
-> [KeyPair GenesisRole]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
nodes
          coreSigners =
            [Maybe (AllIssuerKeys c GenesisDelegate)]
-> [AllIssuerKeys c GenesisDelegate]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (AllIssuerKeys c GenesisDelegate)]
 -> [AllIssuerKeys c GenesisDelegate])
-> [Maybe (AllIssuerKeys c GenesisDelegate)]
-> [AllIssuerKeys c GenesisDelegate]
forall a b. (a -> b) -> a -> b
$
              (KeyHash GenesisDelegate
 -> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
 -> Maybe (AllIssuerKeys c GenesisDelegate))
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> KeyHash GenesisDelegate
-> Maybe (AllIssuerKeys c GenesisDelegate)
forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
genesisDelegatesByHash (KeyHash GenesisDelegate
 -> Maybe (AllIssuerKeys c GenesisDelegate))
-> (GenDelegPair -> KeyHash GenesisDelegate)
-> GenDelegPair
-> Maybe (AllIssuerKeys c GenesisDelegate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenDelegPair -> KeyHash GenesisDelegate
genDelegKeyHash (GenDelegPair -> Maybe (AllIssuerKeys c GenesisDelegate))
-> [GenDelegPair] -> [Maybe (AllIssuerKeys c GenesisDelegate)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (KeyHash GenesisRole) GenDelegPair -> [GenDelegPair]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash GenesisRole) GenDelegPair
genDelegs
          failedWitnessLookup = [AllIssuerKeys c GenesisDelegate] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AllIssuerKeys c GenesisDelegate]
coreSigners Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Map (KeyHash GenesisRole) GenDelegPair -> Int
forall k a. Map k a -> Int
Map.size Map (KeyHash GenesisRole) GenDelegPair
genDelegs
      if failedWitnessLookup
        then -- discard
          pure (Nothing, [])
        else
          let wits = KeyPair GenesisDelegate -> KeyPair Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a Witness
asWitness (KeyPair GenesisDelegate -> KeyPair Witness)
-> (AllIssuerKeys c GenesisDelegate -> KeyPair GenesisDelegate)
-> AllIssuerKeys c GenesisDelegate
-> KeyPair Witness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllIssuerKeys c GenesisDelegate -> KeyPair GenesisDelegate
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold (AllIssuerKeys c GenesisDelegate -> KeyPair Witness)
-> [AllIssuerKeys c GenesisDelegate] -> [KeyPair Witness]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AllIssuerKeys c GenesisDelegate]
coreSigners
           in QC.frequency
                [
                  ( frequencyTxUpdates
                  , (,wits) <$> genUpdateForNodes c s e genesisKeys pp
                  )
                ,
                  ( 100 - frequencyTxUpdates
                  , pure (Nothing, [])
                  )
                ]