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

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

import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose (..), AlonzoScript (..), ExUnits (..))
import Cardano.Ledger.Alonzo.Translation ()
import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..))
import Cardano.Ledger.Alonzo.TxAuxData (mkAlonzoTxAuxData)
import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..), Redeemers (..), TxDats (..))
import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.Translation ()
import Cardano.Ledger.Babbage.TxBody (BabbageTxBody (..), BabbageTxOut (..))
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Binary (mkSized)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Genesis (NoGenesis (..))
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.Mary.Value (MaryValue (..))
import Cardano.Ledger.Plutus.Data (
  Data (..),
  Datum (..),
  dataToBinaryData,
  hashData,
 )
import Cardano.Ledger.Plutus.Language (Language (..))
import Cardano.Ledger.Shelley.API (
  ApplyTxError (..),
  Credential (..),
  Network (..),
  NewEpochState (..),
  ProposedPPUpdates (..),
  RewardAccount (..),
  TxId (..),
  Update (..),
 )
import Cardano.Ledger.Shelley.Rules (ShelleyDelegsPredFailure (..), ShelleyLedgerPredFailure (..))
import Cardano.Ledger.Shelley.Scripts
import Cardano.Ledger.Shelley.Tx (ShelleyTx (..))
import Cardano.Ledger.TxIn (mkTxInPartial)
import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..))
import Data.Default (def)
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Lens.Micro
import qualified PlutusLedgerApi.Common as P
import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysFails, alwaysSucceeds)
import Test.Cardano.Ledger.Core.KeyPair (mkAddr, mkWitnessesVKey)
import qualified Test.Cardano.Ledger.Core.Utils as SLE
import qualified Test.Cardano.Ledger.Mary.Examples.Consensus as MarySLE
import qualified Test.Cardano.Ledger.Shelley.Examples.Consensus as SLE

-- | ShelleyLedgerExamples for Babbage era
ledgerExamplesBabbage :: SLE.ShelleyLedgerExamples BabbageEra
ledgerExamplesBabbage :: ShelleyLedgerExamples BabbageEra
ledgerExamplesBabbage =
  SLE.ShelleyLedgerExamples
    { sleBlock :: Block (BHeader StandardCrypto) BabbageEra
SLE.sleBlock = forall era.
EraSegWits era =>
Tx era -> Block (BHeader StandardCrypto) era
SLE.exampleShelleyLedgerBlock AlonzoTx BabbageEra
exampleTransactionInBlock
    , sleHashHeader :: HashHeader
SLE.sleHashHeader = HashHeader
SLE.exampleHashHeader
    , sleTx :: Tx BabbageEra
SLE.sleTx = AlonzoTx BabbageEra
exampleTransactionInBlock
    , sleApplyTxError :: ApplyTxError BabbageEra
SLE.sleApplyTxError =
        forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
ApplyTxError forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            forall era.
PredicateFailure (EraRule "DELEGS" era)
-> ShelleyLedgerPredFailure era
DelegsFailure forall a b. (a -> b) -> a -> b
$
              forall era. KeyHash 'StakePool -> ShelleyDelegsPredFailure era
DelegateeNotRegisteredDELEG @BabbageEra (forall (discriminator :: KeyRole). Int -> KeyHash discriminator
SLE.mkKeyHash Int
1)
    , sleRewardsCredentials :: Set (Either Coin (Credential 'Staking))
SLE.sleRewardsCredentials =
        forall a. Ord a => [a] -> Set a
Set.fromList
          [ forall a b. a -> Either a b
Left (Integer -> Coin
Coin Integer
100)
          , forall a b. b -> Either a b
Right (forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (Int -> ScriptHash
SLE.mkScriptHash Int
1))
          , forall a b. b -> Either a b
Right (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (forall (discriminator :: KeyRole). Int -> KeyHash discriminator
SLE.mkKeyHash Int
2))
          ]
    , sleResultExamples :: ShelleyResultExamples BabbageEra
SLE.sleResultExamples = ShelleyResultExamples BabbageEra
resultExamples
    , sleNewEpochState :: NewEpochState BabbageEra
SLE.sleNewEpochState = NewEpochState BabbageEra
exampleBabbageNewEpochState
    , sleChainDepState :: ChainDepState
SLE.sleChainDepState = Word64 -> ChainDepState
SLE.exampleLedgerChainDepState Word64
1
    , sleTranslationContext :: TranslationContext BabbageEra
SLE.sleTranslationContext = forall era. NoGenesis era
NoGenesis
    }
  where
    resultExamples :: ShelleyResultExamples BabbageEra
resultExamples =
      SLE.ShelleyResultExamples
        { srePParams :: PParams BabbageEra
SLE.srePParams = forall a. Default a => a
def
        , sreProposedPPUpdates :: ProposedPPUpdates BabbageEra
SLE.sreProposedPPUpdates = ProposedPPUpdates BabbageEra
examplePPPU
        , srePoolDistr :: PoolDistr
SLE.srePoolDistr = PoolDistr
SLE.examplePoolDistr
        , sreNonMyopicRewards :: Map
  (Either Coin (Credential 'Staking)) (Map (KeyHash 'StakePool) Coin)
SLE.sreNonMyopicRewards = Map
  (Either Coin (Credential 'Staking)) (Map (KeyHash 'StakePool) Coin)
SLE.exampleNonMyopicRewards
        , sreShelleyGenesis :: ShelleyGenesis
SLE.sreShelleyGenesis = ShelleyGenesis
SLE.testShelleyGenesis
        }
    examplePPPU :: ProposedPPUpdates BabbageEra
examplePPPU =
      forall era.
Map (KeyHash 'Genesis) (PParamsUpdate era) -> ProposedPPUpdates era
ProposedPPUpdates forall a b. (a -> b) -> a -> b
$
        forall k a. k -> a -> Map k a
Map.singleton
          (forall (discriminator :: KeyRole). Int -> KeyHash discriminator
SLE.mkKeyHash Int
0)
          (forall era. EraPParams era => PParamsUpdate era
emptyPParamsUpdate forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Natural)
ppuCollateralPercentageL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Natural
150)

collateralOutput :: BabbageTxOut BabbageEra
collateralOutput :: BabbageTxOut BabbageEra
collateralOutput =
  forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut
    ((KeyPair 'Payment, KeyPair 'Staking) -> Addr
mkAddr (KeyPair 'Payment
SLE.examplePayKey, KeyPair 'Staking
SLE.exampleStakeKey))
    (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
8675309) forall a. Monoid a => a
mempty)
    forall era. Datum era
NoDatum
    forall a. StrictMaybe a
SNothing

exampleTxBodyBabbage :: TxBody BabbageEra
exampleTxBodyBabbage :: TxBody BabbageEra
exampleTxBodyBabbage =
  forall era.
BabbageEraTxBody era =>
Set TxIn
-> Set TxIn
-> Set TxIn
-> StrictSeq (Sized (TxOut era))
-> StrictMaybe (Sized (TxOut era))
-> StrictMaybe Coin
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> Set (KeyHash 'Witness)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> BabbageTxBody era
BabbageTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (SafeHash EraIndependentTxBody -> TxId
TxId (forall a. Int -> SafeHash a
SLE.mkDummySafeHash Int
1)) Integer
0]) -- spending inputs
    (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (SafeHash EraIndependentTxBody -> TxId
TxId (forall a. Int -> SafeHash a
SLE.mkDummySafeHash Int
2)) Integer
1]) -- collateral inputs
    (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (SafeHash EraIndependentTxBody -> TxId
TxId (forall a. Int -> SafeHash a
SLE.mkDummySafeHash Int
1)) Integer
3]) -- reference inputs
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ forall a. EncCBOR a => Version -> a -> Sized a
mkSized (forall era. Era era => Version
eraProtVerHigh @BabbageEra) forall a b. (a -> b) -> a -> b
$
            forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut
              ((KeyPair 'Payment, KeyPair 'Staking) -> Addr
mkAddr (KeyPair 'Payment
SLE.examplePayKey, KeyPair 'Staking
SLE.exampleStakeKey))
              (Int -> MaryValue
MarySLE.exampleMultiAssetValue Int
2)
              (forall era. BinaryData era -> Datum era
Datum forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data era -> BinaryData era
dataToBinaryData Data BabbageEra
datumExample) -- inline datum
              (forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$ forall (l :: Language) era.
(HasCallStack, PlutusLanguage l, AlonzoEraScript era) =>
Natural -> Script era
alwaysSucceeds @'PlutusV2 Natural
3) -- reference script
        ]
    )
    (forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$ forall a. EncCBOR a => Version -> a -> Sized a
mkSized (forall era. Era era => Version
eraProtVerHigh @BabbageEra) BabbageTxOut BabbageEra
collateralOutput) -- collateral return
    (forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
8675309) -- collateral tot
    forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
StrictSeq (TxCert era)
SLE.exampleCerts -- txcerts
    ( Map RewardAccount Coin -> Withdrawals
Withdrawals forall a b. (a -> b) -> a -> b
$
        forall k a. k -> a -> Map k a
Map.singleton
          (Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet (forall (r :: KeyRole). KeyPair r -> Credential r
SLE.keyToCredential KeyPair 'Staking
SLE.exampleStakeKey))
          (Integer -> Coin
Coin Integer
100) -- txwdrls
    )
    (Integer -> Coin
Coin Integer
999) -- txfee
    (StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval (forall a. a -> StrictMaybe a
SJust (Word64 -> SlotNo
SlotNo Word64
2)) (forall a. a -> StrictMaybe a
SJust (Word64 -> SlotNo
SlotNo Word64
4))) -- txvldt
    ( forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$
        forall era. ProposedPPUpdates era -> EpochNo -> Update era
Update
          ( forall era.
Map (KeyHash 'Genesis) (PParamsUpdate era) -> ProposedPPUpdates era
ProposedPPUpdates forall a b. (a -> b) -> a -> b
$
              forall k a. k -> a -> Map k a
Map.singleton
                (forall (discriminator :: KeyRole). Int -> KeyHash discriminator
SLE.mkKeyHash Int
1)
                (forall era. EraPParams era => PParamsUpdate era
emptyPParamsUpdate forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Word16)
ppuMaxBHSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Word16
4000)
          )
          (Word64 -> EpochNo
EpochNo Word64
0)
    ) -- txUpdates
    (forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ forall (discriminator :: KeyRole). Int -> KeyHash discriminator
SLE.mkKeyHash Int
212) -- reqSignerHashes
    MultiAsset
exampleMultiAsset -- mint
    (forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$ forall a. Int -> SafeHash a
SLE.mkDummySafeHash Int
42) -- scriptIntegrityHash
    (forall a. a -> StrictMaybe a
SJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeHash EraIndependentTxAuxData -> TxAuxDataHash
TxAuxDataHash forall a b. (a -> b) -> a -> b
$ forall a. Int -> SafeHash a
SLE.mkDummySafeHash Int
42) -- adHash
    (forall a. a -> StrictMaybe a
SJust Network
Mainnet) -- txnetworkid
  where
    MaryValue Coin
_ MultiAsset
exampleMultiAsset = Int -> MaryValue
MarySLE.exampleMultiAssetValue Int
3

datumExample :: Data BabbageEra
datumExample :: Data BabbageEra
datumExample = forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
191)

redeemerExample :: Data BabbageEra
redeemerExample :: Data BabbageEra
redeemerExample = forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
919)

exampleTx :: ShelleyTx BabbageEra
exampleTx :: ShelleyTx BabbageEra
exampleTx =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    TxBody BabbageEra
exampleTxBodyBabbage
    ( forall era.
AlonzoEraScript era =>
Set (WitVKey 'Witness)
-> Set BootstrapWitness
-> Map ScriptHash (Script era)
-> TxDats era
-> Redeemers era
-> AlonzoTxWits era
AlonzoTxWits
        (forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody BabbageEra
exampleTxBodyBabbage) [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
SLE.examplePayKey]) -- vkey
        forall a. Monoid a => a
mempty -- bootstrap
        ( forall k a. k -> a -> Map k a
Map.singleton
            (forall era. EraScript era => Script era -> ScriptHash
hashScript @BabbageEra forall a b. (a -> b) -> a -> b
$ forall (l :: Language) era.
(HasCallStack, PlutusLanguage l, AlonzoEraScript era) =>
Natural -> Script era
alwaysSucceeds @'PlutusV1 Natural
3)
            (forall (l :: Language) era.
(HasCallStack, PlutusLanguage l, AlonzoEraScript era) =>
Natural -> Script era
alwaysSucceeds @'PlutusV1 Natural
3) -- txscripts
        )
        (forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (forall era. Data era -> DataHash
hashData Data BabbageEra
datumExample) Data BabbageEra
datumExample)
        ( forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers forall a b. (a -> b) -> a -> b
$
            forall k a. k -> a -> Map k a
Map.singleton (forall (f :: * -> * -> *) era.
f Word32 TxIn -> AlonzoPlutusPurpose f era
AlonzoSpending forall a b. (a -> b) -> a -> b
$ forall ix it. ix -> AsIx ix it
AsIx Word32
0) (Data BabbageEra
redeemerExample, Natural -> Natural -> ExUnits
ExUnits Natural
5000 Natural
5000)
        ) -- redeemers
    )
    ( forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) era.
(Foldable f, AlonzoEraScript era) =>
Map Word64 Metadatum -> f (AlonzoScript era) -> AlonzoTxAuxData era
mkAlonzoTxAuxData
          Map Word64 Metadatum
SLE.exampleAuxDataMap -- metadata
          [forall (l :: Language) era.
(HasCallStack, PlutusLanguage l, AlonzoEraScript era) =>
Natural -> Script era
alwaysFails @'PlutusV1 Natural
2, forall era. Timelock era -> AlonzoScript era
TimelockScript forall a b. (a -> b) -> a -> b
$ forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf forall a. Monoid a => a
mempty] -- Scripts
    )

exampleTransactionInBlock :: AlonzoTx BabbageEra
exampleTransactionInBlock :: AlonzoTx BabbageEra
exampleTransactionInBlock = forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx BabbageTxBody BabbageEra
b AlonzoTxWits BabbageEra
w (Bool -> IsValid
IsValid Bool
True) StrictMaybe (AlonzoTxAuxData BabbageEra)
a
  where
    ShelleyTx TxBody BabbageEra
b TxWits BabbageEra
w StrictMaybe (TxAuxData BabbageEra)
a = ShelleyTx BabbageEra
exampleTx

exampleBabbageNewEpochState :: NewEpochState BabbageEra
exampleBabbageNewEpochState :: NewEpochState BabbageEra
exampleBabbageNewEpochState =
  forall era.
(EraTxOut era, EraGov era, Default (StashedAVVMAddresses era)) =>
Value era -> PParams era -> PParams era -> NewEpochState era
SLE.exampleNewEpochState
    (Int -> MaryValue
MarySLE.exampleMultiAssetValue Int
1)
    forall era. EraPParams era => PParams era
emptyPParams
    (forall era. EraPParams era => PParams era
emptyPParams forall a b. a -> (a -> b) -> b
& forall era.
BabbageEraPParams era =>
Lens' (PParams era) CoinPerByte
ppCoinsPerUTxOByteL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> CoinPerByte
CoinPerByte (Integer -> Coin
Coin Integer
1))