{-# 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.CertState (EraCertState (..))
import Cardano.Ledger.Coin (DeltaCoin (..), toDeltaCoin)
import Cardano.Ledger.Keys (coerceKeyRole)
import Cardano.Ledger.Shelley.API (
  AccountState (..),
  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 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,
  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.
  (EraGen era, ProtVerAtMost era 8, EraCertState era) =>
  Constants ->
  KeySpace era ->
  PParams era ->
  AccountState ->
  CertState era ->
  SlotNo ->
  Gen (Maybe (TxCert era, CertCred era))
genTxCert :: forall era.
(EraGen era, ProtVerAtMost era 8, EraCertState era) =>
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, 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
        , forall era.
(Era era, ShelleyEraTxCert era, ProtVerAtMost era 8,
 EraCertState era) =>
[(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 = CertState era
dpState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL
      pState :: PState era
pState = CertState era
dpState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState 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 :: 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 c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential 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 c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential 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 c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential 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 c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential 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, 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 :: 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 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 =
        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 (CertState era
dpState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL))
      availableDelegates :: KeyPairs
availableDelegates = forall a. (a -> Bool) -> [a] -> [a]
filter (StakeCredential -> Bool
registeredDelegate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential 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 (CertState era
dpState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL)
      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, EraCertState era) =>
  -- | 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,
 EraCertState era) =>
[(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_ = CertState era
dpState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) GenDelegs
dsGenDelegsL
    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 (CertState era
dpState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (Map FutureGenDeleg GenDelegPair)
dsFutureGenDelegsL)
    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