{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Shelley.Examples.Consensus where

import Cardano.Crypto.DSIGN as DSIGN
import Cardano.Crypto.Hash as Hash
import Cardano.Crypto.KES as KES
import Cardano.Crypto.Seed as Seed
import qualified Cardano.Crypto.VRF as VRF
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Keys hiding (hashVerKeyVRF)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.API hiding (hashVerKeyVRF)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.Translation (emptyFromByronTranslationContext)
import Cardano.Ledger.Shelley.TxWits
import Cardano.Protocol.Crypto
import Cardano.Protocol.TPraos.API
import Cardano.Protocol.TPraos.BHeader
import Cardano.Protocol.TPraos.OCert
import Cardano.Protocol.TPraos.Rules.Prtcl
import Cardano.Protocol.TPraos.Rules.Tickn
import Cardano.Slotting.EpochInfo
import qualified Data.ByteString as Strict
import Data.Coerce (coerce)
import Data.Default
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
import Data.Proxy
import Data.Sequence.Strict (StrictSeq)
import qualified Data.Sequence.Strict as StrictSeq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (pack)
import Data.Time
import Data.Word (Word64, Word8)
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Binary.Random (mkDummyHash)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkWitnessesVKey)
import Test.Cardano.Ledger.Shelley.Generator.Core
import Test.Cardano.Ledger.Shelley.Utils hiding (mkVRFKeyPair)

{-------------------------------------------------------------------------------
  ShelleyLedgerExamples
-------------------------------------------------------------------------------}

data ShelleyResultExamples era = ShelleyResultExamples
  { forall era. ShelleyResultExamples era -> PParams era
srePParams :: PParams era
  , forall era. ShelleyResultExamples era -> ProposedPPUpdates era
sreProposedPPUpdates :: ProposedPPUpdates era
  , forall era. ShelleyResultExamples era -> PoolDistr
srePoolDistr :: PoolDistr
  , forall era.
ShelleyResultExamples era
-> Map
     (Either Coin (Credential 'Staking)) (Map (KeyHash 'StakePool) Coin)
sreNonMyopicRewards ::
      Map
        (Either Coin (Credential 'Staking))
        (Map (KeyHash 'StakePool) Coin)
  , forall era. ShelleyResultExamples era -> ShelleyGenesis
sreShelleyGenesis :: ShelleyGenesis
  }

deriving instance
  ( Eq (PParams era)
  , Eq (PParamsUpdate era)
  , Era era
  ) =>
  Eq (ShelleyResultExamples era)

data ShelleyLedgerExamples era = ShelleyLedgerExamples
  { forall era.
ShelleyLedgerExamples era -> Block (BHeader StandardCrypto) era
sleBlock :: Block (BHeader StandardCrypto) era
  , forall era. ShelleyLedgerExamples era -> HashHeader
sleHashHeader :: HashHeader
  , forall era. ShelleyLedgerExamples era -> Tx era
sleTx :: Tx era
  , forall era. ShelleyLedgerExamples era -> ApplyTxError era
sleApplyTxError :: ApplyTxError era
  , forall era.
ShelleyLedgerExamples era
-> Set (Either Coin (Credential 'Staking))
sleRewardsCredentials :: Set (Either Coin (Credential 'Staking))
  , forall era. ShelleyLedgerExamples era -> ShelleyResultExamples era
sleResultExamples :: ShelleyResultExamples era
  , forall era. ShelleyLedgerExamples era -> NewEpochState era
sleNewEpochState :: NewEpochState era
  , forall era. ShelleyLedgerExamples era -> ChainDepState
sleChainDepState :: ChainDepState
  , forall era. ShelleyLedgerExamples era -> TranslationContext era
sleTranslationContext :: TranslationContext era
  }

deriving instance
  ( EraTx era
  , EraGov era
  , Eq (TxSeq era)
  , Eq (PredicateFailure (EraRule "LEDGER" era))
  , Eq (StashedAVVMAddresses era)
  , Eq (TranslationContext era)
  , Eq (CertState era)
  , Eq (InstantStake era)
  ) =>
  Eq (ShelleyLedgerExamples era)

{-------------------------------------------------------------------------------
  Default constructor
-------------------------------------------------------------------------------}

defaultShelleyLedgerExamples ::
  forall era.
  ( EraSegWits era
  , EraGov era
  , EraStake era
  , EraCertState era
  , PredicateFailure (EraRule "DELEGS" era) ~ ShelleyDelegsPredFailure era
  , PredicateFailure (EraRule "LEDGER" era) ~ ShelleyLedgerPredFailure era
  , Default (StashedAVVMAddresses era)
  , ProtVerAtMost era 4
  ) =>
  (TxBody era -> [KeyPair 'Witness] -> TxWits era) ->
  (ShelleyTx era -> Tx era) ->
  Value era ->
  TxBody era ->
  TxAuxData era ->
  TranslationContext era ->
  ShelleyLedgerExamples era
defaultShelleyLedgerExamples :: forall era.
(EraSegWits era, EraGov era, EraStake era, EraCertState era,
 PredicateFailure (EraRule "DELEGS" era)
 ~ ShelleyDelegsPredFailure era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ ShelleyLedgerPredFailure era,
 Default (StashedAVVMAddresses era), ProtVerAtMost era 4) =>
(TxBody era -> [KeyPair 'Witness] -> TxWits era)
-> (ShelleyTx era -> Tx era)
-> Value era
-> TxBody era
-> TxAuxData era
-> TranslationContext era
-> ShelleyLedgerExamples era
defaultShelleyLedgerExamples TxBody era -> [KeyPair 'Witness] -> TxWits era
mkWitnesses ShelleyTx era -> Tx era
mkAlonzoTx Value era
value TxBody era
txBody TxAuxData era
auxData TranslationContext era
translationContext =
  ShelleyLedgerExamples
    { sleBlock :: Block (BHeader StandardCrypto) era
sleBlock = Tx era -> Block (BHeader StandardCrypto) era
forall era.
EraSegWits era =>
Tx era -> Block (BHeader StandardCrypto) era
exampleShelleyLedgerBlock (ShelleyTx era -> Tx era
mkAlonzoTx ShelleyTx era
tx)
    , sleHashHeader :: HashHeader
sleHashHeader = HashHeader
exampleHashHeader
    , sleTx :: Tx era
sleTx = ShelleyTx era -> Tx era
mkAlonzoTx ShelleyTx era
tx
    , sleApplyTxError :: ApplyTxError era
sleApplyTxError =
        NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
NonEmpty (ShelleyLedgerPredFailure era) -> ApplyTxError era
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
ApplyTxError (NonEmpty (ShelleyLedgerPredFailure era) -> ApplyTxError era)
-> (ShelleyDelegsPredFailure era
    -> NonEmpty (ShelleyLedgerPredFailure era))
-> ShelleyDelegsPredFailure era
-> ApplyTxError era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerPredFailure era
-> NonEmpty (ShelleyLedgerPredFailure era)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShelleyLedgerPredFailure era
 -> NonEmpty (ShelleyLedgerPredFailure era))
-> (ShelleyDelegsPredFailure era -> ShelleyLedgerPredFailure era)
-> ShelleyDelegsPredFailure era
-> NonEmpty (ShelleyLedgerPredFailure era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredicateFailure (EraRule "DELEGS" era)
-> ShelleyLedgerPredFailure era
ShelleyDelegsPredFailure era -> ShelleyLedgerPredFailure era
forall era.
PredicateFailure (EraRule "DELEGS" era)
-> ShelleyLedgerPredFailure era
DelegsFailure (ShelleyDelegsPredFailure era -> ApplyTxError era)
-> ShelleyDelegsPredFailure era -> ApplyTxError era
forall a b. (a -> b) -> a -> b
$
          forall era. KeyHash 'StakePool -> ShelleyDelegsPredFailure era
DelegateeNotRegisteredDELEG @era (Int -> KeyHash 'StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1)
    , sleRewardsCredentials :: Set (Either Coin (Credential 'Staking))
sleRewardsCredentials =
        [Either Coin (Credential 'Staking)]
-> Set (Either Coin (Credential 'Staking))
forall a. Ord a => [a] -> Set a
Set.fromList
          [ Coin -> Either Coin (Credential 'Staking)
forall a b. a -> Either a b
Left (Integer -> Coin
Coin Integer
100)
          , Credential 'Staking -> Either Coin (Credential 'Staking)
forall a b. b -> Either a b
Right (ScriptHash -> Credential 'Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (Int -> ScriptHash
mkScriptHash Int
1))
          , Credential 'Staking -> Either Coin (Credential 'Staking)
forall a b. b -> Either a b
Right (KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (Int -> KeyHash 'Staking
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
2))
          ]
    , sleResultExamples :: ShelleyResultExamples era
sleResultExamples = ShelleyResultExamples era
resultExamples
    , sleNewEpochState :: NewEpochState era
sleNewEpochState =
        Value era -> PParams era -> PParams era -> NewEpochState era
forall era.
(EraTxOut era, EraGov era, EraStake era, EraCertState era,
 Default (StashedAVVMAddresses era)) =>
Value era -> PParams era -> PParams era -> NewEpochState era
exampleNewEpochState
          Value era
value
          PParams era
forall era. EraPParams era => PParams era
emptyPParams
          (PParams era
forall era. EraPParams era => PParams era
emptyPParams PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppMinUTxOValueL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1)
    , sleChainDepState :: ChainDepState
sleChainDepState = Word64 -> ChainDepState
exampleLedgerChainDepState Word64
1
    , sleTranslationContext :: TranslationContext era
sleTranslationContext = TranslationContext era
translationContext
    }
  where
    tx :: ShelleyTx era
tx = (TxBody era -> [KeyPair 'Witness] -> TxWits era)
-> TxBody era -> TxAuxData era -> ShelleyTx era
forall era.
EraTx era =>
(TxBody era -> [KeyPair 'Witness] -> TxWits era)
-> TxBody era -> TxAuxData era -> ShelleyTx era
exampleTx TxBody era -> [KeyPair 'Witness] -> TxWits era
mkWitnesses TxBody era
txBody TxAuxData era
auxData

    resultExamples :: ShelleyResultExamples era
resultExamples =
      ShelleyResultExamples
        { srePParams :: PParams era
srePParams = PParams era
forall a. Default a => a
def
        , sreProposedPPUpdates :: ProposedPPUpdates era
sreProposedPPUpdates = ProposedPPUpdates era
forall era. EraPParams era => ProposedPPUpdates era
exampleProposedPParamsUpdates
        , srePoolDistr :: PoolDistr
srePoolDistr = PoolDistr
examplePoolDistr
        , sreNonMyopicRewards :: Map
  (Either Coin (Credential 'Staking)) (Map (KeyHash 'StakePool) Coin)
sreNonMyopicRewards = Map
  (Either Coin (Credential 'Staking)) (Map (KeyHash 'StakePool) Coin)
exampleNonMyopicRewards
        , sreShelleyGenesis :: ShelleyGenesis
sreShelleyGenesis = ShelleyGenesis
testShelleyGenesis
        }

{-------------------------------------------------------------------------------
  Helper constructors
-------------------------------------------------------------------------------}

exampleShelleyLedgerBlock ::
  forall era.
  EraSegWits era =>
  Tx era ->
  Block (BHeader StandardCrypto) era
exampleShelleyLedgerBlock :: forall era.
EraSegWits era =>
Tx era -> Block (BHeader StandardCrypto) era
exampleShelleyLedgerBlock Tx era
tx = BHeader StandardCrypto
-> TxSeq era -> Block (BHeader StandardCrypto) era
forall h era. h -> TxSeq era -> Block h era
Block BHeader StandardCrypto
blockHeader TxSeq era
blockBody
  where
    keys :: AllIssuerKeys StandardCrypto 'StakePool
    keys :: AllIssuerKeys StandardCrypto 'StakePool
keys = AllIssuerKeys StandardCrypto 'StakePool
forall (r :: KeyRole). AllIssuerKeys StandardCrypto r
exampleKeys

    hotKey :: UnsoundPureSignKeyKES (KES StandardCrypto)
hotKey = KESKeyPair StandardCrypto
-> UnsoundPureSignKeyKES (KES StandardCrypto)
forall c. KESKeyPair c -> UnsoundPureSignKeyKES (KES c)
kesSignKey (KESKeyPair StandardCrypto
 -> UnsoundPureSignKeyKES (KES StandardCrypto))
-> KESKeyPair StandardCrypto
-> UnsoundPureSignKeyKES (KES StandardCrypto)
forall a b. (a -> b) -> a -> b
$ (KESPeriod, KESKeyPair StandardCrypto) -> KESKeyPair StandardCrypto
forall a b. (a, b) -> b
snd ((KESPeriod, KESKeyPair StandardCrypto)
 -> KESKeyPair StandardCrypto)
-> (KESPeriod, KESKeyPair StandardCrypto)
-> KESKeyPair StandardCrypto
forall a b. (a -> b) -> a -> b
$ NonEmpty (KESPeriod, KESKeyPair StandardCrypto)
-> (KESPeriod, KESKeyPair StandardCrypto)
forall a. NonEmpty a -> a
NE.head (NonEmpty (KESPeriod, KESKeyPair StandardCrypto)
 -> (KESPeriod, KESKeyPair StandardCrypto))
-> NonEmpty (KESPeriod, KESKeyPair StandardCrypto)
-> (KESPeriod, KESKeyPair StandardCrypto)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys StandardCrypto 'StakePool
-> NonEmpty (KESPeriod, KESKeyPair StandardCrypto)
forall c (r :: KeyRole).
AllIssuerKeys c r -> NonEmpty (KESPeriod, KESKeyPair c)
aikHot AllIssuerKeys StandardCrypto 'StakePool
keys
    KeyPair VKey 'StakePool
vKeyCold SignKeyDSIGN Ed25519DSIGN
_ = AllIssuerKeys StandardCrypto 'StakePool -> KeyPair 'StakePool
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys StandardCrypto 'StakePool
keys

    blockHeader :: BHeader StandardCrypto
    blockHeader :: BHeader StandardCrypto
blockHeader = BHBody StandardCrypto
-> SignedKES (KES StandardCrypto) (BHBody StandardCrypto)
-> BHeader StandardCrypto
forall c.
Crypto c =>
BHBody c -> SignedKES (KES c) (BHBody c) -> BHeader c
BHeader BHBody StandardCrypto
blockHeaderBody (ContextKES (Sum6KES Ed25519DSIGN HASH)
-> Period
-> BHBody StandardCrypto
-> UnsoundPureSignKeyKES (Sum6KES Ed25519DSIGN HASH)
-> SignedKES (Sum6KES Ed25519DSIGN HASH) (BHBody StandardCrypto)
forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v
-> Period -> a -> UnsoundPureSignKeyKES v -> SignedKES v a
unsoundPureSignedKES () Period
0 BHBody StandardCrypto
blockHeaderBody UnsoundPureSignKeyKES (Sum6KES Ed25519DSIGN HASH)
hotKey)

    blockHeaderBody :: BHBody StandardCrypto
    blockHeaderBody :: BHBody StandardCrypto
blockHeaderBody =
      BHBody
        { bheaderBlockNo :: BlockNo
bheaderBlockNo = Word64 -> BlockNo
BlockNo Word64
3
        , bheaderSlotNo :: SlotNo
bheaderSlotNo = Word64 -> SlotNo
SlotNo Word64
9
        , bheaderPrev :: PrevHash
bheaderPrev = HashHeader -> PrevHash
BlockHash (Hash HASH EraIndependentBlockHeader -> HashHeader
HashHeader (Int -> Hash HASH EraIndependentBlockHeader
forall h a b. (HashAlgorithm h, EncCBOR a) => a -> Hash h b
mkDummyHash (Int
2 :: Int)))
        , bheaderVk :: VKey 'BlockIssuer
bheaderVk = VKey 'StakePool -> VKey 'BlockIssuer
forall (r :: KeyRole) (r' :: KeyRole). VKey r -> VKey r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole VKey 'StakePool
vKeyCold
        , bheaderVrfVk :: VerKeyVRF (VRF StandardCrypto)
bheaderVrfVk = VRFKeyPair StandardCrypto -> VerKeyVRF (VRF StandardCrypto)
forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey (VRFKeyPair StandardCrypto -> VerKeyVRF (VRF StandardCrypto))
-> VRFKeyPair StandardCrypto -> VerKeyVRF (VRF StandardCrypto)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys StandardCrypto 'StakePool
-> VRFKeyPair StandardCrypto
forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf AllIssuerKeys StandardCrypto 'StakePool
keys
        , bheaderEta :: CertifiedVRF (VRF StandardCrypto) Nonce
bheaderEta = Seed -> SignKeyVRF PraosVRF -> CertifiedVRF PraosVRF Nonce
forall v a b.
(Signable v a, VRFAlgorithm v, ContextVRF v ~ (),
 Coercible b (CertifiedVRF v a)) =>
a -> SignKeyVRF v -> b
mkCertifiedVRF (Int -> Seed
mkBytes Int
0) (VRFKeyPair StandardCrypto -> SignKeyVRF (VRF StandardCrypto)
forall c. VRFKeyPair c -> SignKeyVRF (VRF c)
vrfSignKey (VRFKeyPair StandardCrypto -> SignKeyVRF (VRF StandardCrypto))
-> VRFKeyPair StandardCrypto -> SignKeyVRF (VRF StandardCrypto)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys StandardCrypto 'StakePool
-> VRFKeyPair StandardCrypto
forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf AllIssuerKeys StandardCrypto 'StakePool
keys)
        , bheaderL :: CertifiedVRF (VRF StandardCrypto) Nat
bheaderL = Seed -> SignKeyVRF PraosVRF -> CertifiedVRF PraosVRF Nat
forall v a b.
(Signable v a, VRFAlgorithm v, ContextVRF v ~ (),
 Coercible b (CertifiedVRF v a)) =>
a -> SignKeyVRF v -> b
mkCertifiedVRF (Int -> Seed
mkBytes Int
1) (VRFKeyPair StandardCrypto -> SignKeyVRF (VRF StandardCrypto)
forall c. VRFKeyPair c -> SignKeyVRF (VRF c)
vrfSignKey (VRFKeyPair StandardCrypto -> SignKeyVRF (VRF StandardCrypto))
-> VRFKeyPair StandardCrypto -> SignKeyVRF (VRF StandardCrypto)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys StandardCrypto 'StakePool
-> VRFKeyPair StandardCrypto
forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf AllIssuerKeys StandardCrypto 'StakePool
keys)
        , bsize :: Word32
bsize = Word32
2345
        , bhash :: Hash HASH EraIndependentBlockBody
bhash = forall era.
EraSegWits era =>
TxSeq era -> Hash HASH EraIndependentBlockBody
hashTxSeq @era TxSeq era
blockBody
        , bheaderOCert :: OCert StandardCrypto
bheaderOCert = AllIssuerKeys StandardCrypto 'StakePool
-> Word64 -> KESPeriod -> OCert StandardCrypto
forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys StandardCrypto 'StakePool
keys Word64
0 (Period -> KESPeriod
KESPeriod Period
0)
        , bprotver :: ProtVer
bprotver = Version -> Nat -> ProtVer
ProtVer (forall (v :: Nat).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2) Nat
0
        }

    blockBody :: TxSeq era
blockBody = forall era. EraSegWits era => StrictSeq (Tx era) -> TxSeq era
toTxSeq @era ([Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [Tx era
tx])

    mkBytes :: Int -> Cardano.Ledger.BaseTypes.Seed
    mkBytes :: Int -> Seed
mkBytes = Hash HASH Seed -> Seed
Seed (Hash HASH Seed -> Seed) -> (Int -> Hash HASH Seed) -> Int -> Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a b. (HashAlgorithm h, EncCBOR a) => a -> Hash h b
mkDummyHash @Blake2b_256

exampleHashHeader :: HashHeader
exampleHashHeader :: HashHeader
exampleHashHeader = Hash HASH Any -> HashHeader
forall a b. Coercible a b => a -> b
coerce (Hash HASH Any -> HashHeader) -> Hash HASH Any -> HashHeader
forall a b. (a -> b) -> a -> b
$ forall h a b. (HashAlgorithm h, EncCBOR a) => a -> Hash h b
mkDummyHash @HASH (Int
0 :: Int)

mkKeyHash :: forall discriminator. Int -> KeyHash discriminator
mkKeyHash :: forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash = Hash ADDRHASH (VerKeyDSIGN Ed25519DSIGN) -> KeyHash discriminator
forall (r :: KeyRole).
Hash ADDRHASH (VerKeyDSIGN Ed25519DSIGN) -> KeyHash r
KeyHash (Hash ADDRHASH (VerKeyDSIGN Ed25519DSIGN) -> KeyHash discriminator)
-> (Int -> Hash ADDRHASH (VerKeyDSIGN Ed25519DSIGN))
-> Int
-> KeyHash discriminator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a b. (HashAlgorithm h, EncCBOR a) => a -> Hash h b
mkDummyHash @ADDRHASH

mkScriptHash :: Int -> ScriptHash
mkScriptHash :: Int -> ScriptHash
mkScriptHash = Hash ADDRHASH EraIndependentScript -> ScriptHash
ScriptHash (Hash ADDRHASH EraIndependentScript -> ScriptHash)
-> (Int -> Hash ADDRHASH EraIndependentScript) -> Int -> ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a b. (HashAlgorithm h, EncCBOR a) => a -> Hash h b
mkDummyHash @ADDRHASH

-- | This is not a valid transaction. We don't care, we are only interested in
-- serialisation, not validation.
exampleTx ::
  forall era.
  EraTx era =>
  (TxBody era -> [KeyPair 'Witness] -> TxWits era) ->
  TxBody era ->
  TxAuxData era ->
  ShelleyTx era
exampleTx :: forall era.
EraTx era =>
(TxBody era -> [KeyPair 'Witness] -> TxWits era)
-> TxBody era -> TxAuxData era -> ShelleyTx era
exampleTx TxBody era -> [KeyPair 'Witness] -> TxWits era
mkWitnesses TxBody era
txBody TxAuxData era
auxData =
  TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx TxBody era
txBody (TxBody era -> [KeyPair 'Witness] -> TxWits era
mkWitnesses TxBody era
txBody [KeyPair 'Witness]
keyPairWits) (TxAuxData era -> StrictMaybe (TxAuxData era)
forall a. a -> StrictMaybe a
SJust TxAuxData era
auxData)
  where
    keyPairWits :: [KeyPair 'Witness]
keyPairWits =
      [ KeyPair 'Payment -> KeyPair 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
examplePayKey
      , KeyPair 'Staking -> KeyPair 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Staking
exampleStakeKey
      , KeyPair Any -> KeyPair 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (KeyPair Any -> KeyPair 'Witness)
-> KeyPair Any -> KeyPair 'Witness
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys StandardCrypto Any -> KeyPair Any
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys StandardCrypto Any
forall (r :: KeyRole). AllIssuerKeys StandardCrypto r
exampleKeys
      ]

exampleProposedPParamsUpdates ::
  EraPParams era =>
  ProposedPPUpdates era
exampleProposedPParamsUpdates :: forall era. EraPParams era => ProposedPPUpdates era
exampleProposedPParamsUpdates =
  Map (KeyHash 'Genesis) (PParamsUpdate era) -> ProposedPPUpdates era
forall era.
Map (KeyHash 'Genesis) (PParamsUpdate era) -> ProposedPPUpdates era
ProposedPPUpdates (Map (KeyHash 'Genesis) (PParamsUpdate era)
 -> ProposedPPUpdates era)
-> Map (KeyHash 'Genesis) (PParamsUpdate era)
-> ProposedPPUpdates era
forall a b. (a -> b) -> a -> b
$
    KeyHash 'Genesis
-> PParamsUpdate era -> Map (KeyHash 'Genesis) (PParamsUpdate era)
forall k a. k -> a -> Map k a
Map.singleton
      (Int -> KeyHash 'Genesis
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
0)
      (PParamsUpdate era
forall era. EraPParams era => PParamsUpdate era
emptyPParamsUpdate PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuKeyDepositL ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Coin -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust (Integer -> Coin
Coin Integer
100))

examplePoolDistr :: PoolDistr
examplePoolDistr :: PoolDistr
examplePoolDistr =
  Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr
    ( [(KeyHash 'StakePool, IndividualPoolStake)]
-> Map (KeyHash 'StakePool) IndividualPoolStake
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [
          ( Int -> KeyHash 'StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1
          , Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF
-> IndividualPoolStake
IndividualPoolStake
              Rational
1
              (Word64 -> CompactForm Coin
CompactCoin Word64
1)
              (forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @StandardCrypto (VRFKeyPair StandardCrypto -> VerKeyVRF (VRF StandardCrypto)
forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey (AllIssuerKeys StandardCrypto Any -> VRFKeyPair StandardCrypto
forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf AllIssuerKeys StandardCrypto Any
forall (r :: KeyRole). AllIssuerKeys StandardCrypto r
exampleKeys)))
          )
        ]
    )
    (Word64 -> CompactForm Coin
CompactCoin Word64
1)

exampleNonMyopicRewards ::
  Map
    (Either Coin (Credential 'Staking))
    (Map (KeyHash 'StakePool) Coin)
exampleNonMyopicRewards :: Map
  (Either Coin (Credential 'Staking)) (Map (KeyHash 'StakePool) Coin)
exampleNonMyopicRewards =
  [(Either Coin (Credential 'Staking),
  Map (KeyHash 'StakePool) Coin)]
-> Map
     (Either Coin (Credential 'Staking)) (Map (KeyHash 'StakePool) Coin)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Coin -> Either Coin (Credential 'Staking)
forall a b. a -> Either a b
Left (Integer -> Coin
Coin Integer
100), KeyHash 'StakePool -> Coin -> Map (KeyHash 'StakePool) Coin
forall k a. k -> a -> Map k a
Map.singleton (Int -> KeyHash 'StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
2) (Integer -> Coin
Coin Integer
3))
    , (Credential 'Staking -> Either Coin (Credential 'Staking)
forall a b. b -> Either a b
Right (ScriptHash -> Credential 'Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (Int -> ScriptHash
mkScriptHash Int
1)), Map (KeyHash 'StakePool) Coin
forall k a. Map k a
Map.empty)
    , (Credential 'Staking -> Either Coin (Credential 'Staking)
forall a b. b -> Either a b
Right (KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (Int -> KeyHash 'Staking
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
2)), KeyHash 'StakePool -> Coin -> Map (KeyHash 'StakePool) Coin
forall k a. k -> a -> Map k a
Map.singleton (Int -> KeyHash 'StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
3) (Integer -> Coin
Coin Integer
9))
    ]

-- | These are dummy values.
testShelleyGenesis :: ShelleyGenesis
testShelleyGenesis :: ShelleyGenesis
testShelleyGenesis =
  ShelleyGenesis
    { sgSystemStart :: UTCTime
sgSystemStart = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
2020 Int
5 Int
14) DiffTime
0
    , sgNetworkMagic :: Word32
sgNetworkMagic = Word32
0
    , sgNetworkId :: Network
sgNetworkId = Network
Testnet
    , -- Chosen to match activeSlotCoeff
      sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff = Rational -> PositiveUnitInterval
forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
0.9
    , sgSecurityParam :: NonZero Word64
sgSecurityParam = Globals -> NonZero Word64
securityParameter Globals
testGlobals
    , sgEpochLength :: EpochSize
sgEpochLength = Identity EpochSize -> EpochSize
forall a. Identity a -> a
runIdentity (Identity EpochSize -> EpochSize)
-> Identity EpochSize -> EpochSize
forall a b. (a -> b) -> a -> b
$ EpochInfo Identity -> EpochNo -> Identity EpochSize
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> EpochNo -> m EpochSize
epochInfoSize EpochInfo Identity
testEpochInfo EpochNo
0
    , sgSlotsPerKESPeriod :: Word64
sgSlotsPerKESPeriod = Globals -> Word64
slotsPerKESPeriod Globals
testGlobals
    , sgMaxKESEvolutions :: Word64
sgMaxKESEvolutions = Globals -> Word64
maxKESEvo Globals
testGlobals
    , -- Not important
      sgSlotLength :: NominalDiffTimeMicro
sgSlotLength = Micro -> NominalDiffTimeMicro
secondsToNominalDiffTimeMicro Micro
2
    , sgUpdateQuorum :: Word64
sgUpdateQuorum = Globals -> Word64
quorum Globals
testGlobals
    , sgMaxLovelaceSupply :: Word64
sgMaxLovelaceSupply = Globals -> Word64
maxLovelaceSupply Globals
testGlobals
    , sgProtocolParams :: PParams ShelleyEra
sgProtocolParams = PParams ShelleyEra
forall era. EraPParams era => PParams era
emptyPParams
    , sgGenDelegs :: Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs = Map (KeyHash 'Genesis) GenDelegPair
forall k a. Map k a
Map.empty
    , sgInitialFunds :: ListMap Addr Coin
sgInitialFunds = ListMap Addr Coin
forall a. Monoid a => a
mempty
    , sgStaking :: ShelleyGenesisStaking
sgStaking = ShelleyGenesisStaking
emptyGenesisStaking
    }

-- | This is probably not a valid ledger. We don't care, we are only
-- interested in serialisation, not validation.
exampleNewEpochState ::
  forall era.
  ( EraTxOut era
  , EraGov era
  , EraStake era
  , EraCertState era
  , Default (StashedAVVMAddresses era)
  ) =>
  Value era ->
  PParams era ->
  PParams era ->
  NewEpochState era
exampleNewEpochState :: forall era.
(EraTxOut era, EraGov era, EraStake era, EraCertState era,
 Default (StashedAVVMAddresses era)) =>
Value era -> PParams era -> PParams era -> NewEpochState era
exampleNewEpochState Value era
value PParams era
ppp PParams era
pp =
  NewEpochState
    { nesEL :: EpochNo
nesEL = Word64 -> EpochNo
EpochNo Word64
0
    , nesBprev :: BlocksMade
nesBprev = Map (KeyHash 'StakePool) Nat -> BlocksMade
BlocksMade (KeyHash 'StakePool -> Nat -> Map (KeyHash 'StakePool) Nat
forall k a. k -> a -> Map k a
Map.singleton (Int -> KeyHash 'StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1) Nat
10)
    , nesBcur :: BlocksMade
nesBcur = Map (KeyHash 'StakePool) Nat -> BlocksMade
BlocksMade (KeyHash 'StakePool -> Nat -> Map (KeyHash 'StakePool) Nat
forall k a. k -> a -> Map k a
Map.singleton (Int -> KeyHash 'StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
2) Nat
3)
    , nesEs :: EpochState era
nesEs = EpochState era
epochState
    , nesRu :: StrictMaybe PulsingRewUpdate
nesRu = PulsingRewUpdate -> StrictMaybe PulsingRewUpdate
forall a. a -> StrictMaybe a
SJust PulsingRewUpdate
rewardUpdate
    , nesPd :: PoolDistr
nesPd = PoolDistr
examplePoolDistr
    , stashedAVVMAddresses :: StashedAVVMAddresses era
stashedAVVMAddresses = StashedAVVMAddresses era
forall a. Default a => a
def
    }
  where
    epochState :: EpochState era
    epochState :: EpochState era
epochState =
      EpochState
        { esChainAccountState :: ChainAccountState
esChainAccountState =
            ChainAccountState
              { casTreasury :: Coin
casTreasury = Integer -> Coin
Coin Integer
10000
              , casReserves :: Coin
casReserves = Integer -> Coin
Coin Integer
1000
              }
        , esSnapshots :: SnapShots
esSnapshots = SnapShots
emptySnapShots
        , esLState :: LedgerState era
esLState =
            LedgerState
              { lsUTxOState :: UTxOState era
lsUTxOState =
                  UTxOState
                    { utxosUtxo :: UTxO era
utxosUtxo =
                        Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era) -> UTxO era)
-> Map TxIn (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$
                          [(TxIn, TxOut era)] -> Map TxIn (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                            [
                              ( TxId -> TxIx -> TxIn
TxIn (SafeHash EraIndependentTxBody -> TxId
TxId (forall a. Int -> SafeHash a
mkDummySafeHash @EraIndependentTxBody Int
1)) TxIx
forall a. Bounded a => a
minBound
                              , Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
value
                              )
                            ]
                    , utxosDeposited :: Coin
utxosDeposited = Integer -> Coin
Coin Integer
1000
                    , utxosFees :: Coin
utxosFees = Integer -> Coin
Coin Integer
1
                    , utxosGovState :: GovState era
utxosGovState = GovState era
forall era. EraGov era => GovState era
emptyGovState
                    , utxosInstantStake :: InstantStake era
utxosInstantStake = InstantStake era
forall a. Monoid a => a
mempty
                    , utxosDonation :: Coin
utxosDonation = Coin
forall a. Monoid a => a
mempty
                    }
              , lsCertState :: CertState era
lsCertState = CertState era
forall a. Default a => a
def
              }
        , esNonMyopic :: NonMyopic
esNonMyopic = NonMyopic
forall a. Default a => a
def
        }
        EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (PParams era -> Identity (PParams era))
-> EpochState era -> Identity (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL ((PParams era -> Identity (PParams era))
 -> EpochState era -> Identity (EpochState era))
-> PParams era -> EpochState era -> EpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
ppp
        EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (PParams era -> Identity (PParams era))
-> EpochState era -> Identity (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Identity (PParams era))
 -> EpochState era -> Identity (EpochState era))
-> PParams era -> EpochState era -> EpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
pp
      where
        addr :: Addr
        addr :: Addr
addr =
          Network -> PaymentCredential -> StakeReference -> Addr
Addr
            Network
Testnet
            (KeyPair 'Payment -> PaymentCredential
forall (r :: KeyRole). KeyPair r -> Credential r
keyToCredential KeyPair 'Payment
examplePayKey)
            (Credential 'Staking -> StakeReference
StakeRefBase (KeyPair 'Staking -> Credential 'Staking
forall (r :: KeyRole). KeyPair r -> Credential r
keyToCredential KeyPair 'Staking
exampleStakeKey))

    rewardUpdate :: PulsingRewUpdate
    rewardUpdate :: PulsingRewUpdate
rewardUpdate =
      forall era.
(EraGov era, EraCertState era) =>
EpochSize
-> BlocksMade
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> NonZero Word64
-> PulsingRewUpdate
startStep @era
        (Word64 -> EpochSize
EpochSize Word64
432000)
        (Map (KeyHash 'StakePool) Nat -> BlocksMade
BlocksMade (KeyHash 'StakePool -> Nat -> Map (KeyHash 'StakePool) Nat
forall k a. k -> a -> Map k a
Map.singleton (Int -> KeyHash 'StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1) Nat
10))
        EpochState era
epochState
        (Integer -> Coin
Coin Integer
1000)
        (Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
testGlobals)
        (forall (n :: Nat) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @10)

exampleLedgerChainDepState :: Word64 -> ChainDepState
exampleLedgerChainDepState :: Word64 -> ChainDepState
exampleLedgerChainDepState Word64
seed =
  ChainDepState
    { csProtocol :: PrtclState
csProtocol =
        Map (KeyHash 'BlockIssuer) Word64 -> Nonce -> Nonce -> PrtclState
PrtclState
          ( [(KeyHash 'BlockIssuer, Word64)]
-> Map (KeyHash 'BlockIssuer) Word64
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [ (Int -> KeyHash 'BlockIssuer
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1, Word64
1)
              , (Int -> KeyHash 'BlockIssuer
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
2, Word64
2)
              ]
          )
          (Word64 -> Nonce
mkNonceFromNumber Word64
seed)
          (Word64 -> Nonce
mkNonceFromNumber Word64
seed)
    , csTickn :: TicknState
csTickn =
        Nonce -> Nonce -> TicknState
TicknState
          Nonce
NeutralNonce
          (Word64 -> Nonce
mkNonceFromNumber Word64
seed)
    , csLabNonce :: Nonce
csLabNonce =
        Word64 -> Nonce
mkNonceFromNumber Word64
seed
    }

testEpochInfo :: EpochInfo Identity
testEpochInfo :: EpochInfo Identity
testEpochInfo = Globals -> EpochInfo Identity
epochInfoPure Globals
testGlobals

mkDummyAnchor :: Int -> Anchor
mkDummyAnchor :: Int -> Anchor
mkDummyAnchor Int
n =
  Anchor
    { anchorUrl :: Url
anchorUrl = Maybe Url -> Url
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Url -> Url) -> (Text -> Maybe Url) -> Text -> Url
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Maybe Url
forall (m :: * -> *). MonadFail m => Int -> Text -> m Url
textToUrl Int
64 (Text -> Url) -> Text -> Url
forall a b. (a -> b) -> a -> b
$ Text
"dummy@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Int -> String
forall a. Show a => a -> String
show Int
n)
    , anchorDataHash :: SafeHash AnchorData
anchorDataHash = forall a. Int -> SafeHash a
mkDummySafeHash @AnchorData Int
n
    }

{-------------------------------------------------------------------------------
  Shelley era specific functions
-------------------------------------------------------------------------------}

-- | ShelleyLedgerExamples for Shelley era
ledgerExamplesShelley :: ShelleyLedgerExamples ShelleyEra
ledgerExamplesShelley :: ShelleyLedgerExamples ShelleyEra
ledgerExamplesShelley =
  (TxBody ShelleyEra -> [KeyPair 'Witness] -> TxWits ShelleyEra)
-> (ShelleyTx ShelleyEra -> Tx ShelleyEra)
-> Value ShelleyEra
-> TxBody ShelleyEra
-> TxAuxData ShelleyEra
-> TranslationContext ShelleyEra
-> ShelleyLedgerExamples ShelleyEra
forall era.
(EraSegWits era, EraGov era, EraStake era, EraCertState era,
 PredicateFailure (EraRule "DELEGS" era)
 ~ ShelleyDelegsPredFailure era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ ShelleyLedgerPredFailure era,
 Default (StashedAVVMAddresses era), ProtVerAtMost era 4) =>
(TxBody era -> [KeyPair 'Witness] -> TxWits era)
-> (ShelleyTx era -> Tx era)
-> Value era
-> TxBody era
-> TxAuxData era
-> TranslationContext era
-> ShelleyLedgerExamples era
defaultShelleyLedgerExamples
    (Proxy ShelleyEra
-> TxBody ShelleyEra
-> [KeyPair 'Witness]
-> ShelleyTxWits ShelleyEra
forall era.
EraTx era =>
Proxy era -> TxBody era -> [KeyPair 'Witness] -> ShelleyTxWits era
mkWitnessesPreAlonzo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ShelleyEra))
    ShelleyTx ShelleyEra -> Tx ShelleyEra
ShelleyTx ShelleyEra -> ShelleyTx ShelleyEra
forall a. a -> a
id
    Value ShelleyEra
Coin
exampleCoin
    TxBody ShelleyEra
exampleTxBodyShelley
    TxAuxData ShelleyEra
exampleAuxiliaryDataShelley
    TranslationContext ShelleyEra
FromByronTranslationContext
emptyFromByronTranslationContext

mkWitnessesPreAlonzo ::
  EraTx era =>
  Proxy era ->
  TxBody era ->
  [KeyPair 'Witness] ->
  ShelleyTxWits era
mkWitnessesPreAlonzo :: forall era.
EraTx era =>
Proxy era -> TxBody era -> [KeyPair 'Witness] -> ShelleyTxWits era
mkWitnessesPreAlonzo Proxy era
_ TxBody era
txBody [KeyPair 'Witness]
keyPairWits =
  ShelleyTxWits era
forall a. Monoid a => a
mempty
    { addrWits =
        mkWitnessesVKey (coerce (hashAnnotated txBody)) keyPairWits
    }

exampleCoin :: Coin
exampleCoin :: Coin
exampleCoin = Integer -> Coin
Coin Integer
10

exampleTxBodyShelley :: TxBody ShelleyEra
exampleTxBodyShelley :: TxBody ShelleyEra
exampleTxBodyShelley =
  Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> TxBody ShelleyEra
ShelleyTxBody
    Set TxIn
exampleTxIns
    ( [ShelleyTxOut ShelleyEra] -> StrictSeq (ShelleyTxOut ShelleyEra)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ Addr -> Value ShelleyEra -> ShelleyTxOut ShelleyEra
forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut (KeyPair 'Payment -> KeyPair 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyPair 'Payment
examplePayKey KeyPair 'Staking
exampleStakeKey) (Integer -> Coin
Coin Integer
100000)
        ]
    )
    StrictSeq (TxCert ShelleyEra)
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
StrictSeq (TxCert era)
exampleCerts
    Withdrawals
exampleWithdrawals
    (Integer -> Coin
Coin Integer
3)
    (Word64 -> SlotNo
SlotNo Word64
10)
    (Update ShelleyEra -> StrictMaybe (Update ShelleyEra)
forall a. a -> StrictMaybe a
SJust (ProposedPPUpdates ShelleyEra -> EpochNo -> Update ShelleyEra
forall era. ProposedPPUpdates era -> EpochNo -> Update era
Update ProposedPPUpdates ShelleyEra
forall era. EraPParams era => ProposedPPUpdates era
exampleProposedPPUpdates (Word64 -> EpochNo
EpochNo Word64
0)))
    (TxAuxDataHash -> StrictMaybe TxAuxDataHash
forall a. a -> StrictMaybe a
SJust TxAuxDataHash
auxiliaryDataHash)
  where
    -- Dummy hash to decouple from the auxiliaryData in 'exampleTx'.
    auxiliaryDataHash :: TxAuxDataHash
    auxiliaryDataHash :: TxAuxDataHash
auxiliaryDataHash =
      SafeHash EraIndependentTxAuxData -> TxAuxDataHash
TxAuxDataHash (SafeHash EraIndependentTxAuxData -> TxAuxDataHash)
-> SafeHash EraIndependentTxAuxData -> TxAuxDataHash
forall a b. (a -> b) -> a -> b
$ forall a. Int -> SafeHash a
mkDummySafeHash @EraIndependentTxAuxData Int
30

exampleAuxDataMap :: Map Word64 Metadatum
exampleAuxDataMap :: Map Word64 Metadatum
exampleAuxDataMap =
  [(Word64, Metadatum)] -> Map Word64 Metadatum
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Word64
1, Text -> Metadatum
S Text
"string")
    , (Word64
2, ByteString -> Metadatum
B ByteString
"bytes")
    , (Word64
3, [Metadatum] -> Metadatum
List [Integer -> Metadatum
I Integer
1, Integer -> Metadatum
I Integer
2])
    , (Word64
4, [(Metadatum, Metadatum)] -> Metadatum
Map [(Integer -> Metadatum
I Integer
3, ByteString -> Metadatum
B ByteString
"b")])
    ]

exampleAuxiliaryDataShelley :: TxAuxData ShelleyEra
exampleAuxiliaryDataShelley :: TxAuxData ShelleyEra
exampleAuxiliaryDataShelley = Map Word64 Metadatum -> ShelleyTxAuxData ShelleyEra
forall era. Era era => Map Word64 Metadatum -> ShelleyTxAuxData era
ShelleyTxAuxData Map Word64 Metadatum
exampleAuxDataMap

exampleTxIns :: Set TxIn
exampleTxIns :: Set TxIn
exampleTxIns =
  [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList
    [ TxId -> TxIx -> TxIn
TxIn (SafeHash EraIndependentTxBody -> TxId
TxId (forall a. Int -> SafeHash a
mkDummySafeHash @EraIndependentTxBody Int
1)) TxIx
forall a. Bounded a => a
minBound
    ]

exampleCerts :: (ShelleyEraTxCert era, ProtVerAtMost era 8) => StrictSeq (TxCert era)
exampleCerts :: forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
StrictSeq (TxCert era)
exampleCerts =
  [TxCert era] -> StrictSeq (TxCert era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
    [ Credential 'Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
RegTxCert (KeyPair 'Staking -> Credential 'Staking
forall (r :: KeyRole). KeyPair r -> Credential r
keyToCredential KeyPair 'Staking
exampleStakeKey)
    , PoolParams -> TxCert era
forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert PoolParams
examplePoolParams
    , MIRCert -> TxCert era
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
MIRCert -> TxCert era
MirTxCert (MIRCert -> TxCert era) -> MIRCert -> TxCert era
forall a b. (a -> b) -> a -> b
$
        MIRPot -> MIRTarget -> MIRCert
MIRCert MIRPot
ReservesMIR (MIRTarget -> MIRCert) -> MIRTarget -> MIRCert
forall a b. (a -> b) -> a -> b
$
          Map (Credential 'Staking) DeltaCoin -> MIRTarget
StakeAddressesMIR (Map (Credential 'Staking) DeltaCoin -> MIRTarget)
-> Map (Credential 'Staking) DeltaCoin -> MIRTarget
forall a b. (a -> b) -> a -> b
$
            [(Credential 'Staking, DeltaCoin)]
-> Map (Credential 'Staking) DeltaCoin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [ (KeyPair 'Staking -> Credential 'Staking
forall (r :: KeyRole). KeyPair r -> Credential r
keyToCredential (Word8 -> KeyPair 'Staking
forall (kd :: KeyRole). Word8 -> KeyPair kd
mkDSIGNKeyPair Word8
2), Integer -> DeltaCoin
DeltaCoin Integer
110)
              ]
    ]

exampleWithdrawals :: Withdrawals
exampleWithdrawals :: Withdrawals
exampleWithdrawals =
  Map RewardAccount Coin -> Withdrawals
Withdrawals (Map RewardAccount Coin -> Withdrawals)
-> Map RewardAccount Coin -> Withdrawals
forall a b. (a -> b) -> a -> b
$
    [(RewardAccount, Coin)] -> Map RewardAccount Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (PoolParams -> RewardAccount
ppRewardAccount PoolParams
examplePoolParams, Integer -> Coin
Coin Integer
100)
      ]

exampleProposedPPUpdates ::
  EraPParams era =>
  ProposedPPUpdates era
exampleProposedPPUpdates :: forall era. EraPParams era => ProposedPPUpdates era
exampleProposedPPUpdates =
  Map (KeyHash 'Genesis) (PParamsUpdate era) -> ProposedPPUpdates era
forall era.
Map (KeyHash 'Genesis) (PParamsUpdate era) -> ProposedPPUpdates era
ProposedPPUpdates (Map (KeyHash 'Genesis) (PParamsUpdate era)
 -> ProposedPPUpdates era)
-> Map (KeyHash 'Genesis) (PParamsUpdate era)
-> ProposedPPUpdates era
forall a b. (a -> b) -> a -> b
$
    KeyHash 'Genesis
-> PParamsUpdate era -> Map (KeyHash 'Genesis) (PParamsUpdate era)
forall k a. k -> a -> Map k a
Map.singleton
      (Int -> KeyHash 'Genesis
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1)
      (PParamsUpdate era
forall era. EraPParams era => PParamsUpdate era
emptyPParamsUpdate PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Word16 -> Identity (StrictMaybe Word16))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Word16)
Lens' (PParamsUpdate era) (StrictMaybe Word16)
ppuMaxBHSizeL ((StrictMaybe Word16 -> Identity (StrictMaybe Word16))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Word16 -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word16 -> StrictMaybe Word16
forall a. a -> StrictMaybe a
SJust Word16
4000)

examplePayKey :: KeyPair 'Payment
examplePayKey :: KeyPair 'Payment
examplePayKey = Word8 -> KeyPair 'Payment
forall (kd :: KeyRole). Word8 -> KeyPair kd
mkDSIGNKeyPair Word8
0

exampleStakeKey :: KeyPair 'Staking
exampleStakeKey :: KeyPair 'Staking
exampleStakeKey = Word8 -> KeyPair 'Staking
forall (kd :: KeyRole). Word8 -> KeyPair kd
mkDSIGNKeyPair Word8
1

exampleKeys :: AllIssuerKeys StandardCrypto r
exampleKeys :: forall (r :: KeyRole). AllIssuerKeys StandardCrypto r
exampleKeys =
  KeyPair r
-> VRFKeyPair StandardCrypto
-> NonEmpty (KESPeriod, KESKeyPair StandardCrypto)
-> KeyHash r
-> AllIssuerKeys StandardCrypto r
forall c (r :: KeyRole).
KeyPair r
-> VRFKeyPair c
-> NonEmpty (KESPeriod, KESKeyPair c)
-> KeyHash r
-> AllIssuerKeys c r
AllIssuerKeys
    KeyPair r
forall {kd :: KeyRole}. KeyPair kd
coldKey
    (Proxy StandardCrypto -> Word8 -> VRFKeyPair StandardCrypto
forall c. Crypto c => Proxy c -> Word8 -> VRFKeyPair c
mkVRFKeyPair (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @StandardCrypto) Word8
1)
    ((Period -> KESPeriod
KESPeriod Period
0, RawSeed -> KESKeyPair StandardCrypto
forall c. Crypto c => RawSeed -> KESKeyPair c
mkKESKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
1 Word64
0 Word64
0 Word64
0 Word64
3)) (KESPeriod, KESKeyPair StandardCrypto)
-> [(KESPeriod, KESKeyPair StandardCrypto)]
-> NonEmpty (KESPeriod, KESKeyPair StandardCrypto)
forall a. a -> [a] -> NonEmpty a
NE.:| [])
    (VKey r -> KeyHash r
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (KeyPair r -> VKey r
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair r
forall {kd :: KeyRole}. KeyPair kd
coldKey))
  where
    coldKey :: KeyPair kd
coldKey = Word8 -> KeyPair kd
forall (kd :: KeyRole). Word8 -> KeyPair kd
mkDSIGNKeyPair Word8
1

keyToCredential :: KeyPair r -> Credential r
keyToCredential :: forall (r :: KeyRole). KeyPair r -> Credential r
keyToCredential = KeyHash r -> Credential r
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash r -> Credential r)
-> (KeyPair r -> KeyHash r) -> KeyPair r -> Credential r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey r -> KeyHash r
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey r -> KeyHash r)
-> (KeyPair r -> VKey r) -> KeyPair r -> KeyHash r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair r -> VKey r
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey

-- | @mkKeyPair'@ from @Test.Cardano.Ledger.Shelley.Utils@ doesn't work for real
-- crypto:
-- <https://github.com/intersectmbo/cardano-ledger/issues/1770>
mkDSIGNKeyPair :: forall kd. Word8 -> KeyPair kd
mkDSIGNKeyPair :: forall (kd :: KeyRole). Word8 -> KeyPair kd
mkDSIGNKeyPair Word8
byte = VKey kd -> SignKeyDSIGN Ed25519DSIGN -> KeyPair kd
forall (kd :: KeyRole).
VKey kd -> SignKeyDSIGN Ed25519DSIGN -> KeyPair kd
KeyPair (VerKeyDSIGN Ed25519DSIGN -> VKey kd
forall (kd :: KeyRole). VerKeyDSIGN Ed25519DSIGN -> VKey kd
VKey (VerKeyDSIGN Ed25519DSIGN -> VKey kd)
-> VerKeyDSIGN Ed25519DSIGN -> VKey kd
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN Ed25519DSIGN -> VerKeyDSIGN Ed25519DSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
DSIGN.deriveVerKeyDSIGN SignKeyDSIGN Ed25519DSIGN
sk) SignKeyDSIGN Ed25519DSIGN
sk
  where
    seed :: Seed
seed =
      ByteString -> Seed
Seed.mkSeedFromBytes (ByteString -> Seed) -> ByteString -> Seed
forall a b. (a -> b) -> a -> b
$
        Int -> Word8 -> ByteString
Strict.replicate
          (Period -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy Ed25519DSIGN -> Period
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Period
DSIGN.seedSizeDSIGN (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @DSIGN)))
          Word8
byte

    sk :: SignKeyDSIGN Ed25519DSIGN
sk = Seed -> SignKeyDSIGN Ed25519DSIGN
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
DSIGN.genKeyDSIGN Seed
seed

mkVRFKeyPair ::
  forall c.
  Crypto c =>
  Proxy c ->
  Word8 ->
  VRFKeyPair c
mkVRFKeyPair :: forall c. Crypto c => Proxy c -> Word8 -> VRFKeyPair c
mkVRFKeyPair Proxy c
_ Word8
byte = SignKeyVRF (VRF c) -> VerKeyVRF (VRF c) -> VRFKeyPair c
forall c. SignKeyVRF (VRF c) -> VerKeyVRF (VRF c) -> VRFKeyPair c
VRFKeyPair SignKeyVRF (VRF c)
sk (SignKeyVRF (VRF c) -> VerKeyVRF (VRF c)
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
VRF.deriveVerKeyVRF SignKeyVRF (VRF c)
sk)
  where
    seed :: Seed
seed =
      ByteString -> Seed
Seed.mkSeedFromBytes (ByteString -> Seed) -> ByteString -> Seed
forall a b. (a -> b) -> a -> b
$
        Int -> Word8 -> ByteString
Strict.replicate
          (Period -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy (VRF c) -> Period
forall v (proxy :: * -> *). VRFAlgorithm v => proxy v -> Period
forall (proxy :: * -> *). proxy (VRF c) -> Period
VRF.seedSizeVRF (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(VRF c))))
          Word8
byte

    sk :: SignKeyVRF (VRF c)
sk = Seed -> SignKeyVRF (VRF c)
forall v. VRFAlgorithm v => Seed -> SignKeyVRF v
VRF.genKeyVRF Seed
seed

examplePoolParams :: PoolParams
examplePoolParams :: PoolParams
examplePoolParams =
  PoolParams
    { ppId :: KeyHash 'StakePool
ppId = VKey 'StakePool -> KeyHash 'StakePool
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey 'StakePool -> KeyHash 'StakePool)
-> VKey 'StakePool -> KeyHash 'StakePool
forall a b. (a -> b) -> a -> b
$ KeyPair 'StakePool -> VKey 'StakePool
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair 'StakePool -> VKey 'StakePool)
-> KeyPair 'StakePool -> VKey 'StakePool
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys StandardCrypto 'StakePool -> KeyPair 'StakePool
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys StandardCrypto 'StakePool
forall (r :: KeyRole). AllIssuerKeys StandardCrypto r
exampleKeys
    , ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppVrf = forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @StandardCrypto (VerKeyVRF (VRF StandardCrypto) -> VRFVerKeyHash 'StakePoolVRF)
-> VerKeyVRF (VRF StandardCrypto) -> VRFVerKeyHash 'StakePoolVRF
forall a b. (a -> b) -> a -> b
$ VRFKeyPair StandardCrypto -> VerKeyVRF (VRF StandardCrypto)
forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey (VRFKeyPair StandardCrypto -> VerKeyVRF (VRF StandardCrypto))
-> VRFKeyPair StandardCrypto -> VerKeyVRF (VRF StandardCrypto)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys StandardCrypto Any -> VRFKeyPair StandardCrypto
forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf AllIssuerKeys StandardCrypto Any
forall (r :: KeyRole). AllIssuerKeys StandardCrypto r
exampleKeys
    , ppPledge :: Coin
ppPledge = Integer -> Coin
Coin Integer
1
    , ppCost :: Coin
ppCost = Integer -> Coin
Coin Integer
5
    , ppMargin :: UnitInterval
ppMargin = Rational -> UnitInterval
forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
0.1
    , ppRewardAccount :: RewardAccount
ppRewardAccount = Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet (KeyPair 'Staking -> Credential 'Staking
forall (r :: KeyRole). KeyPair r -> Credential r
keyToCredential KeyPair 'Staking
exampleStakeKey)
    , ppOwners :: Set (KeyHash 'Staking)
ppOwners = KeyHash 'Staking -> Set (KeyHash 'Staking)
forall a. a -> Set a
Set.singleton (KeyHash 'Staking -> Set (KeyHash 'Staking))
-> KeyHash 'Staking -> Set (KeyHash 'Staking)
forall a b. (a -> b) -> a -> b
$ VKey 'Staking -> KeyHash 'Staking
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey 'Staking -> KeyHash 'Staking)
-> VKey 'Staking -> KeyHash 'Staking
forall a b. (a -> b) -> a -> b
$ KeyPair 'Staking -> VKey 'Staking
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'Staking
exampleStakeKey
    , ppRelays :: StrictSeq StakePoolRelay
ppRelays = StrictSeq StakePoolRelay
forall a. StrictSeq a
StrictSeq.empty
    , ppMetadata :: StrictMaybe PoolMetadata
ppMetadata =
        PoolMetadata -> StrictMaybe PoolMetadata
forall a. a -> StrictMaybe a
SJust (PoolMetadata -> StrictMaybe PoolMetadata)
-> PoolMetadata -> StrictMaybe PoolMetadata
forall a b. (a -> b) -> a -> b
$
          PoolMetadata
            { pmUrl :: Url
pmUrl = Maybe Url -> Url
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Url -> Url) -> Maybe Url -> Url
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Maybe Url
forall (m :: * -> *). MonadFail m => Int -> Text -> m Url
textToUrl Int
64 Text
"consensus.pool"
            , pmHash :: ByteString
pmHash = ByteString
"{}"
            }
    }