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

-- |
-- Module      : Test.Cardano.Ledger.Shelley.Examples.GenesisDelegation
-- Description : Genesis Delegation Example
--
-- Example demonstrating Genesis Delegation
module Test.Cardano.Ledger.Shelley.Examples.GenesisDelegation (
  genesisDelegExample,
)
where

import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Block (Block, bheader)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Keys (GenDelegPair (..), asWitness)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Tx (ShelleyTx (..))
import Cardano.Ledger.Shelley.TxBody (ShelleyTxBody (..))
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits, 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.Crypto (hashVerKeyVRF)
import Cardano.Protocol.TPraos.BHeader (BHeader, bhHash)
import Cardano.Protocol.TPraos.OCert (KESPeriod (..))
import Data.Default (Default)
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 (
  coreNodeKeysBySchedule,
  coreNodeSK,
  coreNodeVK,
 )
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 (
  NatNonce (..),
  VRFKeyPair (..),
  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 (
  RawSeed (..),
  getBlockNonce,
  mkKeyPair,
  mkVRFKeyPair,
 )
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

initUTxO :: EraTxOut era => UTxO era
initUTxO :: forall era. EraTxOut era => UTxO era
initUTxO =
  forall era. TxId -> [TxOut era] -> UTxO era
genesisCoins
    TxId
genesisId
    [ forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
Cast.aliceAddr Value era
aliceInitCoin
    , forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
Cast.bobAddr Value era
bobInitCoin
    ]
  where
    aliceInitCoin :: Value era
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 :: Value era
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

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

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

newGenDelegate :: KeyPair 'GenesisDelegate
newGenDelegate :: KeyPair 'GenesisDelegate
newGenDelegate = forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair forall {kd :: KeyRole}. VKey kd
vkCold SignKeyDSIGN DSIGN
skCold
  where
    (SignKeyDSIGN DSIGN
skCold, VKey kd
vkCold) = forall (kd :: KeyRole). RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
mkKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
108 Word64
0 Word64
0 Word64
0 Word64
1)

newGenesisVrfKH :: VRFVerKeyHash 'GenDelegVRF
newGenesisVrfKH :: VRFVerKeyHash 'GenDelegVRF
newGenesisVrfKH = forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @MockCrypto (forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey (forall c. Crypto c => RawSeed -> VRFKeyPair c
mkVRFKeyPair @MockCrypto (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
9 Word64
8 Word64
7 Word64
6 Word64
5)))

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

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 Coin
aliceCoinEx1)
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
KeyHash 'Genesis
-> KeyHash 'GenesisDelegate
-> VRFVerKeyHash 'GenDelegVRF
-> TxCert era
GenesisDelegTxCert
            (forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (Int -> VKey 'Genesis
coreNodeVK Int
0))
            (forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'GenesisDelegate
newGenDelegate))
            VRFVerKeyHash 'GenDelegVRF
newGenesisVrfKH
        ]
    )
    (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
    aliceCoinEx1 :: Coin
aliceCoinEx1 = Coin
aliceInitCoin forall t. Val t => t -> t -> t
<-> forall t s. Inject t s => t -> s
Val.inject Coin
feeTx1
    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

txEx1 :: ShelleyTx ShelleyEra
txEx1 :: ShelleyTx ShelleyEra
txEx1 = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx ShelleyTxBody ShelleyEra
txbodyEx1 ShelleyTxWits ShelleyEra
txwits forall a. StrictMaybe a
SNothing
  where
    txwits :: ShelleyTxWits ShelleyEra
    txwits :: ShelleyTxWits ShelleyEra
txwits =
      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 a b. (a -> b) -> a -> b
$
                        forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair @'Genesis
                          (Int -> VKey 'Genesis
coreNodeVK Int
0)
                          (Int -> SignKeyDSIGN DSIGN
coreNodeSK Int
0)
                     ]
              )
        }

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 @ShelleyEra
    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 @MockCrypto (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))

newGenDeleg :: (FutureGenDeleg, GenDelegPair)
newGenDeleg :: (FutureGenDeleg, GenDelegPair)
newGenDeleg =
  ( SlotNo -> KeyHash 'Genesis -> FutureGenDeleg
FutureGenDeleg (Word64 -> SlotNo
SlotNo Word64
43) (forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ Int -> VKey 'Genesis
coreNodeVK Int
0)
  , KeyHash 'GenesisDelegate
-> VRFVerKeyHash 'GenDelegVRF -> GenDelegPair
GenDelegPair (forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'GenesisDelegate
newGenDelegate) VRFVerKeyHash 'GenDelegVRF
newGenesisVrfKH
  )

expectedStEx1 :: ChainState ShelleyEra
expectedStEx1 :: ChainState ShelleyEra
expectedStEx1 =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceUnfrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce @ShelleyEra 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.
(FutureGenDeleg, GenDelegPair) -> ChainState era -> ChainState era
C.setFutureGenDeleg (FutureGenDeleg, GenDelegPair)
newGenDeleg
    forall a b. (a -> b) -> a -> b
$ forall era.
(EraTxOut era, ProtVerAtMost era 4, ProtVerAtMost era 6,
 EraGov era, Default (StashedAVVMAddresses era)) =>
ChainState era
initStGenesisDeleg

-- === Block 1, Slot 10, Epoch 0
--
-- In the first block, stage a new future genesis delegate
genesisDelegation1 :: CHAINExample ShelleyEra
genesisDelegation1 :: CHAINExample ShelleyEra
genesisDelegation1 = forall era.
ChainState era
-> Block (BHeader MockCrypto) era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
-> CHAINExample era
CHAINExample forall era.
(EraTxOut era, ProtVerAtMost era 4, ProtVerAtMost era 6,
 EraGov era, Default (StashedAVVMAddresses era)) =>
ChainState era
initStGenesisDeleg Block (BHeader MockCrypto) ShelleyEra
blockEx1 (forall a b. b -> Either a b
Right ChainState ShelleyEra
expectedStEx1)

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

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 @ShelleyEra
    (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
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 @MockCrypto (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 :: PulsingRewUpdate
pulserEx2 :: PulsingRewUpdate
pulserEx2 = forall era. EraGov era => ChainState era -> PulsingRewUpdate
makePulser' ChainState ShelleyEra
expectedStEx1

expectedStEx2 :: ChainState ShelleyEra
expectedStEx2 :: ChainState ShelleyEra
expectedStEx2 =
  forall era. Nonce -> ChainState era -> ChainState era
C.evolveNonceUnfrozen (forall era. Block (BHeader MockCrypto) era -> Nonce
getBlockNonce @ShelleyEra 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.
(FutureGenDeleg, GenDelegPair) -> ChainState era -> ChainState era
C.adoptFutureGenDeleg (FutureGenDeleg, GenDelegPair)
newGenDeleg
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. PulsingRewUpdate -> ChainState era -> ChainState era
C.pulserUpdate PulsingRewUpdate
pulserEx2
    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
expectedStEx1

-- === Block 2, Slot 50, Epoch 0
--
-- Submit an empty block to trigger adopting the genesis delegation.
genesisDelegation2 :: CHAINExample ShelleyEra
genesisDelegation2 :: CHAINExample ShelleyEra
genesisDelegation2 = 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)

--
-- Genesis Delegation Test Group
--

genesisDelegExample :: TestTree
genesisDelegExample :: TestTree
genesisDelegExample =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"genesis delegation"
    [ TestName -> Assertion -> TestTree
testCase TestName
"stage genesis key delegation" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample CHAINExample ShelleyEra
genesisDelegation1
    , TestName -> Assertion -> TestTree
testCase TestName
"adopt genesis key delegation" forall a b. (a -> b) -> a -> b
$ HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample CHAINExample ShelleyEra
genesisDelegation2
    ]