{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Shelley.BenchmarkFunctions (
  ledgerSpendOneUTxO,
  ledgerSpendOneGivenUTxO,
  initUTxO, -- How to precompute env for the UTxO transactions
  ledgerEnv,
  ledgerRegisterStakeKeys,
  ledgerDeRegisterStakeKeys,
  ledgerRewardWithdrawals,
  ledgerStateWithNregisteredKeys, -- How to precompute env for the StakeKey transactions
  ledgerRegisterStakePools,
  ledgerReRegisterStakePools,
  ledgerRetireStakePools,
  ledgerStateWithNregisteredPools, -- How to precompute env for the Stake Pool transactions
  ledgerDelegateManyKeysOnePool,
  ledgerStateWithNkeysMpools, -- How to precompute env for the Stake Delegation transactions
)
where

import Cardano.Ledger.Address (Addr, RewardAccount (..))
import Cardano.Ledger.BaseTypes (
  EpochInterval (..),
  Network (..),
  StrictMaybe (..),
  TxIx,
  inject,
  mkTxIxPartial,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.PoolParams (
  PoolParams (..),
  ppCost,
  ppId,
  ppMargin,
  ppMetadata,
  ppOwners,
  ppPledge,
  ppRelays,
  ppRewardAccount,
  ppVrf,
 )
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  AccountState (..),
  LedgerState (..),
  UTxOState (..),
 )
import Cardano.Ledger.Shelley.Rules (LedgerEnv (..), ShelleyLEDGER)
import Cardano.Ledger.Shelley.Tx (ShelleyTx (..))
import Cardano.Ledger.Shelley.TxBody (ShelleyTxBody (..))
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.Shelley.TxWits (addrWits)
import Cardano.Ledger.Slot (EpochNo (..), SlotNo (..))
import Cardano.Ledger.TxIn (TxIn (..), mkTxInPartial)
import Cardano.Protocol.Crypto (hashVerKeyVRF)
import Control.State.Transition.Extended (TRC (..), applySTS)
import Data.Default (def)
import qualified Data.Map.Strict as Map
import Data.Sequence.Strict (StrictSeq)
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Data.Word (Word64)
import GHC.Stack
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkAddr, mkWitnessesVKey, vKey)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Generator.Core (
  VRFKeyPair (..),
  genesisCoins,
 )
import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen ()
import Test.Cardano.Ledger.Shelley.Utils (
  RawSeed (..),
  mkKeyPair,
  mkKeyPair',
  mkVRFKeyPair,
  runShelleyBase,
  unsafeBoundRational,
 )

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

aliceStake :: KeyPair 'Staking
aliceStake :: KeyPair 'Staking
aliceStake = forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair forall {kd :: KeyRole}. VKey kd
vk SignKeyDSIGN DSIGN
sk
  where
    (SignKeyDSIGN DSIGN
sk, VKey kd
vk) = forall (kd :: KeyRole). RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
mkKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
0 Word64
0 Word64
0 Word64
0 Word64
1)

alicePay :: KeyPair 'Payment
alicePay :: KeyPair 'Payment
alicePay = forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair forall {kd :: KeyRole}. VKey kd
vk SignKeyDSIGN DSIGN
sk
  where
    (SignKeyDSIGN DSIGN
sk, VKey kd
vk) = forall (kd :: KeyRole). RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
mkKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
0 Word64
0 Word64
0 Word64
0 Word64
0)

aliceAddr :: Addr
aliceAddr :: Addr
aliceAddr = (KeyPair 'Payment, KeyPair 'Staking) -> Addr
mkAddr (KeyPair 'Payment
alicePay, KeyPair 'Staking
aliceStake)

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

injcoins :: Integer -> [ShelleyTxOut ShelleyEra]
injcoins :: Integer -> [ShelleyTxOut ShelleyEra]
injcoins Integer
n = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Integer
_ -> forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
100)) [Integer
0 .. Integer
n]

-- Cretae an initial UTxO set with n-many transaction outputs
initUTxO :: Integer -> UTxOState ShelleyEra
initUTxO :: Integer -> UTxOState ShelleyEra
initUTxO Integer
n =
  forall era.
UTxO era
-> Coin
-> Coin
-> GovState era
-> IncrementalStake
-> Coin
-> UTxOState era
UTxOState
    (forall era. TxId -> [TxOut era] -> UTxO era
genesisCoins TxId
genesisId (Integer -> [ShelleyTxOut ShelleyEra]
injcoins Integer
n))
    (Integer -> Coin
Coin Integer
0)
    (Integer -> Coin
Coin Integer
0)
    forall a. Default a => a
def
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty

-- Protocal Parameters used for the benchmarknig tests.
-- Note that the fees and deposits are set to zero for
-- ease of creating transactions.
ppsBench :: (EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) => PParams era
ppsBench :: forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppsBench =
  forall era. EraPParams era => PParams era
emptyPParams
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxBBSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
50000
    forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) UnitInterval
ppDL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
0.5
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) EpochInterval
ppEMaxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
10000
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
0
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word16
ppMaxBHSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word16
10000
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxTxSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
1000000000
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
0
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeBL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
0
    forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
ppMinUTxOValueL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
10
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
0
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppRhoL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
0.0021
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) UnitInterval
ppTauL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
0.2

ledgerEnv :: (EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) => LedgerEnv era
ledgerEnv :: forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv = forall era.
SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams era
-> AccountState
-> Bool
-> LedgerEnv era
LedgerEnv (Word64 -> SlotNo
SlotNo Word64
0) forall a. Maybe a
Nothing forall a. Bounded a => a
minBound forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppsBench (Coin -> Coin -> AccountState
AccountState (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0)) Bool
False

testLEDGER ::
  LedgerState ShelleyEra ->
  ShelleyTx ShelleyEra ->
  LedgerEnv ShelleyEra ->
  ()
testLEDGER :: LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerEnv ShelleyEra -> ()
testLEDGER LedgerState ShelleyEra
initSt ShelleyTx ShelleyEra
tx LedgerEnv ShelleyEra
env = do
  let st :: Either
  (NonEmpty (ShelleyLedgerPredFailure ShelleyEra))
  (LedgerState ShelleyEra)
st = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS @(ShelleyLEDGER ShelleyEra) (forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv ShelleyEra
env, LedgerState ShelleyEra
initSt, ShelleyTx ShelleyEra
tx))
  case Either
  (NonEmpty (ShelleyLedgerPredFailure ShelleyEra))
  (LedgerState ShelleyEra)
st of
    Right LedgerState ShelleyEra
_ -> ()
    Left NonEmpty (ShelleyLedgerPredFailure ShelleyEra)
e -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show NonEmpty (ShelleyLedgerPredFailure ShelleyEra)
e

txbSpendOneUTxO :: ShelleyTxBody ShelleyEra
txbSpendOneUTxO :: ShelleyTxBody ShelleyEra
txbSpendOneUTxO =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [TxId -> TxIx -> TxIn
TxIn TxId
genesisId forall a. Bounded a => a
minBound])
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
10)
        , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
89)
        ]
    )
    forall a. StrictSeq a
StrictSeq.empty
    (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
    (Integer -> Coin
Coin Integer
1)
    (Word64 -> SlotNo
SlotNo Word64
10)
    forall a. StrictMaybe a
SNothing
    forall a. StrictMaybe a
SNothing

txSpendOneUTxO :: ShelleyTx ShelleyEra
txSpendOneUTxO :: ShelleyTx ShelleyEra
txSpendOneUTxO =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    ShelleyTxBody ShelleyEra
txbSpendOneUTxO
    forall a. Monoid a => a
mempty
      { addrWits :: Set (WitVKey 'Witness)
addrWits = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody ShelleyEra
txbSpendOneUTxO) [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay]
      }
    forall a. StrictMaybe a
SNothing

ledgerSpendOneUTxO :: Integer -> ()
ledgerSpendOneUTxO :: Integer -> ()
ledgerSpendOneUTxO Integer
n = LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerEnv ShelleyEra -> ()
testLEDGER (Integer -> LedgerState ShelleyEra
initLedgerState Integer
n) ShelleyTx ShelleyEra
txSpendOneUTxO forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv

ledgerSpendOneGivenUTxO :: UTxOState ShelleyEra -> ()
ledgerSpendOneGivenUTxO :: UTxOState ShelleyEra -> ()
ledgerSpendOneGivenUTxO UTxOState ShelleyEra
state = LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerEnv ShelleyEra -> ()
testLEDGER (forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState ShelleyEra
state forall a. Default a => a
def) ShelleyTx ShelleyEra
txSpendOneUTxO forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv

-- ===========================================================================
--
-- Register a stake keys when there are a lot of registered stake keys
--

-- Create stake key pairs, corresponding to seeds
-- (RawSeed start 0 0 0 0) through (RawSeed end 0 0 0 0)
stakeKeys :: Word64 -> Word64 -> [KeyPair 'Staking]
stakeKeys :: Word64 -> Word64 -> [KeyPair 'Staking]
stakeKeys Word64
start Word64
end = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Word64
w -> forall (kd :: KeyRole). RawSeed -> KeyPair kd
mkKeyPair' (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
w Word64
0 Word64
0 Word64
0 Word64
0)) [Word64
start .. Word64
end]

stakeKeyOne :: KeyPair 'Staking
stakeKeyOne :: KeyPair 'Staking
stakeKeyOne = forall (kd :: KeyRole). RawSeed -> KeyPair kd
mkKeyPair' (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
1 Word64
0 Word64
0 Word64
0 Word64
0)

stakeKeyToCred :: KeyPair 'Staking -> Credential 'Staking
stakeKeyToCred :: KeyPair 'Staking -> Credential 'Staking
stakeKeyToCred = forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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

firstStakeKeyCred :: Credential 'Staking
firstStakeKeyCred :: Credential 'Staking
firstStakeKeyCred = KeyPair 'Staking -> Credential 'Staking
stakeKeyToCred KeyPair 'Staking
stakeKeyOne

-- Create stake key registration certificates
stakeKeyRegistrations :: [KeyPair 'Staking] -> StrictSeq (TxCert ShelleyEra)
stakeKeyRegistrations :: [KeyPair 'Staking] -> StrictSeq (TxCert ShelleyEra)
stakeKeyRegistrations [KeyPair 'Staking]
keys =
  forall a. [a] -> StrictSeq a
StrictSeq.fromList forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
RegTxCert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) [KeyPair 'Staking]
keys

-- Create a transaction body given a sequence of certificates.
-- It spends the genesis coin given by the index ix.
txbFromCerts :: TxIx -> StrictSeq (TxCert ShelleyEra) -> ShelleyTxBody ShelleyEra
txbFromCerts :: TxIx -> StrictSeq (TxCert ShelleyEra) -> ShelleyTxBody ShelleyEra
txbFromCerts TxIx
ix StrictSeq (TxCert ShelleyEra)
regCerts =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [TxId -> TxIx -> TxIn
TxIn TxId
genesisId TxIx
ix])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
100)])
    StrictSeq (TxCert ShelleyEra)
regCerts
    (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
    (Integer -> Coin
Coin Integer
0)
    (Word64 -> SlotNo
SlotNo Word64
10)
    forall a. StrictMaybe a
SNothing
    forall a. StrictMaybe a
SNothing

makeSimpleTx ::
  ShelleyTxBody ShelleyEra ->
  [KeyPair 'Witness] ->
  ShelleyTx ShelleyEra
makeSimpleTx :: ShelleyTxBody ShelleyEra
-> [KeyPair 'Witness] -> ShelleyTx ShelleyEra
makeSimpleTx ShelleyTxBody ShelleyEra
txbody [KeyPair 'Witness]
keysAddr =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    ShelleyTxBody ShelleyEra
txbody
    forall a. Monoid a => a
mempty
      { addrWits :: Set (WitVKey 'Witness)
addrWits = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody ShelleyEra
txbody) [KeyPair 'Witness]
keysAddr
      }
    forall a. StrictMaybe a
SNothing

-- Create a transaction that registers stake credentials.
txRegStakeKeys :: TxIx -> [KeyPair 'Staking] -> ShelleyTx ShelleyEra
txRegStakeKeys :: TxIx -> [KeyPair 'Staking] -> ShelleyTx ShelleyEra
txRegStakeKeys TxIx
ix [KeyPair 'Staking]
keys =
  ShelleyTxBody ShelleyEra
-> [KeyPair 'Witness] -> ShelleyTx ShelleyEra
makeSimpleTx
    (TxIx -> StrictSeq (TxCert ShelleyEra) -> ShelleyTxBody ShelleyEra
txbFromCerts TxIx
ix forall a b. (a -> b) -> a -> b
$ [KeyPair 'Staking] -> StrictSeq (TxCert ShelleyEra)
stakeKeyRegistrations [KeyPair 'Staking]
keys)
    [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay]

initLedgerState :: Integer -> LedgerState ShelleyEra
initLedgerState :: Integer -> LedgerState ShelleyEra
initLedgerState Integer
n = forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState (Integer -> UTxOState ShelleyEra
initUTxO Integer
n) forall a. Default a => a
def

makeLEDGERState ::
  HasCallStack => LedgerState ShelleyEra -> ShelleyTx ShelleyEra -> LedgerState ShelleyEra
makeLEDGERState :: HasCallStack =>
LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerState ShelleyEra
makeLEDGERState LedgerState ShelleyEra
start ShelleyTx ShelleyEra
tx =
  let st :: ReaderT
  Globals
  Identity
  (Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER ShelleyEra)))
     (State (ShelleyLEDGER ShelleyEra)))
st = forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS @(ShelleyLEDGER ShelleyEra) (forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv, LedgerState ShelleyEra
start, ShelleyTx ShelleyEra
tx))
   in case forall a. ShelleyBase a -> a
runShelleyBase ReaderT
  Globals
  Identity
  (Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER ShelleyEra)))
     (State (ShelleyLEDGER ShelleyEra)))
st of
        Right LedgerState ShelleyEra
st' -> LedgerState ShelleyEra
st'
        Left NonEmpty (ShelleyLedgerPredFailure ShelleyEra)
e -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show NonEmpty (ShelleyLedgerPredFailure ShelleyEra)
e

-- Create a ledger state that has registered stake credentials that
-- are seeded with (RawSeed n 0 0 0 0) to (RawSeed m 0 0 0 0).
-- It is pre-populated with 2 genesis injcoins.
ledgerStateWithNregisteredKeys :: Word64 -> Word64 -> LedgerState ShelleyEra
ledgerStateWithNregisteredKeys :: Word64 -> Word64 -> LedgerState ShelleyEra
ledgerStateWithNregisteredKeys Word64
n Word64
m =
  HasCallStack =>
LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerState ShelleyEra
makeLEDGERState (Integer -> LedgerState ShelleyEra
initLedgerState Integer
1) forall a b. (a -> b) -> a -> b
$ TxIx -> [KeyPair 'Staking] -> ShelleyTx ShelleyEra
txRegStakeKeys forall a. Bounded a => a
minBound (Word64 -> Word64 -> [KeyPair 'Staking]
stakeKeys Word64
n Word64
m)

-- ===========================================================
-- Stake Key Registration example

-- Given a ledger state, presumably created by ledgerStateWithNregisteredKeys n m,
-- so that keys (RawSeed n 0 0 0 0) through (RawSeed m 0 0 0 0) are already registered,
-- register new keys (RawSeed x 0 0 0 0) through (RawSeed y 0 0 0 0).
-- Note that [n, m] must be disjoint from [x, y].
ledgerRegisterStakeKeys :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerRegisterStakeKeys :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerRegisterStakeKeys Word64
x Word64
y LedgerState ShelleyEra
state =
  LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerEnv ShelleyEra -> ()
testLEDGER
    LedgerState ShelleyEra
state
    (TxIx -> [KeyPair 'Staking] -> ShelleyTx ShelleyEra
txRegStakeKeys (HasCallStack => Integer -> TxIx
mkTxIxPartial Integer
1) (Word64 -> Word64 -> [KeyPair 'Staking]
stakeKeys Word64
x Word64
y))
    forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv

-- ===========================================================
-- Deregistration example

-- Create a transaction body that de-registers stake credentials,
-- corresponding to the keys seeded with (RawSeed x 0 0 0 0) to (RawSeed y 0 0 0 0)
txbDeRegStakeKey :: Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbDeRegStakeKey :: Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbDeRegStakeKey Word64
x Word64
y =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
genesisId Integer
1])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
100)])
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
UnRegTxCert forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair 'Staking -> Credential 'Staking
stakeKeyToCred) (Word64 -> Word64 -> [KeyPair 'Staking]
stakeKeys Word64
x Word64
y)
    )
    (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
    (Integer -> Coin
Coin Integer
0)
    (Word64 -> SlotNo
SlotNo Word64
10)
    forall a. StrictMaybe a
SNothing
    forall a. StrictMaybe a
SNothing

-- Create a transaction that deregisters stake credentials numbered x through y.
-- It spends the genesis coin indexed by 1.
txDeRegStakeKeys :: Word64 -> Word64 -> ShelleyTx ShelleyEra
txDeRegStakeKeys :: Word64 -> Word64 -> ShelleyTx ShelleyEra
txDeRegStakeKeys Word64
x Word64
y =
  ShelleyTxBody ShelleyEra
-> [KeyPair 'Witness] -> ShelleyTx ShelleyEra
makeSimpleTx
    (Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbDeRegStakeKey Word64
x Word64
y)
    (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (Word64 -> Word64 -> [KeyPair 'Staking]
stakeKeys Word64
x Word64
y))

-- Given a ledger state, presumably created by ledgerStateWithNregisteredKeys n m,
-- so that keys (RawSeed n 0 0 0 0) through (RawSeed m 0 0 0 0) are already registered,
-- deregister keys (RawSeed x 0 0 0 0) through (RawSeed y 0 0 0 0).
-- Note that [x, y] must be contained in [n, m].
ledgerDeRegisterStakeKeys :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerDeRegisterStakeKeys :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerDeRegisterStakeKeys Word64
x Word64
y LedgerState ShelleyEra
state =
  LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerEnv ShelleyEra -> ()
testLEDGER
    LedgerState ShelleyEra
state
    (Word64 -> Word64 -> ShelleyTx ShelleyEra
txDeRegStakeKeys Word64
x Word64
y)
    forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv

-- ===========================================================
-- Reward Withdrawal example

-- Create a transaction body that withdrawals from reward accounts,
-- corresponding to the keys seeded with (RawSeed x 0 0 0 0) to (RawSeed y 0 0 0 0).
txbWithdrawals :: Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbWithdrawals :: Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbWithdrawals Word64
x Word64
y =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
genesisId Integer
1])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
100)])
    forall a. StrictSeq a
StrictSeq.empty
    ( Map RewardAccount Coin -> Withdrawals
Withdrawals forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\KeyPair 'Staking
ks -> (Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet (KeyPair 'Staking -> Credential 'Staking
stakeKeyToCred KeyPair 'Staking
ks), Integer -> Coin
Coin Integer
0)) (Word64 -> Word64 -> [KeyPair 'Staking]
stakeKeys Word64
x Word64
y)
    )
    (Integer -> Coin
Coin Integer
0)
    (Word64 -> SlotNo
SlotNo Word64
10)
    forall a. StrictMaybe a
SNothing
    forall a. StrictMaybe a
SNothing

-- Create a transaction that withdrawals from a reward accounts.
-- It spends the genesis coin indexed by 1.
txWithdrawals :: Word64 -> Word64 -> ShelleyTx ShelleyEra
txWithdrawals :: Word64 -> Word64 -> ShelleyTx ShelleyEra
txWithdrawals Word64
x Word64
y =
  ShelleyTxBody ShelleyEra
-> [KeyPair 'Witness] -> ShelleyTx ShelleyEra
makeSimpleTx
    (Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbWithdrawals Word64
x Word64
y)
    (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (Word64 -> Word64 -> [KeyPair 'Staking]
stakeKeys Word64
x Word64
y))

-- Given a ledger state, presumably created by ledgerStateWithNregisteredKeys n m,
-- so that keys (RawSeed n 0 0 0 0) through (RawSeed m 0 0 0 0) are already registered,
-- make reward withdrawals for keys (RawSeed x 0 0 0 0) through (RawSeed y 0 0 0 0).
-- Note that [x, y] must be contained in [n, m].
ledgerRewardWithdrawals :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerRewardWithdrawals :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerRewardWithdrawals Word64
x Word64
y LedgerState ShelleyEra
state = LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerEnv ShelleyEra -> ()
testLEDGER LedgerState ShelleyEra
state (Word64 -> Word64 -> ShelleyTx ShelleyEra
txWithdrawals Word64
x Word64
y) forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv

-- ===========================================================================
--
-- Register a stake pool when there are a lot of registered stake pool
--

-- Create stake pool key pairs, corresponding to seeds
-- (RawSeed start 0 0 0 0) through (RawSeed end 0 0 0 0)
poolColdKeys :: Word64 -> Word64 -> [KeyPair 'StakePool]
poolColdKeys :: Word64 -> Word64 -> [KeyPair 'StakePool]
poolColdKeys Word64
start Word64
end = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Word64
w -> forall (kd :: KeyRole). RawSeed -> KeyPair kd
mkKeyPair' (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
w Word64
1 Word64
0 Word64
0 Word64
0)) [Word64
start .. Word64
end]

firstStakePool :: KeyPair 'StakePool
firstStakePool :: KeyPair 'StakePool
firstStakePool = forall (kd :: KeyRole). RawSeed -> KeyPair kd
mkKeyPair' (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
1 Word64
1 Word64
0 Word64
0 Word64
0)

mkPoolKeyHash :: KeyPair 'StakePool -> KeyHash 'StakePool
mkPoolKeyHash :: KeyPair 'StakePool -> KeyHash 'StakePool
mkPoolKeyHash = 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

firstStakePoolKeyHash :: KeyHash 'StakePool
firstStakePoolKeyHash :: KeyHash 'StakePool
firstStakePoolKeyHash = KeyPair 'StakePool -> KeyHash 'StakePool
mkPoolKeyHash KeyPair 'StakePool
firstStakePool

vrfKeyHash :: VRFVerKeyHash 'StakePoolVRF
vrfKeyHash :: VRFVerKeyHash 'StakePoolVRF
vrfKeyHash = 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 b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => RawSeed -> VRFKeyPair c
mkVRFKeyPair @MockCrypto forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
0 Word64
0 Word64
0 Word64
0 Word64
0

mkPoolParameters :: KeyPair 'StakePool -> PoolParams
mkPoolParameters :: KeyPair 'StakePool -> PoolParams
mkPoolParameters KeyPair 'StakePool
keys =
  PoolParams
    { ppId :: KeyHash 'StakePool
ppId = forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'StakePool
keys)
    , ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppVrf = VRFVerKeyHash 'StakePoolVRF
vrfKeyHash
    , ppPledge :: Coin
ppPledge = Integer -> Coin
Coin Integer
0
    , ppCost :: Coin
ppCost = Integer -> Coin
Coin Integer
0
    , ppMargin :: UnitInterval
ppMargin = forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
0
    , ppRewardAccount :: RewardAccount
ppRewardAccount = Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet Credential 'Staking
firstStakeKeyCred
    , ppOwners :: Set (KeyHash 'Staking)
ppOwners = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Staking
stakeKeyOne)
    , ppRelays :: StrictSeq StakePoolRelay
ppRelays = forall a. StrictSeq a
StrictSeq.empty
    , ppMetadata :: StrictMaybe PoolMetadata
ppMetadata = forall a. StrictMaybe a
SNothing
    }

-- Create stake pool registration certs
poolRegCerts :: [KeyPair 'StakePool] -> StrictSeq (TxCert ShelleyEra)
poolRegCerts :: [KeyPair 'StakePool] -> StrictSeq (TxCert ShelleyEra)
poolRegCerts = forall a. [a] -> StrictSeq a
StrictSeq.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair 'StakePool -> PoolParams
mkPoolParameters)

-- Create a transaction that registers stake pools.
txRegStakePools :: TxIx -> [KeyPair 'StakePool] -> ShelleyTx ShelleyEra
txRegStakePools :: TxIx -> [KeyPair 'StakePool] -> ShelleyTx ShelleyEra
txRegStakePools TxIx
ix [KeyPair 'StakePool]
keys =
  ShelleyTxBody ShelleyEra
-> [KeyPair 'Witness] -> ShelleyTx ShelleyEra
makeSimpleTx
    (TxIx -> StrictSeq (TxCert ShelleyEra) -> ShelleyTxBody ShelleyEra
txbFromCerts TxIx
ix forall a b. (a -> b) -> a -> b
$ [KeyPair 'StakePool] -> StrictSeq (TxCert ShelleyEra)
poolRegCerts [KeyPair 'StakePool]
keys)
    ([forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay, forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Staking
stakeKeyOne] forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness [KeyPair 'StakePool]
keys)

-- Create a ledger state that has n registered stake pools.
-- The keys are seeded with (RawSeed n 1 0 0 0) to (RawSeed m 1 0 0 0)
-- It is pre-populated with 2 genesis injcoins.
ledgerStateWithNregisteredPools :: Word64 -> Word64 -> LedgerState ShelleyEra
ledgerStateWithNregisteredPools :: Word64 -> Word64 -> LedgerState ShelleyEra
ledgerStateWithNregisteredPools Word64
n Word64
m =
  HasCallStack =>
LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerState ShelleyEra
makeLEDGERState (Integer -> LedgerState ShelleyEra
initLedgerState Integer
1) forall a b. (a -> b) -> a -> b
$ TxIx -> [KeyPair 'StakePool] -> ShelleyTx ShelleyEra
txRegStakePools forall a. Bounded a => a
minBound (Word64 -> Word64 -> [KeyPair 'StakePool]
poolColdKeys Word64
n Word64
m)

-- ===========================================================
-- Stake Pool Registration example

-- Given a ledger state, presumably created by ledgerStateWithNregisteredPools n m,
-- so that pool keys (RawSeed n 1 0 0 0) through (RawSeed m 1 0 0 0) are already registered,
-- register new pools (RawSeed x 0 0 0 0) through (RawSeed y 0 0 0 0).
-- Note that [n, m] must be disjoint from [x, y].
ledgerRegisterStakePools :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerRegisterStakePools :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerRegisterStakePools Word64
x Word64
y LedgerState ShelleyEra
state =
  LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerEnv ShelleyEra -> ()
testLEDGER
    LedgerState ShelleyEra
state
    (TxIx -> [KeyPair 'StakePool] -> ShelleyTx ShelleyEra
txRegStakePools (HasCallStack => Integer -> TxIx
mkTxIxPartial Integer
1) (Word64 -> Word64 -> [KeyPair 'StakePool]
poolColdKeys Word64
x Word64
y))
    forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv

-- ===========================================================
-- Stake Pool Re-Registration/Update example

-- Given a ledger state, presumably created by ledgerStateWithNregisteredPools n m,
-- so that pool keys (RawSeed n 1 0 0 0) through (RawSeed m 1 0 0 0) are already registered,
-- re-register pools (RawSeed x 0 0 0 0) through (RawSeed y 0 0 0 0).
-- Note that [n, m] must be contained in [x, y].
ledgerReRegisterStakePools :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerReRegisterStakePools :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerReRegisterStakePools Word64
x Word64
y LedgerState ShelleyEra
state =
  LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerEnv ShelleyEra -> ()
testLEDGER
    LedgerState ShelleyEra
state
    (TxIx -> [KeyPair 'StakePool] -> ShelleyTx ShelleyEra
txRegStakePools (HasCallStack => Integer -> TxIx
mkTxIxPartial Integer
1) (Word64 -> Word64 -> [KeyPair 'StakePool]
poolColdKeys Word64
x Word64
y))
    forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv

-- ===========================================================
-- Stake Pool Retirement example

-- Create a transaction body that retires stake pools,
-- corresponding to the keys seeded with (RawSeed x 1 0 0 0) to (RawSeed y 1 0 0 0)
txbRetireStakePool :: Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbRetireStakePool :: Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbRetireStakePool Word64
x Word64
y =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
genesisId Integer
1])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
100)])
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          (\KeyPair 'StakePool
ks -> forall era.
EraTxCert era =>
KeyHash 'StakePool -> EpochNo -> TxCert era
RetirePoolTxCert (KeyPair 'StakePool -> KeyHash 'StakePool
mkPoolKeyHash KeyPair 'StakePool
ks) (Word64 -> EpochNo
EpochNo Word64
1))
          (Word64 -> Word64 -> [KeyPair 'StakePool]
poolColdKeys Word64
x Word64
y)
    )
    (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
    (Integer -> Coin
Coin Integer
0)
    (Word64 -> SlotNo
SlotNo Word64
10)
    forall a. StrictMaybe a
SNothing
    forall a. StrictMaybe a
SNothing

-- Create a transaction that retires stake pools x through y.
-- It spends the genesis coin indexed by 1.
txRetireStakePool :: Word64 -> Word64 -> ShelleyTx ShelleyEra
txRetireStakePool :: Word64 -> Word64 -> ShelleyTx ShelleyEra
txRetireStakePool Word64
x Word64
y =
  ShelleyTxBody ShelleyEra
-> [KeyPair 'Witness] -> ShelleyTx ShelleyEra
makeSimpleTx
    (Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbRetireStakePool Word64
x Word64
y)
    (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (Word64 -> Word64 -> [KeyPair 'StakePool]
poolColdKeys Word64
x Word64
y))

-- Given a ledger state, presumably created by ledgerStateWithNregisteredPools n m,
-- so that pool keys (RawSeed n 1 0 0 0) through (RawSeed m 1 0 0 0) are already registered,
-- retire pools (RawSeed x 0 0 0 0) through (RawSeed y 0 0 0 0).
-- Note that [n, m] must be contained in [x, y].
ledgerRetireStakePools :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerRetireStakePools :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerRetireStakePools Word64
x Word64
y LedgerState ShelleyEra
state = LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerEnv ShelleyEra -> ()
testLEDGER LedgerState ShelleyEra
state (Word64 -> Word64 -> ShelleyTx ShelleyEra
txRetireStakePool Word64
x Word64
y) forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv

-- ===========================================================================
--
-- Delegate Stake Credentials when many stake keys and stake pools are registered.
--

-- Create a ledger state that has n registered stake keys and m stake pools.
-- The stake keys are seeded with (RawSeed 1 0 0 0 0) to (RawSeed n 0 0 0 0)
-- The stake pools are seeded with (RawSeed 1 1 0 0 0) to (RawSeed m 1 0 0 0)
-- It is pre-populated with 3 genesis injcoins.
ledgerStateWithNkeysMpools :: Word64 -> Word64 -> LedgerState ShelleyEra
ledgerStateWithNkeysMpools :: Word64 -> Word64 -> LedgerState ShelleyEra
ledgerStateWithNkeysMpools Word64
n Word64
m =
  HasCallStack =>
LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerState ShelleyEra
makeLEDGERState
    (HasCallStack =>
LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerState ShelleyEra
makeLEDGERState (Integer -> LedgerState ShelleyEra
initLedgerState Integer
2) forall a b. (a -> b) -> a -> b
$ TxIx -> [KeyPair 'Staking] -> ShelleyTx ShelleyEra
txRegStakeKeys forall a. Bounded a => a
minBound (Word64 -> Word64 -> [KeyPair 'Staking]
stakeKeys Word64
1 Word64
n))
    (TxIx -> [KeyPair 'StakePool] -> ShelleyTx ShelleyEra
txRegStakePools (HasCallStack => Integer -> TxIx
mkTxIxPartial Integer
1) (Word64 -> Word64 -> [KeyPair 'StakePool]
poolColdKeys Word64
1 Word64
m))

-- Create a transaction body that delegates several keys to ONE stake pool,
-- corresponding to the keys seeded with (RawSeed n 0 0 0 0) to (RawSeed m 0 0 0 0)
txbDelegate :: Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbDelegate :: Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbDelegate Word64
n Word64
m =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
genesisId Integer
2])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
aliceAddr (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
100)])
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          (\KeyPair 'Staking
ks -> forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> KeyHash 'StakePool -> TxCert era
DelegStakeTxCert (KeyPair 'Staking -> Credential 'Staking
stakeKeyToCred KeyPair 'Staking
ks) KeyHash 'StakePool
firstStakePoolKeyHash)
          (Word64 -> Word64 -> [KeyPair 'Staking]
stakeKeys Word64
n Word64
m)
    )
    (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
    (Integer -> Coin
Coin Integer
0)
    (Word64 -> SlotNo
SlotNo Word64
10)
    forall a. StrictMaybe a
SNothing
    forall a. StrictMaybe a
SNothing

-- Create a transaction that delegates stake.
txDelegate :: Word64 -> Word64 -> ShelleyTx ShelleyEra
txDelegate :: Word64 -> Word64 -> ShelleyTx ShelleyEra
txDelegate Word64
n Word64
m =
  ShelleyTxBody ShelleyEra
-> [KeyPair 'Witness] -> ShelleyTx ShelleyEra
makeSimpleTx
    (Word64 -> Word64 -> ShelleyTxBody ShelleyEra
txbDelegate Word64
n Word64
m)
    (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
alicePay forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (Word64 -> Word64 -> [KeyPair 'Staking]
stakeKeys Word64
n Word64
m))

-- Given a ledger state, presumably created by ledgerStateWithNkeysMpools n m,
-- so that stake keys (RawSeed 1 0 0 0 0) through (RawSeed n 0 0 0 0) are already registered
-- and pool keys (RawSeed 1 1 0 0 0) through (RawSeed m 1 0 0 0) are already registered,
-- delegate stake keys (RawSeed x 0 0 0 0) through (RawSeed y 0 0 0 0) to ONE pool.
-- Note that [x, y] must be contained in [1, n].
ledgerDelegateManyKeysOnePool :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerDelegateManyKeysOnePool :: Word64 -> Word64 -> LedgerState ShelleyEra -> ()
ledgerDelegateManyKeysOnePool Word64
x Word64
y LedgerState ShelleyEra
state = LedgerState ShelleyEra
-> ShelleyTx ShelleyEra -> LedgerEnv ShelleyEra -> ()
testLEDGER LedgerState ShelleyEra
state (Word64 -> Word64 -> ShelleyTx ShelleyEra
txDelegate Word64
x Word64
y) forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv