{-# 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 (..))
import Cardano.Ledger.Crypto
import Cardano.Ledger.EpochBoundary (emptySnapShot)
import Cardano.Ledger.Keys (
  KeyRole (..),
  asWitness,
 )
import Cardano.Ledger.SafeHash (hashAnnotated)
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 (ExMock, Mock)
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 :: Crypto c => UTxO (ShelleyEra c)
initUTxO :: forall c. Crypto c => UTxO (ShelleyEra c)
initUTxO =
  forall era. TxId (EraCrypto era) -> [TxOut era] -> UTxO era
genesisCoins
    forall c. HashAlgorithm (HASH c) => TxId c
genesisId
    [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
Cast.aliceAddr Coin
aliceInitCoin
    , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
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 :: forall c. Crypto c => Coin -> ChainState (ShelleyEra c)
initStMIR :: forall c. Crypto c => Coin -> ChainState (ShelleyEra c)
initStMIR Coin
treasury = ChainState (ShelleyEra c)
cs {chainNes :: NewEpochState (ShelleyEra c)
chainNes = (forall era. ChainState era -> NewEpochState era
chainNes ChainState (ShelleyEra c)
cs) {nesEs :: EpochState (ShelleyEra c)
nesEs = EpochState (ShelleyEra c)
es'}}
  where
    cs :: ChainState (ShelleyEra c)
cs = forall era.
(EraTxOut era, ProtVerAtMost era 4, ProtVerAtMost era 6,
 Default (StashedAVVMAddresses era), EraGov era) =>
UTxO era -> ChainState era
initSt @(ShelleyEra c) forall c. Crypto c => UTxO (ShelleyEra c)
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 b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ChainState era -> NewEpochState era
chainNes forall a b. (a -> b) -> a -> b
$ ChainState (ShelleyEra c)
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 c)
es' = (forall era. NewEpochState era -> EpochState era
nesEs forall a b. (a -> b) -> a -> b
$ forall era. ChainState era -> NewEpochState era
chainNes ChainState (ShelleyEra c)
cs) {esAccountState :: AccountState
esAccountState = AccountState
as'}

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

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

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

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

txbodyEx1 :: Crypto c => MIRPot -> TxBody (ShelleyEra c)
txbodyEx1 :: forall c. Crypto c => MIRPot -> TxBody (ShelleyEra c)
txbodyEx1 MIRPot
pot =
  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.singleton forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut forall c. Crypto c => Addr c
Cast.aliceAddr Coin
aliceCoinEx1)
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ forall era. MIRCert (EraCrypto era) -> ShelleyTxCert era
ShelleyTxCertMir (forall c. MIRPot -> MIRTarget c -> MIRCert c
MIRCert MIRPot
pot forall c. Crypto c => MIRTarget c
ir)
        , forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
RegTxCert forall c. Crypto c => Credential 'Staking c
Cast.aliceSHK
        ]
    )
    (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
  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 :: Crypto c => [Int] -> [KeyPair 'Witness c]
mirWits :: forall c. Crypto c => [Int] -> [KeyPair 'Witness c]
mirWits = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v (r :: KeyRole). AllIssuerKeys v r -> KeyPair r v
aikCold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => Int -> AllIssuerKeys c 'GenesisDelegate
coreNodeIssuerKeys)

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

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

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

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

blockEx1 ::
  forall c.
  ExMock (EraCrypto (ShelleyEra c)) =>
  MIRPot ->
  Block (BHeader c) (ShelleyEra c)
blockEx1 :: forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> Block (BHeader c) (ShelleyEra c)
blockEx1 = forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
[KeyPair 'Witness (EraCrypto (ShelleyEra c))]
-> MIRPot -> Block (BHeader c) (ShelleyEra c)
blockEx1' forall c. Crypto c => [KeyPair 'Witness c]
sufficientMIRWits

expectedStEx1' ::
  forall c.
  ExMock (EraCrypto (ShelleyEra c)) =>
  [KeyPair 'Witness (EraCrypto (ShelleyEra c))] ->
  MIRPot ->
  ChainState (ShelleyEra c)
expectedStEx1' :: forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
[KeyPair 'Witness (EraCrypto (ShelleyEra c))]
-> MIRPot -> ChainState (ShelleyEra c)
expectedStEx1' [KeyPair 'Witness (EraCrypto (ShelleyEra c))]
txwits MIRPot
pot =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceUnfrozen (forall era. Era era => Block (BHeader (EraCrypto era)) era -> Nonce
getBlockNonce (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
[KeyPair 'Witness (EraCrypto (ShelleyEra c))]
-> MIRPot -> Block (BHeader c) (ShelleyEra c)
blockEx1' @c [KeyPair 'Witness (EraCrypto (ShelleyEra c))]
txwits MIRPot
pot))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Era era =>
Block (BHeader (EraCrypto era)) era
-> ChainState era -> ChainState era
C.newLab (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
[KeyPair 'Witness (EraCrypto (ShelleyEra c))]
-> MIRPot -> Block (BHeader c) (ShelleyEra c)
blockEx1' [KeyPair 'Witness (EraCrypto (ShelleyEra c))]
txwits MIRPot
pot)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraPParams era =>
PParams era
-> Coin
-> [Credential 'Staking (EraCrypto era)]
-> [PoolParams (EraCrypto era)]
-> ChainState era
-> ChainState era
C.feesAndDeposits forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Coin
feeTx1 [forall c. Crypto c => Credential 'Staking c
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 (forall c. Crypto c => MIRPot -> TxBody (ShelleyEra c)
txbodyEx1 MIRPot
pot)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Credential 'Staking (EraCrypto era)
-> Ptr -> ChainState era -> ChainState era
C.newStakeCred forall c. Crypto c => Credential 'Staking c
Cast.aliceSHK (SlotNo -> TxIx -> CertIx -> Ptr
Ptr (Word64 -> SlotNo
SlotNo Word64
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 (EraCrypto era)
-> MIRPot -> Coin -> ChainState era -> ChainState era
C.mir forall c. Crypto c => Credential 'Staking c
Cast.aliceSHK MIRPot
pot Coin
aliceMIRCoin
    forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => Coin -> ChainState (ShelleyEra c)
initStMIR (Integer -> Coin
Coin Integer
1000)

expectedStEx1 ::
  forall c.
  ExMock (EraCrypto (ShelleyEra c)) =>
  MIRPot ->
  ChainState (ShelleyEra c)
expectedStEx1 :: forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> ChainState (ShelleyEra c)
expectedStEx1 = forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
[KeyPair 'Witness (EraCrypto (ShelleyEra c))]
-> MIRPot -> ChainState (ShelleyEra c)
expectedStEx1' forall c. Crypto c => [KeyPair 'Witness c]
sufficientMIRWits

-- === Block 1, Slot 10, Epoch 0, Successful MIR Reserves Example
--
-- In the first block, submit a MIR cert drawing from the reserves.
mir1 :: ExMock (EraCrypto (ShelleyEra c)) => MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mir1 :: forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mir1 MIRPot
pot =
  forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample
    (forall c. Crypto c => Coin -> ChainState (ShelleyEra c)
initStMIR (Integer -> Coin
Coin Integer
1000))
    (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> Block (BHeader c) (ShelleyEra c)
blockEx1 MIRPot
pot)
    (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> ChainState (ShelleyEra c)
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 ::
  forall c.
  ExMock (EraCrypto (ShelleyEra c)) =>
  MIRPot ->
  CHAINExample (BHeader c) (ShelleyEra c)
mirFailWits :: forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mirFailWits MIRPot
pot =
  forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample
    (forall c. Crypto c => Coin -> ChainState (ShelleyEra c)
initStMIR (Integer -> Coin
Coin Integer
1000))
    (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
[KeyPair 'Witness (EraCrypto (ShelleyEra c))]
-> MIRPot -> Block (BHeader c) (ShelleyEra c)
blockEx1' forall c. Crypto c => [KeyPair 'Witness c]
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 (EraCrypto era))
-> ShelleyUtxowPredFailure era
MIRInsufficientGenesisSigsUTXOW Set (KeyHash 'Witness c)
ws
    )
  where
    ws :: Set (KeyHash 'Witness c)
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) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v (r :: KeyRole). AllIssuerKeys v r -> KeyHash r v
aikColdKeyHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => Int -> AllIssuerKeys c '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 ::
  ExMock (EraCrypto (ShelleyEra c)) =>
  MIRPot ->
  Coin ->
  Coin ->
  Coin ->
  CHAINExample (BHeader c) (ShelleyEra c)
mirFailFunds :: forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot
-> Coin -> Coin -> Coin -> CHAINExample (BHeader c) (ShelleyEra c)
mirFailFunds MIRPot
pot Coin
treasury Coin
llNeeded Coin
llReceived =
  forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample
    (forall c. Crypto c => Coin -> ChainState (ShelleyEra c)
initStMIR Coin
treasury)
    (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
[KeyPair 'Witness (EraCrypto (ShelleyEra c))]
-> MIRPot -> Block (BHeader c) (ShelleyEra c)
blockEx1' forall c. Crypto c => [KeyPair 'Witness c]
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 ::
  forall c.
  ExMock (EraCrypto (ShelleyEra c)) =>
  MIRPot ->
  Block (BHeader c) (ShelleyEra c)
blockEx2 :: forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> Block (BHeader c) (ShelleyEra c)
blockEx2 MIRPot
pot =
  forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) (WithResult Seed),
 Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlockFakeVRF
    (forall c. Crypto c => BHeader c -> HashHeader c
bhHash forall a b. (a -> b) -> a -> b
$ forall h era. Block h era -> h
bheader @(BHeader c) @(ShelleyEra c) (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> Block (BHeader c) (ShelleyEra c)
blockEx1 MIRPot
pot))
    (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) 'GenesisDelegate
coreNodeKeysBySchedule @(ShelleyEra c) 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)
    (forall c. Crypto c => Nonce
nonce0 @(EraCrypto (ShelleyEra c)))
    (Natural -> NatNonce
NatNonce Natural
2)
    forall a. Bounded a => a
minBound
    Word
2
    Word
0
    (forall c (r :: KeyRole).
(Crypto c, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert (forall era.
(HasCallStack, EraPParams era) =>
PParams era
-> Word64 -> AllIssuerKeys (EraCrypto era) 'GenesisDelegate
coreNodeKeysBySchedule @(ShelleyEra c) forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx Word64
50) Word64
0 (Word -> KESPeriod
KESPeriod Word
0))

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

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

-- === Block 2, Slot 50, Epoch 0
--
-- Submit an empty block to create an empty reward update.
mir2 ::
  ExMock (EraCrypto (ShelleyEra c)) =>
  MIRPot ->
  CHAINExample (BHeader c) (ShelleyEra c)
mir2 :: forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mir2 MIRPot
pot =
  forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample
    (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> ChainState (ShelleyEra c)
expectedStEx1 MIRPot
pot)
    (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> Block (BHeader c) (ShelleyEra c)
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 (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> ChainState (ShelleyEra c)
expectedStEx2 MIRPot
pot))

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

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

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

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

-- === Block 3, Slot 110, Epoch 1
--
-- Submit an empty block in the next epoch to apply the MIR rewards.
mir3 :: ExMock (EraCrypto (ShelleyEra c)) => MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mir3 :: forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mir3 MIRPot
pot = forall h era.
ChainState era
-> Block h era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample h era
CHAINExample (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> ChainState (ShelleyEra c)
expectedStEx2 MIRPot
pot) (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> Block (BHeader c) (ShelleyEra c)
blockEx3 MIRPot
pot) (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> ChainState (ShelleyEra c)
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 (BHeader C_Crypto) (ShelleyEra C_Crypto) -> Assertion
testCHAINExample (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mir1 MIRPot
ReservesMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"create MIR cert - treasury" forall a b. (a -> b) -> a -> b
$ HasCallStack =>
CHAINExample (BHeader C_Crypto) (ShelleyEra C_Crypto) -> Assertion
testCHAINExample (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mir1 MIRPot
TreasuryMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"insufficient MIR witnesses, reserves" forall a b. (a -> b) -> a -> b
$
        HasCallStack =>
CHAINExample (BHeader C_Crypto) (ShelleyEra C_Crypto) -> Assertion
testCHAINExample (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mirFailWits MIRPot
ReservesMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"insufficient MIR witnesses, treasury" forall a b. (a -> b) -> a -> b
$
        HasCallStack =>
CHAINExample (BHeader C_Crypto) (ShelleyEra C_Crypto) -> Assertion
testCHAINExample (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mirFailWits MIRPot
TreasuryMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"insufficient MIR funds, reserves" forall a b. (a -> b) -> a -> b
$
        HasCallStack =>
CHAINExample (BHeader C_Crypto) (ShelleyEra C_Crypto) -> Assertion
testCHAINExample (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot
-> Coin -> Coin -> Coin -> CHAINExample (BHeader c) (ShelleyEra c)
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 (BHeader C_Crypto) (ShelleyEra C_Crypto) -> Assertion
testCHAINExample (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot
-> Coin -> Coin -> Coin -> CHAINExample (BHeader c) (ShelleyEra c)
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 (BHeader C_Crypto) (ShelleyEra C_Crypto) -> Assertion
testCHAINExample (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mir2 MIRPot
ReservesMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"end of epoch after MIR - treasury" forall a b. (a -> b) -> a -> b
$
        HasCallStack =>
CHAINExample (BHeader C_Crypto) (ShelleyEra C_Crypto) -> Assertion
testCHAINExample (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mir2 MIRPot
TreasuryMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"apply MIR - reserves" forall a b. (a -> b) -> a -> b
$ HasCallStack =>
CHAINExample (BHeader C_Crypto) (ShelleyEra C_Crypto) -> Assertion
testCHAINExample (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mir3 MIRPot
ReservesMIR)
    , TestName -> Assertion -> TestTree
testCase TestName
"apply MIR - treasury" forall a b. (a -> b) -> a -> b
$ HasCallStack =>
CHAINExample (BHeader C_Crypto) (ShelleyEra C_Crypto) -> Assertion
testCHAINExample (forall c.
ExMock (EraCrypto (ShelleyEra c)) =>
MIRPot -> CHAINExample (BHeader c) (ShelleyEra c)
mir3 MIRPot
TreasuryMIR)
    ]