{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Test.Cardano.Ledger.Shelley.Examples.Mir
-- Description : MIR Example
--
-- Example demonstrating the Move Instantaneous Rewards mechanism
module Test.Cardano.Ledger.Shelley.Examples.Mir (
  mirExample,
)
where

import Cardano.Ledger.BaseTypes (Mismatch (..), Nonce, StrictMaybe (..), mkCertIxPartial)
import Cardano.Ledger.Block (Block, bheader)
import Cardano.Ledger.Coin (Coin (..), toDeltaCoin)
import Cardano.Ledger.Credential (Ptr (..), SlotNo32 (..))
import Cardano.Ledger.EpochBoundary (emptySnapShot)
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  AccountState (..),
  EpochState (..),
  NewEpochState (..),
  PulsingRewUpdate,
  emptyRewardUpdate,
 )
import Cardano.Ledger.Shelley.Rules (
  ShelleyDelegPredFailure (..),
  ShelleyUtxowPredFailure (..),
 )
import Cardano.Ledger.Shelley.Tx (ShelleyTx (..))
import Cardano.Ledger.Shelley.TxBody (ShelleyTxBody (..))
import Cardano.Ledger.Shelley.TxCert (ShelleyTxCert (..))
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.Shelley.TxWits (addrWits)
import Cardano.Ledger.Slot (BlockNo (..), SlotNo (..))
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.UTxO (UTxO (..))
import Cardano.Ledger.Val ((<+>), (<->))
import qualified Cardano.Ledger.Val as Val
import Cardano.Protocol.TPraos.BHeader (BHeader, bhHash)
import Cardano.Protocol.TPraos.OCert (KESPeriod (..))
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkWitnessesVKey)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Examples (CHAINExample (..), testCHAINExample)
import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast
import qualified Test.Cardano.Ledger.Shelley.Examples.Combinators as C
import Test.Cardano.Ledger.Shelley.Examples.Federation (
  coreNodeIssuerKeys,
  coreNodeKeysBySchedule,
 )
import Test.Cardano.Ledger.Shelley.Examples.Init (
  initSt,
  lastByronHeaderHash,
  nonce0,
  ppEx,
 )
import Test.Cardano.Ledger.Shelley.Examples.PoolLifetime (makePulser')
import Test.Cardano.Ledger.Shelley.Generator.Core (
  AllIssuerKeys (..),
  NatNonce (..),
  genesisCoins,
  mkBlockFakeVRF,
  mkOCert,
 )
import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen ()
import Test.Cardano.Ledger.Shelley.Rules.Chain (ChainState (..), TestChainPredicateFailure (..))
import Test.Cardano.Ledger.Shelley.Utils (getBlockNonce)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

initUTxO :: UTxO ShelleyEra
initUTxO :: UTxO ShelleyEra
initUTxO =
  forall era. TxId -> [TxOut era] -> UTxO era
genesisCoins
    TxId
genesisId
    [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr Coin
aliceInitCoin
    , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr Coin
bobInitCoin
    ]
  where
    aliceInitCoin :: Coin
aliceInitCoin = forall t s. Inject t s => t -> s
Val.inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin forall a b. (a -> b) -> a -> b
$ Integer
10 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000
    bobInitCoin :: Coin
bobInitCoin = forall t s. Inject t s => t -> s
Val.inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin forall a b. (a -> b) -> a -> b
$ Integer
1 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000

initStMIR :: Coin -> ChainState ShelleyEra
initStMIR :: Coin -> ChainState ShelleyEra
initStMIR Coin
treasury = ChainState ShelleyEra
cs {chainNes :: NewEpochState ShelleyEra
chainNes = (forall era. ChainState era -> NewEpochState era
chainNes ChainState ShelleyEra
cs) {nesEs :: EpochState ShelleyEra
nesEs = EpochState ShelleyEra
es'}}
  where
    cs :: ChainState ShelleyEra
cs = forall era.
(EraTxOut era, ProtVerAtMost era 4, ProtVerAtMost era 6,
 Default (StashedAVVMAddresses era), EraGov era) =>
UTxO era -> ChainState era
initSt @ShelleyEra UTxO ShelleyEra
initUTxO
    as :: AccountState
as = forall era. EpochState era -> AccountState
esAccountState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs forall a b. (a -> b) -> a -> b
$ forall era. ChainState era -> NewEpochState era
chainNes ChainState ShelleyEra
cs
    as' :: AccountState
as' =
      AccountState
as
        { asTreasury :: Coin
asTreasury = AccountState -> Coin
asTreasury AccountState
as forall t. Val t => t -> t -> t
<+> Coin
treasury
        , asReserves :: Coin
asReserves = AccountState -> Coin
asReserves AccountState
as forall t. Val t => t -> t -> t
<-> Coin
treasury
        }
    es' :: EpochState ShelleyEra
es' = (forall era. NewEpochState era -> EpochState era
nesEs forall a b. (a -> b) -> a -> b
$ forall era. ChainState era -> NewEpochState era
chainNes ChainState ShelleyEra
cs) {esAccountState :: AccountState
esAccountState = AccountState
as'}

--
-- Block 1, Slot 10, Epoch 0
--

aliceMIRCoin :: Coin
aliceMIRCoin :: Coin
aliceMIRCoin = Integer -> Coin
Coin Integer
100

ir :: MIRTarget
ir :: MIRTarget
ir = Map (Credential 'Staking) DeltaCoin -> MIRTarget
StakeAddressesMIR forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Credential 'Staking
Cast.aliceSHK, Coin -> DeltaCoin
toDeltaCoin Coin
aliceMIRCoin)]

feeTx1 :: Coin
feeTx1 :: Coin
feeTx1 = Integer -> Coin
Coin Integer
1

txbodyEx1 :: MIRPot -> TxBody ShelleyEra
txbodyEx1 :: MIRPot -> TxBody ShelleyEra
txbodyEx1 MIRPot
pot =
  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.singleton forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr Coin
aliceCoinEx1)
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ forall era. MIRCert -> ShelleyTxCert era
ShelleyTxCertMir (MIRPot -> MIRTarget -> MIRCert
MIRCert MIRPot
pot MIRTarget
ir)
        , forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
RegTxCert Credential 'Staking
Cast.aliceSHK
        ]
    )
    (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
  where
    aliceInitCoin :: Coin
aliceInitCoin = forall t s. Inject t s => t -> s
Val.inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin forall a b. (a -> b) -> a -> b
$ Integer
10 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
* Integer
1000
    aliceCoinEx1 :: Coin
aliceCoinEx1 = Coin
aliceInitCoin forall t. Val t => t -> t -> t
<-> forall t s. Inject t s => t -> s
Val.inject (Coin
feeTx1 forall t. Val t => t -> t -> t
<+> Integer -> Coin
Coin Integer
7)

mirWits :: [Int] -> [KeyPair 'Witness]
mirWits :: [Int] -> [KeyPair 'Witness]
mirWits = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeIssuerKeys)

sufficientMIRWits :: [KeyPair 'Witness]
sufficientMIRWits :: [KeyPair 'Witness]
sufficientMIRWits = [Int] -> [KeyPair 'Witness]
mirWits [Int
0 .. Int
4]

insufficientMIRWits :: [KeyPair 'Witness]
insufficientMIRWits :: [KeyPair 'Witness]
insufficientMIRWits = [Int] -> [KeyPair 'Witness]
mirWits [Int
0 .. Int
3]

txEx1 :: [KeyPair 'Witness] -> MIRPot -> ShelleyTx ShelleyEra
txEx1 :: [KeyPair 'Witness] -> MIRPot -> ShelleyTx ShelleyEra
txEx1 [KeyPair 'Witness]
txwits MIRPot
pot =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    (MIRPot -> TxBody ShelleyEra
txbodyEx1 MIRPot
pot)
    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 forall a b. (a -> b) -> a -> b
$ MIRPot -> TxBody ShelleyEra
txbodyEx1 MIRPot
pot)
            ([forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.alicePay] forall a. Semigroup a => a -> a -> a
<> [KeyPair 'Witness]
txwits)
      }
    forall a. StrictMaybe a
SNothing

blockEx1' :: [KeyPair 'Witness] -> MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx1' :: [KeyPair 'Witness]
-> MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx1' [KeyPair 'Witness]
txwits MIRPot
pot =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    HashHeader
lastByronHeaderHash
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @ShelleyEra forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
10)
    [[KeyPair 'Witness] -> MIRPot -> ShelleyTx ShelleyEra
txEx1 [KeyPair 'Witness]
txwits MIRPot
pot]
    (Word64 -> SlotNo
SlotNo Word64
10)
    (Word64 -> BlockNo
BlockNo Word64
1)
    Nonce
nonce0
    (Natural -> NatNonce
NatNonce Natural
1)
    forall a. Bounded a => a
minBound
    Word
0
    Word
0
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @ShelleyEra forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
10) Word64
0 (Word -> KESPeriod
KESPeriod Word
0))

blockEx1 :: MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx1 :: MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx1 = [KeyPair 'Witness]
-> MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx1' [KeyPair 'Witness]
sufficientMIRWits

expectedStEx1' :: [KeyPair 'Witness] -> MIRPot -> ChainState ShelleyEra
expectedStEx1' :: [KeyPair 'Witness] -> MIRPot -> ChainState ShelleyEra
expectedStEx1' [KeyPair 'Witness]
txwits MIRPot
pot =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceUnfrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce ([KeyPair 'Witness]
-> MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx1' [KeyPair 'Witness]
txwits MIRPot
pot))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newLab ([KeyPair 'Witness]
-> MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx1' [KeyPair 'Witness]
txwits MIRPot
pot)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraPParams era =>
PParams era
-> Coin
-> [Credential 'Staking]
-> [PoolParams]
-> ChainState era
-> ChainState era
C.feesAndDeposits forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Coin
feeTx1 [Credential 'Staking
Cast.aliceSHK] []
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(EraTx era, EraGov era) =>
TxBody era -> ChainState era -> ChainState era
C.newUTxO (MIRPot -> TxBody ShelleyEra
txbodyEx1 MIRPot
pot)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking -> Ptr -> ChainState era -> ChainState era
C.newStakeCred Credential 'Staking
Cast.aliceSHK (SlotNo32 -> TxIx -> CertIx -> Ptr
Ptr (Word32 -> SlotNo32
SlotNo32 Word32
10) forall a. Bounded a => a
minBound (HasCallStack => Integer -> CertIx
mkCertIxPartial Integer
1))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking
-> MIRPot -> Coin -> ChainState era -> ChainState era
C.mir Credential 'Staking
Cast.aliceSHK MIRPot
pot Coin
aliceMIRCoin
    forall a b. (a -> b) -> a -> b
$ Coin -> ChainState ShelleyEra
initStMIR (Integer -> Coin
Coin Integer
1000)

expectedStEx1 :: MIRPot -> ChainState ShelleyEra
expectedStEx1 :: MIRPot -> ChainState ShelleyEra
expectedStEx1 = [KeyPair 'Witness] -> MIRPot -> ChainState ShelleyEra
expectedStEx1' [KeyPair 'Witness]
sufficientMIRWits

-- === Block 1, Slot 10, Epoch 0, Successful MIR Reserves Example
--
-- In the first block, submit a MIR cert drawing from the reserves.
mir1 :: MIRPot -> CHAINExample ShelleyEra
mir1 :: MIRPot -> CHAINExample ShelleyEra
mir1 MIRPot
pot =
  forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample
    (Coin -> ChainState ShelleyEra
initStMIR (Integer -> Coin
Coin Integer
1000))
    (MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx1 MIRPot
pot)
    (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ MIRPot -> ChainState ShelleyEra
expectedStEx1 MIRPot
pot)

-- === Block 1, Slot 10, Epoch 0, Insufficient MIR Wits, Reserves Example
--
-- In the first block, submit a MIR cert drawing from the reserves.
mirFailWits :: MIRPot -> CHAINExample ShelleyEra
mirFailWits :: MIRPot -> CHAINExample ShelleyEra
mirFailWits MIRPot
pot =
  forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample
    (Coin -> ChainState ShelleyEra
initStMIR (Integer -> Coin
Coin Integer
1000))
    ([KeyPair 'Witness]
-> MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx1' [KeyPair 'Witness]
insufficientMIRWits MIRPot
pot)
    ( forall a b. a -> Either a b
Left
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "BBODY" era)
-> TestChainPredicateFailure era
BbodyFailure
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure
        forall a b. (a -> b) -> a -> b
$ forall era. Set (KeyHash 'Witness) -> ShelleyUtxowPredFailure era
MIRInsufficientGenesisSigsUTXOW Set (KeyHash 'Witness)
ws
    )
  where
    ws :: Set (KeyHash 'Witness)
ws = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeIssuerKeys) [Int
0 .. Int
3]

-- === Block 1, Slot 10, Epoch 0, Insufficient MIR funds, Reserves Example
--
-- In the first block, submit a MIR cert drawing from the reserves.
mirFailFunds ::
  MIRPot ->
  Coin ->
  Coin ->
  Coin ->
  CHAINExample ShelleyEra
mirFailFunds :: MIRPot -> Coin -> Coin -> Coin -> CHAINExample ShelleyEra
mirFailFunds MIRPot
pot Coin
treasury Coin
llNeeded Coin
llReceived =
  forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample
    (Coin -> ChainState ShelleyEra
initStMIR Coin
treasury)
    ([KeyPair 'Witness]
-> MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx1' [KeyPair 'Witness]
sufficientMIRWits MIRPot
pot)
    ( forall a b. a -> Either a b
Left
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "BBODY" era)
-> TestChainPredicateFailure era
BbodyFailure
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure
        forall a b. (a -> b) -> a -> b
$ forall era.
MIRPot -> Mismatch 'RelLTEQ Coin -> ShelleyDelegPredFailure era
InsufficientForInstantaneousRewardsDELEG MIRPot
pot
        forall a b. (a -> b) -> a -> b
$ forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch Coin
llNeeded Coin
llReceived
    )

--
-- Block 2, Slot 50, Epoch 0
--

blockEx2 :: MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx2 :: MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx2 MIRPot
pot =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader (MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx1 MIRPot
pot))
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @ShelleyEra forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
50)
    []
    (Word64 -> SlotNo
SlotNo Word64
50)
    (Word64 -> BlockNo
BlockNo Word64
2)
    Nonce
nonce0
    (Natural -> NatNonce
NatNonce Natural
2)
    forall a. Bounded a => a
minBound
    Word
2
    Word
0
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @ShelleyEra forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
50) Word64
0 (Word -> KESPeriod
KESPeriod Word
0))

pulserEx2 :: MIRPot -> PulsingRewUpdate
pulserEx2 :: MIRPot -> PulsingRewUpdate
pulserEx2 MIRPot
pot = forall era. EraGov era => ChainState era -> PulsingRewUpdate
makePulser' (MIRPot -> ChainState ShelleyEra
expectedStEx1 MIRPot
pot)

expectedStEx2 :: MIRPot -> ChainState ShelleyEra
expectedStEx2 :: MIRPot -> ChainState ShelleyEra
expectedStEx2 MIRPot
pot =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceUnfrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce (MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx2 MIRPot
pot))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newLab (MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx2 MIRPot
pot)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. PulsingRewUpdate -> ChainState era -> ChainState era
C.pulserUpdate (MIRPot -> PulsingRewUpdate
pulserEx2 MIRPot
pot)
    forall a b. (a -> b) -> a -> b
$ MIRPot -> ChainState ShelleyEra
expectedStEx1 MIRPot
pot

-- === Block 2, Slot 50, Epoch 0
--
-- Submit an empty block to create an empty reward update.
mir2 :: MIRPot -> CHAINExample ShelleyEra
mir2 :: MIRPot -> CHAINExample ShelleyEra
mir2 MIRPot
pot =
  forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample
    (MIRPot -> ChainState ShelleyEra
expectedStEx1 MIRPot
pot)
    (MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx2 MIRPot
pot)
    (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ChainState era -> ChainState era
C.solidifyProposals (MIRPot -> ChainState ShelleyEra
expectedStEx2 MIRPot
pot))

--
-- Block 3, Slot 110, Epoch 1
--

epoch1Nonce :: MIRPot -> Nonce
epoch1Nonce :: MIRPot -> Nonce
epoch1Nonce MIRPot
pot = forall era. ChainState era -> Nonce
chainCandidateNonce (MIRPot -> ChainState ShelleyEra
expectedStEx2 MIRPot
pot)

blockEx3 :: MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx3 :: MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx3 MIRPot
pot =
  forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader (MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx2 MIRPot
pot))
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @ShelleyEra forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
110)
    []
    (Word64 -> SlotNo
SlotNo Word64
110)
    (Word64 -> BlockNo
BlockNo Word64
3)
    (MIRPot -> Nonce
epoch1Nonce MIRPot
pot)
    (Natural -> NatNonce
NatNonce Natural
3)
    forall a. Bounded a => a
minBound
    Word
5
    Word
0
    (forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era -> Word64 -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeKeysBySchedule @ShelleyEra forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
110) Word64
0 (Word -> KESPeriod
KESPeriod Word
0))

expectedStEx3 :: MIRPot -> ChainState ShelleyEra
expectedStEx3 :: MIRPot -> ChainState ShelleyEra
expectedStEx3 MIRPot
pot =
  forall era.
(ProtVerAtMost era 6, EraGov era) =>
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newEpoch (MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx3 MIRPot
pot)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. SnapShot -> Coin -> ChainState era -> ChainState era
C.newSnapshot SnapShot
emptySnapShot Coin
feeTx1
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraGov era =>
RewardUpdate -> ChainState era -> ChainState era
C.applyRewardUpdate RewardUpdate
emptyRewardUpdate
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
MIRPot
-> Map (Credential 'Staking) Coin
-> ChainState era
-> ChainState era
C.applyMIR MIRPot
pot (forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking
Cast.aliceSHK Coin
aliceMIRCoin)
    forall a b. (a -> b) -> a -> b
$ MIRPot -> ChainState ShelleyEra
expectedStEx2 MIRPot
pot

-- === Block 3, Slot 110, Epoch 1
--
-- Submit an empty block in the next epoch to apply the MIR rewards.
mir3 :: MIRPot -> CHAINExample ShelleyEra
mir3 :: MIRPot -> CHAINExample ShelleyEra
mir3 MIRPot
pot = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample (MIRPot -> ChainState ShelleyEra
expectedStEx2 MIRPot
pot) (MIRPot -> Block (BHeader MockCrypto) ShelleyEra
blockEx3 MIRPot
pot) (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ MIRPot -> ChainState ShelleyEra
expectedStEx3 MIRPot
pot)

--
-- MIR Test Group
--

mirExample :: TestTree
mirExample :: TestTree
mirExample =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"move inst rewards"
    [ TestName -> Assertion -> TestTree
testCase TestName
"create MIR cert - reserves" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample (MIRPot -> CHAINExample ShelleyEra
mir1 MIRPot
ReservesMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"create MIR cert - treasury" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample (MIRPot -> CHAINExample ShelleyEra
mir1 MIRPot
TreasuryMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"insufficient MIR witnesses, reserves" forall a b. (a -> b) -> a -> b
$
        HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample (MIRPot -> CHAINExample ShelleyEra
mirFailWits MIRPot
ReservesMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"insufficient MIR witnesses, treasury" forall a b. (a -> b) -> a -> b
$
        HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample (MIRPot -> CHAINExample ShelleyEra
mirFailWits MIRPot
TreasuryMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"insufficient MIR funds, reserves" forall a b. (a -> b) -> a -> b
$
        HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample (MIRPot -> Coin -> Coin -> Coin -> CHAINExample ShelleyEra
mirFailFunds MIRPot
ReservesMIR (Integer -> Coin
Coin Integer
34000000000000000) (Integer -> Coin
Coin Integer
100) (Integer -> Coin
Coin Integer
0))
    , TestName -> Assertion -> TestTree
testCase TestName
"insufficient MIR funds, treasury" forall a b. (a -> b) -> a -> b
$
        HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample (MIRPot -> Coin -> Coin -> Coin -> CHAINExample ShelleyEra
mirFailFunds MIRPot
TreasuryMIR (Integer -> Coin
Coin Integer
99) (Integer -> Coin
Coin Integer
100) (Integer -> Coin
Coin Integer
99))
    , TestName -> Assertion -> TestTree
testCase TestName
"end of epoch after MIR - reserves" forall a b. (a -> b) -> a -> b
$
        HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample (MIRPot -> CHAINExample ShelleyEra
mir2 MIRPot
ReservesMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"end of epoch after MIR - treasury" forall a b. (a -> b) -> a -> b
$
        HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample (MIRPot -> CHAINExample ShelleyEra
mir2 MIRPot
TreasuryMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"apply MIR - reserves" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample (MIRPot -> CHAINExample ShelleyEra
mir3 MIRPot
ReservesMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"apply MIR - treasury" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample (MIRPot -> CHAINExample ShelleyEra
mir3 MIRPot
TreasuryMIR)
    ]