{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Test.Cardano.Ledger.Shelley.Generator.TxCert (
  genTxCert,
  CertCred (..),
) where

import Cardano.Ledger.Address (RewardAccount (..))
import Cardano.Ledger.Coin (DeltaCoin (..), toDeltaCoin)
import Cardano.Ledger.Keys (coerceKeyRole)
import Cardano.Ledger.Shelley (hardforkAlonzoAllowMIRTransfer)
import Cardano.Ledger.Shelley.API (
  Coin (..),
  Credential (..),
  GenDelegPair (..),
  GenDelegs (..),
  Network (..),
  StrictMaybe (..),
  VKey,
 )
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (availableAfterMIR)
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Slot (EpochNo (EpochNo), SlotNo)
import Cardano.Protocol.Crypto (Crypto, hashVerKeyVRF)
import Control.Monad (replicateM)
import Data.Foldable (fold)
import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Ratio ((%))
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Lens.Micro ((^.))
import Numeric.Natural (Natural)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair, KeyPairs, vKey)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Generator.Core (
  AllIssuerKeys (..),
  KeySpace (..),
  genInteger,
  genWord64,
  mkCredential,
  tooLateInEpoch,
 )
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen)
import Test.Cardano.Ledger.Shelley.Utils
import Test.Cardano.Protocol.TPraos.Create (VRFKeyPair (..))
import Test.QuickCheck (Gen)
import qualified Test.QuickCheck as QC

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

data CertCred era
  = CoreKeyCred [GenesisKeyPair MockCrypto]
  | StakeCred (KeyPair Staking)
  | PoolCred (KeyPair StakePool)
  | ScriptCred (Script era, Script era)
  | DelegateCred [KeyPair GenesisDelegate]
  | NoCred

deriving instance (Era era, Show (Script era)) => Show (CertCred era)

-- | Occasionally generate a valid certificate
--
-- Returning `Nothing` indicates a failure to generate a value, usually due to lack of
-- available values from the pre-populated (e.g. key) spaces.
-- A `Just` represents a successfully generated value.
--
-- Different generators return witnesses that are either genesis or regular keys.
--
-- Note: we register keys and pools more often than deregistering/retiring them,
-- and we generate more delegations than registrations of keys/pools.
genTxCert ::
  forall era c.
  (EraGen era, AtMostEra "Babbage" era, EraCertState era, Crypto c) =>
  Constants ->
  KeySpace c era ->
  PParams era ->
  ChainAccountState ->
  CertState era ->
  SlotNo ->
  Gen (Maybe (TxCert era, CertCred era))
genTxCert :: forall era c.
(EraGen era, AtMostEra "Babbage" era, EraCertState era,
 Crypto c) =>
Constants
-> KeySpace c era
-> PParams era
-> ChainAccountState
-> CertState era
-> SlotNo
-> Gen (Maybe (TxCert era, CertCred era))
genTxCert
  c :: Constants
c@( Constants
        { Int
frequencyRegCert :: Int
frequencyRegCert :: Constants -> Int
frequencyRegCert
        , Int
frequencyRegPoolCert :: Int
frequencyRegPoolCert :: Constants -> Int
frequencyRegPoolCert
        , Int
frequencyDelegCert :: Int
frequencyDelegCert :: Constants -> Int
frequencyDelegCert
        , Int
frequencyGenesisDelegationCert :: Int
frequencyGenesisDelegationCert :: Constants -> Int
frequencyGenesisDelegationCert
        , Int
frequencyDeRegKeyCert :: Int
frequencyDeRegKeyCert :: Constants -> Int
frequencyDeRegKeyCert
        , Int
frequencyRetirePoolCert :: Int
frequencyRetirePoolCert :: Constants -> Int
frequencyRetirePoolCert
        , Int
frequencyMIRCert :: Int
frequencyMIRCert :: Constants -> Int
frequencyMIRCert
        }
      )
  KeySpace_
    { [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
ksCoreNodes :: [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
ksCoreNodes :: forall c era.
KeySpace c era
-> [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
ksCoreNodes
    , KeyPairs
ksKeyPairs :: KeyPairs
ksKeyPairs :: forall c era. KeySpace c era -> KeyPairs
ksKeyPairs
    , [(Script era, Script era)]
ksMSigScripts :: [(Script era, Script era)]
ksMSigScripts :: forall c era. KeySpace c era -> [(Script era, Script era)]
ksMSigScripts
    , [AllIssuerKeys c StakePool]
ksStakePools :: [AllIssuerKeys c StakePool]
ksStakePools :: forall c era. KeySpace c era -> [AllIssuerKeys c StakePool]
ksStakePools
    , [AllIssuerKeys c GenesisDelegate]
ksGenesisDelegates :: [AllIssuerKeys c GenesisDelegate]
ksGenesisDelegates :: forall c era. KeySpace c era -> [AllIssuerKeys c GenesisDelegate]
ksGenesisDelegates
    , 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
    }
  PParams era
pparams
  ChainAccountState
accountState
  CertState era
dpState
  SlotNo
slot =
    [(Int, Gen (Maybe (TxCert era, CertCred era)))]
-> Gen (Maybe (TxCert era, CertCred era))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
      [ (Int
frequencyRegCert, Constants
-> KeyPairs
-> [(Script era, Script era)]
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
forall era.
(EraScript era, ShelleyEraTxCert era, EraAccounts era) =>
Constants
-> KeyPairs
-> [(Script era, Script era)]
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genRegKeyCert Constants
c KeyPairs
ksKeyPairs [(Script era, Script era)]
ksMSigScripts DState era
dState)
      , (Int
frequencyRegPoolCert, [AllIssuerKeys c StakePool]
-> KeyPairs -> Coin -> Gen (Maybe (TxCert era, CertCred era))
forall era c.
(Era era, EraTxCert era, Crypto c) =>
[AllIssuerKeys c StakePool]
-> KeyPairs -> Coin -> Gen (Maybe (TxCert era, CertCred era))
genRegPool [AllIssuerKeys c StakePool]
ksStakePools KeyPairs
ksKeyPairs (PParams era
pparams PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppMinPoolCostL))
      , (Int
frequencyDelegCert, Constants
-> KeyPairs
-> [(Script era, Script era)]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
forall era.
(EraScript era, ShelleyEraTxCert era, EraCertState era) =>
Constants
-> KeyPairs
-> [(Script era, Script era)]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
genDelegation Constants
c KeyPairs
ksKeyPairs [(Script era, Script era)]
ksMSigScripts CertState era
dpState)
      ,
        ( Int
frequencyGenesisDelegationCert
        , [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
-> [AllIssuerKeys c GenesisDelegate]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
forall era c.
(Era era, ShelleyEraTxCert era, AtMostEra "Babbage" era,
 EraCertState era, Crypto c) =>
[(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
-> [AllIssuerKeys c GenesisDelegate]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
genGenesisDelegation [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
ksCoreNodes [AllIssuerKeys c GenesisDelegate]
ksGenesisDelegates CertState era
dpState
        )
      , (Int
frequencyDeRegKeyCert, Constants
-> KeyPairs
-> [(Script era, Script era)]
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
forall era.
(EraScript era, EraAccounts era, ShelleyEraTxCert era) =>
Constants
-> KeyPairs
-> [(Script era, Script era)]
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genDeRegKeyCert Constants
c KeyPairs
ksKeyPairs [(Script era, Script era)]
ksMSigScripts DState era
dState)
      , (Int
frequencyRetirePoolCert, PParams era
-> [AllIssuerKeys c StakePool]
-> PState era
-> SlotNo
-> Gen (Maybe (TxCert era, CertCred era))
forall era c.
(EraPParams era, EraTxCert era) =>
PParams era
-> [AllIssuerKeys c StakePool]
-> PState era
-> SlotNo
-> Gen (Maybe (TxCert era, CertCred era))
genRetirePool PParams era
pparams [AllIssuerKeys c StakePool]
ksStakePools PState era
pState SlotNo
slot)
      ,
        ( Int
frequencyMIRCert
        , SlotNo
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> ChainAccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
forall era c.
(EraPParams era, EraAccounts era, ShelleyEraTxCert era,
 AtMostEra "Babbage" era) =>
SlotNo
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> ChainAccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewards
            SlotNo
slot
            Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
ksIndexedGenDelegates
            PParams era
pparams
            ChainAccountState
accountState
            DState era
dState
        )
      ]
    where
      dState :: DState era
dState = CertState era
dpState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL
      pState :: PState era
pState = CertState era
dpState CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL

-- | Generate a RegKey certificate
genRegKeyCert ::
  forall era.
  (EraScript era, ShelleyEraTxCert era, EraAccounts era) =>
  Constants ->
  KeyPairs ->
  [(Script era, Script era)] ->
  DState era ->
  Gen (Maybe (TxCert era, CertCred era))
genRegKeyCert :: forall era.
(EraScript era, ShelleyEraTxCert era, EraAccounts era) =>
Constants
-> KeyPairs
-> [(Script era, Script era)]
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genRegKeyCert
  Constants {Int
frequencyKeyCredReg :: Int
frequencyKeyCredReg :: Constants -> Int
frequencyKeyCredReg, Int
frequencyScriptCredReg :: Int
frequencyScriptCredReg :: Constants -> Int
frequencyScriptCredReg}
  KeyPairs
keys
  [(Script era, Script era)]
scripts
  DState era
delegSt =
    [(Int, Gen (Maybe (TxCert era, CertCred era)))]
-> Gen (Maybe (TxCert era, CertCred era))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
      [
        ( Int
frequencyKeyCredReg
        , case KeyPairs
availableKeys of
            [] -> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
            KeyPairs
_ -> do
              (_payKey, stakeKey) <- KeyPairs -> Gen (KeyPair Payment, KeyPair Staking)
forall a. HasCallStack => [a] -> Gen a
QC.elements KeyPairs
availableKeys
              pure $
                Just
                  ( RegTxCert (mkCredential stakeKey)
                  , NoCred
                  )
        )
      ,
        ( Int
frequencyScriptCredReg
        , case [(Script era, Script era)]
availableScripts of
            [] -> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
            [(Script era, Script era)]
_ -> do
              (_, stakeScript) <- [(Script era, Script era)] -> Gen (Script era, Script era)
forall a. HasCallStack => [a] -> Gen a
QC.elements [(Script era, Script era)]
availableScripts
              pure $
                Just
                  ( RegTxCert (scriptToCred' stakeScript)
                  , NoCred
                  )
        )
      ]
    where
      scriptToCred' :: Script era -> Credential Staking
scriptToCred' = ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential Staking)
-> (Script era -> ScriptHash) -> Script era -> Credential Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraScript era => Script era -> ScriptHash
hashScript @era
      notRegistered :: Credential Staking -> Bool
notRegistered Credential Staking
cred = Bool -> Bool
not (Credential Staking -> Accounts era -> Bool
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Bool
isAccountRegistered Credential Staking
cred (DState era
delegSt DState era
-> Getting (Accounts era) (DState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. Getting (Accounts era) (DState era) (Accounts era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL))
      availableKeys :: KeyPairs
availableKeys = ((KeyPair Payment, KeyPair Staking) -> Bool)
-> KeyPairs -> KeyPairs
forall a. (a -> Bool) -> [a] -> [a]
filter (Credential Staking -> Bool
notRegistered (Credential Staking -> Bool)
-> ((KeyPair Payment, KeyPair Staking) -> Credential Staking)
-> (KeyPair Payment, KeyPair Staking)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair Staking -> Credential Staking
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential (KeyPair Staking -> Credential Staking)
-> ((KeyPair Payment, KeyPair Staking) -> KeyPair Staking)
-> (KeyPair Payment, KeyPair Staking)
-> Credential Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyPair Payment, KeyPair Staking) -> KeyPair Staking
forall a b. (a, b) -> b
snd) KeyPairs
keys
      availableScripts :: [(Script era, Script era)]
availableScripts = ((Script era, Script era) -> Bool)
-> [(Script era, Script era)] -> [(Script era, Script era)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Credential Staking -> Bool
notRegistered (Credential Staking -> Bool)
-> ((Script era, Script era) -> Credential Staking)
-> (Script era, Script era)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script era -> Credential Staking
scriptToCred' (Script era -> Credential Staking)
-> ((Script era, Script era) -> Script era)
-> (Script era, Script era)
-> Credential Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Script era, Script era) -> Script era
forall a b. (a, b) -> b
snd) [(Script era, Script era)]
scripts

-- | Generate a DeRegKey certificate along with the staking credential, which is
-- needed to witness the certificate.
genDeRegKeyCert ::
  forall era.
  (EraScript era, EraAccounts era, ShelleyEraTxCert era) =>
  Constants ->
  KeyPairs ->
  [(Script era, Script era)] ->
  DState era ->
  Gen (Maybe (TxCert era, CertCred era))
genDeRegKeyCert :: forall era.
(EraScript era, EraAccounts era, ShelleyEraTxCert era) =>
Constants
-> KeyPairs
-> [(Script era, Script era)]
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genDeRegKeyCert Constants {Int
frequencyKeyCredDeReg :: Int
frequencyKeyCredDeReg :: Constants -> Int
frequencyKeyCredDeReg, Int
frequencyScriptCredDeReg :: Int
frequencyScriptCredDeReg :: Constants -> Int
frequencyScriptCredDeReg} KeyPairs
keys [(Script era, Script era)]
scripts DState era
dState =
  [(Int, Gen (Maybe (TxCert era, CertCred era)))]
-> Gen (Maybe (TxCert era, CertCred era))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
    [
      ( Int
frequencyKeyCredDeReg
      , case KeyPairs
availableKeys of
          [] -> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
          KeyPairs
_ -> do
            (_payKey, stakeKey) <- KeyPairs -> Gen (KeyPair Payment, KeyPair Staking)
forall a. HasCallStack => [a] -> Gen a
QC.elements KeyPairs
availableKeys
            pure $ Just (UnRegTxCert (mkCredential stakeKey), StakeCred stakeKey)
      )
    ,
      ( Int
frequencyScriptCredDeReg
      , case [(Script era, Script era)]
availableScripts of
          [] -> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
          [(Script era, Script era)]
_ -> do
            scriptPair@(_, stakeScript) <- [(Script era, Script era)] -> Gen (Script era, Script era)
forall a. HasCallStack => [a] -> Gen a
QC.elements [(Script era, Script era)]
availableScripts
            pure $
              Just
                ( UnRegTxCert (scriptToCred' stakeScript)
                , ScriptCred scriptPair
                )
      )
    ]
  where
    scriptToCred' :: Script era -> Credential Staking
scriptToCred' = ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential Staking)
-> (Script era -> ScriptHash) -> Script era -> Credential Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraScript era => Script era -> ScriptHash
hashScript @era
    registered :: Credential Staking -> Bool
registered Credential Staking
cred = Credential Staking -> Accounts era -> Bool
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Bool
isAccountRegistered Credential Staking
cred (DState era
dState DState era
-> Getting (Accounts era) (DState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. Getting (Accounts era) (DState era) (Accounts era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL)
    availableKeys :: KeyPairs
availableKeys =
      ((KeyPair Payment, KeyPair Staking) -> Bool)
-> KeyPairs -> KeyPairs
forall a. (a -> Bool) -> [a] -> [a]
filter
        ( \(KeyPair Payment
_, KeyPair Staking
k) ->
            let cred :: Credential Staking
cred = KeyPair Staking -> Credential Staking
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential KeyPair Staking
k
             in (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> (Credential Staking -> Bool)
-> Credential Staking
-> Bool
-> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Credential Staking -> Bool
registered (Credential Staking -> Bool -> Bool)
-> (Credential Staking -> Bool) -> Credential Staking -> Bool
forall a b.
(Credential Staking -> a -> b)
-> (Credential Staking -> a) -> Credential Staking -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Credential Staking -> Bool
zeroRewards) Credential Staking
cred
        )
        KeyPairs
keys
    availableScripts :: [(Script era, Script era)]
availableScripts =
      ((Script era, Script era) -> Bool)
-> [(Script era, Script era)] -> [(Script era, Script era)]
forall a. (a -> Bool) -> [a] -> [a]
filter
        ( \(Script era
_, Script era
s) ->
            let cred :: Credential Staking
cred = Script era -> Credential Staking
scriptToCred' Script era
s
             in (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> (Credential Staking -> Bool)
-> Credential Staking
-> Bool
-> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Credential Staking -> Bool
registered (Credential Staking -> Bool -> Bool)
-> (Credential Staking -> Bool) -> Credential Staking -> Bool
forall a b.
(Credential Staking -> a -> b)
-> (Credential Staking -> a) -> Credential Staking -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Credential Staking -> Bool
zeroRewards) Credential Staking
cred
        )
        [(Script era, Script era)]
scripts
    zeroRewards :: Credential Staking -> Bool
zeroRewards Credential Staking
cred =
      case Credential Staking -> Accounts era -> Maybe (AccountState era)
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Maybe (AccountState era)
lookupAccountState Credential Staking
cred (DState era
dState DState era
-> Getting (Accounts era) (DState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. Getting (Accounts era) (DState era) (Accounts era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL) of
        Maybe (AccountState era)
Nothing -> Bool
False
        Just AccountState era
accountState -> AccountState era
accountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL CompactForm Coin -> CompactForm Coin -> Bool
forall a. Eq a => a -> a -> Bool
== CompactForm Coin
forall a. Monoid a => a
mempty

-- | Generate a new delegation certificate by picking a registered staking
-- credential and pool. The delegation is witnessed by the delegator's
-- credential which we return along with the certificate.
--
-- Returns nothing if there are no registered staking credentials or no
-- registered pools.
genDelegation ::
  forall era.
  (EraScript era, ShelleyEraTxCert era, EraCertState era) =>
  Constants ->
  KeyPairs ->
  [(Script era, Script era)] ->
  CertState era ->
  Gen (Maybe (TxCert era, CertCred era))
genDelegation :: forall era.
(EraScript era, ShelleyEraTxCert era, EraCertState era) =>
Constants
-> KeyPairs
-> [(Script era, Script era)]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
genDelegation
  Constants {Int
frequencyKeyCredDelegation :: Int
frequencyKeyCredDelegation :: Constants -> Int
frequencyKeyCredDelegation, Int
frequencyScriptCredDelegation :: Int
frequencyScriptCredDelegation :: Constants -> Int
frequencyScriptCredDelegation}
  KeyPairs
keys
  [(Script era, Script era)]
scripts
  CertState era
dpState =
    if [KeyHash StakePool] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KeyHash StakePool]
availablePools
      then Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
      else
        [(Int, Gen (Maybe (TxCert era, CertCred era)))]
-> Gen (Maybe (TxCert era, CertCred era))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
          [
            ( Int
frequencyKeyCredDelegation
            , if KeyPairs -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null KeyPairs
availableDelegates
                then Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
                else
                  (KeyPair Payment, KeyPair Staking)
-> KeyHash StakePool -> Maybe (TxCert era, CertCred era)
forall {era} {a} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ProtVerIsInBounds
   "at most"
   era
   11
   (OrdCond (CmpNat (ProtVerLow era) 11) 'True 'True 'False),
 ShelleyEraTxCert era) =>
(a, KeyPair Staking)
-> KeyHash StakePool -> Maybe (TxCert era, CertCred era)
mkCert
                    ((KeyPair Payment, KeyPair Staking)
 -> KeyHash StakePool -> Maybe (TxCert era, CertCred era))
-> Gen (KeyPair Payment, KeyPair Staking)
-> Gen (KeyHash StakePool -> Maybe (TxCert era, CertCred era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPairs -> Gen (KeyPair Payment, KeyPair Staking)
forall a. HasCallStack => [a] -> Gen a
QC.elements KeyPairs
availableDelegates
                    Gen (KeyHash StakePool -> Maybe (TxCert era, CertCred era))
-> Gen (KeyHash StakePool)
-> Gen (Maybe (TxCert era, CertCred era))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [KeyHash StakePool] -> Gen (KeyHash StakePool)
forall a. HasCallStack => [a] -> Gen a
QC.elements [KeyHash StakePool]
availablePools
            )
          ,
            ( Int
frequencyScriptCredDelegation
            , if [(Script era, Script era)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Script era, Script era)]
availableDelegatesScripts
                then Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
                else
                  (Script era, Script era)
-> KeyHash StakePool -> Maybe (TxCert era, CertCred era)
mkCertFromScript
                    ((Script era, Script era)
 -> KeyHash StakePool -> Maybe (TxCert era, CertCred era))
-> Gen (Script era, Script era)
-> Gen (KeyHash StakePool -> Maybe (TxCert era, CertCred era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)] -> Gen (Script era, Script era)
forall a. HasCallStack => [a] -> Gen a
QC.elements [(Script era, Script era)]
availableDelegatesScripts
                    Gen (KeyHash StakePool -> Maybe (TxCert era, CertCred era))
-> Gen (KeyHash StakePool)
-> Gen (Maybe (TxCert era, CertCred era))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [KeyHash StakePool] -> Gen (KeyHash StakePool)
forall a. HasCallStack => [a] -> Gen a
QC.elements [KeyHash StakePool]
availablePools
            )
          ]
    where
      scriptToCred' :: Script era -> Credential Staking
scriptToCred' = ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential Staking)
-> (Script era -> ScriptHash) -> Script era -> Credential Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraScript era => Script era -> ScriptHash
hashScript @era
      mkCert :: (a, KeyPair Staking)
-> KeyHash StakePool -> Maybe (TxCert era, CertCred era)
mkCert (a
_, KeyPair Staking
delegatorKey) KeyHash StakePool
poolKey = (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just (TxCert era
cert, KeyPair Staking -> CertCred era
forall era. KeyPair Staking -> CertCred era
StakeCred KeyPair Staking
delegatorKey)
        where
          cert :: TxCert era
cert = Credential Staking -> KeyHash StakePool -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
DelegStakeTxCert (KeyPair Staking -> Credential Staking
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential KeyPair Staking
delegatorKey) KeyHash StakePool
poolKey
      mkCertFromScript :: (Script era, Script era)
-> KeyHash StakePool -> Maybe (TxCert era, CertCred era)
mkCertFromScript (Script era
s, Script era
delegatorScript) KeyHash StakePool
poolKey =
        (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just (TxCert era
scriptCert, (Script era, Script era) -> CertCred era
forall era. (Script era, Script era) -> CertCred era
ScriptCred (Script era
s, Script era
delegatorScript))
        where
          scriptCert :: TxCert era
scriptCert =
            Credential Staking -> KeyHash StakePool -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
DelegStakeTxCert (Script era -> Credential Staking
scriptToCred' Script era
delegatorScript) KeyHash StakePool
poolKey
      registeredDelegate :: Credential Staking -> Bool
registeredDelegate Credential Staking
cred = Credential Staking -> Accounts era -> Bool
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Bool
isAccountRegistered Credential Staking
cred (CertState era
dpState CertState era
-> Getting (Accounts era) (CertState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. (DState era -> Const (Accounts era) (DState era))
-> CertState era -> Const (Accounts era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const (Accounts era) (DState era))
 -> CertState era -> Const (Accounts era) (CertState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> DState era -> Const (Accounts era) (DState era))
-> Getting (Accounts era) (CertState era) (Accounts era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const (Accounts era) (Accounts era))
-> DState era -> Const (Accounts era) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL)
      availableDelegates :: KeyPairs
availableDelegates = ((KeyPair Payment, KeyPair Staking) -> Bool)
-> KeyPairs -> KeyPairs
forall a. (a -> Bool) -> [a] -> [a]
filter (Credential Staking -> Bool
registeredDelegate (Credential Staking -> Bool)
-> ((KeyPair Payment, KeyPair Staking) -> Credential Staking)
-> (KeyPair Payment, KeyPair Staking)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair Staking -> Credential Staking
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential (KeyPair Staking -> Credential Staking)
-> ((KeyPair Payment, KeyPair Staking) -> KeyPair Staking)
-> (KeyPair Payment, KeyPair Staking)
-> Credential Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyPair Payment, KeyPair Staking) -> KeyPair Staking
forall a b. (a, b) -> b
snd) KeyPairs
keys
      availableDelegatesScripts :: [(Script era, Script era)]
availableDelegatesScripts =
        ((Script era, Script era) -> Bool)
-> [(Script era, Script era)] -> [(Script era, Script era)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Credential Staking -> Bool
registeredDelegate (Credential Staking -> Bool)
-> ((Script era, Script era) -> Credential Staking)
-> (Script era, Script era)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script era -> Credential Staking
scriptToCred' (Script era -> Credential Staking)
-> ((Script era, Script era) -> Script era)
-> (Script era, Script era)
-> Credential Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Script era, Script era) -> Script era
forall a b. (a, b) -> b
snd) [(Script era, Script era)]
scripts
      registeredPools :: Map (KeyHash StakePool) StakePoolState
registeredPools = PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools (CertState era
dpState CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL)
      availablePools :: [KeyHash StakePool]
availablePools = Map (KeyHash StakePool) StakePoolState -> [KeyHash StakePool]
forall k a. Map k a -> [k]
Map.keys Map (KeyHash StakePool) StakePoolState
registeredPools

genGenesisDelegation ::
  forall era c.
  (Era era, ShelleyEraTxCert era, AtMostEra "Babbage" era, EraCertState era, Crypto c) =>
  -- | Core nodes
  [(GenesisKeyPair c, AllIssuerKeys c GenesisDelegate)] ->
  -- | All potential genesis delegate keys
  [AllIssuerKeys c GenesisDelegate] ->
  CertState era ->
  Gen (Maybe (TxCert era, CertCred era))
genGenesisDelegation :: forall era c.
(Era era, ShelleyEraTxCert era, AtMostEra "Babbage" era,
 EraCertState era, Crypto c) =>
[(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
-> [AllIssuerKeys c GenesisDelegate]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
genGenesisDelegation [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
coreNodes [AllIssuerKeys c GenesisDelegate]
delegateKeys CertState era
dpState =
  if [KeyPair GenesisRole] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KeyPair GenesisRole]
genesisDelegators Bool -> Bool -> Bool
|| [AllIssuerKeys c GenesisDelegate] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AllIssuerKeys c GenesisDelegate]
availableDelegatees
    then Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
    else do
      gk <- [KeyPair GenesisRole] -> Gen (KeyPair GenesisRole)
forall a. HasCallStack => [a] -> Gen a
QC.elements [KeyPair GenesisRole]
genesisDelegators
      AllIssuerKeys {aikCold, aikVrf} <- QC.elements availableDelegatees
      case Map.lookup (hashVKey gk) genDelegs_ of
        Maybe GenDelegPair
Nothing -> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
        Just GenDelegPair
_ -> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (TxCert era, CertCred era)
 -> Gen (Maybe (TxCert era, CertCred era)))
-> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a b. (a -> b) -> a -> b
$ KeyPair GenesisRole
-> KeyPair GenesisDelegate
-> VerKeyVRF (VRF c)
-> Maybe (TxCert era, CertCred era)
mkCert KeyPair GenesisRole
gk KeyPair GenesisDelegate
aikCold (VRFKeyPair c -> VerKeyVRF (VRF c)
forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey VRFKeyPair c
aikVrf)
  where
    allDelegateKeys :: [AllIssuerKeys c GenesisDelegate]
allDelegateKeys = ((KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)
-> AllIssuerKeys c GenesisDelegate
forall a b. (a, b) -> b
snd ((KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)
 -> AllIssuerKeys c GenesisDelegate)
-> [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
-> [AllIssuerKeys c GenesisDelegate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(KeyPair GenesisRole, AllIssuerKeys c GenesisDelegate)]
coreNodes) [AllIssuerKeys c GenesisDelegate]
-> [AllIssuerKeys c GenesisDelegate]
-> [AllIssuerKeys c GenesisDelegate]
forall a. Semigroup a => a -> a -> a
<> [AllIssuerKeys c GenesisDelegate]
delegateKeys
    hashVKey :: KeyPair kd -> KeyHash kd
hashVKey = VKey kd -> KeyHash kd
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey kd -> KeyHash kd)
-> (KeyPair kd -> VKey kd) -> KeyPair kd -> KeyHash kd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair kd -> VKey kd
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey
    mkCert :: KeyPair GenesisRole
-> KeyPair GenesisDelegate
-> VerKeyVRF (VRF c)
-> Maybe (TxCert era, CertCred era)
mkCert KeyPair GenesisRole
gkey KeyPair GenesisDelegate
key VerKeyVRF (VRF c)
vrf =
      (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just
        ( KeyHash GenesisRole
-> KeyHash GenesisDelegate
-> VRFVerKeyHash GenDelegVRF
-> TxCert era
forall era.
(ShelleyEraTxCert era, AtMostEra "Babbage" era) =>
KeyHash GenesisRole
-> KeyHash GenesisDelegate
-> VRFVerKeyHash GenDelegVRF
-> TxCert era
GenesisDelegTxCert
            (KeyPair GenesisRole -> KeyHash GenesisRole
forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey KeyPair GenesisRole
gkey)
            (KeyPair GenesisDelegate -> KeyHash GenesisDelegate
forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey KeyPair GenesisDelegate
key)
            (forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @c VerKeyVRF (VRF c)
vrf)
        , [KeyPair GenesisRole] -> CertCred era
forall era. [KeyPair GenesisRole] -> CertCred era
CoreKeyCred [KeyPair GenesisRole
gkey]
        )
    GenDelegs Map (KeyHash GenesisRole) GenDelegPair
genDelegs_ = 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
    genesisDelegator :: KeyHash GenesisRole -> Bool
genesisDelegator KeyHash GenesisRole
k = KeyHash GenesisRole
-> Map (KeyHash GenesisRole) GenDelegPair -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member KeyHash GenesisRole
k Map (KeyHash GenesisRole) GenDelegPair
genDelegs_
    genesisDelegators :: [KeyPair GenesisRole]
genesisDelegators = (KeyPair GenesisRole -> Bool)
-> [KeyPair GenesisRole] -> [KeyPair GenesisRole]
forall a. (a -> Bool) -> [a] -> [a]
filter (KeyHash GenesisRole -> Bool
genesisDelegator (KeyHash GenesisRole -> Bool)
-> (KeyPair GenesisRole -> KeyHash GenesisRole)
-> KeyPair GenesisRole
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair GenesisRole -> KeyHash GenesisRole
forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey) ((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)]
coreNodes)
    activeGenDelegsKeyHashSet :: Set (KeyHash GenesisDelegate)
activeGenDelegsKeyHashSet =
      [KeyHash GenesisDelegate] -> Set (KeyHash GenesisDelegate)
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash GenesisDelegate] -> Set (KeyHash GenesisDelegate))
-> [KeyHash GenesisDelegate] -> Set (KeyHash GenesisDelegate)
forall a b. (a -> b) -> a -> b
$ GenDelegPair -> KeyHash GenesisDelegate
genDelegKeyHash (GenDelegPair -> KeyHash GenesisDelegate)
-> [GenDelegPair] -> [KeyHash 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_
    futureGenDelegsKeyHashSet :: Set (KeyHash GenesisDelegate)
futureGenDelegsKeyHashSet =
      [KeyHash GenesisDelegate] -> Set (KeyHash GenesisDelegate)
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash GenesisDelegate] -> Set (KeyHash GenesisDelegate))
-> [KeyHash GenesisDelegate] -> Set (KeyHash GenesisDelegate)
forall a b. (a -> b) -> a -> b
$ GenDelegPair -> KeyHash GenesisDelegate
genDelegKeyHash (GenDelegPair -> KeyHash GenesisDelegate)
-> [GenDelegPair] -> [KeyHash GenesisDelegate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map FutureGenDeleg GenDelegPair -> [GenDelegPair]
forall k a. Map k a -> [a]
Map.elems (CertState era
dpState CertState era
-> Getting
     (Map FutureGenDeleg GenDelegPair)
     (CertState era)
     (Map FutureGenDeleg GenDelegPair)
-> Map FutureGenDeleg GenDelegPair
forall s a. s -> Getting a s a -> a
^. (DState era
 -> Const (Map FutureGenDeleg GenDelegPair) (DState era))
-> CertState era
-> Const (Map FutureGenDeleg GenDelegPair) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era
  -> Const (Map FutureGenDeleg GenDelegPair) (DState era))
 -> CertState era
 -> Const (Map FutureGenDeleg GenDelegPair) (CertState era))
-> ((Map FutureGenDeleg GenDelegPair
     -> Const
          (Map FutureGenDeleg GenDelegPair)
          (Map FutureGenDeleg GenDelegPair))
    -> DState era
    -> Const (Map FutureGenDeleg GenDelegPair) (DState era))
-> Getting
     (Map FutureGenDeleg GenDelegPair)
     (CertState era)
     (Map FutureGenDeleg GenDelegPair)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map FutureGenDeleg GenDelegPair
 -> Const
      (Map FutureGenDeleg GenDelegPair)
      (Map FutureGenDeleg GenDelegPair))
-> DState era
-> Const (Map FutureGenDeleg GenDelegPair) (DState era)
forall era (f :: * -> *).
Functor f =>
(Map FutureGenDeleg GenDelegPair
 -> f (Map FutureGenDeleg GenDelegPair))
-> DState era -> f (DState era)
dsFutureGenDelegsL)
    notActiveDelegatee :: KeyHash GenesisDelegate -> Bool
notActiveDelegatee KeyHash GenesisDelegate
k = KeyHash GenesisDelegate -> KeyHash GenesisDelegate
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash GenesisDelegate
k KeyHash GenesisDelegate -> Set (KeyHash GenesisDelegate) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (KeyHash GenesisDelegate)
activeGenDelegsKeyHashSet
    notFutureDelegatee :: KeyHash GenesisDelegate -> Bool
notFutureDelegatee KeyHash GenesisDelegate
k = KeyHash GenesisDelegate -> KeyHash GenesisDelegate
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash GenesisDelegate
k KeyHash GenesisDelegate -> Set (KeyHash GenesisDelegate) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (KeyHash GenesisDelegate)
futureGenDelegsKeyHashSet
    notDelegatee :: KeyHash GenesisDelegate -> Bool
notDelegatee KeyHash GenesisDelegate
k = KeyHash GenesisDelegate -> Bool
notActiveDelegatee KeyHash GenesisDelegate
k Bool -> Bool -> Bool
&& KeyHash GenesisDelegate -> Bool
notFutureDelegatee KeyHash GenesisDelegate
k
    availableDelegatees :: [AllIssuerKeys c GenesisDelegate]
availableDelegatees = (AllIssuerKeys c GenesisDelegate -> Bool)
-> [AllIssuerKeys c GenesisDelegate]
-> [AllIssuerKeys c GenesisDelegate]
forall a. (a -> Bool) -> [a] -> [a]
filter (KeyHash GenesisDelegate -> Bool
notDelegatee (KeyHash GenesisDelegate -> Bool)
-> (AllIssuerKeys c GenesisDelegate -> KeyHash GenesisDelegate)
-> AllIssuerKeys c GenesisDelegate
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair GenesisDelegate -> KeyHash GenesisDelegate
forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey (KeyPair GenesisDelegate -> KeyHash GenesisDelegate)
-> (AllIssuerKeys c GenesisDelegate -> KeyPair GenesisDelegate)
-> AllIssuerKeys c GenesisDelegate
-> KeyHash GenesisDelegate
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]
allDelegateKeys

-- | Generate PoolParams and the key witness.
genStakePool ::
  forall c.
  Crypto c =>
  -- | Available keys for stake pool registration
  [AllIssuerKeys c StakePool] ->
  -- | KeyPairs containing staking keys to act as owners/reward account
  KeyPairs ->
  -- | Minimum pool cost Protocol Param
  Coin ->
  Gen (StakePoolParams, KeyPair StakePool)
genStakePool :: forall c.
Crypto c =>
[AllIssuerKeys c StakePool]
-> KeyPairs -> Coin -> Gen (StakePoolParams, KeyPair StakePool)
genStakePool [AllIssuerKeys c StakePool]
poolKeys KeyPairs
skeys (Coin Integer
minPoolCost) =
  AllIssuerKeys c StakePool
-> Coin
-> Coin
-> Nat
-> VKey Staking
-> (StakePoolParams, KeyPair StakePool)
mkStakePoolParams
    (AllIssuerKeys c StakePool
 -> Coin
 -> Coin
 -> Nat
 -> VKey Staking
 -> (StakePoolParams, KeyPair StakePool))
-> Gen (AllIssuerKeys c StakePool)
-> Gen
     (Coin
      -> Coin
      -> Nat
      -> VKey Staking
      -> (StakePoolParams, KeyPair StakePool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AllIssuerKeys c StakePool] -> Gen (AllIssuerKeys c StakePool)
forall a. HasCallStack => [a] -> Gen a
QC.elements [AllIssuerKeys c StakePool]
poolKeys
    Gen
  (Coin
   -> Coin
   -> Nat
   -> VKey Staking
   -> (StakePoolParams, KeyPair StakePool))
-> Gen Coin
-> Gen
     (Coin
      -> Nat -> VKey Staking -> (StakePoolParams, KeyPair StakePool))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( Integer -> Coin
Coin -- pledge
            (Integer -> Coin) -> Gen Integer -> Gen Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Gen Integer)] -> Gen Integer
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
              [ (Int
1, Integer -> Integer -> Gen Integer
genInteger Integer
1 Integer
100)
              , (Int
5, Integer -> Gen Integer
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0)
              ]
        )
    Gen
  (Coin
   -> Nat -> VKey Staking -> (StakePoolParams, KeyPair StakePool))
-> Gen Coin
-> Gen
     (Nat -> VKey Staking -> (StakePoolParams, KeyPair StakePool))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (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
minPoolCost (Integer
minPoolCost Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
50)) -- cost
    Gen (Nat -> VKey Staking -> (StakePoolParams, KeyPair StakePool))
-> Gen Nat
-> Gen (VKey Staking -> (StakePoolParams, KeyPair StakePool))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Integer -> Nat
forall a. Num a => Integer -> a
fromInteger (Integer -> Nat) -> Gen Integer -> Gen Nat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
QC.choose (Integer
0, Integer
100) :: Gen Natural)
    Gen (VKey Staking -> (StakePoolParams, KeyPair StakePool))
-> Gen (VKey Staking) -> Gen (StakePoolParams, KeyPair StakePool)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyPairs -> Gen (VKey Staking)
getAnyStakeKey KeyPairs
skeys
  where
    getAnyStakeKey :: KeyPairs -> Gen (VKey Staking)
    getAnyStakeKey :: KeyPairs -> Gen (VKey Staking)
getAnyStakeKey KeyPairs
keys = KeyPair Staking -> VKey Staking
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair Staking -> VKey Staking)
-> ((KeyPair Payment, KeyPair Staking) -> KeyPair Staking)
-> (KeyPair Payment, KeyPair Staking)
-> VKey Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyPair Payment, KeyPair Staking) -> KeyPair Staking
forall a b. (a, b) -> b
snd ((KeyPair Payment, KeyPair Staking) -> VKey Staking)
-> Gen (KeyPair Payment, KeyPair Staking) -> Gen (VKey Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPairs -> Gen (KeyPair Payment, KeyPair Staking)
forall a. HasCallStack => [a] -> Gen a
QC.elements KeyPairs
keys
    mkStakePoolParams ::
      AllIssuerKeys c StakePool ->
      Coin ->
      Coin ->
      Natural ->
      VKey Staking ->
      (StakePoolParams, KeyPair StakePool)
    mkStakePoolParams :: AllIssuerKeys c StakePool
-> Coin
-> Coin
-> Nat
-> VKey Staking
-> (StakePoolParams, KeyPair StakePool)
mkStakePoolParams AllIssuerKeys c StakePool
allPoolKeys Coin
pledge Coin
cost Nat
marginPercent VKey Staking
acntKey =
      let interval :: UnitInterval
interval = Rational -> UnitInterval
forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational (Rational -> UnitInterval) -> Rational -> UnitInterval
forall a b. (a -> b) -> a -> b
$ Nat -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Nat
marginPercent Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
100
          spps :: StakePoolParams
spps =
            KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF
-> Coin
-> Coin
-> UnitInterval
-> RewardAccount
-> Set (KeyHash Staking)
-> StrictSeq StakePoolRelay
-> StrictMaybe PoolMetadata
-> StakePoolParams
StakePoolParams
              (VKey StakePool -> KeyHash StakePool
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey StakePool -> KeyHash StakePool)
-> (KeyPair StakePool -> VKey StakePool)
-> KeyPair StakePool
-> KeyHash StakePool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair StakePool -> VKey StakePool
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair StakePool -> KeyHash StakePool)
-> KeyPair StakePool -> KeyHash StakePool
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c StakePool -> KeyPair StakePool
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys c StakePool
allPoolKeys)
              (forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @c (VerKeyVRF (VRF c) -> VRFVerKeyHash StakePoolVRF)
-> (VRFKeyPair c -> VerKeyVRF (VRF c))
-> VRFKeyPair c
-> VRFVerKeyHash StakePoolVRF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VRFKeyPair c -> VerKeyVRF (VRF c)
forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey (VRFKeyPair c -> VRFVerKeyHash StakePoolVRF)
-> VRFKeyPair c -> VRFVerKeyHash StakePoolVRF
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c StakePool -> VRFKeyPair c
forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf AllIssuerKeys c StakePool
allPoolKeys)
              Coin
pledge
              Coin
cost
              UnitInterval
interval
              (Network -> Credential Staking -> RewardAccount
RewardAccount Network
Testnet (Credential Staking -> RewardAccount)
-> Credential Staking -> RewardAccount
forall a b. (a -> b) -> a -> b
$ KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> KeyHash Staking -> Credential Staking
forall a b. (a -> b) -> a -> b
$ VKey Staking -> KeyHash Staking
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey VKey Staking
acntKey)
              Set (KeyHash Staking)
forall a. Set a
Set.empty
              StrictSeq StakePoolRelay
forall a. StrictSeq a
StrictSeq.empty
              StrictMaybe PoolMetadata
forall a. StrictMaybe a
SNothing
       in (StakePoolParams
spps, AllIssuerKeys c StakePool -> KeyPair StakePool
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys c StakePool
allPoolKeys)

-- | Generate `RegPool` and the key witness.
genRegPool ::
  (Era era, EraTxCert era, Crypto c) =>
  [AllIssuerKeys c StakePool] ->
  KeyPairs ->
  Coin ->
  Gen (Maybe (TxCert era, CertCred era))
genRegPool :: forall era c.
(Era era, EraTxCert era, Crypto c) =>
[AllIssuerKeys c StakePool]
-> KeyPairs -> Coin -> Gen (Maybe (TxCert era, CertCred era))
genRegPool [AllIssuerKeys c StakePool]
poolKeys KeyPairs
keyPairs Coin
minPoolCost = do
  (pps, poolKey) <- [AllIssuerKeys c StakePool]
-> KeyPairs -> Coin -> Gen (StakePoolParams, KeyPair StakePool)
forall c.
Crypto c =>
[AllIssuerKeys c StakePool]
-> KeyPairs -> Coin -> Gen (StakePoolParams, KeyPair StakePool)
genStakePool [AllIssuerKeys c StakePool]
poolKeys KeyPairs
keyPairs Coin
minPoolCost
  pure $ Just (RegPoolTxCert pps, PoolCred poolKey)

-- | Generate a RetirePool along with the keypair which registered it.
--
-- Choose a `KeyHash` to retire, by pulling from the set of registered
-- `KeyHash`s in the `stakePools` mapping. Generate a random epoch within an
-- acceptable range of the current epoch. In addition to the `RetirePool`
-- constructed value, return the keypair which corresponds to the selected
-- `KeyHash`, by doing a lookup in the set of `availableKeys`.
genRetirePool ::
  (EraPParams era, EraTxCert era) =>
  PParams era ->
  [AllIssuerKeys c StakePool] ->
  PState era ->
  SlotNo ->
  Gen (Maybe (TxCert era, CertCred era))
genRetirePool :: forall era c.
(EraPParams era, EraTxCert era) =>
PParams era
-> [AllIssuerKeys c StakePool]
-> PState era
-> SlotNo
-> Gen (Maybe (TxCert era, CertCred era))
genRetirePool PParams era
_pp [AllIssuerKeys c StakePool]
poolKeys (PState {Map (KeyHash StakePool) StakePoolState
psStakePools :: forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools :: Map (KeyHash StakePool) StakePoolState
psStakePools, Map (KeyHash StakePool) EpochNo
psRetiring :: Map (KeyHash StakePool) EpochNo
psRetiring :: forall era. PState era -> Map (KeyHash StakePool) EpochNo
psRetiring}) SlotNo
slot =
  if [KeyHash StakePool] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KeyHash StakePool]
retireable
    then Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
    else
      ( \KeyHash StakePool
keyHash EpochNo
epoch ->
          (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just
            ( KeyHash StakePool -> EpochNo -> TxCert era
forall era.
EraTxCert era =>
KeyHash StakePool -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash StakePool
keyHash EpochNo
epoch
            , KeyPair StakePool -> CertCred era
forall era. KeyPair StakePool -> CertCred era
PoolCred (AllIssuerKeys c StakePool -> KeyPair StakePool
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold (AllIssuerKeys c StakePool -> KeyPair StakePool)
-> AllIssuerKeys c StakePool -> KeyPair StakePool
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool -> AllIssuerKeys c StakePool
lookupHash KeyHash StakePool
keyHash)
            )
      )
        (KeyHash StakePool -> EpochNo -> Maybe (TxCert era, CertCred era))
-> Gen (KeyHash StakePool)
-> Gen (EpochNo -> Maybe (TxCert era, CertCred era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyHash StakePool] -> Gen (KeyHash StakePool)
forall a. HasCallStack => [a] -> Gen a
QC.elements [KeyHash StakePool]
retireable
        Gen (EpochNo -> Maybe (TxCert era, CertCred era))
-> Gen EpochNo -> Gen (Maybe (TxCert era, CertCred era))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word64 -> EpochNo
EpochNo (Word64 -> EpochNo) -> Gen Word64 -> Gen EpochNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> Word64 -> Gen Word64
genWord64 Word64
epochLow Word64
epochHigh)
  where
    retireable :: [KeyHash StakePool]
retireable = Map (KeyHash StakePool) StakePoolState -> [KeyHash StakePool]
forall k a. Map k a -> [k]
Map.keys (Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) EpochNo
-> Map (KeyHash StakePool) StakePoolState
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map (KeyHash StakePool) StakePoolState
psStakePools Map (KeyHash StakePool) EpochNo
psRetiring)
    lookupHash :: KeyHash StakePool -> AllIssuerKeys c StakePool
lookupHash KeyHash StakePool
hk' =
      AllIssuerKeys c StakePool
-> Maybe (AllIssuerKeys c StakePool) -> AllIssuerKeys c StakePool
forall a. a -> Maybe a -> a
fromMaybe
        (String -> AllIssuerKeys c StakePool
forall a. HasCallStack => String -> a
error String
"genRetirePool: could not find keyHash")
        ((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 c StakePool
x -> AllIssuerKeys c StakePool -> KeyHash StakePool
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys c StakePool
x KeyHash StakePool -> KeyHash StakePool -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash StakePool
hk') [AllIssuerKeys c StakePool]
poolKeys)
    EpochNo Word64
cepoch = SlotNo -> EpochNo
epochFromSlotNo SlotNo
slot
    epochLow :: Word64
epochLow = Word64
cepoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
    -- if epochHigh is more than a few epochs above epochLow, then
    -- because our traces are at most, maybe 6 or so traces long,
    -- we will never reap any pools. Choosing a delta between 1 and 10
    -- should give good mix of sometimes reaping, but mostly not.
    epochHigh :: Word64
epochHigh = Word64
cepoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
10

-- | Generate an InstantaneousRewards Transfer certificate
genInstantaneousRewardsAccounts ::
  (EraPParams era, EraAccounts era, ShelleyEraTxCert era, AtMostEra "Babbage" era) =>
  SlotNo ->
  -- | Index over the cold key hashes of all possible Genesis Delegates
  Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate) ->
  PParams era ->
  ChainAccountState ->
  DState era ->
  Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsAccounts :: forall era c.
(EraPParams era, EraAccounts era, ShelleyEraTxCert era,
 AtMostEra "Babbage" era) =>
SlotNo
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> ChainAccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsAccounts SlotNo
s Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
genesisDelegatesByHash PParams era
pparams ChainAccountState
accountState DState era
delegSt = do
  let (GenDelegs Map (KeyHash GenesisRole) GenDelegPair
genDelegs_) = DState era -> GenDelegs
forall era. DState era -> GenDelegs
dsGenDelegs DState era
delegSt
      lookupGenDelegate' :: KeyHash GenesisDelegate -> AllIssuerKeys c GenesisDelegate
lookupGenDelegate' KeyHash GenesisDelegate
gk =
        AllIssuerKeys c GenesisDelegate
-> Maybe (AllIssuerKeys c GenesisDelegate)
-> AllIssuerKeys c GenesisDelegate
forall a. a -> Maybe a -> a
fromMaybe
          (String -> AllIssuerKeys c GenesisDelegate
forall a. HasCallStack => String -> a
error String
"genInstantaneousRewardsAccounts: lookupGenDelegate failed")
          (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 KeyHash GenesisDelegate
gk Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
genesisDelegatesByHash)
      accountsMap :: Map (Credential Staking) (AccountState era)
accountsMap = DState era
delegSt DState era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (DState era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. (Accounts era
 -> Const
      (Map (Credential Staking) (AccountState era)) (Accounts era))
-> DState era
-> Const (Map (Credential Staking) (AccountState era)) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era
  -> Const
       (Map (Credential Staking) (AccountState era)) (Accounts era))
 -> DState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (DState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> Accounts era
    -> Const
         (Map (Credential Staking) (AccountState era)) (Accounts era))
-> Getting
     (Map (Credential Staking) (AccountState era))
     (DState era)
     (Map (Credential Staking) (AccountState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential Staking) (AccountState era)
 -> Const
      (Map (Credential Staking) (AccountState era))
      (Map (Credential Staking) (AccountState era)))
-> Accounts era
-> Const
     (Map (Credential Staking) (AccountState era)) (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL
  winnerCreds <-
    Int -> [Credential Staking] -> [Credential Staking]
forall a. Int -> [a] -> [a]
take
      (Int -> [Credential Staking] -> [Credential Staking])
-> Gen Int -> Gen ([Credential Staking] -> [Credential Staking])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> Gen Int
forall a. HasCallStack => [a] -> Gen a
QC.elements [Int
0 .. (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Map (Credential Staking) (AccountState era) -> Int
forall k a. Map k a -> Int
Map.size Map (Credential Staking) (AccountState era)
accountsMap Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
      Gen ([Credential Staking] -> [Credential Staking])
-> Gen [Credential Staking] -> Gen [Credential Staking]
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Credential Staking] -> Gen [Credential Staking]
forall a. [a] -> Gen [a]
QC.shuffle (Map (Credential Staking) (AccountState era) -> [Credential Staking]
forall k a. Map k a -> [k]
Map.keys Map (Credential Staking) (AccountState era)
accountsMap)
  coins <- replicateM (length winnerCreds) $ genInteger 1 1000
  let credCoinMap = [(Credential Staking, DeltaCoin)]
-> Map (Credential Staking) DeltaCoin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Credential Staking, DeltaCoin)]
 -> Map (Credential Staking) DeltaCoin)
-> [(Credential Staking, DeltaCoin)]
-> Map (Credential Staking) DeltaCoin
forall a b. (a -> b) -> a -> b
$ [Credential Staking]
-> [DeltaCoin] -> [(Credential Staking, DeltaCoin)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Credential Staking]
winnerCreds ((Integer -> DeltaCoin) -> [Integer] -> [DeltaCoin]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> DeltaCoin
DeltaCoin [Integer]
coins)

  coreSigners <-
    take
      <$> QC.elements [5 .. (max 0 $ length genDelegs_ - 1)]
      <*> QC.shuffle (lookupGenDelegate' . genDelegKeyHash <$> Map.elems genDelegs_)

  pot <- QC.elements [ReservesMIR, TreasuryMIR]
  let available = MIRPot -> ChainAccountState -> InstantaneousRewards -> Coin
availableAfterMIR MIRPot
pot ChainAccountState
accountState (DState era -> InstantaneousRewards
forall era. DState era -> InstantaneousRewards
dsIRewards DState era
delegSt)
  let rewardAmount = [DeltaCoin] -> DeltaCoin
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([DeltaCoin] -> DeltaCoin) -> [DeltaCoin] -> DeltaCoin
forall a b. (a -> b) -> a -> b
$ Map (Credential Staking) DeltaCoin -> [DeltaCoin]
forall k a. Map k a -> [a]
Map.elems Map (Credential Staking) DeltaCoin
credCoinMap
      insufficientFunds = Coin -> DeltaCoin
toDeltaCoin Coin
available DeltaCoin -> DeltaCoin -> Bool
forall a. Ord a => a -> a -> Bool
< DeltaCoin
rewardAmount
  pure $
    if -- Discard this generator (by returning Nothing) if:
    -- we are in full decentralisation mode (d=0) when IR certs are not allowed
    pparams ^. ppDG == minBound
      -- or when we don't have keys available for generating an IR cert
      || null credCoinMap
      -- or it's too late in the epoch for IR certs
      || tooLateInEpoch s
      -- or the rewards exceed the pot amount
      || insufficientFunds
      then Nothing
      else
        Just
          ( MirTxCert (MIRCert pot (StakeAddressesMIR credCoinMap))
          , DelegateCred (aikCold <$> coreSigners)
          )

-- | Generate an InstantaneousRewards Transfer
genInstantaneousRewardsTransfer ::
  (EraPParams era, ShelleyEraTxCert era, AtMostEra "Babbage" era) =>
  SlotNo ->
  -- | Index over the cold key hashes of all possible Genesis Delegates
  Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate) ->
  PParams era ->
  ChainAccountState ->
  DState era ->
  Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsTransfer :: forall era c.
(EraPParams era, ShelleyEraTxCert era, AtMostEra "Babbage" era) =>
SlotNo
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> ChainAccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsTransfer SlotNo
s Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
genesisDelegatesByHash PParams era
pparams ChainAccountState
accountState DState era
delegSt = do
  let (GenDelegs Map (KeyHash GenesisRole) GenDelegPair
genDelegs_) = DState era -> GenDelegs
forall era. DState era -> GenDelegs
dsGenDelegs DState era
delegSt
      lookupGenDelegate' :: KeyHash GenesisDelegate -> AllIssuerKeys c GenesisDelegate
lookupGenDelegate' KeyHash GenesisDelegate
gk =
        AllIssuerKeys c GenesisDelegate
-> Maybe (AllIssuerKeys c GenesisDelegate)
-> AllIssuerKeys c GenesisDelegate
forall a. a -> Maybe a -> a
fromMaybe
          (String -> AllIssuerKeys c GenesisDelegate
forall a. HasCallStack => String -> a
error String
"genInstantaneousRewardsTransfer: lookupGenDelegate failed")
          (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 KeyHash GenesisDelegate
gk Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
genesisDelegatesByHash)

  coreSigners <-
    Int
-> [AllIssuerKeys c GenesisDelegate]
-> [AllIssuerKeys c GenesisDelegate]
forall a. Int -> [a] -> [a]
take
      (Int
 -> [AllIssuerKeys c GenesisDelegate]
 -> [AllIssuerKeys c GenesisDelegate])
-> Gen Int
-> Gen
     ([AllIssuerKeys c GenesisDelegate]
      -> [AllIssuerKeys c GenesisDelegate])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> Gen Int
forall a. HasCallStack => [a] -> Gen a
QC.elements [Int
5 .. (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Map (KeyHash GenesisRole) GenDelegPair -> Int
forall a. Map (KeyHash GenesisRole) a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map (KeyHash GenesisRole) GenDelegPair
genDelegs_ Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
      Gen
  ([AllIssuerKeys c GenesisDelegate]
   -> [AllIssuerKeys c GenesisDelegate])
-> Gen [AllIssuerKeys c GenesisDelegate]
-> Gen [AllIssuerKeys c GenesisDelegate]
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [AllIssuerKeys c GenesisDelegate]
-> Gen [AllIssuerKeys c GenesisDelegate]
forall a. [a] -> Gen [a]
QC.shuffle (KeyHash GenesisDelegate -> AllIssuerKeys c GenesisDelegate
lookupGenDelegate' (KeyHash GenesisDelegate -> AllIssuerKeys c GenesisDelegate)
-> (GenDelegPair -> KeyHash GenesisDelegate)
-> GenDelegPair
-> AllIssuerKeys c GenesisDelegate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenDelegPair -> KeyHash GenesisDelegate
genDelegKeyHash (GenDelegPair -> AllIssuerKeys c GenesisDelegate)
-> [GenDelegPair] -> [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_)

  pot <- QC.elements [ReservesMIR, TreasuryMIR]
  let Coin available = availableAfterMIR pot accountState (dsIRewards delegSt)
  amount <- if available > 0 then QC.choose (0, available) else pure 0
  pure $
    if -- Discard this generator (by returning Nothing) if:
    -- we are in full decentralisation mode (d=0) when IR certs are not allowed
    pparams ^. ppDG == minBound
      -- or it's too late in the epoch for IR certs
      || tooLateInEpoch s
      then Nothing
      else
        Just
          ( MirTxCert (MIRCert pot (SendToOppositePotMIR $ Coin amount))
          , DelegateCred (aikCold <$> coreSigners)
          )

genInstantaneousRewards ::
  (EraPParams era, EraAccounts era, ShelleyEraTxCert era, AtMostEra "Babbage" era) =>
  SlotNo ->
  -- | Index over the cold key hashes of all possible Genesis Delegates
  Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate) ->
  PParams era ->
  ChainAccountState ->
  DState era ->
  Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewards :: forall era c.
(EraPParams era, EraAccounts era, ShelleyEraTxCert era,
 AtMostEra "Babbage" era) =>
SlotNo
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> ChainAccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewards SlotNo
slot Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
genesisDelegatesByHash PParams era
pparams ChainAccountState
accountState DState era
delegSt =
  if ProtVer -> Bool
hardforkAlonzoAllowMIRTransfer (PParams era
pparams 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)
    then
      [Gen (Maybe (TxCert era, CertCred era))]
-> Gen (Maybe (TxCert era, CertCred era))
forall a. HasCallStack => [Gen a] -> Gen a
QC.oneof
        [ SlotNo
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> ChainAccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
forall era c.
(EraPParams era, EraAccounts era, ShelleyEraTxCert era,
 AtMostEra "Babbage" era) =>
SlotNo
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> ChainAccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsAccounts
            SlotNo
slot
            Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
genesisDelegatesByHash
            PParams era
pparams
            ChainAccountState
accountState
            DState era
delegSt
        , SlotNo
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> ChainAccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
forall era c.
(EraPParams era, ShelleyEraTxCert era, AtMostEra "Babbage" era) =>
SlotNo
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> ChainAccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsTransfer
            SlotNo
slot
            Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
genesisDelegatesByHash
            PParams era
pparams
            ChainAccountState
accountState
            DState era
delegSt
        ]
    else
      SlotNo
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> ChainAccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
forall era c.
(EraPParams era, EraAccounts era, ShelleyEraTxCert era,
 AtMostEra "Babbage" era) =>
SlotNo
-> Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
-> PParams era
-> ChainAccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsAccounts
        SlotNo
slot
        Map (KeyHash GenesisDelegate) (AllIssuerKeys c GenesisDelegate)
genesisDelegatesByHash
        PParams era
pparams
        ChainAccountState
accountState
        DState era
delegSt