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

-- |
-- Module      : Test.Cardano.Ledger.Shelley.Examples.Updates
-- Description : Protocol Parameter Update Example
--
-- Example demonstrating using the protocol parameter update system.
module Test.Cardano.Ledger.Shelley.Examples.Updates (
  updatesExample,
  updates4,
)
where

import Cardano.Ledger.BaseTypes (
  BlocksMade (..),
  Nonce,
  StrictMaybe (..),
  mkNonceFromNumber,
  (⭒),
 )
import Cardano.Ledger.Block (Block, bheader)
import Cardano.Ledger.Coin (Coin (..))
import qualified Cardano.Ledger.EpochBoundary as EB
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (PulsingRewUpdate, emptyRewardUpdate)
import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (..), Update (..))
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 (
  BlockNo (..),
  EpochNo (..),
  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 Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Core.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,
  coreNodeVK,
 )
import Test.Cardano.Ledger.Shelley.Examples.Init (
  initSt,
  lastByronHeaderHash,
  nonce0,
  ppEx,
 )
import Test.Cardano.Ledger.Shelley.Examples.PoolLifetime (makeCompletedPulser)
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 (..))
import Test.Cardano.Ledger.Shelley.Utils (getBlockNonce)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

aliceInitCoin :: Coin
aliceInitCoin :: Coin
aliceInitCoin = 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 :: Coin
bobInitCoin = 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

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 (forall t s. Inject t s => t -> s
Val.inject Coin
aliceInitCoin)
    , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr (forall t s. Inject t s => t -> s
Val.inject Coin
bobInitCoin)
    ]

initStUpdates :: ChainState ShelleyEra
initStUpdates :: ChainState ShelleyEra
initStUpdates = forall era.
(EraTxOut era, ProtVerAtMost era 4, ProtVerAtMost era 6,
 Default (StashedAVVMAddresses era), EraGov era) =>
UTxO era -> ChainState era
initSt UTxO ShelleyEra
initUTxO

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

ppVoteA :: PParamsUpdate ShelleyEra
ppVoteA :: PParamsUpdate ShelleyEra
ppVoteA =
  forall era. EraPParams era => PParamsUpdate era
emptyPParamsUpdate
    forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuPoolDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (Integer -> Coin
Coin Integer
200)
    forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParamsUpdate era) (StrictMaybe Nonce)
ppuExtraEntropyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (Word64 -> Nonce
mkNonceFromNumber Word64
123)

collectVotes ::
  PParamsUpdate ShelleyEra ->
  [Int] ->
  ProposedPPUpdates ShelleyEra
collectVotes :: PParamsUpdate ShelleyEra -> [Int] -> ProposedPPUpdates ShelleyEra
collectVotes PParamsUpdate ShelleyEra
vote =
  forall era.
Map (KeyHash 'Genesis) (PParamsUpdate era) -> ProposedPPUpdates era
ProposedPPUpdates forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
n -> (forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ Int -> VKey 'Genesis
coreNodeVK Int
n, PParamsUpdate ShelleyEra
vote)))

ppVotes1 :: ProposedPPUpdates ShelleyEra
ppVotes1 :: ProposedPPUpdates ShelleyEra
ppVotes1 = PParamsUpdate ShelleyEra -> [Int] -> ProposedPPUpdates ShelleyEra
collectVotes PParamsUpdate ShelleyEra
ppVoteA [Int
0, Int
3, Int
4]

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

aliceCoinEx1 :: Coin
aliceCoinEx1 :: Coin
aliceCoinEx1 = Coin
aliceInitCoin forall t. Val t => t -> t -> t
<-> Coin
feeTx1

txbodyEx1 :: ShelleyTxBody ShelleyEra
txbodyEx1 :: ShelleyTxBody ShelleyEra
txbodyEx1 =
  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 (forall t s. Inject t s => t -> s
Val.inject Coin
aliceCoinEx1))
    forall a. StrictSeq a
StrictSeq.empty
    (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
    Coin
feeTx1
    (Word64 -> SlotNo
SlotNo Word64
10)
    (forall a. a -> StrictMaybe a
SJust (forall era. ProposedPPUpdates era -> EpochNo -> Update era
Update ProposedPPUpdates ShelleyEra
ppVotes1 (Word64 -> EpochNo
EpochNo Word64
0)))
    forall a. StrictMaybe a
SNothing

txEx1 :: ShelleyTx ShelleyEra
txEx1 :: ShelleyTx ShelleyEra
txEx1 =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    ShelleyTxBody ShelleyEra
txbodyEx1
    forall a. Monoid a => a
mempty
      { addrWits :: Set (WitVKey 'Witness)
addrWits =
          forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey
            (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody ShelleyEra
txbodyEx1)
            ( [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.alicePay]
                forall a. Semigroup a => a -> a -> a
<> [ 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 a b. (a -> b) -> a -> b
$ Int -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeIssuerKeys Int
0
                   , 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 a b. (a -> b) -> a -> b
$ Int -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeIssuerKeys Int
3
                   , 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 a b. (a -> b) -> a -> b
$ Int -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeIssuerKeys Int
4
                   ]
            )
      }
    forall a. StrictMaybe a
SNothing

blockEx1 :: Block (BHeader MockCrypto) ShelleyEra
blockEx1 :: Block (BHeader MockCrypto) ShelleyEra
blockEx1 =
  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)
    [ShelleyTx ShelleyEra
txEx1]
    (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))

expectedStEx1 :: ChainState ShelleyEra
expectedStEx1 :: ChainState ShelleyEra
expectedStEx1 =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceUnfrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce Block (BHeader MockCrypto) ShelleyEra
blockEx1)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newLab Block (BHeader MockCrypto) ShelleyEra
blockEx1
    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 [] []
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(EraTx era, EraGov era) =>
TxBody era -> ChainState era -> ChainState era
C.newUTxO ShelleyTxBody ShelleyEra
txbodyEx1
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(GovState era ~ ShelleyGovState era, EraPParams era) =>
ProposedPPUpdates era -> ChainState era -> ChainState era
C.setCurrentProposals ProposedPPUpdates ShelleyEra
ppVotes1
    forall a b. (a -> b) -> a -> b
$ ChainState ShelleyEra
initStUpdates

-- === Block 1, Slot 10, Epoch 0
--
-- In the first block, three genesis keys vote on the same new parameters.
updates1 :: CHAINExample ShelleyEra
updates1 :: CHAINExample ShelleyEra
updates1 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState ShelleyEra
initStUpdates Block (BHeader MockCrypto) ShelleyEra
blockEx1 (forall a b. b -> Either a b
Right ChainState ShelleyEra
expectedStEx1)

--
-- Block 2, Slot 20, Epoch 0
--

ppVotes2 :: ProposedPPUpdates ShelleyEra
ppVotes2 :: ProposedPPUpdates ShelleyEra
ppVotes2 = PParamsUpdate ShelleyEra -> [Int] -> ProposedPPUpdates ShelleyEra
collectVotes PParamsUpdate ShelleyEra
ppVoteA [Int
1, Int
5]

updateEx3B :: Update ShelleyEra
updateEx3B :: Update ShelleyEra
updateEx3B = forall era. ProposedPPUpdates era -> EpochNo -> Update era
Update ProposedPPUpdates ShelleyEra
ppVotes2 (Word64 -> EpochNo
EpochNo Word64
0)

feeTx2 :: Coin
feeTx2 :: Coin
feeTx2 = Integer -> Coin
Coin Integer
1

aliceCoinEx2 :: Coin
aliceCoinEx2 :: Coin
aliceCoinEx2 = Coin
aliceCoinEx1 forall t. Val t => t -> t -> t
<-> Coin
feeTx2

txbodyEx2 :: ShelleyTxBody ShelleyEra
txbodyEx2 :: ShelleyTxBody ShelleyEra
txbodyEx2 =
  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 (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody ShelleyTxBody ShelleyEra
txbodyEx1) 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 (forall t s. Inject t s => t -> s
Val.inject Coin
aliceCoinEx2))
    forall a. StrictSeq a
StrictSeq.empty
    (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
    (Integer -> Coin
Coin Integer
1)
    (Word64 -> SlotNo
SlotNo Word64
31)
    (forall a. a -> StrictMaybe a
SJust Update ShelleyEra
updateEx3B)
    forall a. StrictMaybe a
SNothing

txEx2 :: ShelleyTx ShelleyEra
txEx2 :: ShelleyTx ShelleyEra
txEx2 =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    ShelleyTxBody ShelleyEra
txbodyEx2
    forall a. Monoid a => a
mempty
      { addrWits :: Set (WitVKey 'Witness)
addrWits =
          forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey
            (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody ShelleyEra
txbodyEx2)
            ( [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.alicePay]
                forall a. Semigroup a => a -> a -> a
<> [ 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 a b. (a -> b) -> a -> b
$ Int -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeIssuerKeys Int
1
                   , 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 a b. (a -> b) -> a -> b
$ Int -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeIssuerKeys Int
5
                   ]
            )
      }
    forall a. StrictMaybe a
SNothing

blockEx2 :: Block (BHeader MockCrypto) ShelleyEra
blockEx2 :: Block (BHeader MockCrypto) ShelleyEra
blockEx2 =
  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 Block (BHeader MockCrypto) ShelleyEra
blockEx1)
    (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
20)
    [ShelleyTx ShelleyEra
txEx2]
    (Word64 -> SlotNo
SlotNo Word64
20)
    (Word64 -> BlockNo
BlockNo Word64
2)
    Nonce
nonce0
    (Natural -> NatNonce
NatNonce Natural
2)
    forall a. Bounded a => a
minBound
    Word
1
    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
20) Word64
0 (Word -> KESPeriod
KESPeriod Word
0))

expectedStEx2 :: ChainState ShelleyEra
expectedStEx2 :: ChainState ShelleyEra
expectedStEx2 =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceUnfrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce Block (BHeader MockCrypto) ShelleyEra
blockEx2)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newLab Block (BHeader MockCrypto) ShelleyEra
blockEx2
    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
feeTx2 [] []
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(EraTx era, EraGov era) =>
TxBody era -> ChainState era -> ChainState era
C.newUTxO ShelleyTxBody ShelleyEra
txbodyEx2
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(GovState era ~ ShelleyGovState era, EraPParams era) =>
ProposedPPUpdates era -> ChainState era -> ChainState era
C.setCurrentProposals (PParamsUpdate ShelleyEra -> [Int] -> ProposedPPUpdates ShelleyEra
collectVotes PParamsUpdate ShelleyEra
ppVoteA [Int
0, Int
1, Int
3, Int
4, Int
5])
    forall a b. (a -> b) -> a -> b
$ ChainState ShelleyEra
expectedStEx1

-- === Block 2, Slot 20, Epoch 0
--
-- In the second block, two more genesis keys vote for the same new parameters.
updates2 :: CHAINExample ShelleyEra
updates2 :: CHAINExample ShelleyEra
updates2 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState ShelleyEra
expectedStEx1 Block (BHeader MockCrypto) ShelleyEra
blockEx2 (forall a b. b -> Either a b
Right ChainState ShelleyEra
expectedStEx2)

--
-- Block 3, Slot 80, Epoch 0
--

ppVoteB :: PParamsUpdate ShelleyEra
ppVoteB :: PParamsUpdate ShelleyEra
ppVoteB =
  forall era. EraPParams era => PParamsUpdate era
emptyPParamsUpdate
    forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinUTxOValueL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (Integer -> Coin
Coin Integer
99)

ppVotes3 :: ProposedPPUpdates ShelleyEra
ppVotes3 :: ProposedPPUpdates ShelleyEra
ppVotes3 = PParamsUpdate ShelleyEra -> [Int] -> ProposedPPUpdates ShelleyEra
collectVotes PParamsUpdate ShelleyEra
ppVoteB [Int
1]

feeTx3 :: Coin
feeTx3 :: Coin
feeTx3 = Integer -> Coin
Coin Integer
1

aliceCoinEx3 :: Coin
aliceCoinEx3 :: Coin
aliceCoinEx3 = Coin
aliceCoinEx2 forall t. Val t => t -> t -> t
<-> Coin
feeTx3

txbodyEx3 :: ShelleyTxBody ShelleyEra
txbodyEx3 :: ShelleyTxBody ShelleyEra
txbodyEx3 =
  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 (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody ShelleyTxBody ShelleyEra
txbodyEx2) 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 (forall t s. Inject t s => t -> s
Val.inject Coin
aliceCoinEx3))
    forall a. StrictSeq a
StrictSeq.empty
    (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty)
    Coin
feeTx3
    (Word64 -> SlotNo
SlotNo Word64
81)
    (forall a. a -> StrictMaybe a
SJust (forall era. ProposedPPUpdates era -> EpochNo -> Update era
Update ProposedPPUpdates ShelleyEra
ppVotes3 (Word64 -> EpochNo
EpochNo Word64
1)))
    forall a. StrictMaybe a
SNothing

txEx3 :: ShelleyTx ShelleyEra
txEx3 :: ShelleyTx ShelleyEra
txEx3 =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    ShelleyTxBody ShelleyEra
txbodyEx3
    forall a. Monoid a => a
mempty
      { addrWits :: Set (WitVKey 'Witness)
addrWits =
          forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey
            (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ShelleyTxBody ShelleyEra
txbodyEx3)
            [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.alicePay, 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 a b. (a -> b) -> a -> b
$ Int -> AllIssuerKeys MockCrypto 'GenesisDelegate
coreNodeIssuerKeys Int
1]
      }
    forall a. StrictMaybe a
SNothing

blockEx3 :: Block (BHeader MockCrypto) ShelleyEra
blockEx3 :: Block (BHeader MockCrypto) ShelleyEra
blockEx3 =
  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 Block (BHeader MockCrypto) ShelleyEra
blockEx2)
    (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
80)
    [ShelleyTx ShelleyEra
txEx3]
    (Word64 -> SlotNo
SlotNo Word64
80)
    (Word64 -> BlockNo
BlockNo Word64
3)
    Nonce
nonce0
    (Natural -> NatNonce
NatNonce Natural
3)
    forall a. Bounded a => a
minBound
    Word
4
    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
80) Word64
0 (Word -> KESPeriod
KESPeriod Word
0))

pulserEx3 :: PulsingRewUpdate
pulserEx3 :: PulsingRewUpdate
pulserEx3 = forall era.
EraGov era =>
BlocksMade -> ChainState era -> PulsingRewUpdate
makeCompletedPulser (Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall a. Monoid a => a
mempty) ChainState ShelleyEra
expectedStEx2

expectedStEx3 :: ChainState ShelleyEra
expectedStEx3 :: ChainState ShelleyEra
expectedStEx3 =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceFrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce Block (BHeader MockCrypto) ShelleyEra
blockEx3)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newLab Block (BHeader MockCrypto) ShelleyEra
blockEx3
    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
feeTx3 [] []
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(EraTx era, EraGov era) =>
TxBody era -> ChainState era -> ChainState era
C.newUTxO ShelleyTxBody ShelleyEra
txbodyEx3
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. PulsingRewUpdate -> ChainState era -> ChainState era
C.pulserUpdate PulsingRewUpdate
pulserEx3
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(GovState era ~ ShelleyGovState era) =>
ProposedPPUpdates era -> ChainState era -> ChainState era
C.setFutureProposals (PParamsUpdate ShelleyEra -> [Int] -> ProposedPPUpdates ShelleyEra
collectVotes PParamsUpdate ShelleyEra
ppVoteB [Int
1])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => ChainState era -> ChainState era
C.solidifyProposals
    forall a b. (a -> b) -> a -> b
$ ChainState ShelleyEra
expectedStEx2

-- === Block 3, Slot 80, Epoch 0
--
-- In the third block, one genesis keys votes for the next epoch
updates3 :: CHAINExample ShelleyEra
updates3 :: CHAINExample ShelleyEra
updates3 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState ShelleyEra
expectedStEx2 Block (BHeader MockCrypto) ShelleyEra
blockEx3 (forall a b. b -> Either a b
Right ChainState ShelleyEra
expectedStEx3)

--
-- Block 4, Slot 110, Epoch 1
--

epoch1Nonce :: Nonce
epoch1Nonce :: Nonce
epoch1Nonce = forall era. ChainState era -> Nonce
chainCandidateNonce ChainState ShelleyEra
expectedStEx3 Nonce -> Nonce -> Nonce
⭒ Word64 -> Nonce
mkNonceFromNumber Word64
123

blockEx4 :: Block (BHeader MockCrypto) ShelleyEra
blockEx4 :: Block (BHeader MockCrypto) ShelleyEra
blockEx4 =
  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 Block (BHeader MockCrypto) ShelleyEra
blockEx3)
    (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
4)
    Nonce
epoch1Nonce
    (Natural -> NatNonce
NatNonce Natural
4)
    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))

ppExUpdated :: PParams ShelleyEra
ppExUpdated :: PParams ShelleyEra
ppExUpdated =
  forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
PParams era
ppEx
    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
200
    forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) Nonce
ppExtraEntropyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word64 -> Nonce
mkNonceFromNumber Word64
123

expectedStEx4 :: ChainState ShelleyEra
expectedStEx4 :: ChainState ShelleyEra
expectedStEx4 =
  forall era.
(ProtVerAtMost era 6, EraGov era) =>
Block (BHeader MockCrypto) era -> ChainState era -> ChainState era
C.newEpoch Block (BHeader MockCrypto) ShelleyEra
blockEx4
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. SnapShot -> Coin -> ChainState era -> ChainState era
C.newSnapshot SnapShot
EB.emptySnapShot (Coin
feeTx1 forall t. Val t => t -> t -> t
<+> Coin
feeTx2 forall t. Val t => t -> t -> t
<+> Coin
feeTx3)
    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.
(GovState era ~ ShelleyGovState era, EraPParams era) =>
ProposedPPUpdates era -> ChainState era -> ChainState era
C.setCurrentProposals (PParamsUpdate ShelleyEra -> [Int] -> ProposedPPUpdates ShelleyEra
collectVotes PParamsUpdate ShelleyEra
ppVoteB [Int
1])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(GovState era ~ ShelleyGovState era) =>
ProposedPPUpdates era -> ChainState era -> ChainState era
C.setFutureProposals (forall era.
Map (KeyHash 'Genesis) (PParamsUpdate era) -> ProposedPPUpdates era
ProposedPPUpdates forall k a. Map k a
Map.empty)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraGov era =>
PParams era -> ChainState era -> ChainState era
C.setPParams PParams ShelleyEra
ppExUpdated
    forall a b. (a -> b) -> a -> b
$ ChainState ShelleyEra
expectedStEx3

-- === Block 4, Slot 110, Epoch 1
--
-- In the fourth block, the new protocol parameters are adopted,
-- and the future vote becomes a current vote.
-- Since the extra entropy was voted on, notice that it is a part
-- of the new epoch nonce.
updates4 :: CHAINExample ShelleyEra
updates4 :: CHAINExample ShelleyEra
updates4 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample ChainState ShelleyEra
expectedStEx3 Block (BHeader MockCrypto) ShelleyEra
blockEx4 (forall a b. b -> Either a b
Right ChainState ShelleyEra
expectedStEx4)

--
-- Updates Test Group
--

updatesExample :: TestTree
updatesExample :: TestTree
updatesExample =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"protocol parameter updates"
    [ TestName -> Assertion -> TestTree
testCase TestName
"get 3/7 votes for a pparam update" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample CHAINExample ShelleyEra
updates1
    , TestName -> Assertion -> TestTree
testCase TestName
"get 5/7 votes for a pparam update" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample CHAINExample ShelleyEra
updates2
    , TestName -> Assertion -> TestTree
testCase TestName
"votes for the next epoch" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample CHAINExample ShelleyEra
updates3
    , TestName -> Assertion -> TestTree
testCase TestName
"processes a pparam update" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample CHAINExample ShelleyEra
updates4
    ]