{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | The example transactions in this module are not valid transactions. We
-- don't care, we are only interested in serialisation, not validation.
module Test.Cardano.Ledger.Allegra.Examples (
  ledgerExamples,
  exampleAllegraTx,
  exampleAllegraBasedTx,
) where

import Cardano.Ledger.Allegra
import Cardano.Ledger.Allegra.Core
import Cardano.Ledger.Allegra.Scripts
import Cardano.Ledger.Allegra.TxBody
import Cardano.Ledger.Genesis (NoGenesis (..))
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.Shelley.Scripts
import Cardano.Slotting.Slot
import qualified Data.MapExtras as Map
import qualified Data.Sequence.Strict as StrictSeq
import Data.Typeable (Typeable)
import Lens.Micro
import Test.Cardano.Ledger.Shelley.Examples (
  LedgerExamples,
  addShelleyBasedTopTxExampleFee,
  addShelleyToBabbageExampleProposedPUpdates,
  addShelleyToBabbageTxCerts,
  addShelleyToConwayTxCerts,
  exampleCoin,
  exampleShelleyBasedTx,
  mkKeyHash,
  mkShelleyBasedLedgerExamples,
 )

ledgerExamples :: LedgerExamples AllegraEra
ledgerExamples :: LedgerExamples AllegraEra
ledgerExamples =
  ApplyTxError AllegraEra
-> Value AllegraEra
-> Tx TopTx AllegraEra
-> TranslationContext AllegraEra
-> LedgerExamples AllegraEra
forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era,
 Default (StashedAVVMAddresses era), AtMostEra "Mary" era) =>
ApplyTxError era
-> Value era
-> Tx TopTx era
-> TranslationContext era
-> LedgerExamples era
mkShelleyBasedLedgerExamples
    ( NonEmpty (ShelleyLedgerPredFailure AllegraEra)
-> ApplyTxError AllegraEra
AllegraApplyTxError (NonEmpty (ShelleyLedgerPredFailure AllegraEra)
 -> ApplyTxError AllegraEra)
-> (ShelleyDelegPredFailure AllegraEra
    -> NonEmpty (ShelleyLedgerPredFailure AllegraEra))
-> ShelleyDelegPredFailure AllegraEra
-> ApplyTxError AllegraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerPredFailure AllegraEra
-> NonEmpty (ShelleyLedgerPredFailure AllegraEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShelleyLedgerPredFailure AllegraEra
 -> NonEmpty (ShelleyLedgerPredFailure AllegraEra))
-> (ShelleyDelegPredFailure AllegraEra
    -> ShelleyLedgerPredFailure AllegraEra)
-> ShelleyDelegPredFailure AllegraEra
-> NonEmpty (ShelleyLedgerPredFailure AllegraEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredicateFailure (EraRule "DELEGS" AllegraEra)
-> ShelleyLedgerPredFailure AllegraEra
ShelleyDelegsPredFailure AllegraEra
-> ShelleyLedgerPredFailure AllegraEra
forall era.
PredicateFailure (EraRule "DELEGS" era)
-> ShelleyLedgerPredFailure era
Shelley.DelegsFailure (ShelleyDelegsPredFailure AllegraEra
 -> ShelleyLedgerPredFailure AllegraEra)
-> (ShelleyDelegPredFailure AllegraEra
    -> ShelleyDelegsPredFailure AllegraEra)
-> ShelleyDelegPredFailure AllegraEra
-> ShelleyLedgerPredFailure AllegraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredicateFailure (EraRule "DELPL" AllegraEra)
-> ShelleyDelegsPredFailure AllegraEra
ShelleyDelplPredFailure AllegraEra
-> ShelleyDelegsPredFailure AllegraEra
forall era.
PredicateFailure (EraRule "DELPL" era)
-> ShelleyDelegsPredFailure era
Shelley.DelplFailure (ShelleyDelplPredFailure AllegraEra
 -> ShelleyDelegsPredFailure AllegraEra)
-> (ShelleyDelegPredFailure AllegraEra
    -> ShelleyDelplPredFailure AllegraEra)
-> ShelleyDelegPredFailure AllegraEra
-> ShelleyDelegsPredFailure AllegraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredicateFailure (EraRule "DELEG" AllegraEra)
-> ShelleyDelplPredFailure AllegraEra
ShelleyDelegPredFailure AllegraEra
-> ShelleyDelplPredFailure AllegraEra
forall era.
PredicateFailure (EraRule "DELEG" era)
-> ShelleyDelplPredFailure era
Shelley.DelegFailure (ShelleyDelegPredFailure AllegraEra -> ApplyTxError AllegraEra)
-> ShelleyDelegPredFailure AllegraEra -> ApplyTxError AllegraEra
forall a b. (a -> b) -> a -> b
$
        forall era. KeyHash StakePool -> ShelleyDelegPredFailure era
Shelley.DelegateeNotRegisteredDELEG @AllegraEra (Int -> KeyHash StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1)
    )
    Value AllegraEra
Coin
exampleCoin
    Tx TopTx AllegraEra
exampleAllegraTx
    TranslationContext AllegraEra
NoGenesis AllegraEra
forall era. NoGenesis era
NoGenesis

exampleAllegraTx :: Tx TopTx AllegraEra
exampleAllegraTx :: Tx TopTx AllegraEra
exampleAllegraTx =
  Tx TopTx AllegraEra
forall era (l :: TxLevel).
(EraTx era, AllegraEraTxAuxData era, AllegraEraScript era,
 AllegraEraTxBody era, Typeable l) =>
Tx l era
exampleAllegraBasedTx
    Tx TopTx AllegraEra
-> (Tx TopTx AllegraEra -> Tx TopTx AllegraEra)
-> Tx TopTx AllegraEra
forall a b. a -> (a -> b) -> b
& Tx TopTx AllegraEra -> Tx TopTx AllegraEra
forall era. EraTx era => Tx TopTx era -> Tx TopTx era
addShelleyBasedTopTxExampleFee
    Tx TopTx AllegraEra
-> (Tx TopTx AllegraEra -> Tx TopTx AllegraEra)
-> Tx TopTx AllegraEra
forall a b. a -> (a -> b) -> b
& Tx TopTx AllegraEra -> Tx TopTx AllegraEra
forall era.
(EraTx era, ShelleyEraTxBody era) =>
Tx TopTx era -> Tx TopTx era
addShelleyToBabbageExampleProposedPUpdates
    Tx TopTx AllegraEra
-> (Tx TopTx AllegraEra -> Tx TopTx AllegraEra)
-> Tx TopTx AllegraEra
forall a b. a -> (a -> b) -> b
& Tx TopTx AllegraEra -> Tx TopTx AllegraEra
forall era (l :: TxLevel).
(EraTx era, ShelleyEraTxCert era, AtMostEra "Babbage" era) =>
Tx l era -> Tx l era
addShelleyToBabbageTxCerts
    Tx TopTx AllegraEra
-> (Tx TopTx AllegraEra -> Tx TopTx AllegraEra)
-> Tx TopTx AllegraEra
forall a b. a -> (a -> b) -> b
& Tx TopTx AllegraEra -> Tx TopTx AllegraEra
forall era (l :: TxLevel).
(EraTx era, ShelleyEraTxCert era) =>
Tx l era -> Tx l era
addShelleyToConwayTxCerts

-- Complete transaction which is compatible with any era starting with Allegra.
-- This transaction forms the basis on which future era transactions will be
-- at the very least based on.
exampleAllegraBasedTx ::
  forall era l.
  ( EraTx era
  , AllegraEraTxAuxData era
  , AllegraEraScript era
  , AllegraEraTxBody era
  , Typeable l
  ) =>
  Tx l era
exampleAllegraBasedTx :: forall era (l :: TxLevel).
(EraTx era, AllegraEraTxAuxData era, AllegraEraScript era,
 AllegraEraTxBody era, Typeable l) =>
Tx l era
exampleAllegraBasedTx =
  Tx l era
forall era (l :: TxLevel).
(EraTx era, ShelleyEraScript era, Typeable l) =>
Tx l era
exampleShelleyBasedTx
    Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (Tx l era))
-> ((Map ScriptHash (Script era)
     -> Identity (Map ScriptHash (Script era)))
    -> TxWits era -> Identity (TxWits era))
-> (Map ScriptHash (Script era)
    -> Identity (Map ScriptHash (Script era)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era)
 -> Identity (Map ScriptHash (Script era)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL ((Map ScriptHash (Script era)
  -> Identity (Map ScriptHash (Script era)))
 -> Tx l era -> Identity (Tx l era))
-> Map ScriptHash (Script era) -> Tx l era -> Tx l era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ (Script era -> ScriptHash)
-> [Script era] -> Map ScriptHash (Script era)
forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
Map.fromElems Script era -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript [NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
forall era. AllegraEraScript era => NativeScript era
exampleTimelock]
    Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (TxAuxData era -> TxAuxData era) -> Tx l era -> Tx l era
forall era (l :: TxLevel).
EraTx era =>
(TxAuxData era -> TxAuxData era) -> Tx l era -> Tx l era
modifyTxAuxData
      ((StrictSeq (NativeScript era)
 -> Identity (StrictSeq (NativeScript era)))
-> TxAuxData era -> Identity (TxAuxData era)
forall era.
AllegraEraTxAuxData era =>
Lens' (TxAuxData era) (StrictSeq (NativeScript era))
Lens' (TxAuxData era) (StrictSeq (NativeScript era))
nativeScriptsTxAuxDataL ((StrictSeq (NativeScript era)
  -> Identity (StrictSeq (NativeScript era)))
 -> TxAuxData era -> Identity (TxAuxData era))
-> StrictSeq (NativeScript era) -> TxAuxData era -> TxAuxData era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ NativeScript era -> StrictSeq (NativeScript era)
forall a. a -> StrictSeq a
StrictSeq.singleton NativeScript era
forall era. AllegraEraScript era => NativeScript era
exampleTimelock)
    Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((ValidityInterval -> Identity ValidityInterval)
    -> TxBody l era -> Identity (TxBody l era))
-> (ValidityInterval -> Identity ValidityInterval)
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidityInterval -> Identity ValidityInterval)
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
AllegraEraTxBody era =>
Lens' (TxBody l era) ValidityInterval
forall (l :: TxLevel). Lens' (TxBody l era) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
 -> Tx l era -> Identity (Tx l era))
-> ValidityInterval -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (Word64 -> SlotNo
SlotNo Word64
2)) (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (Word64 -> SlotNo
SlotNo Word64
4))

exampleTimelock :: AllegraEraScript era => NativeScript era
exampleTimelock :: forall era. AllegraEraScript era => NativeScript era
exampleTimelock =
  Int -> StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
2 (StrictSeq (NativeScript era) -> NativeScript era)
-> StrictSeq (NativeScript era) -> NativeScript era
forall a b. (a -> b) -> a -> b
$
    [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
      [ StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (StrictSeq (NativeScript era) -> NativeScript era)
-> StrictSeq (NativeScript era) -> NativeScript era
forall a b. (a -> b) -> a -> b
$
          [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
            [ SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart (Word64 -> SlotNo
SlotNo Word64
0)
            , SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeExpire (Word64 -> SlotNo
SlotNo Word64
9)
            ]
      , StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf (StrictSeq (NativeScript era) -> NativeScript era)
-> StrictSeq (NativeScript era) -> NativeScript era
forall a b. (a -> b) -> a -> b
$
          [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
            [ KeyHash Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature (Int -> KeyHash Witness
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
0)
            , KeyHash Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature (Int -> KeyHash Witness
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1)
            ]
      , KeyHash Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature (Int -> KeyHash Witness
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
100)
      ]