{-# 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 Control.SetAlgebra (dom, domain, eval, (∈))
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 Data.Set ((\\))
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 => 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 -> StakeCredential
scriptToCred' = ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> StakeCredential)
-> (Script era -> ScriptHash) -> Script era -> StakeCredential
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraScript era => Script era -> ScriptHash
hashScript @era
      notRegistered :: StakeCredential -> Bool
notRegistered StakeCredential
cred = Bool -> Bool
not (StakeCredential -> Accounts era -> Bool
forall era.
EraAccounts era =>
StakeCredential -> Accounts era -> Bool
isAccountRegistered StakeCredential
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 (StakeCredential -> Bool
notRegistered (StakeCredential -> Bool)
-> ((KeyPair Payment, KeyPair Staking) -> StakeCredential)
-> (KeyPair Payment, KeyPair Staking)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair Staking -> StakeCredential
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential (KeyPair Staking -> StakeCredential)
-> ((KeyPair Payment, KeyPair Staking) -> KeyPair Staking)
-> (KeyPair Payment, KeyPair Staking)
-> StakeCredential
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 (StakeCredential -> Bool
notRegistered (StakeCredential -> Bool)
-> ((Script era, Script era) -> StakeCredential)
-> (Script era, Script era)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script era -> StakeCredential
scriptToCred' (Script era -> StakeCredential)
-> ((Script era, Script era) -> Script era)
-> (Script era, Script era)
-> StakeCredential
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 -> StakeCredential
scriptToCred' = ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> StakeCredential)
-> (Script era -> ScriptHash) -> Script era -> StakeCredential
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraScript era => Script era -> ScriptHash
hashScript @era
    registered :: StakeCredential -> Bool
registered StakeCredential
cred = StakeCredential -> Accounts era -> Bool
forall era.
EraAccounts era =>
StakeCredential -> Accounts era -> Bool
isAccountRegistered StakeCredential
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 :: StakeCredential
cred = KeyPair Staking -> StakeCredential
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential KeyPair Staking
k
             in (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> (StakeCredential -> Bool) -> StakeCredential -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StakeCredential -> Bool
registered (StakeCredential -> Bool -> Bool)
-> (StakeCredential -> Bool) -> StakeCredential -> Bool
forall a b.
(StakeCredential -> a -> b)
-> (StakeCredential -> a) -> StakeCredential -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StakeCredential -> Bool
zeroRewards) StakeCredential
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 :: StakeCredential
cred = Script era -> StakeCredential
scriptToCred' Script era
s
             in (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> (StakeCredential -> Bool) -> StakeCredential -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StakeCredential -> Bool
registered (StakeCredential -> Bool -> Bool)
-> (StakeCredential -> Bool) -> StakeCredential -> Bool
forall a b.
(StakeCredential -> a -> b)
-> (StakeCredential -> a) -> StakeCredential -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StakeCredential -> Bool
zeroRewards) StakeCredential
cred
        )
        [(Script era, Script era)]
scripts
    zeroRewards :: StakeCredential -> Bool
zeroRewards StakeCredential
cred =
      case StakeCredential -> Accounts era -> Maybe (AccountState era)
forall era.
EraAccounts era =>
StakeCredential -> Accounts era -> Maybe (AccountState era)
lookupAccountState StakeCredential
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 -> StakeCredential
scriptToCred' = ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> StakeCredential)
-> (Script era -> ScriptHash) -> Script era -> StakeCredential
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 = StakeCredential -> KeyHash StakePool -> TxCert era
forall era.
ShelleyEraTxCert era =>
StakeCredential -> KeyHash StakePool -> TxCert era
DelegStakeTxCert (KeyPair Staking -> StakeCredential
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 =
            StakeCredential -> KeyHash StakePool -> TxCert era
forall era.
ShelleyEraTxCert era =>
StakeCredential -> KeyHash StakePool -> TxCert era
DelegStakeTxCert (Script era -> StakeCredential
scriptToCred' Script era
delegatorScript) KeyHash StakePool
poolKey
      registeredDelegate :: StakeCredential -> Bool
registeredDelegate StakeCredential
cred = StakeCredential -> Accounts era -> Bool
forall era.
EraAccounts era =>
StakeCredential -> Accounts era -> Bool
isAccountRegistered StakeCredential
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 (StakeCredential -> Bool
registeredDelegate (StakeCredential -> Bool)
-> ((KeyPair Payment, KeyPair Staking) -> StakeCredential)
-> (KeyPair Payment, KeyPair Staking)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair Staking -> StakeCredential
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential (KeyPair Staking -> StakeCredential)
-> ((KeyPair Payment, KeyPair Staking) -> KeyPair Staking)
-> (KeyPair Payment, KeyPair Staking)
-> StakeCredential
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 (StakeCredential -> Bool
registeredDelegate (StakeCredential -> Bool)
-> ((Script era, Script era) -> StakeCredential)
-> (Script era, Script era)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script era -> StakeCredential
scriptToCred' (Script era -> StakeCredential)
-> ((Script era, Script era) -> Script era)
-> (Script era, Script era)
-> StakeCredential
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 = Set (KeyHash StakePool) -> [KeyHash StakePool]
forall a. Set a -> [a]
Set.toList (Set (KeyHash StakePool) -> [KeyHash StakePool])
-> Set (KeyHash StakePool) -> [KeyHash StakePool]
forall a b. (a -> b) -> a -> b
$ Map (KeyHash StakePool) StakePoolState -> Set (KeyHash StakePool)
forall k v. Ord k => Map k v -> Set k
forall (f :: * -> * -> *) k v. (Basic f, Ord k) => f k v -> Set k
domain 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 = Exp Bool -> Bool
forall s t. Embed s t => Exp t -> s
eval (KeyHash GenesisRole
k KeyHash GenesisRole
-> Exp (Sett (KeyHash GenesisRole) ()) -> Exp Bool
forall k (g :: * -> * -> *) s.
(Show k, Ord k, Iter g, HasExp s (g k ())) =>
k -> s -> Exp Bool
∈ Map (KeyHash GenesisRole) GenDelegPair
-> Exp (Sett (KeyHash GenesisRole) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom 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 -> StakeCredential -> RewardAccount
RewardAccount Network
Testnet (StakeCredential -> RewardAccount)
-> StakeCredential -> RewardAccount
forall a b. (a -> b) -> a -> b
$ KeyHash Staking -> StakeCredential
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> StakeCredential)
-> KeyHash Staking -> StakeCredential
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 era
pState 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
    stakePools :: Map (KeyHash StakePool) StakePoolState
stakePools = PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools PState era
pState
    registered_ :: Set (KeyHash StakePool)
registered_ = Exp (Sett (KeyHash StakePool) ()) -> Set (KeyHash StakePool)
forall s t. Embed s t => Exp t -> s
eval (Map (KeyHash StakePool) StakePoolState
-> Exp (Sett (KeyHash StakePool) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (KeyHash StakePool) StakePoolState
stakePools)
    retiring_ :: Set (KeyHash StakePool)
retiring_ = Map (KeyHash StakePool) EpochNo -> Set (KeyHash StakePool)
forall k v. Ord k => Map k v -> Set k
forall (f :: * -> * -> *) k v. (Basic f, Ord k) => f k v -> Set k
domain (PState era -> Map (KeyHash StakePool) EpochNo
forall era. PState era -> Map (KeyHash StakePool) EpochNo
psRetiring PState era
pState)
    retireable :: [KeyHash StakePool]
retireable = Set (KeyHash StakePool) -> [KeyHash StakePool]
forall a. Set a -> [a]
Set.toList (Set (KeyHash StakePool)
registered_ Set (KeyHash StakePool)
-> Set (KeyHash StakePool) -> Set (KeyHash StakePool)
forall a. Ord a => Set a -> Set a -> Set a
\\ Set (KeyHash StakePool)
retiring_)
    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 StakeCredential (AccountState era)
accountsMap = DState era
delegSt DState era
-> Getting
     (Map StakeCredential (AccountState era))
     (DState era)
     (Map StakeCredential (AccountState era))
-> Map StakeCredential (AccountState era)
forall s a. s -> Getting a s a -> a
^. (Accounts era
 -> Const (Map StakeCredential (AccountState era)) (Accounts era))
-> DState era
-> Const (Map StakeCredential (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 StakeCredential (AccountState era)) (Accounts era))
 -> DState era
 -> Const (Map StakeCredential (AccountState era)) (DState era))
-> ((Map StakeCredential (AccountState era)
     -> Const
          (Map StakeCredential (AccountState era))
          (Map StakeCredential (AccountState era)))
    -> Accounts era
    -> Const (Map StakeCredential (AccountState era)) (Accounts era))
-> Getting
     (Map StakeCredential (AccountState era))
     (DState era)
     (Map StakeCredential (AccountState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map StakeCredential (AccountState era)
 -> Const
      (Map StakeCredential (AccountState era))
      (Map StakeCredential (AccountState era)))
-> Accounts era
-> Const (Map StakeCredential (AccountState era)) (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map StakeCredential (AccountState era))
Lens' (Accounts era) (Map StakeCredential (AccountState era))
accountsMapL
  winnerCreds <-
    Int -> [StakeCredential] -> [StakeCredential]
forall a. Int -> [a] -> [a]
take
      (Int -> [StakeCredential] -> [StakeCredential])
-> Gen Int -> Gen ([StakeCredential] -> [StakeCredential])
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 StakeCredential (AccountState era) -> Int
forall k a. Map k a -> Int
Map.size Map StakeCredential (AccountState era)
accountsMap Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
      Gen ([StakeCredential] -> [StakeCredential])
-> Gen [StakeCredential] -> Gen [StakeCredential]
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [StakeCredential] -> Gen [StakeCredential]
forall a. [a] -> Gen [a]
QC.shuffle (Map StakeCredential (AccountState era) -> [StakeCredential]
forall k a. Map k a -> [k]
Map.keys Map StakeCredential (AccountState era)
accountsMap)
  coins <- replicateM (length winnerCreds) $ genInteger 1 1000
  let credCoinMap = [(StakeCredential, DeltaCoin)] -> Map StakeCredential DeltaCoin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(StakeCredential, DeltaCoin)] -> Map StakeCredential DeltaCoin)
-> [(StakeCredential, DeltaCoin)] -> Map StakeCredential DeltaCoin
forall a b. (a -> b) -> a -> b
$ [StakeCredential] -> [DeltaCoin] -> [(StakeCredential, DeltaCoin)]
forall a b. [a] -> [b] -> [(a, b)]
zip [StakeCredential]
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 StakeCredential DeltaCoin -> [DeltaCoin]
forall k a. Map k a -> [a]
Map.elems Map StakeCredential 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