{-# 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 (
  LedgerExamples (..),
  ledgerExamples,
  -- functions used in building examples for other eras
  mkLedgerExamples,
  exampleCerts,
  exampleWithdrawals,
  exampleAuxDataMap,
  exampleNonMyopicRewards,
  exampleCoin,
  examplePayKey,
  exampleStakeKey,
  exampleNewEpochState,
  examplePoolDistr,
  exampleStakePoolParams,
  exampleTxIns,
  exampleProposedPPUpdates,
  exampleByronAddress,
  testShelleyGenesis,
  -- utility functions
  keyToCredential,
  mkDSIGNKeyPair,
  mkKeyHash,
  mkScriptHash,
  mkWitnessesPreAlonzo,
  seedFromByte,
  seedFromWords,
) where

import qualified Cardano.Chain.Common as Byron
import Cardano.Crypto.DSIGN as DSIGN
import Cardano.Crypto.Hash as Hash
import Cardano.Crypto.Seed as Seed
import qualified Cardano.Crypto.Signing as Byron
import qualified Cardano.Crypto.Wallet as Byron
import Cardano.Ledger.Address (BootstrapAddress (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (EncCBOR (..), hashWithEncoder)
import Cardano.Ledger.Coin
import Cardano.Ledger.Keys
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.API
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.Slotting.EpochInfo
import qualified Data.ByteString as Strict
import Data.Coerce (coerce)
import Data.Default
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.Time
import Data.Word (Word64, Word8)
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Binary.Random (mkDummyHash)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkAddr, mkWitnessesVKey)
import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash, testGlobals, unsafeBoundRational)
import Test.Cardano.Ledger.Shelley.Arbitrary (RawSeed (..))

data LedgerExamples era = LedgerExamples
  { -- tx
    forall era. LedgerExamples era -> Tx TopTx era
leTx :: Tx TopTx era
  , forall era. LedgerExamples era -> ApplyTxError era
leApplyTxError :: ApplyTxError era
  , -- protocol parameters
    forall era. LedgerExamples era -> PParams era
lePParams :: PParams era
  , forall era. LedgerExamples era -> ProposedPPUpdates era
leProposedPPUpdates :: ProposedPPUpdates era
  , -- Ledger state
    forall era. LedgerExamples era -> NewEpochState era
leNewEpochState :: NewEpochState era
  , forall era. LedgerExamples era -> PoolDistr
lePoolDistr :: PoolDistr
  , -- rewards and delegation
    forall era.
LedgerExamples era -> Set (Either Coin (Credential Staking))
leRewardsCredentials :: Set (Either Coin (Credential Staking))
  , forall era.
LedgerExamples era
-> Map
     (Either Coin (Credential Staking)) (Map (KeyHash StakePool) Coin)
leNonMyopicRewards ::
      Map
        (Either Coin (Credential Staking))
        (Map (KeyHash StakePool) Coin)
  , forall era. LedgerExamples era -> TranslationContext era
leTranslationContext :: TranslationContext era
  , forall era. LedgerExamples era -> ShelleyGenesis
leShelleyGenesis :: ShelleyGenesis
  }

deriving instance
  ( EraTx era
  , Eq (PParams era)
  , Eq (PParamsUpdate era)
  , EraGov era
  , Eq (Tx TopTx era)
  , Eq (PredicateFailure (EraRule "LEDGER" era))
  , Eq (StashedAVVMAddresses era)
  , Eq (TranslationContext era)
  , Eq (CertState era)
  , Eq (InstantStake era)
  ) =>
  Eq (LedgerExamples era)

ledgerExamples :: LedgerExamples ShelleyEra
ledgerExamples :: LedgerExamples ShelleyEra
ledgerExamples =
  (TxBody TopTx ShelleyEra -> [KeyPair Witness] -> TxWits ShelleyEra)
-> Value ShelleyEra
-> TxBody TopTx ShelleyEra
-> TxAuxData ShelleyEra
-> TranslationContext ShelleyEra
-> LedgerExamples ShelleyEra
forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era,
 PredicateFailure (EraRule "DELEGS" era)
 ~ ShelleyDelegsPredFailure era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ ShelleyLedgerPredFailure era,
 Default (StashedAVVMAddresses era), AtMostEra "Mary" era) =>
(TxBody TopTx era -> [KeyPair Witness] -> TxWits era)
-> Value era
-> TxBody TopTx era
-> TxAuxData era
-> TranslationContext era
-> LedgerExamples era
mkLedgerExamples
    (Proxy ShelleyEra
-> TxBody TopTx ShelleyEra
-> [KeyPair Witness]
-> ShelleyTxWits ShelleyEra
forall era.
EraTx era =>
Proxy era
-> TxBody TopTx era -> [KeyPair Witness] -> ShelleyTxWits era
mkWitnessesPreAlonzo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ShelleyEra))
    Coin
Value ShelleyEra
exampleCoin
    TxBody TopTx ShelleyEra
exampleTxBodyShelley
    TxAuxData ShelleyEra
exampleAuxiliaryDataShelley
    TranslationContext ShelleyEra
FromByronTranslationContext
emptyFromByronTranslationContext

mkLedgerExamples ::
  forall era.
  ( EraTx era
  , EraGov era
  , EraStake era
  , EraCertState era
  , PredicateFailure (EraRule "DELEGS" era) ~ ShelleyDelegsPredFailure era
  , PredicateFailure (EraRule "LEDGER" era) ~ ShelleyLedgerPredFailure era
  , Default (StashedAVVMAddresses era)
  , AtMostEra "Mary" era
  ) =>
  (TxBody TopTx era -> [KeyPair Witness] -> TxWits era) ->
  Value era ->
  TxBody TopTx era ->
  TxAuxData era ->
  TranslationContext era ->
  LedgerExamples era
mkLedgerExamples :: forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era,
 PredicateFailure (EraRule "DELEGS" era)
 ~ ShelleyDelegsPredFailure era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ ShelleyLedgerPredFailure era,
 Default (StashedAVVMAddresses era), AtMostEra "Mary" era) =>
(TxBody TopTx era -> [KeyPair Witness] -> TxWits era)
-> Value era
-> TxBody TopTx era
-> TxAuxData era
-> TranslationContext era
-> LedgerExamples era
mkLedgerExamples
  TxBody TopTx era -> [KeyPair Witness] -> TxWits era
mkWitnesses
  Value era
value
  TxBody TopTx era
txBody
  TxAuxData era
auxData
  TranslationContext era
translationContext =
    LedgerExamples
      { leTx :: Tx TopTx era
leTx = Tx TopTx era
tx
      , leApplyTxError :: ApplyTxError era
leApplyTxError =
          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)
      , lePParams :: PParams era
lePParams = PParams era
forall a. Default a => a
def
      , leProposedPPUpdates :: ProposedPPUpdates era
leProposedPPUpdates =
          Map (KeyHash GenesisRole) (PParamsUpdate era)
-> ProposedPPUpdates era
forall era.
Map (KeyHash GenesisRole) (PParamsUpdate era)
-> ProposedPPUpdates era
ProposedPPUpdates (Map (KeyHash GenesisRole) (PParamsUpdate era)
 -> ProposedPPUpdates era)
-> Map (KeyHash GenesisRole) (PParamsUpdate era)
-> ProposedPPUpdates era
forall a b. (a -> b) -> a -> b
$
            KeyHash GenesisRole
-> PParamsUpdate era
-> Map (KeyHash GenesisRole) (PParamsUpdate era)
forall k a. k -> a -> Map k a
Map.singleton
              (Int -> KeyHash GenesisRole
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, HasCallStack) =>
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))
      , leNewEpochState :: NewEpochState era
leNewEpochState =
          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, AtMostEra "Mary" era, HasCallStack) =>
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)
      , lePoolDistr :: PoolDistr
lePoolDistr = PoolDistr
examplePoolDistr
      , leRewardsCredentials :: Set (Either Coin (Credential Staking))
leRewardsCredentials =
          [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))
            ]
      , leNonMyopicRewards :: Map
  (Either Coin (Credential Staking)) (Map (KeyHash StakePool) Coin)
leNonMyopicRewards = Map
  (Either Coin (Credential Staking)) (Map (KeyHash StakePool) Coin)
exampleNonMyopicRewards
      , leTranslationContext :: TranslationContext era
leTranslationContext = TranslationContext era
translationContext
      , leShelleyGenesis :: ShelleyGenesis
leShelleyGenesis = ShelleyGenesis
testShelleyGenesis
      }
    where
      tx :: Tx TopTx era
tx = (TxBody TopTx era -> [KeyPair Witness] -> TxWits era)
-> TxBody TopTx era -> TxAuxData era -> Tx TopTx era
forall era.
EraTx era =>
(TxBody TopTx era -> [KeyPair Witness] -> TxWits era)
-> TxBody TopTx era -> TxAuxData era -> Tx TopTx era
exampleTx TxBody TopTx era -> [KeyPair Witness] -> TxWits era
mkWitnesses TxBody TopTx era
txBody TxAuxData era
auxData

-- | This is not a valid transaction. We don't care, we are only interested in
-- serialisation, not validation.
exampleTx ::
  forall era.
  EraTx era =>
  (TxBody TopTx era -> [KeyPair Witness] -> TxWits era) ->
  TxBody TopTx era ->
  TxAuxData era ->
  Tx TopTx era
exampleTx :: forall era.
EraTx era =>
(TxBody TopTx era -> [KeyPair Witness] -> TxWits era)
-> TxBody TopTx era -> TxAuxData era -> Tx TopTx era
exampleTx TxBody TopTx era -> [KeyPair Witness] -> TxWits era
mkWitnesses TxBody TopTx era
txBody TxAuxData era
auxData =
  forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
mkBasicTx @era TxBody TopTx era
txBody
    Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL
      ((TxWits era -> Identity (TxWits era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> TxWits era -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxBody TopTx era -> [KeyPair Witness] -> TxWits era
mkWitnesses TxBody TopTx era
txBody [KeyPair Witness]
keyPairWits
    Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (TxAuxData era)))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
auxDataTxL
      ((StrictMaybe (TxAuxData era)
  -> Identity (StrictMaybe (TxAuxData era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictMaybe (TxAuxData era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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 (ZonkAny 0) -> KeyPair Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a Witness
asWitness (KeyPair (ZonkAny 0) -> KeyPair Witness)
-> KeyPair (ZonkAny 0) -> KeyPair Witness
forall a b. (a -> b) -> a -> b
$ Word8 -> KeyPair (ZonkAny 0)
forall (kd :: KeyRole). Word8 -> KeyPair kd
mkDSIGNKeyPair Word8
1
      ]

-- | 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) Natural -> BlocksMade
BlocksMade (KeyHash StakePool -> Natural -> Map (KeyHash StakePool) Natural
forall k a. k -> a -> Map k a
Map.singleton (Int -> KeyHash StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1) Natural
10)
    , nesBcur :: BlocksMade
nesBcur = Map (KeyHash StakePool) Natural -> BlocksMade
BlocksMade (KeyHash StakePool -> Natural -> Map (KeyHash StakePool) Natural
forall k a. k -> a -> Map k a
Map.singleton (Int -> KeyHash StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
2) Natural
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 -> Credential Payment -> StakeReference -> Addr
Addr
            Network
Testnet
            (KeyPair Payment -> Credential Payment
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) Natural -> BlocksMade
BlocksMade (KeyHash StakePool -> Natural -> Map (KeyHash StakePool) Natural
forall k a. k -> a -> Map k a
Map.singleton (Int -> KeyHash StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1) Natural
10))
        EpochState era
epochState
        (Integer -> Coin
Coin Integer
1000)
        (Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
testGlobals)
        (forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @10)

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)
              VRFVerKeyHash StakePoolVRF
exampleVrfVerKeyHash
          )
        ]
    )
    (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 (Globals -> EpochInfo Identity
epochInfoPure Globals
testGlobals) (Word64 -> EpochNo
EpochNo Word64
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 GenesisRole) GenDelegPair
sgGenDelegs = Map (KeyHash GenesisRole) 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
    }

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

exampleTxBodyShelley :: TxBody TopTx ShelleyEra
exampleTxBodyShelley :: TxBody TopTx ShelleyEra
exampleTxBodyShelley =
  Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> TxBody TopTx 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, AtMostEra "Babbage" era) =>
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

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

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")])
    ]

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, AtMostEra "Babbage" era) => StrictSeq (TxCert era)
exampleCerts :: forall era.
(ShelleyEraTxCert era, AtMostEra "Babbage" era) =>
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)
    , StakePoolParams -> TxCert era
forall era. EraTxCert era => StakePoolParams -> TxCert era
RegPoolTxCert StakePoolParams
exampleStakePoolParams
    , MIRCert -> TxCert era
forall era.
(ShelleyEraTxCert era, AtMostEra "Babbage" era) =>
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
      [ (RewardAccount
exampleRewardAccount, Integer -> Coin
Coin Integer
100)
      ]

exampleProposedPPUpdates ::
  EraPParams era =>
  ProposedPPUpdates era
exampleProposedPPUpdates :: forall era. EraPParams era => ProposedPPUpdates era
exampleProposedPPUpdates =
  Map (KeyHash GenesisRole) (PParamsUpdate era)
-> ProposedPPUpdates era
forall era.
Map (KeyHash GenesisRole) (PParamsUpdate era)
-> ProposedPPUpdates era
ProposedPPUpdates (Map (KeyHash GenesisRole) (PParamsUpdate era)
 -> ProposedPPUpdates era)
-> Map (KeyHash GenesisRole) (PParamsUpdate era)
-> ProposedPPUpdates era
forall a b. (a -> b) -> a -> b
$
    KeyHash GenesisRole
-> PParamsUpdate era
-> Map (KeyHash GenesisRole) (PParamsUpdate era)
forall k a. k -> a -> Map k a
Map.singleton
      (Int -> KeyHash GenesisRole
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)

exampleStakePoolParams :: StakePoolParams
exampleStakePoolParams :: StakePoolParams
exampleStakePoolParams =
  StakePoolParams
    { sppId :: KeyHash StakePool
sppId = 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
$ Word8 -> KeyPair StakePool
forall (kd :: KeyRole). Word8 -> KeyPair kd
mkDSIGNKeyPair Word8
1
    , sppVrf :: VRFVerKeyHash StakePoolVRF
sppVrf = VRFVerKeyHash StakePoolVRF
exampleVrfVerKeyHash
    , sppPledge :: Coin
sppPledge = Integer -> Coin
Coin Integer
1
    , sppCost :: Coin
sppCost = Integer -> Coin
Coin Integer
5
    , sppMargin :: UnitInterval
sppMargin = Rational -> UnitInterval
forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
0.1
    , sppRewardAccount :: RewardAccount
sppRewardAccount = RewardAccount
exampleRewardAccount
    , sppOwners :: Set (KeyHash Staking)
sppOwners = 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
    , sppRelays :: StrictSeq StakePoolRelay
sppRelays = StrictSeq StakePoolRelay
forall a. StrictSeq a
StrictSeq.empty
    , sppMetadata :: StrictMaybe PoolMetadata
sppMetadata =
        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
"{}"
            }
    }

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

exampleVrfVerKeyHash :: VRFVerKeyHash StakePoolVRF
exampleVrfVerKeyHash :: VRFVerKeyHash StakePoolVRF
exampleVrfVerKeyHash = Hash HASH KeyRoleVRF -> VRFVerKeyHash StakePoolVRF
forall (r :: KeyRoleVRF). Hash HASH KeyRoleVRF -> VRFVerKeyHash r
VRFVerKeyHash Hash HASH KeyRoleVRF
"c5e21ab1c9f6022d81c3b25e3436cb7f1df77f9652ae3e1310c28e621dd87b4c"

exampleRewardAccount :: RewardAccount
exampleRewardAccount :: RewardAccount
exampleRewardAccount = Network -> Credential Staking -> RewardAccount
RewardAccount Network
Testnet (KeyPair Staking -> Credential Staking
forall (r :: KeyRole). KeyPair r -> Credential r
keyToCredential KeyPair Staking
exampleStakeKey)

exampleByronAddress :: Addr
exampleByronAddress :: Addr
exampleByronAddress = BootstrapAddress -> Addr
AddrBootstrap (Address -> BootstrapAddress
BootstrapAddress Address
byronAddr)
  where
    byronAddr :: Address
byronAddr = AddrSpendingData -> AddrAttributes -> Address
Byron.makeAddress AddrSpendingData
asd AddrAttributes
attrs
    asd :: AddrSpendingData
asd = VerificationKey -> AddrSpendingData
Byron.VerKeyASD VerificationKey
byronVerificationKey
    attrs :: AddrAttributes
attrs =
      Maybe HDAddressPayload -> NetworkMagic -> AddrAttributes
Byron.AddrAttributes
        (HDAddressPayload -> Maybe HDAddressPayload
forall a. a -> Maybe a
Just (ByteString -> HDAddressPayload
Byron.HDAddressPayload ByteString
"a compressed lenna.png"))
        (Word32 -> NetworkMagic
Byron.NetworkTestnet Word32
0)
    byronVerificationKey :: VerificationKey
byronVerificationKey = SigningKey -> VerificationKey
Byron.toVerification SigningKey
signingKey
    signingKey :: SigningKey
signingKey = XPrv -> SigningKey
Byron.SigningKey (XPrv -> SigningKey) -> XPrv -> SigningKey
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> XPrv
forall passPhrase seed.
(ByteArrayAccess passPhrase, ByteArrayAccess seed) =>
seed -> passPhrase -> XPrv
Byron.generate ByteString
seed (ByteString
forall a. Monoid a => a
mempty :: ByteString)
    seed :: ByteString
seed = ByteString
"12345678901234567890123456789012" :: ByteString

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

-- | @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 DSIGN -> KeyPair kd
forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair (VerKeyDSIGN DSIGN -> VKey kd
forall (kd :: KeyRole). VerKeyDSIGN DSIGN -> VKey kd
VKey (VerKeyDSIGN DSIGN -> VKey kd) -> VerKeyDSIGN DSIGN -> VKey kd
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN DSIGN -> VerKeyDSIGN DSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
DSIGN.deriveVerKeyDSIGN SignKeyDSIGN DSIGN
sk) SignKeyDSIGN DSIGN
sk
  where
    sk :: SignKeyDSIGN DSIGN
sk = Seed -> SignKeyDSIGN DSIGN
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
DSIGN.genKeyDSIGN (Seed -> SignKeyDSIGN DSIGN) -> Seed -> SignKeyDSIGN DSIGN
forall a b. (a -> b) -> a -> b
$ Word8 -> Int -> Seed
seedFromByte Word8
byte Int
size
    size :: Int
size = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ Proxy DSIGN -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
DSIGN.seedSizeDSIGN (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @DSIGN)

mkKeyHash :: forall discriminator. Int -> KeyHash discriminator
mkKeyHash :: forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash = Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash discriminator
forall (r :: KeyRole).
Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
KeyHash (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash discriminator)
-> (Int -> Hash ADDRHASH (VerKeyDSIGN DSIGN))
-> 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

seedFromByte :: Word8 -> Int -> Seed.Seed
seedFromByte :: Word8 -> Int -> Seed
seedFromByte Word8
byte Int
size =
  ByteString -> Seed
Seed.mkSeedFromBytes (ByteString -> Seed) -> ByteString -> Seed
forall a b. (a -> b) -> a -> b
$
    Int -> Word8 -> ByteString
Strict.replicate
      Int
size
      Word8
byte

seedFromWords :: RawSeed -> Seed.Seed
seedFromWords :: RawSeed -> Seed
seedFromWords RawSeed
ws =
  ByteString -> Seed
Seed.mkSeedFromBytes (ByteString -> Seed)
-> (Hash HASH RawSeed -> ByteString) -> Hash HASH RawSeed -> Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash HASH RawSeed -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes (Hash HASH RawSeed -> Seed) -> Hash HASH RawSeed -> Seed
forall a b. (a -> b) -> a -> b
$ forall h a.
HashAlgorithm h =>
Version -> (a -> Encoding) -> a -> Hash h a
hashWithEncoder @HASH Version
shelleyProtVer RawSeed -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR RawSeed
ws

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