{-# 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 (
  AccountState (..),
  CertState (..),
  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, rewards)
import Cardano.Ledger.Slot (EpochNo (EpochNo), SlotNo)
import qualified Cardano.Ledger.UMap as UM
import Cardano.Protocol.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,
  mkCred,
  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.
  (EraGen era, ProtVerAtMost era 8) =>
  Constants ->
  KeySpace era ->
  PParams era ->
  AccountState ->
  CertState era ->
  SlotNo ->
  Gen (Maybe (TxCert era, CertCred era))
genTxCert :: forall era.
(EraGen era, ProtVerAtMost era 8) =>
Constants
-> KeySpace era
-> PParams era
-> AccountState
-> CertState era
-> SlotNo
-> Gen (Maybe (TxCert era, CertCred era))
genTxCert
  c :: Constants
c@( Constants
        { Int
frequencyRegCert :: Constants -> Int
frequencyRegCert :: Int
frequencyRegCert
        , Int
frequencyRegPoolCert :: Constants -> Int
frequencyRegPoolCert :: Int
frequencyRegPoolCert
        , Int
frequencyDelegCert :: Constants -> Int
frequencyDelegCert :: Int
frequencyDelegCert
        , Int
frequencyGenesisDelegationCert :: Constants -> Int
frequencyGenesisDelegationCert :: Int
frequencyGenesisDelegationCert
        , Int
frequencyDeRegKeyCert :: Constants -> Int
frequencyDeRegKeyCert :: Int
frequencyDeRegKeyCert
        , Int
frequencyRetirePoolCert :: Constants -> Int
frequencyRetirePoolCert :: Int
frequencyRetirePoolCert
        , Int
frequencyMIRCert :: Constants -> Int
frequencyMIRCert :: Int
frequencyMIRCert
        }
      )
  KeySpace_
    { [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes :: forall era.
KeySpace era
-> [(GenesisKeyPair MockCrypto,
     AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes
    , KeyPairs
ksKeyPairs :: forall era. KeySpace era -> KeyPairs
ksKeyPairs :: KeyPairs
ksKeyPairs
    , [(Script era, Script era)]
ksMSigScripts :: forall era. KeySpace era -> [(Script era, Script era)]
ksMSigScripts :: [(Script era, Script era)]
ksMSigScripts
    , [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools :: forall era. KeySpace era -> [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools :: [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools
    , [AllIssuerKeys MockCrypto 'GenesisDelegate]
ksGenesisDelegates :: forall era.
KeySpace era -> [AllIssuerKeys MockCrypto 'GenesisDelegate]
ksGenesisDelegates :: [AllIssuerKeys MockCrypto 'GenesisDelegate]
ksGenesisDelegates
    , Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates :: forall era.
KeySpace era
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates :: Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates
    }
  PParams era
pparams
  AccountState
accountState
  CertState era
dpState
  SlotNo
slot =
    forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
      [ (Int
frequencyRegCert, 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, forall era.
(Era era, EraTxCert era) =>
[AllIssuerKeys MockCrypto 'StakePool]
-> KeyPairs -> Coin -> Gen (Maybe (TxCert era, CertCred era))
genRegPool [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools KeyPairs
ksKeyPairs (PParams era
pparams forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppMinPoolCostL))
      , (Int
frequencyDelegCert, forall era.
(EraScript era, ShelleyEraTxCert 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
        , forall era.
(Era era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
[(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
-> [AllIssuerKeys MockCrypto 'GenesisDelegate]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
genGenesisDelegation [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes [AllIssuerKeys MockCrypto 'GenesisDelegate]
ksGenesisDelegates CertState era
dpState
        )
      , (Int
frequencyDeRegKeyCert, 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, forall era.
(EraPParams era, EraTxCert era) =>
PParams era
-> [AllIssuerKeys MockCrypto 'StakePool]
-> PState era
-> SlotNo
-> Gen (Maybe (TxCert era, CertCred era))
genRetirePool PParams era
pparams [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools PState era
pState SlotNo
slot)
      ,
        ( Int
frequencyMIRCert
        , forall era.
(EraPParams era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
SlotNo
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
-> PParams era
-> AccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewards
            SlotNo
slot
            Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates
            PParams era
pparams
            AccountState
accountState
            DState era
dState
        )
      ]
    where
      dState :: DState era
dState = forall era. CertState era -> DState era
certDState CertState era
dpState
      pState :: PState era
pState = forall era. CertState era -> PState era
certPState CertState era
dpState

-- | 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 :: Constants -> Int
frequencyKeyCredReg :: Int
frequencyKeyCredReg, Int
frequencyScriptCredReg :: Constants -> Int
frequencyScriptCredReg :: Int
frequencyScriptCredReg}
  KeyPairs
keys
  [(Script era, Script era)]
scripts
  DState era
delegSt =
    forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
      [
        ( Int
frequencyKeyCredReg
        , case KeyPairs
availableKeys of
            [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            KeyPairs
_ -> do
              (KeyPair 'Payment
_payKey, KeyPair 'Staking
stakeKey) <- forall a. HasCallStack => [a] -> Gen a
QC.elements KeyPairs
availableKeys
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                forall a. a -> Maybe a
Just
                  ( forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert (forall (kr :: KeyRole). KeyPair kr -> Credential kr
mkCred KeyPair 'Staking
stakeKey)
                  , forall era. CertCred era
NoCred
                  )
        )
      ,
        ( Int
frequencyScriptCredReg
        , case [(Script era, Script era)]
availableScripts of
            [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            [(Script era, Script era)]
_ -> do
              (Script era
_, Script era
stakeScript) <- forall a. HasCallStack => [a] -> Gen a
QC.elements [(Script era, Script era)]
availableScripts
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                forall a. a -> Maybe a
Just
                  ( forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert (Script era -> StakeCredential
scriptToCred' Script era
stakeScript)
                  , forall era. CertCred era
NoCred
                  )
        )
      ]
    where
      scriptToCred' :: Script era -> StakeCredential
scriptToCred' = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj 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 = forall k v. k -> UView k v -> Bool
UM.notMember StakeCredential
k (forall era. DState era -> UView StakeCredential RDPair
rewards DState era
delegSt)
      availableKeys :: KeyPairs
availableKeys = forall a. (a -> Bool) -> [a] -> [a]
filter (StakeCredential -> Bool
notRegistered forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole). KeyPair kr -> Credential kr
mkCred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) KeyPairs
keys
      availableScripts :: [(Script era, Script era)]
availableScripts = forall a. (a -> Bool) -> [a] -> [a]
filter (StakeCredential -> Bool
notRegistered forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script era -> StakeCredential
scriptToCred' forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: Constants -> Int
frequencyKeyCredDeReg :: Int
frequencyKeyCredDeReg, Int
frequencyScriptCredDeReg :: Constants -> Int
frequencyScriptCredDeReg :: Int
frequencyScriptCredDeReg} KeyPairs
keys [(Script era, Script era)]
scripts DState era
dState =
  forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
    [
      ( Int
frequencyKeyCredDeReg
      , case KeyPairs
availableKeys of
          [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          KeyPairs
_ -> do
            (KeyPair 'Payment
_payKey, KeyPair 'Staking
stakeKey) <- forall a. HasCallStack => [a] -> Gen a
QC.elements KeyPairs
availableKeys
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert (forall (kr :: KeyRole). KeyPair kr -> Credential kr
mkCred KeyPair 'Staking
stakeKey), forall era. KeyPair 'Staking -> CertCred era
StakeCred KeyPair 'Staking
stakeKey)
      )
    ,
      ( Int
frequencyScriptCredDeReg
      , case [(Script era, Script era)]
availableScripts of
          [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          [(Script era, Script era)]
_ -> do
            scriptPair :: (Script era, Script era)
scriptPair@(Script era
_, Script era
stakeScript) <- forall a. HasCallStack => [a] -> Gen a
QC.elements [(Script era, Script era)]
availableScripts
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
              forall a. a -> Maybe a
Just
                ( forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert (Script era -> StakeCredential
scriptToCred' Script era
stakeScript)
                , forall era. (Script era, Script era) -> CertCred era
ScriptCred (Script era, Script era)
scriptPair
                )
      )
    ]
  where
    scriptToCred' :: Script era -> StakeCredential
scriptToCred' = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj 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 = forall k v. k -> UView k v -> Bool
UM.member StakeCredential
k (forall era. DState era -> UView StakeCredential RDPair
rewards DState era
dState)
    availableKeys :: KeyPairs
availableKeys =
      forall a. (a -> Bool) -> [a] -> [a]
filter
        ( \(KeyPair 'Payment
_, KeyPair 'Staking
k) ->
            let cred :: StakeCredential
cred = forall (kr :: KeyRole). KeyPair kr -> Credential kr
mkCred KeyPair 'Staking
k
             in (Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StakeCredential -> Bool
registered 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 =
      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
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StakeCredential -> Bool
registered 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 forall k v. k -> UView k v -> Maybe v
UM.lookup (RewardAccount -> StakeCredential
raCredential forall a b. (a -> b) -> a -> b
$ Network -> StakeCredential -> RewardAccount
RewardAccount Network
Testnet StakeCredential
k) (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 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) =>
  Constants ->
  KeyPairs ->
  [(Script era, Script era)] ->
  CertState era ->
  Gen (Maybe (TxCert era, CertCred era))
genDelegation :: forall era.
(EraScript era, ShelleyEraTxCert era) =>
Constants
-> KeyPairs
-> [(Script era, Script era)]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
genDelegation
  Constants {Int
frequencyKeyCredDelegation :: Constants -> Int
frequencyKeyCredDelegation :: Int
frequencyKeyCredDelegation, Int
frequencyScriptCredDelegation :: Constants -> Int
frequencyScriptCredDelegation :: Int
frequencyScriptCredDelegation}
  KeyPairs
keys
  [(Script era, Script era)]
scripts
  CertState era
dpState =
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KeyHash 'StakePool]
availablePools
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      else
        forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
          [
            ( Int
frequencyKeyCredDelegation
            , if forall (t :: * -> *) a. Foldable t => t a -> Bool
null KeyPairs
availableDelegates
                then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                else
                  forall {era} {a} {era}.
ShelleyEraTxCert era =>
(a, KeyPair 'Staking)
-> KeyHash 'StakePool -> Maybe (TxCert era, CertCred era)
mkCert
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [a] -> Gen a
QC.elements KeyPairs
availableDelegates
                    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. HasCallStack => [a] -> Gen a
QC.elements [KeyHash 'StakePool]
availablePools
            )
          ,
            ( Int
frequencyScriptCredDelegation
            , if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Script era, Script era)]
availableDelegatesScripts
                then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                else
                  (Script era, Script era)
-> KeyHash 'StakePool -> Maybe (TxCert era, CertCred era)
mkCertFromScript
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [a] -> Gen a
QC.elements [(Script era, Script era)]
availableDelegatesScripts
                    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. HasCallStack => [a] -> Gen a
QC.elements [KeyHash 'StakePool]
availablePools
            )
          ]
    where
      scriptToCred' :: Script era -> StakeCredential
scriptToCred' = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj 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 = forall a. a -> Maybe a
Just (TxCert era
cert, forall era. KeyPair 'Staking -> CertCred era
StakeCred KeyPair 'Staking
delegatorKey)
        where
          cert :: TxCert era
cert = forall era.
ShelleyEraTxCert era =>
StakeCredential -> KeyHash 'StakePool -> TxCert era
DelegStakeTxCert (forall (kr :: KeyRole). KeyPair kr -> Credential kr
mkCred 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 =
        forall a. a -> Maybe a
Just (TxCert era
scriptCert, forall era. (Script era, Script era) -> CertCred era
ScriptCred (Script era
s, Script era
delegatorScript))
        where
          scriptCert :: TxCert era
scriptCert =
            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 = forall k v. k -> UView k v -> Bool
UM.member StakeCredential
k (forall era. DState era -> UView StakeCredential RDPair
rewards (forall era. CertState era -> DState era
certDState CertState era
dpState))
      availableDelegates :: KeyPairs
availableDelegates = forall a. (a -> Bool) -> [a] -> [a]
filter (StakeCredential -> Bool
registeredDelegate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole). KeyPair kr -> Credential kr
mkCred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) KeyPairs
keys
      availableDelegatesScripts :: [(Script era, Script era)]
availableDelegatesScripts =
        forall a. (a -> Bool) -> [a] -> [a]
filter (StakeCredential -> Bool
registeredDelegate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script era -> StakeCredential
scriptToCred' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Script era, Script era)]
scripts
      registeredPools :: Map (KeyHash 'StakePool) PoolParams
registeredPools = forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams (forall era. CertState era -> PState era
certPState CertState era
dpState)
      availablePools :: [KeyHash 'StakePool]
availablePools = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> * -> *) k v. (Basic f, Ord k) => f k v -> Set k
domain Map (KeyHash 'StakePool) PoolParams
registeredPools

genGenesisDelegation ::
  (Era era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
  -- | Core nodes
  [(GenesisKeyPair MockCrypto, AllIssuerKeys MockCrypto 'GenesisDelegate)] ->
  -- | All potential genesis delegate keys
  [AllIssuerKeys MockCrypto 'GenesisDelegate] ->
  CertState era ->
  Gen (Maybe (TxCert era, CertCred era))
genGenesisDelegation :: forall era.
(Era era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
[(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
-> [AllIssuerKeys MockCrypto 'GenesisDelegate]
-> CertState era
-> Gen (Maybe (TxCert era, CertCred era))
genGenesisDelegation [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodes [AllIssuerKeys MockCrypto 'GenesisDelegate]
delegateKeys CertState era
dpState =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenesisKeyPair MockCrypto]
genesisDelegators Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AllIssuerKeys MockCrypto 'GenesisDelegate]
availableDelegatees
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    else do
      GenesisKeyPair MockCrypto
gk <- forall a. HasCallStack => [a] -> Gen a
QC.elements [GenesisKeyPair MockCrypto]
genesisDelegators
      AllIssuerKeys {KeyPair 'GenesisDelegate
aikCold :: forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold :: KeyPair 'GenesisDelegate
aikCold, VRFKeyPair MockCrypto
aikVrf :: forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf :: VRFKeyPair MockCrypto
aikVrf} <- forall a. HasCallStack => [a] -> Gen a
QC.elements [AllIssuerKeys MockCrypto 'GenesisDelegate]
availableDelegatees
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey GenesisKeyPair MockCrypto
gk) Map (KeyHash 'Genesis) GenDelegPair
genDelegs_ of
        Maybe GenDelegPair
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just GenDelegPair
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {era} {era}.
(ProtVerIsInBounds
   "at most"
   era
   8
   (OrdCond (CmpNat (ProtVerLow era) 8) 'True 'True 'False),
 ShelleyEraTxCert era) =>
GenesisKeyPair MockCrypto
-> KeyPair 'GenesisDelegate
-> VerKeyVRF FakeVRF
-> Maybe (TxCert era, CertCred era)
mkCert GenesisKeyPair MockCrypto
gk KeyPair 'GenesisDelegate
aikCold (forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey VRFKeyPair MockCrypto
aikVrf)
  where
    allDelegateKeys :: [AllIssuerKeys MockCrypto 'GenesisDelegate]
allDelegateKeys = (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodes) forall a. Semigroup a => a -> a -> a
<> [AllIssuerKeys MockCrypto 'GenesisDelegate]
delegateKeys
    hashVKey :: KeyPair kd -> KeyHash kd
hashVKey = forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey
    mkCert :: GenesisKeyPair MockCrypto
-> KeyPair 'GenesisDelegate
-> VerKeyVRF FakeVRF
-> Maybe (TxCert era, CertCred era)
mkCert GenesisKeyPair MockCrypto
gkey KeyPair 'GenesisDelegate
key VerKeyVRF FakeVRF
vrf =
      forall a. a -> Maybe a
Just
        ( forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
KeyHash 'Genesis
-> KeyHash 'GenesisDelegate
-> VRFVerKeyHash 'GenDelegVRF
-> TxCert era
GenesisDelegTxCert
            (forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey GenesisKeyPair MockCrypto
gkey)
            (forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey KeyPair 'GenesisDelegate
key)
            (forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @MockCrypto VerKeyVRF FakeVRF
vrf)
        , forall era. [GenesisKeyPair MockCrypto] -> CertCred era
CoreKeyCred [GenesisKeyPair MockCrypto
gkey]
        )
    GenDelegs Map (KeyHash 'Genesis) GenDelegPair
genDelegs_ = forall era. DState era -> GenDelegs
dsGenDelegs forall a b. (a -> b) -> a -> b
$ forall era. CertState era -> DState era
certDState CertState era
dpState
    genesisDelegator :: KeyHash 'Genesis -> Bool
genesisDelegator KeyHash 'Genesis
k = forall s t. Embed s t => Exp t -> s
eval (KeyHash 'Genesis
k forall k (g :: * -> * -> *) s.
(Show k, Ord k, Iter g, HasExp s (g k ())) =>
k -> s -> Exp Bool
∈ forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (KeyHash 'Genesis) GenDelegPair
genDelegs_)
    genesisDelegators :: [GenesisKeyPair MockCrypto]
genesisDelegators = forall a. (a -> Bool) -> [a] -> [a]
filter (KeyHash 'Genesis -> Bool
genesisDelegator forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey) (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
coreNodes)
    activeGenDelegsKeyHashSet :: Set (KeyHash 'GenesisDelegate)
activeGenDelegsKeyHashSet =
      forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ GenDelegPair -> KeyHash 'GenesisDelegate
genDelegKeyHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'Genesis) GenDelegPair
genDelegs_
    futureGenDelegsKeyHashSet :: Set (KeyHash 'GenesisDelegate)
futureGenDelegsKeyHashSet =
      forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ GenDelegPair -> KeyHash 'GenesisDelegate
genDelegKeyHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [a]
Map.elems (forall era. DState era -> Map FutureGenDeleg GenDelegPair
dsFutureGenDelegs forall a b. (a -> b) -> a -> b
$ forall era. CertState era -> DState era
certDState CertState era
dpState)
    notActiveDelegatee :: KeyHash 'GenesisDelegate -> Bool
notActiveDelegatee KeyHash 'GenesisDelegate
k = forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'GenesisDelegate
k forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (KeyHash 'GenesisDelegate)
activeGenDelegsKeyHashSet
    notFutureDelegatee :: KeyHash 'GenesisDelegate -> Bool
notFutureDelegatee KeyHash 'GenesisDelegate
k = forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'GenesisDelegate
k 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 MockCrypto 'GenesisDelegate]
availableDelegatees = forall a. (a -> Bool) -> [a] -> [a]
filter (KeyHash 'GenesisDelegate -> Bool
notDelegatee forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {kd :: KeyRole}. KeyPair kd -> KeyHash kd
hashVKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold) [AllIssuerKeys MockCrypto 'GenesisDelegate]
allDelegateKeys

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

-- | Generate `RegPool` and the key witness.
genRegPool ::
  (Era era, EraTxCert era) =>
  [AllIssuerKeys MockCrypto 'StakePool] ->
  KeyPairs ->
  Coin ->
  Gen (Maybe (TxCert era, CertCred era))
genRegPool :: forall era.
(Era era, EraTxCert era) =>
[AllIssuerKeys MockCrypto 'StakePool]
-> KeyPairs -> Coin -> Gen (Maybe (TxCert era, CertCred era))
genRegPool [AllIssuerKeys MockCrypto 'StakePool]
poolKeys KeyPairs
keyPairs Coin
minPoolCost = do
  (PoolParams
pps, KeyPair 'StakePool
poolKey) <- [AllIssuerKeys MockCrypto 'StakePool]
-> KeyPairs -> Coin -> Gen (PoolParams, KeyPair 'StakePool)
genStakePool [AllIssuerKeys MockCrypto 'StakePool]
poolKeys KeyPairs
keyPairs Coin
minPoolCost
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert PoolParams
pps, 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 MockCrypto 'StakePool] ->
  PState era ->
  SlotNo ->
  Gen (Maybe (TxCert era, CertCred era))
genRetirePool :: forall era.
(EraPParams era, EraTxCert era) =>
PParams era
-> [AllIssuerKeys MockCrypto 'StakePool]
-> PState era
-> SlotNo
-> Gen (Maybe (TxCert era, CertCred era))
genRetirePool PParams era
_pp [AllIssuerKeys MockCrypto 'StakePool]
poolKeys PState era
pState SlotNo
slot =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KeyHash 'StakePool]
retireable
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    else
      ( \KeyHash 'StakePool
keyHash EpochNo
epoch ->
          forall a. a -> Maybe a
Just
            ( forall era.
EraTxCert era =>
KeyHash 'StakePool -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash 'StakePool
keyHash EpochNo
epoch
            , forall era. KeyPair 'StakePool -> CertCred era
PoolCred (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> AllIssuerKeys MockCrypto 'StakePool
lookupHash KeyHash 'StakePool
keyHash)
            )
      )
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [a] -> Gen a
QC.elements [KeyHash 'StakePool]
retireable
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word64 -> EpochNo
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 = forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams PState era
pState
    registered_ :: Set (KeyHash 'StakePool)
registered_ = forall s t. Embed s t => Exp t -> s
eval (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_ = forall (f :: * -> * -> *) k v. (Basic f, Ord k) => f k v -> Set k
domain (forall era. PState era -> Map (KeyHash 'StakePool) EpochNo
psRetiring PState era
pState)
    retireable :: [KeyHash 'StakePool]
retireable = forall a. Set a -> [a]
Set.toList (Set (KeyHash 'StakePool)
registered_ forall a. Ord a => Set a -> Set a -> Set a
\\ Set (KeyHash 'StakePool)
retiring_)
    lookupHash :: KeyHash 'StakePool -> AllIssuerKeys MockCrypto 'StakePool
lookupHash KeyHash 'StakePool
hk' =
      forall a. a -> Maybe a -> a
fromMaybe
        (forall a. HasCallStack => String -> a
error String
"genRetirePool: could not find keyHash")
        (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\AllIssuerKeys MockCrypto 'StakePool
x -> forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash AllIssuerKeys MockCrypto 'StakePool
x forall a. Eq a => a -> a -> Bool
== KeyHash 'StakePool
hk') [AllIssuerKeys MockCrypto 'StakePool]
poolKeys)
    EpochNo Word64
cepoch = SlotNo -> EpochNo
epochFromSlotNo SlotNo
slot
    epochLow :: Word64
epochLow = Word64
cepoch 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 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 MockCrypto 'GenesisDelegate) ->
  PParams era ->
  AccountState ->
  DState era ->
  Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsAccounts :: forall era.
(EraPParams era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
SlotNo
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
-> PParams era
-> AccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsAccounts SlotNo
s Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
genesisDelegatesByHash PParams era
pparams AccountState
accountState DState era
delegSt = do
  let (GenDelegs Map (KeyHash 'Genesis) GenDelegPair
genDelegs_) = forall era. DState era -> GenDelegs
dsGenDelegs DState era
delegSt
      lookupGenDelegate' :: KeyHash 'GenesisDelegate
-> AllIssuerKeys MockCrypto 'GenesisDelegate
lookupGenDelegate' KeyHash 'GenesisDelegate
gk =
        forall a. a -> Maybe a -> a
fromMaybe
          (forall a. HasCallStack => String -> a
error String
"genInstantaneousRewardsAccounts: lookupGenDelegate failed")
          (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'GenesisDelegate
gk Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
genesisDelegatesByHash)
      credentials :: UView StakeCredential RDPair
credentials = forall era. DState era -> UView StakeCredential RDPair
rewards DState era
delegSt
  [StakeCredential]
winnerCreds <-
    forall a. Int -> [a] -> [a]
take
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [a] -> Gen a
QC.elements [Int
0 .. (forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ forall k v. UView k v -> Int
UM.size UView StakeCredential RDPair
credentials forall a. Num a => a -> a -> a
- Int
1)]
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. [a] -> Gen [a]
QC.shuffle (forall a. Set a -> [a]
Set.toList (forall k v. UView k v -> Set k
UM.domain UView StakeCredential RDPair
credentials))
  [Integer]
coins <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [StakeCredential]
winnerCreds) forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Gen Integer
genInteger Integer
1 Integer
1000
  let credCoinMap :: Map StakeCredential DeltaCoin
credCoinMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [StakeCredential]
winnerCreds (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> DeltaCoin
DeltaCoin [Integer]
coins)

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

  MIRPot
pot <- forall a. HasCallStack => [a] -> Gen a
QC.elements [MIRPot
ReservesMIR, MIRPot
TreasuryMIR]
  let available :: Coin
available = MIRPot -> AccountState -> InstantaneousRewards -> Coin
availableAfterMIR MIRPot
pot AccountState
accountState (forall era. DState era -> InstantaneousRewards
dsIRewards DState era
delegSt)
  let rewardAmount :: DeltaCoin
rewardAmount = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map StakeCredential DeltaCoin
credCoinMap
      insufficientFunds :: Bool
insufficientFunds = Coin -> DeltaCoin
toDeltaCoin Coin
available forall a. Ord a => a -> a -> Bool
< DeltaCoin
rewardAmount
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
minBound
      -- or when we don't have keys available for generating an IR cert
      Bool -> Bool -> 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 forall a. Maybe a
Nothing
      else
        forall a. a -> Maybe a
Just
          ( 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))
          , forall era. [KeyPair 'GenesisDelegate] -> CertCred era
DelegateCred (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AllIssuerKeys MockCrypto '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 MockCrypto 'GenesisDelegate) ->
  PParams era ->
  AccountState ->
  DState era ->
  Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsTransfer :: forall era.
(EraPParams era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
SlotNo
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
-> PParams era
-> AccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsTransfer SlotNo
s Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
genesisDelegatesByHash PParams era
pparams AccountState
accountState DState era
delegSt = do
  let (GenDelegs Map (KeyHash 'Genesis) GenDelegPair
genDelegs_) = forall era. DState era -> GenDelegs
dsGenDelegs DState era
delegSt
      lookupGenDelegate' :: KeyHash 'GenesisDelegate
-> AllIssuerKeys MockCrypto 'GenesisDelegate
lookupGenDelegate' KeyHash 'GenesisDelegate
gk =
        forall a. a -> Maybe a -> a
fromMaybe
          (forall a. HasCallStack => String -> a
error String
"genInstantaneousRewardsTransfer: lookupGenDelegate failed")
          (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'GenesisDelegate
gk Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
genesisDelegatesByHash)

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

  MIRPot
pot <- forall a. HasCallStack => [a] -> Gen a
QC.elements [MIRPot
ReservesMIR, MIRPot
TreasuryMIR]
  let Coin Integer
available = MIRPot -> AccountState -> InstantaneousRewards -> Coin
availableAfterMIR MIRPot
pot AccountState
accountState (forall era. DState era -> InstantaneousRewards
dsIRewards DState era
delegSt)
  Integer
amount <- if Integer
available forall a. Ord a => a -> a -> Bool
> Integer
0 then forall a. Random a => (a, a) -> Gen a
QC.choose (Integer
0, Integer
available) else forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
ppDG forall a. Eq a => a -> a -> Bool
== 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 forall a. Maybe a
Nothing
      else
        forall a. a -> Maybe a
Just
          ( forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
MIRCert -> TxCert era
MirTxCert (MIRPot -> MIRTarget -> MIRCert
MIRCert MIRPot
pot (Coin -> MIRTarget
SendToOppositePotMIR forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
amount))
          , forall era. [KeyPair 'GenesisDelegate] -> CertCred era
DelegateCred (forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AllIssuerKeys MockCrypto '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 MockCrypto 'GenesisDelegate) ->
  PParams era ->
  AccountState ->
  DState era ->
  Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewards :: forall era.
(EraPParams era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
SlotNo
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
-> PParams era
-> AccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewards SlotNo
slot Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
genesisDelegatesByHash PParams era
pparams AccountState
accountState DState era
delegSt =
  if ProtVer -> Bool
HardForks.allowMIRTransfer (PParams era
pparams forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL)
    then
      forall a. HasCallStack => [Gen a] -> Gen a
QC.oneof
        [ forall era.
(EraPParams era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
SlotNo
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
-> PParams era
-> AccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsAccounts
            SlotNo
slot
            Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
genesisDelegatesByHash
            PParams era
pparams
            AccountState
accountState
            DState era
delegSt
        , forall era.
(EraPParams era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
SlotNo
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
-> PParams era
-> AccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsTransfer
            SlotNo
slot
            Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
genesisDelegatesByHash
            PParams era
pparams
            AccountState
accountState
            DState era
delegSt
        ]
    else
      forall era.
(EraPParams era, ShelleyEraTxCert era, ProtVerAtMost era 8) =>
SlotNo
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
-> PParams era
-> AccountState
-> DState era
-> Gen (Maybe (TxCert era, CertCred era))
genInstantaneousRewardsAccounts
        SlotNo
slot
        Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
genesisDelegatesByHash
        PParams era
pparams
        AccountState
accountState
        DState era
delegSt