{-# 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.API (
  ChainAccountState (..),
  Coin (..),
  Credential (..),
  DState (..),
  GenDelegPair (..),
  GenDelegs (..),
  Network (..),
  PState (..),
  PoolParams (..),
  StrictMaybe (..),
  VKey,
 )
import Cardano.Ledger.Shelley.Core
import qualified Cardano.Ledger.Shelley.HardForks as HardForks
import Cardano.Ledger.Shelley.LedgerState (
  availableAfterMIR,
  dsFutureGenDelegsL,
  dsGenDelegsL,
  rewards,
 )
import Cardano.Ledger.Slot (EpochNo (EpochNo), SlotNo)
import Cardano.Ledger.State (EraCertState (..))
import qualified Cardano.Ledger.UMap as UM
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 (elems, fromList, lookup)
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, ProtVerAtMost era 8, 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, ProtVerAtMost era 8, 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 'Genesis, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes :: [(KeyPair 'Genesis, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes :: forall c era.
KeySpace c era
-> [(KeyPair 'Genesis, 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) =>
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 'Genesis, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
forall era c.
(Era era, ShelleyEraTxCert era, ProtVerAtMost era 8,
 EraCertState era, Crypto c) =>
[(KeyPair 'Genesis, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
genGenesisDelegation [(KeyPair 'Genesis, 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, 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, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
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) =>
  Constants ->
  KeyPairs ->
  [(Script era, Script era)] ->
  DState era ->
  Gen (Maybe (TxCert era, CertCred era))
genRegKeyCert :: forall era.
(EraScript era, ShelleyEraTxCert 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
              (KeyPair 'Payment
_payKey, KeyPair 'Staking
stakeKey) <- KeyPairs -> Gen (KeyPair 'Payment, KeyPair 'Staking)
forall a. HasCallStack => [a] -> Gen a
QC.elements KeyPairs
availableKeys
              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)
 -> Gen (Maybe (TxCert era, CertCred era)))
-> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a b. (a -> b) -> a -> b
$
                (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just
                  ( StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert (KeyPair 'Staking -> StakeCredential
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential KeyPair 'Staking
stakeKey)
                  , CertCred era
forall era. CertCred era
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
              (Script era
_, Script era
stakeScript) <- [(Script era, Script era)] -> Gen (Script era, Script era)
forall a. HasCallStack => [a] -> Gen a
QC.elements [(Script era, Script era)]
availableScripts
              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)
 -> Gen (Maybe (TxCert era, CertCred era)))
-> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a b. (a -> b) -> a -> b
$
                (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just
                  ( StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert (Script era -> StakeCredential
scriptToCred' Script era
stakeScript)
                  , CertCred era
forall era. CertCred era
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
k = StakeCredential -> UView StakeCredential RDPair -> Bool
forall k v. k -> UView k v -> Bool
UM.notMember StakeCredential
k (DState era -> UView StakeCredential RDPair
forall era. DState era -> UView StakeCredential RDPair
rewards DState era
delegSt)
      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, ShelleyEraTxCert era) =>
  Constants ->
  KeyPairs ->
  [(Script era, Script era)] ->
  DState era ->
  Gen (Maybe (TxCert era, CertCred era))
genDeRegKeyCert :: forall era.
(EraScript 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
            (KeyPair 'Payment
_payKey, KeyPair 'Staking
stakeKey) <- KeyPairs -> Gen (KeyPair 'Payment, KeyPair 'Staking)
forall a. HasCallStack => [a] -> Gen a
QC.elements KeyPairs
availableKeys
            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)
 -> Gen (Maybe (TxCert era, CertCred era)))
-> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a b. (a -> b) -> a -> b
$ (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just (StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert (KeyPair 'Staking -> StakeCredential
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential KeyPair 'Staking
stakeKey), KeyPair 'Staking -> CertCred era
forall era. KeyPair 'Staking -> CertCred era
StakeCred KeyPair 'Staking
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 :: (Script era, Script era)
scriptPair@(Script era
_, Script era
stakeScript) <- [(Script era, Script era)] -> Gen (Script era, Script era)
forall a. HasCallStack => [a] -> Gen a
QC.elements [(Script era, Script era)]
availableScripts
            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)
 -> Gen (Maybe (TxCert era, CertCred era)))
-> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a b. (a -> b) -> a -> b
$
              (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just
                ( StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert (Script era -> StakeCredential
scriptToCred' Script era
stakeScript)
                , (Script era, Script era) -> CertCred era
forall era. (Script era, Script era) -> CertCred era
ScriptCred (Script era, Script era)
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
k = StakeCredential -> UView StakeCredential RDPair -> Bool
forall k v. k -> UView k v -> Bool
UM.member StakeCredential
k (DState era -> UView StakeCredential RDPair
forall era. DState era -> UView StakeCredential RDPair
rewards DState era
dState)
    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
k = case StakeCredential -> UView StakeCredential RDPair -> Maybe RDPair
forall k v. k -> UView k v -> Maybe v
UM.lookup (RewardAccount -> StakeCredential
raCredential (RewardAccount -> StakeCredential)
-> RewardAccount -> StakeCredential
forall a b. (a -> b) -> a -> b
$ Network -> StakeCredential -> RewardAccount
RewardAccount Network
Testnet StakeCredential
k) (DState era -> UView StakeCredential RDPair
forall era. DState era -> UView StakeCredential RDPair
rewards DState era
dState) of
      Maybe RDPair
Nothing -> Bool
False
      Just (UM.RDPair CompactForm Coin
ccoin CompactForm Coin
_) -> CompactForm Coin
ccoin CompactForm Coin -> CompactForm Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> CompactForm Coin
UM.CompactCoin Word64
0

-- | 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 ...),
 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
k = StakeCredential -> UView StakeCredential RDPair -> Bool
forall k v. k -> UView k v -> Bool
UM.member StakeCredential
k (DState era -> UView StakeCredential RDPair
forall era. DState era -> UView StakeCredential RDPair
rewards (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))
      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) PoolParams
registeredPools = PState era -> Map (KeyHash 'StakePool) PoolParams
forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams (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) PoolParams -> 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) PoolParams
registeredPools

genGenesisDelegation ::
  forall era c.
  (Era era, ShelleyEraTxCert era, ProtVerAtMost era 8, 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, ProtVerAtMost era 8,
 EraCertState era, Crypto c) =>
[(KeyPair 'Genesis, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
genGenesisDelegation [(KeyPair 'Genesis, AllIssuerKeys c 'GenesisDelegate)]
coreNodes [AllIssuerKeys c 'GenesisDelegate]
delegateKeys CertState era
dpState =
  if [KeyPair 'Genesis] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KeyPair 'Genesis]
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
      KeyPair 'Genesis
gk <- [KeyPair 'Genesis] -> Gen (KeyPair 'Genesis)
forall a. HasCallStack => [a] -> Gen a
QC.elements [KeyPair 'Genesis]
genesisDelegators
      AllIssuerKeys {KeyPair 'GenesisDelegate
aikCold :: KeyPair 'GenesisDelegate
aikCold :: forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold, VRFKeyPair c
aikVrf :: VRFKeyPair c
aikVrf :: forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf} <- [AllIssuerKeys c 'GenesisDelegate]
-> Gen (AllIssuerKeys c 'GenesisDelegate)
forall a. HasCallStack => [a] -> Gen a
QC.elements [AllIssuerKeys c 'GenesisDelegate]
availableDelegatees
      case KeyHash 'Genesis
-> Map (KeyHash 'Genesis) GenDelegPair -> Maybe GenDelegPair
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (KeyPair 'Genesis -> KeyHash 'Genesis
forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey KeyPair 'Genesis
gk) Map (KeyHash 'Genesis) GenDelegPair
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 'Genesis
-> KeyPair 'GenesisDelegate
-> VerKeyVRF (VRF c)
-> Maybe (TxCert era, CertCred era)
mkCert KeyPair 'Genesis
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 'Genesis, AllIssuerKeys c 'GenesisDelegate)
-> AllIssuerKeys c 'GenesisDelegate
forall a b. (a, b) -> b
snd ((KeyPair 'Genesis, AllIssuerKeys c 'GenesisDelegate)
 -> AllIssuerKeys c 'GenesisDelegate)
-> [(KeyPair 'Genesis, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(KeyPair 'Genesis, 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 'Genesis
-> KeyPair 'GenesisDelegate
-> VerKeyVRF (VRF c)
-> Maybe (TxCert era, CertCred era)
mkCert KeyPair 'Genesis
gkey KeyPair 'GenesisDelegate
key VerKeyVRF (VRF c)
vrf =
      (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just
        ( KeyHash 'Genesis
-> KeyHash 'GenesisDelegate
-> VRFVerKeyHash 'GenDelegVRF
-> TxCert era
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
KeyHash 'Genesis
-> KeyHash 'GenesisDelegate
-> VRFVerKeyHash 'GenDelegVRF
-> TxCert era
GenesisDelegTxCert
            (KeyPair 'Genesis -> KeyHash 'Genesis
forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey KeyPair 'Genesis
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 'Genesis] -> CertCred era
forall era. [KeyPair 'Genesis] -> CertCred era
CoreKeyCred [KeyPair 'Genesis
gkey]
        )
    GenDelegs Map (KeyHash 'Genesis) 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 'Genesis -> Bool
genesisDelegator KeyHash 'Genesis
k = Exp Bool -> Bool
forall s t. Embed s t => Exp t -> s
eval (KeyHash 'Genesis
k KeyHash 'Genesis -> Exp (Sett (KeyHash 'Genesis) ()) -> Exp Bool
forall k (g :: * -> * -> *) s.
(Show k, Ord k, Iter g, HasExp s (g k ())) =>
k -> s -> Exp Bool
∈ Map (KeyHash 'Genesis) GenDelegPair
-> Exp (Sett (KeyHash 'Genesis) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (KeyHash 'Genesis) GenDelegPair
genDelegs_)
    genesisDelegators :: [KeyPair 'Genesis]
genesisDelegators = (KeyPair 'Genesis -> Bool)
-> [KeyPair 'Genesis] -> [KeyPair 'Genesis]
forall a. (a -> Bool) -> [a] -> [a]
filter (KeyHash 'Genesis -> Bool
genesisDelegator (KeyHash 'Genesis -> Bool)
-> (KeyPair 'Genesis -> KeyHash 'Genesis)
-> KeyPair 'Genesis
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair 'Genesis -> KeyHash 'Genesis
forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey) ((KeyPair 'Genesis, AllIssuerKeys c 'GenesisDelegate)
-> KeyPair 'Genesis
forall a b. (a, b) -> a
fst ((KeyPair 'Genesis, AllIssuerKeys c 'GenesisDelegate)
 -> KeyPair 'Genesis)
-> [(KeyPair 'Genesis, AllIssuerKeys c 'GenesisDelegate)]
-> [KeyPair 'Genesis]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(KeyPair 'Genesis, 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 'Genesis) GenDelegPair -> [GenDelegPair]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'Genesis) 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 (PoolParams, KeyPair 'StakePool)
genStakePool :: forall c.
Crypto c =>
[AllIssuerKeys c 'StakePool]
-> KeyPairs -> Coin -> Gen (PoolParams, KeyPair 'StakePool)
genStakePool [AllIssuerKeys c 'StakePool]
poolKeys KeyPairs
skeys (Coin Integer
minPoolCost) =
  AllIssuerKeys c 'StakePool
-> Coin
-> Coin
-> Nat
-> VKey 'Staking
-> (PoolParams, KeyPair 'StakePool)
mkPoolParams
    (AllIssuerKeys c 'StakePool
 -> Coin
 -> Coin
 -> Nat
 -> VKey 'Staking
 -> (PoolParams, KeyPair 'StakePool))
-> Gen (AllIssuerKeys c 'StakePool)
-> Gen
     (Coin
      -> Coin
      -> Nat
      -> VKey 'Staking
      -> (PoolParams, 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
   -> (PoolParams, KeyPair 'StakePool))
-> Gen Coin
-> Gen
     (Coin -> Nat -> VKey 'Staking -> (PoolParams, 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 -> (PoolParams, KeyPair 'StakePool))
-> Gen Coin
-> Gen (Nat -> VKey 'Staking -> (PoolParams, 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 -> (PoolParams, KeyPair 'StakePool))
-> Gen Nat
-> Gen (VKey 'Staking -> (PoolParams, 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 -> (PoolParams, KeyPair 'StakePool))
-> Gen (VKey 'Staking) -> Gen (PoolParams, 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
    mkPoolParams ::
      AllIssuerKeys c 'StakePool ->
      Coin ->
      Coin ->
      Natural ->
      VKey 'Staking ->
      (PoolParams, KeyPair 'StakePool)
    mkPoolParams :: AllIssuerKeys c 'StakePool
-> Coin
-> Coin
-> Nat
-> VKey 'Staking
-> (PoolParams, KeyPair 'StakePool)
mkPoolParams 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
          pps :: PoolParams
pps =
            KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF
-> Coin
-> Coin
-> UnitInterval
-> RewardAccount
-> Set (KeyHash 'Staking)
-> StrictSeq StakePoolRelay
-> StrictMaybe PoolMetadata
-> PoolParams
PoolParams
              (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 (PoolParams
pps, 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
  (PoolParams
pps, KeyPair 'StakePool
poolKey) <- [AllIssuerKeys c 'StakePool]
-> KeyPairs -> Coin -> Gen (PoolParams, KeyPair 'StakePool)
forall c.
Crypto c =>
[AllIssuerKeys c 'StakePool]
-> KeyPairs -> Coin -> Gen (PoolParams, KeyPair 'StakePool)
genStakePool [AllIssuerKeys c 'StakePool]
poolKeys KeyPairs
keyPairs Coin
minPoolCost
  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)
 -> Gen (Maybe (TxCert era, CertCred era)))
-> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a b. (a -> b) -> a -> b
$ (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just (PoolParams -> TxCert era
forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert PoolParams
pps, KeyPair 'StakePool -> CertCred era
forall era. KeyPair 'StakePool -> CertCred era
PoolCred KeyPair 'StakePool
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) PoolParams
stakePools = PState era -> Map (KeyHash 'StakePool) PoolParams
forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams 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) PoolParams
-> Exp (Sett (KeyHash 'StakePool) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (KeyHash 'StakePool) PoolParams
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, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
  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, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
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 'Genesis) 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)
      credentials :: UView StakeCredential RDPair
credentials = DState era -> UView StakeCredential RDPair
forall era. DState era -> UView StakeCredential RDPair
rewards DState era
delegSt
  [StakeCredential]
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
$ UView StakeCredential RDPair -> Int
forall k v. UView k v -> Int
UM.size UView StakeCredential RDPair
credentials 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 (Set StakeCredential -> [StakeCredential]
forall a. Set a -> [a]
Set.toList (UView StakeCredential RDPair -> Set StakeCredential
forall k v. UView k v -> Set k
UM.domain UView StakeCredential RDPair
credentials))
  [Integer]
coins <- Int -> Gen Integer -> Gen [Integer]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([StakeCredential] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StakeCredential]
winnerCreds) (Gen Integer -> Gen [Integer]) -> Gen Integer -> Gen [Integer]
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Gen Integer
genInteger Integer
1 Integer
1000
  let credCoinMap :: Map StakeCredential DeltaCoin
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)

  [AllIssuerKeys c 'GenesisDelegate]
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 'Genesis) GenDelegPair -> Int
forall a. Map (KeyHash 'Genesis) a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map (KeyHash 'Genesis) 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 'Genesis) GenDelegPair -> [GenDelegPair]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'Genesis) GenDelegPair
genDelegs_)

  MIRPot
pot <- [MIRPot] -> Gen MIRPot
forall a. HasCallStack => [a] -> Gen a
QC.elements [MIRPot
ReservesMIR, MIRPot
TreasuryMIR]
  let available :: Coin
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
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 :: Bool
insufficientFunds = Coin -> DeltaCoin
toDeltaCoin Coin
available DeltaCoin -> DeltaCoin -> Bool
forall a. Ord a => a -> a -> Bool
< DeltaCoin
rewardAmount
  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)
 -> Gen (Maybe (TxCert era, CertCred era)))
-> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a b. (a -> b) -> a -> b
$
    if -- Discard this generator (by returning Nothing) if:
    -- we are in full decentralisation mode (d=0) when IR certs are not allowed
    PParams era
pparams PParams era
-> Getting UnitInterval (PParams era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams era) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams era) UnitInterval
ppDG UnitInterval -> UnitInterval -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInterval
forall a. Bounded a => a
minBound
      -- or when we don't have keys available for generating an IR cert
      Bool -> Bool -> Bool
|| Map StakeCredential DeltaCoin -> Bool
forall a. Map StakeCredential a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map StakeCredential DeltaCoin
credCoinMap
      -- or it's too late in the epoch for IR certs
      Bool -> Bool -> Bool
|| SlotNo -> Bool
tooLateInEpoch SlotNo
s
      -- or the rewards exceed the pot amount
      Bool -> Bool -> Bool
|| Bool
insufficientFunds
      then Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
      else
        (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just
          ( MIRCert -> TxCert era
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
MIRCert -> TxCert era
MirTxCert (MIRPot -> MIRTarget -> MIRCert
MIRCert MIRPot
pot (Map StakeCredential DeltaCoin -> MIRTarget
StakeAddressesMIR Map StakeCredential DeltaCoin
credCoinMap))
          , [KeyPair 'GenesisDelegate] -> CertCred era
forall era. [KeyPair 'GenesisDelegate] -> CertCred era
DelegateCred (AllIssuerKeys c 'GenesisDelegate -> KeyPair 'GenesisDelegate
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold (AllIssuerKeys c 'GenesisDelegate -> KeyPair 'GenesisDelegate)
-> [AllIssuerKeys c 'GenesisDelegate] -> [KeyPair 'GenesisDelegate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AllIssuerKeys c 'GenesisDelegate]
coreSigners)
          )

-- | Generate an InstantaneousRewards Transfer
genInstantaneousRewardsTransfer ::
  (EraPParams era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
  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, ProtVerAtMost era 8) =>
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 'Genesis) 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)

  [AllIssuerKeys c 'GenesisDelegate]
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 'Genesis) GenDelegPair -> Int
forall a. Map (KeyHash 'Genesis) a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map (KeyHash 'Genesis) 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 'Genesis) GenDelegPair -> [GenDelegPair]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'Genesis) GenDelegPair
genDelegs_)

  MIRPot
pot <- [MIRPot] -> Gen MIRPot
forall a. HasCallStack => [a] -> Gen a
QC.elements [MIRPot
ReservesMIR, MIRPot
TreasuryMIR]
  let Coin Integer
available = MIRPot -> ChainAccountState -> InstantaneousRewards -> Coin
availableAfterMIR MIRPot
pot ChainAccountState
accountState (DState era -> InstantaneousRewards
forall era. DState era -> InstantaneousRewards
dsIRewards DState era
delegSt)
  Integer
amount <- if Integer
available Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 then (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
QC.choose (Integer
0, Integer
available) else Integer -> Gen Integer
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
  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)
 -> Gen (Maybe (TxCert era, CertCred era)))
-> Maybe (TxCert era, CertCred era)
-> Gen (Maybe (TxCert era, CertCred era))
forall a b. (a -> b) -> a -> b
$
    if -- Discard this generator (by returning Nothing) if:
    -- we are in full decentralisation mode (d=0) when IR certs are not allowed
    PParams era
pparams PParams era
-> Getting UnitInterval (PParams era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams era) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams era) UnitInterval
ppDG UnitInterval -> UnitInterval -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInterval
forall a. Bounded a => a
minBound
      -- or it's too late in the epoch for IR certs
      Bool -> Bool -> Bool
|| SlotNo -> Bool
tooLateInEpoch SlotNo
s
      then Maybe (TxCert era, CertCred era)
forall a. Maybe a
Nothing
      else
        (TxCert era, CertCred era) -> Maybe (TxCert era, CertCred era)
forall a. a -> Maybe a
Just
          ( MIRCert -> TxCert era
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
MIRCert -> TxCert era
MirTxCert (MIRPot -> MIRTarget -> MIRCert
MIRCert MIRPot
pot (Coin -> MIRTarget
SendToOppositePotMIR (Coin -> MIRTarget) -> Coin -> MIRTarget
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
amount))
          , [KeyPair 'GenesisDelegate] -> CertCred era
forall era. [KeyPair 'GenesisDelegate] -> CertCred era
DelegateCred (AllIssuerKeys c 'GenesisDelegate -> KeyPair 'GenesisDelegate
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold (AllIssuerKeys c 'GenesisDelegate -> KeyPair 'GenesisDelegate)
-> [AllIssuerKeys c 'GenesisDelegate] -> [KeyPair 'GenesisDelegate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AllIssuerKeys c 'GenesisDelegate]
coreSigners)
          )

genInstantaneousRewards ::
  (EraPParams era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
  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, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
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
HardForks.allowMIRTransfer (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, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
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, ProtVerAtMost era 8) =>
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, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
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