{-# 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
  B, -- Era instance for Benchmarking
  B_Crypto, -- Crypto instance for Benchmarking
)
where

import Cardano.Crypto.Hash.Blake2b (Blake2b_256)
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.Crypto (Crypto (..))
import Cardano.Ledger.Keys (
  KeyHash,
  KeyRole (..),
  KeyRoleVRF (StakePoolVRF),
  VRFVerKeyHash,
  asWitness,
  hashKey,
  hashVerKeyVRF,
 )
import Cardano.Ledger.PoolParams (
  PoolParams (..),
  ppCost,
  ppId,
  ppMargin,
  ppMetadata,
  ppOwners,
  ppPledge,
  ppRelays,
  ppRewardAccount,
  ppVrf,
 )
import Cardano.Ledger.SafeHash (hashAnnotated)
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.TPraos.API (PraosCrypto)
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 qualified Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes as Original (
  C_Crypto,
 )
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,
 )

-- ===============================================
-- A special Era to run the Benchmarks in

type B = ShelleyEra B_Crypto

data B_Crypto

instance Cardano.Ledger.Crypto.Crypto B_Crypto where
  type KES B_Crypto = KES Original.C_Crypto
  type VRF B_Crypto = VRF Original.C_Crypto
  type DSIGN B_Crypto = DSIGN Original.C_Crypto
  type HASH B_Crypto = Blake2b_256
  type ADDRHASH B_Crypto = Blake2b_256

instance PraosCrypto B_Crypto

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

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

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

aliceAddr :: Addr B_Crypto
aliceAddr :: Addr B_Crypto
aliceAddr = forall c.
Crypto c =>
(KeyPair 'Payment c, KeyPair 'Staking c) -> Addr c
mkAddr (KeyPair 'Payment B_Crypto
alicePay, KeyPair 'Staking B_Crypto
aliceStake)

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

injcoins :: Integer -> [ShelleyTxOut B]
injcoins :: Integer -> [ShelleyTxOut B]
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 (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr B_Crypto
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 B
initUTxO :: Integer -> UTxOState B
initUTxO Integer
n =
  forall era.
UTxO era
-> Coin
-> Coin
-> GovState era
-> IncrementalStake (EraCrypto era)
-> Coin
-> UTxOState era
UTxOState
    (forall era. TxId (EraCrypto era) -> [TxOut era] -> UTxO era
genesisCoins forall c. HashAlgorithm (HASH c) => TxId c
genesisId (Integer -> [ShelleyTxOut B]
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 B ->
  ShelleyTx B ->
  LedgerEnv B ->
  ()
testLEDGER :: LedgerState B -> ShelleyTx B -> LedgerEnv B -> ()
testLEDGER LedgerState B
initSt ShelleyTx B
tx LedgerEnv B
env = do
  let st :: Either (NonEmpty (ShelleyLedgerPredFailure B)) (LedgerState B)
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 B) (forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv B
env, LedgerState B
initSt, ShelleyTx B
tx))
  case Either (NonEmpty (ShelleyLedgerPredFailure B)) (LedgerState B)
st of
    Right LedgerState B
_ -> ()
    Left NonEmpty (ShelleyLedgerPredFailure B)
e -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show NonEmpty (ShelleyLedgerPredFailure B)
e

txbSpendOneUTxO :: ShelleyTxBody B
txbSpendOneUTxO :: ShelleyTxBody B
txbSpendOneUTxO =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
genesisId forall a. Bounded a => a
minBound])
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr B_Crypto
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 (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr B_Crypto
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
    (forall c. Map (RewardAccount c) Coin -> Withdrawals c
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 B
txSpendOneUTxO :: ShelleyTx B
txSpendOneUTxO =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    ShelleyTxBody B
txbSpendOneUTxO
    forall a. Monoid a => a
mempty
      { addrWits :: Set (WitVKey 'Witness (EraCrypto B))
addrWits = forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated ShelleyTxBody B
txbSpendOneUTxO) [forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'Payment B_Crypto
alicePay]
      }
    forall a. StrictMaybe a
SNothing

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

ledgerSpendOneGivenUTxO :: UTxOState B -> ()
ledgerSpendOneGivenUTxO :: UTxOState B -> ()
ledgerSpendOneGivenUTxO UTxOState B
state = LedgerState B -> ShelleyTx B -> LedgerEnv B -> ()
testLEDGER (forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState B
state forall a. Default a => a
def) ShelleyTx B
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 B_Crypto]
stakeKeys :: Word64 -> Word64 -> [KeyPair 'Staking B_Crypto]
stakeKeys Word64
start Word64
end = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Word64
w -> forall c (kd :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
RawSeed -> KeyPair kd c
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 B_Crypto
stakeKeyOne :: KeyPair 'Staking B_Crypto
stakeKeyOne = forall c (kd :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
RawSeed -> KeyPair kd c
mkKeyPair' (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
1 Word64
0 Word64
0 Word64
0 Word64
0)

stakeKeyToCred :: KeyPair 'Staking B_Crypto -> Credential 'Staking B_Crypto
stakeKeyToCred :: KeyPair 'Staking B_Crypto -> Credential 'Staking B_Crypto
stakeKeyToCred = forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey

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

-- Create stake key registration certificates
stakeKeyRegistrations :: [KeyPair 'Staking B_Crypto] -> StrictSeq (TxCert B)
stakeKeyRegistrations :: [KeyPair 'Staking B_Crypto] -> StrictSeq (TxCert B)
stakeKeyRegistrations [KeyPair 'Staking B_Crypto]
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 =>
StakeCredential (EraCrypto era) -> TxCert era
RegTxCert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey) [KeyPair 'Staking B_Crypto]
keys

-- Create a transaction body given a sequence of certificates.
-- It spends the genesis coin given by the index ix.
txbFromCerts :: TxIx -> StrictSeq (TxCert B) -> ShelleyTxBody B
txbFromCerts :: TxIx -> StrictSeq (TxCert B) -> ShelleyTxBody B
txbFromCerts TxIx
ix StrictSeq (TxCert B)
regCerts =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. TxId c -> TxIx -> TxIn c
TxIn forall c. HashAlgorithm (HASH c) => TxId c
genesisId TxIx
ix])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr B_Crypto
aliceAddr (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
100)])
    StrictSeq (TxCert B)
regCerts
    (forall c. Map (RewardAccount c) Coin -> Withdrawals c
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 B ->
  [KeyPair 'Witness B_Crypto] ->
  ShelleyTx B
makeSimpleTx :: ShelleyTxBody B -> [KeyPair 'Witness B_Crypto] -> ShelleyTx B
makeSimpleTx ShelleyTxBody B
txbody [KeyPair 'Witness B_Crypto]
keysAddr =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    ShelleyTxBody B
txbody
    forall a. Monoid a => a
mempty
      { addrWits :: Set (WitVKey 'Witness (EraCrypto B))
addrWits = forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated ShelleyTxBody B
txbody) [KeyPair 'Witness B_Crypto]
keysAddr
      }
    forall a. StrictMaybe a
SNothing

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

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

makeLEDGERState :: HasCallStack => LedgerState B -> ShelleyTx B -> LedgerState B
makeLEDGERState :: HasCallStack => LedgerState B -> ShelleyTx B -> LedgerState B
makeLEDGERState LedgerState B
start ShelleyTx B
tx =
  let st :: ReaderT
  Globals
  Identity
  (Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER B)))
     (State (ShelleyLEDGER B)))
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 B) (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 B
start, ShelleyTx B
tx))
   in case forall a. ShelleyBase a -> a
runShelleyBase ReaderT
  Globals
  Identity
  (Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER B)))
     (State (ShelleyLEDGER B)))
st of
        Right LedgerState B
st' -> LedgerState B
st'
        Left NonEmpty (ShelleyLedgerPredFailure B)
e -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show NonEmpty (ShelleyLedgerPredFailure B)
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 B
ledgerStateWithNregisteredKeys :: Word64 -> Word64 -> LedgerState B
ledgerStateWithNregisteredKeys Word64
n Word64
m =
  HasCallStack => LedgerState B -> ShelleyTx B -> LedgerState B
makeLEDGERState (Integer -> LedgerState B
initLedgerState Integer
1) forall a b. (a -> b) -> a -> b
$ TxIx -> [KeyPair 'Staking B_Crypto] -> ShelleyTx B
txRegStakeKeys forall a. Bounded a => a
minBound (Word64 -> Word64 -> [KeyPair 'Staking B_Crypto]
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 B -> ()
ledgerRegisterStakeKeys :: Word64 -> Word64 -> LedgerState B -> ()
ledgerRegisterStakeKeys Word64
x Word64
y LedgerState B
state =
  LedgerState B -> ShelleyTx B -> LedgerEnv B -> ()
testLEDGER
    LedgerState B
state
    (TxIx -> [KeyPair 'Staking B_Crypto] -> ShelleyTx B
txRegStakeKeys (HasCallStack => Integer -> TxIx
mkTxIxPartial Integer
1) (Word64 -> Word64 -> [KeyPair 'Staking B_Crypto]
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 B
txbDeRegStakeKey :: Word64 -> Word64 -> ShelleyTxBody B
txbDeRegStakeKey Word64
x Word64
y =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial forall c. HashAlgorithm (HASH c) => TxId c
genesisId Integer
1])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr B_Crypto
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 =>
StakeCredential (EraCrypto era) -> TxCert era
UnRegTxCert forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair 'Staking B_Crypto -> Credential 'Staking B_Crypto
stakeKeyToCred) (Word64 -> Word64 -> [KeyPair 'Staking B_Crypto]
stakeKeys Word64
x Word64
y)
    )
    (forall c. Map (RewardAccount c) Coin -> Withdrawals c
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 B
txDeRegStakeKeys :: Word64 -> Word64 -> ShelleyTx B
txDeRegStakeKeys Word64
x Word64
y =
  ShelleyTxBody B -> [KeyPair 'Witness B_Crypto] -> ShelleyTx B
makeSimpleTx
    (Word64 -> Word64 -> ShelleyTxBody B
txbDeRegStakeKey Word64
x Word64
y)
    (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'Payment B_Crypto
alicePay forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness (Word64 -> Word64 -> [KeyPair 'Staking B_Crypto]
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 B -> ()
ledgerDeRegisterStakeKeys :: Word64 -> Word64 -> LedgerState B -> ()
ledgerDeRegisterStakeKeys Word64
x Word64
y LedgerState B
state =
  LedgerState B -> ShelleyTx B -> LedgerEnv B -> ()
testLEDGER
    LedgerState B
state
    (Word64 -> Word64 -> ShelleyTx B
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 B
txbWithdrawals :: Word64 -> Word64 -> ShelleyTxBody B
txbWithdrawals Word64
x Word64
y =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial forall c. HashAlgorithm (HASH c) => TxId c
genesisId Integer
1])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr B_Crypto
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
    ( forall c. Map (RewardAccount c) Coin -> Withdrawals c
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 B_Crypto
ks -> (forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
Testnet (KeyPair 'Staking B_Crypto -> Credential 'Staking B_Crypto
stakeKeyToCred KeyPair 'Staking B_Crypto
ks), Integer -> Coin
Coin Integer
0)) (Word64 -> Word64 -> [KeyPair 'Staking B_Crypto]
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 B
txWithdrawals :: Word64 -> Word64 -> ShelleyTx B
txWithdrawals Word64
x Word64
y =
  ShelleyTxBody B -> [KeyPair 'Witness B_Crypto] -> ShelleyTx B
makeSimpleTx
    (Word64 -> Word64 -> ShelleyTxBody B
txbWithdrawals Word64
x Word64
y)
    (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'Payment B_Crypto
alicePay forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness (Word64 -> Word64 -> [KeyPair 'Staking B_Crypto]
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 B -> ()
ledgerRewardWithdrawals :: Word64 -> Word64 -> LedgerState B -> ()
ledgerRewardWithdrawals Word64
x Word64
y LedgerState B
state = LedgerState B -> ShelleyTx B -> LedgerEnv B -> ()
testLEDGER LedgerState B
state (Word64 -> Word64 -> ShelleyTx B
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 B_Crypto]
poolColdKeys :: Word64 -> Word64 -> [KeyPair 'StakePool B_Crypto]
poolColdKeys Word64
start Word64
end = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Word64
w -> forall c (kd :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
RawSeed -> KeyPair kd c
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 B_Crypto
firstStakePool :: KeyPair 'StakePool B_Crypto
firstStakePool = forall c (kd :: KeyRole).
DSIGNAlgorithm (DSIGN c) =>
RawSeed -> KeyPair kd c
mkKeyPair' (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
1 Word64
1 Word64
0 Word64
0 Word64
0)

mkPoolKeyHash :: KeyPair 'StakePool B_Crypto -> KeyHash 'StakePool B_Crypto
mkPoolKeyHash :: KeyPair 'StakePool B_Crypto -> KeyHash 'StakePool B_Crypto
mkPoolKeyHash = forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey

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

vrfKeyHash :: VRFVerKeyHash 'StakePoolVRF B_Crypto
vrfKeyHash :: VRFVerKeyHash 'StakePoolVRF B_Crypto
vrfKeyHash = forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF c -> VRFVerKeyHash r c
hashVerKeyVRF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. VRFKeyPair c -> VerKeyVRF c
vrfVerKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => RawSeed -> VRFKeyPair c
mkVRFKeyPair @B_Crypto 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 B_Crypto -> PoolParams B_Crypto
mkPoolParameters :: KeyPair 'StakePool B_Crypto -> PoolParams B_Crypto
mkPoolParameters KeyPair 'StakePool B_Crypto
keys =
  PoolParams
    { ppId :: KeyHash 'StakePool B_Crypto
ppId = forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey (forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey KeyPair 'StakePool B_Crypto
keys)
    , ppVrf :: VRFVerKeyHash 'StakePoolVRF B_Crypto
ppVrf = VRFVerKeyHash 'StakePoolVRF B_Crypto
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 B_Crypto
ppRewardAccount = forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
Testnet Credential 'Staking B_Crypto
firstStakeKeyCred
    , ppOwners :: Set (KeyHash 'Staking B_Crypto)
ppOwners = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey (forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey KeyPair 'Staking B_Crypto
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 B_Crypto] -> StrictSeq (TxCert B)
poolRegCerts :: [KeyPair 'StakePool B_Crypto] -> StrictSeq (TxCert B)
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 (EraCrypto era) -> TxCert era
RegPoolTxCert forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair 'StakePool B_Crypto -> PoolParams B_Crypto
mkPoolParameters)

-- Create a transaction that registers stake pools.
txRegStakePools :: TxIx -> [KeyPair 'StakePool B_Crypto] -> ShelleyTx B
txRegStakePools :: TxIx -> [KeyPair 'StakePool B_Crypto] -> ShelleyTx B
txRegStakePools TxIx
ix [KeyPair 'StakePool B_Crypto]
keys =
  ShelleyTxBody B -> [KeyPair 'Witness B_Crypto] -> ShelleyTx B
makeSimpleTx
    (TxIx -> StrictSeq (TxCert B) -> ShelleyTxBody B
txbFromCerts TxIx
ix forall a b. (a -> b) -> a -> b
$ [KeyPair 'StakePool B_Crypto] -> StrictSeq (TxCert B)
poolRegCerts [KeyPair 'StakePool B_Crypto]
keys)
    ([forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'Payment B_Crypto
alicePay, forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'Staking B_Crypto
stakeKeyOne] forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness [KeyPair 'StakePool B_Crypto]
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 B
ledgerStateWithNregisteredPools :: Word64 -> Word64 -> LedgerState B
ledgerStateWithNregisteredPools Word64
n Word64
m =
  HasCallStack => LedgerState B -> ShelleyTx B -> LedgerState B
makeLEDGERState (Integer -> LedgerState B
initLedgerState Integer
1) forall a b. (a -> b) -> a -> b
$ TxIx -> [KeyPair 'StakePool B_Crypto] -> ShelleyTx B
txRegStakePools forall a. Bounded a => a
minBound (Word64 -> Word64 -> [KeyPair 'StakePool B_Crypto]
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 B -> ()
ledgerRegisterStakePools :: Word64 -> Word64 -> LedgerState B -> ()
ledgerRegisterStakePools Word64
x Word64
y LedgerState B
state =
  LedgerState B -> ShelleyTx B -> LedgerEnv B -> ()
testLEDGER
    LedgerState B
state
    (TxIx -> [KeyPair 'StakePool B_Crypto] -> ShelleyTx B
txRegStakePools (HasCallStack => Integer -> TxIx
mkTxIxPartial Integer
1) (Word64 -> Word64 -> [KeyPair 'StakePool B_Crypto]
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 B -> ()
ledgerReRegisterStakePools :: Word64 -> Word64 -> LedgerState B -> ()
ledgerReRegisterStakePools Word64
x Word64
y LedgerState B
state =
  LedgerState B -> ShelleyTx B -> LedgerEnv B -> ()
testLEDGER
    LedgerState B
state
    (TxIx -> [KeyPair 'StakePool B_Crypto] -> ShelleyTx B
txRegStakePools (HasCallStack => Integer -> TxIx
mkTxIxPartial Integer
1) (Word64 -> Word64 -> [KeyPair 'StakePool B_Crypto]
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 B
txbRetireStakePool :: Word64 -> Word64 -> ShelleyTxBody B
txbRetireStakePool Word64
x Word64
y =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial forall c. HashAlgorithm (HASH c) => TxId c
genesisId Integer
1])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr B_Crypto
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 B_Crypto
ks -> forall era.
EraTxCert era =>
KeyHash 'StakePool (EraCrypto era) -> EpochNo -> TxCert era
RetirePoolTxCert (KeyPair 'StakePool B_Crypto -> KeyHash 'StakePool B_Crypto
mkPoolKeyHash KeyPair 'StakePool B_Crypto
ks) (Word64 -> EpochNo
EpochNo Word64
1))
          (Word64 -> Word64 -> [KeyPair 'StakePool B_Crypto]
poolColdKeys Word64
x Word64
y)
    )
    (forall c. Map (RewardAccount c) Coin -> Withdrawals c
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 B
txRetireStakePool :: Word64 -> Word64 -> ShelleyTx B
txRetireStakePool Word64
x Word64
y =
  ShelleyTxBody B -> [KeyPair 'Witness B_Crypto] -> ShelleyTx B
makeSimpleTx
    (Word64 -> Word64 -> ShelleyTxBody B
txbRetireStakePool Word64
x Word64
y)
    (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'Payment B_Crypto
alicePay forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness (Word64 -> Word64 -> [KeyPair 'StakePool B_Crypto]
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 B -> ()
ledgerRetireStakePools :: Word64 -> Word64 -> LedgerState B -> ()
ledgerRetireStakePools Word64
x Word64
y LedgerState B
state = LedgerState B -> ShelleyTx B -> LedgerEnv B -> ()
testLEDGER LedgerState B
state (Word64 -> Word64 -> ShelleyTx B
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 B
ledgerStateWithNkeysMpools :: Word64 -> Word64 -> LedgerState B
ledgerStateWithNkeysMpools Word64
n Word64
m =
  HasCallStack => LedgerState B -> ShelleyTx B -> LedgerState B
makeLEDGERState
    (HasCallStack => LedgerState B -> ShelleyTx B -> LedgerState B
makeLEDGERState (Integer -> LedgerState B
initLedgerState Integer
2) forall a b. (a -> b) -> a -> b
$ TxIx -> [KeyPair 'Staking B_Crypto] -> ShelleyTx B
txRegStakeKeys forall a. Bounded a => a
minBound (Word64 -> Word64 -> [KeyPair 'Staking B_Crypto]
stakeKeys Word64
1 Word64
n))
    (TxIx -> [KeyPair 'StakePool B_Crypto] -> ShelleyTx B
txRegStakePools (HasCallStack => Integer -> TxIx
mkTxIxPartial Integer
1) (Word64 -> Word64 -> [KeyPair 'StakePool B_Crypto]
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 B
txbDelegate :: Word64 -> Word64 -> ShelleyTxBody B
txbDelegate Word64
n Word64
m =
  forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial forall c. HashAlgorithm (HASH c) => TxId c
genesisId Integer
2])
    (forall a. [a] -> StrictSeq a
StrictSeq.fromList [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr B_Crypto
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 B_Crypto
ks -> forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> TxCert era
DelegStakeTxCert (KeyPair 'Staking B_Crypto -> Credential 'Staking B_Crypto
stakeKeyToCred KeyPair 'Staking B_Crypto
ks) KeyHash 'StakePool B_Crypto
firstStakePoolKeyHash)
          (Word64 -> Word64 -> [KeyPair 'Staking B_Crypto]
stakeKeys Word64
n Word64
m)
    )
    (forall c. Map (RewardAccount c) Coin -> Withdrawals c
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 B
txDelegate :: Word64 -> Word64 -> ShelleyTx B
txDelegate Word64
n Word64
m =
  ShelleyTxBody B -> [KeyPair 'Witness B_Crypto] -> ShelleyTx B
makeSimpleTx
    (Word64 -> Word64 -> ShelleyTxBody B
txbDelegate Word64
n Word64
m)
    (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyPair 'Payment B_Crypto
alicePay forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness (Word64 -> Word64 -> [KeyPair 'Staking B_Crypto]
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 B -> ()
ledgerDelegateManyKeysOnePool :: Word64 -> Word64 -> LedgerState B -> ()
ledgerDelegateManyKeysOnePool Word64
x Word64
y LedgerState B
state = LedgerState B -> ShelleyTx B -> LedgerEnv B -> ()
testLEDGER LedgerState B
state (Word64 -> Word64 -> ShelleyTx B
txDelegate Word64
x Word64
y) forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
LedgerEnv era
ledgerEnv