{-# 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 (
  AuxiliaryDataHash (..),
  mkAlonzoTxAuxData,
 )
import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..), Redeemers (..), TxDats (..))
import Cardano.Ledger.Babbage (Babbage)
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.Crypto (StandardCrypto)
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.SafeHash (hashAnnotated)
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.Class (def)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
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 Babbage
ledgerExamplesBabbage :: ShelleyLedgerExamples Babbage
ledgerExamplesBabbage =
  SLE.ShelleyLedgerExamples
    { sleBlock :: Block (BHeader (EraCrypto Babbage)) Babbage
SLE.sleBlock = forall era.
(EraSegWits era, PraosCrypto (EraCrypto era)) =>
Tx era -> Block (BHeader (EraCrypto era)) era
SLE.exampleShelleyLedgerBlock AlonzoTx Babbage
exampleTransactionInBlock
    , sleHashHeader :: HashHeader (EraCrypto Babbage)
SLE.sleHashHeader = forall era.
ShelleyBasedEra' era =>
Proxy era -> HashHeader (EraCrypto era)
SLE.exampleHashHeader (forall {k} (t :: k). Proxy t
Proxy @Babbage)
    , sleTx :: Tx Babbage
SLE.sleTx = AlonzoTx Babbage
exampleTransactionInBlock
    , sleApplyTxError :: ApplyTxError Babbage
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 (EraCrypto era) -> ShelleyDelegsPredFailure era
DelegateeNotRegisteredDELEG @Babbage (forall c (discriminator :: KeyRole).
Crypto c =>
Int -> KeyHash discriminator c
SLE.mkKeyHash Int
1)
    , sleRewardsCredentials :: Set (Either Coin (Credential 'Staking (EraCrypto Babbage)))
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) c. ScriptHash c -> Credential kr c
ScriptHashObj (forall c. Crypto c => Int -> ScriptHash c
SLE.mkScriptHash Int
1))
          , forall a b. b -> Either a b
Right (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj (forall c (discriminator :: KeyRole).
Crypto c =>
Int -> KeyHash discriminator c
SLE.mkKeyHash Int
2))
          ]
    , sleResultExamples :: ShelleyResultExamples Babbage
SLE.sleResultExamples = ShelleyResultExamples Babbage
resultExamples
    , sleNewEpochState :: NewEpochState Babbage
SLE.sleNewEpochState = NewEpochState Babbage
exampleBabbageNewEpochState
    , sleChainDepState :: ChainDepState (EraCrypto Babbage)
SLE.sleChainDepState = forall c. Crypto c => Word64 -> ChainDepState c
SLE.exampleLedgerChainDepState Word64
1
    , sleTranslationContext :: TranslationContext Babbage
SLE.sleTranslationContext = forall era. NoGenesis era
NoGenesis
    }
  where
    resultExamples :: ShelleyResultExamples Babbage
resultExamples =
      SLE.ShelleyResultExamples
        { srePParams :: PParams Babbage
SLE.srePParams = forall a. Default a => a
def
        , sreProposedPPUpdates :: ProposedPPUpdates Babbage
SLE.sreProposedPPUpdates = ProposedPPUpdates Babbage
examplePPPU
        , srePoolDistr :: PoolDistr (EraCrypto Babbage)
SLE.srePoolDistr = forall c. PraosCrypto c => PoolDistr c
SLE.examplePoolDistr
        , sreNonMyopicRewards :: Map
  (Either Coin (Credential 'Staking (EraCrypto Babbage)))
  (Map (KeyHash 'StakePool (EraCrypto Babbage)) Coin)
SLE.sreNonMyopicRewards = forall c.
Crypto c =>
Map
  (Either Coin (Credential 'Staking c))
  (Map (KeyHash 'StakePool c) Coin)
SLE.exampleNonMyopicRewards
        , sreShelleyGenesis :: ShelleyGenesis (EraCrypto Babbage)
SLE.sreShelleyGenesis = forall c. Crypto c => ShelleyGenesis c
SLE.testShelleyGenesis
        }
    examplePPPU :: ProposedPPUpdates Babbage
examplePPPU =
      forall era.
Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
ProposedPPUpdates forall a b. (a -> b) -> a -> b
$
        forall k a. k -> a -> Map k a
Map.singleton
          (forall c (discriminator :: KeyRole).
Crypto c =>
Int -> KeyHash discriminator c
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 Babbage
collateralOutput :: BabbageTxOut Babbage
collateralOutput =
  forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr (EraCrypto era)
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut
    (forall c.
Crypto c =>
(KeyPair 'Payment c, KeyPair 'Staking c) -> Addr c
mkAddr (forall c. Crypto c => KeyPair 'Payment c
SLE.examplePayKey, forall c. Crypto c => KeyPair 'Staking c
SLE.exampleStakeKey))
    (forall c. Coin -> MultiAsset c -> MaryValue c
MaryValue (Integer -> Coin
Coin Integer
8675309) forall a. Monoid a => a
mempty)
    forall era. Datum era
NoDatum
    forall a. StrictMaybe a
SNothing

exampleTxBodyBabbage :: TxBody Babbage
exampleTxBodyBabbage :: TxBody Babbage
exampleTxBodyBabbage =
  forall era.
BabbageEraTxBody era =>
Set (TxIn (EraCrypto era))
-> Set (TxIn (EraCrypto era))
-> Set (TxIn (EraCrypto era))
-> StrictSeq (Sized (TxOut era))
-> StrictMaybe (Sized (TxOut era))
-> StrictMaybe Coin
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> Set (KeyHash 'Witness (EraCrypto era))
-> MultiAsset (EraCrypto era)
-> StrictMaybe (ScriptIntegrityHash (EraCrypto era))
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> StrictMaybe Network
-> BabbageTxBody era
BabbageTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial (forall c. SafeHash c EraIndependentTxBody -> TxId c
TxId (forall c a. Crypto c => Proxy c -> Int -> SafeHash c a
SLE.mkDummySafeHash forall {k} (t :: k). Proxy t
Proxy Int
1)) Integer
0]) -- spending inputs
    (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial (forall c. SafeHash c EraIndependentTxBody -> TxId c
TxId (forall c a. Crypto c => Proxy c -> Int -> SafeHash c a
SLE.mkDummySafeHash forall {k} (t :: k). Proxy t
Proxy Int
2)) Integer
1]) -- collateral inputs
    (forall a. Ord a => [a] -> Set a
Set.fromList [forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial (forall c. SafeHash c EraIndependentTxBody -> TxId c
TxId (forall c a. Crypto c => Proxy c -> Int -> SafeHash c a
SLE.mkDummySafeHash forall {k} (t :: k). Proxy t
Proxy 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 @Babbage) forall a b. (a -> b) -> a -> b
$
            forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr (EraCrypto era)
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut
              (forall c.
Crypto c =>
(KeyPair 'Payment c, KeyPair 'Staking c) -> Addr c
mkAddr (forall c. Crypto c => KeyPair 'Payment c
SLE.examplePayKey, forall c. Crypto c => KeyPair 'Staking c
SLE.exampleStakeKey))
              (forall c. Crypto c => Int -> MaryValue c
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 Babbage
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 @Babbage) BabbageTxOut Babbage
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
    ( forall c. Map (RewardAcnt c) Coin -> Withdrawals c
Withdrawals forall a b. (a -> b) -> a -> b
$
        forall k a. k -> a -> Map k a
Map.singleton
          (forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
Testnet (forall c (r :: KeyRole). Crypto c => KeyPair r c -> Credential r c
SLE.keyToCredential forall c. Crypto c => KeyPair 'Staking c
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 (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
ProposedPPUpdates forall a b. (a -> b) -> a -> b
$
              forall k a. k -> a -> Map k a
Map.singleton
                (forall c (discriminator :: KeyRole).
Crypto c =>
Int -> KeyHash discriminator c
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 c (discriminator :: KeyRole).
Crypto c =>
Int -> KeyHash discriminator c
SLE.mkKeyHash Int
212) -- reqSignerHashes
    MultiAsset StandardCrypto
exampleMultiAsset -- mint
    (forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$ forall c a. Crypto c => Proxy c -> Int -> SafeHash c a
SLE.mkDummySafeHash (forall {k} (t :: k). Proxy t
Proxy @StandardCrypto) Int
42) -- scriptIntegrityHash
    (forall a. a -> StrictMaybe a
SJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. SafeHash c EraIndependentTxAuxData -> AuxiliaryDataHash c
AuxiliaryDataHash forall a b. (a -> b) -> a -> b
$ forall c a. Crypto c => Proxy c -> Int -> SafeHash c a
SLE.mkDummySafeHash (forall {k} (t :: k). Proxy t
Proxy @StandardCrypto) Int
42) -- adHash
    (forall a. a -> StrictMaybe a
SJust Network
Mainnet) -- txnetworkid
  where
    MaryValue Coin
_ MultiAsset StandardCrypto
exampleMultiAsset = forall c. Crypto c => Int -> MaryValue c
MarySLE.exampleMultiAssetValue Int
3

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

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

exampleTx :: ShelleyTx Babbage
exampleTx :: ShelleyTx Babbage
exampleTx =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    TxBody Babbage
exampleTxBodyBabbage
    ( forall era.
AlonzoEraScript era =>
Set (WitVKey 'Witness (EraCrypto era))
-> Set (BootstrapWitness (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> TxDats era
-> Redeemers era
-> AlonzoTxWits era
AlonzoTxWits
        (forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
mkWitnessesVKey (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody Babbage
exampleTxBodyBabbage) [forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall c. Crypto c => KeyPair 'Payment c
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 (EraCrypto era)
hashScript @Babbage 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 (EraCrypto era)) (Data era) -> TxDats era
TxDats forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (forall era. Era era => Data era -> DataHash (EraCrypto era)
hashData Data Babbage
datumExample) Data Babbage
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 (EraCrypto era)) -> AlonzoPlutusPurpose f era
AlonzoSpending forall a b. (a -> b) -> a -> b
$ forall ix it. ix -> AsIx ix it
AsIx Word32
0) (Data Babbage
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 Babbage
exampleTransactionInBlock :: AlonzoTx Babbage
exampleTransactionInBlock = forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx BabbageTxBody Babbage
b AlonzoTxWits Babbage
w (Bool -> IsValid
IsValid Bool
True) StrictMaybe (AlonzoTxAuxData Babbage)
a
  where
    ShelleyTx TxBody Babbage
b TxWits Babbage
w StrictMaybe (TxAuxData Babbage)
a = ShelleyTx Babbage
exampleTx

exampleBabbageNewEpochState :: NewEpochState Babbage
exampleBabbageNewEpochState :: NewEpochState Babbage
exampleBabbageNewEpochState =
  forall era.
(EraTxOut era, EraGov era, ShelleyBasedEra' era,
 Default (StashedAVVMAddresses era)) =>
Value era -> PParams era -> PParams era -> NewEpochState era
SLE.exampleNewEpochState
    (forall c. Crypto c => Int -> MaryValue c
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))