{-# 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,
  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 Cardano.Ledger.Shelley.Rules (
  ShelleyDelegPredFailure (DelegateeNotRegisteredDELEG),
  ShelleyDelegsPredFailure (DelplFailure),
  ShelleyDelplPredFailure (DelegFailure),
  ShelleyLedgerPredFailure (DelegsFailure),
 )
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
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
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
DelegFailure (ShelleyDelegPredFailure AllegraEra -> ApplyTxError AllegraEra)
-> ShelleyDelegPredFailure AllegraEra -> ApplyTxError AllegraEra
forall a b. (a -> b) -> a -> b
$
        forall era. KeyHash StakePool -> ShelleyDelegPredFailure era
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
  where
    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)
      ]