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

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

import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..))
import Cardano.Ledger.Alonzo.Scripts (
  AlonzoPlutusPurpose (..),
  AlonzoScript (..),
  ExUnits (..),
  Prices (..),
 )
import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..))
import Cardano.Ledger.Alonzo.TxAuxData (mkAlonzoTxAuxData)
import Cardano.Ledger.Alonzo.TxBody (AlonzoTxBody (..), AlonzoTxOut (..))
import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..), Redeemers (..), TxDats (..))
import Cardano.Ledger.BaseTypes (NonNegativeInterval, StrictMaybe (..), boundRational)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.Mary.Value (MaryValue (..))
import Cardano.Ledger.Plutus.CostModels (mkCostModels)
import Cardano.Ledger.Plutus.Data (Data (..), 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 GHC.Stack (HasCallStack)
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 Test.Cardano.Ledger.Core.Utils (mkDummySafeHash)
import qualified Test.Cardano.Ledger.Mary.Examples.Consensus as SLE
import Test.Cardano.Ledger.Plutus (zeroTestingCostModelV1)
import qualified Test.Cardano.Ledger.Shelley.Examples.Consensus as SLE

-- | ShelleyLedgerExamples for Alonzo era
ledgerExamplesAlonzo :: SLE.ShelleyLedgerExamples AlonzoEra
ledgerExamplesAlonzo :: ShelleyLedgerExamples AlonzoEra
ledgerExamplesAlonzo =
  SLE.ShelleyLedgerExamples
    { sleBlock :: Block (BHeader StandardCrypto) AlonzoEra
SLE.sleBlock = forall era.
EraSegWits era =>
Tx era -> Block (BHeader StandardCrypto) era
SLE.exampleShelleyLedgerBlock AlonzoTx AlonzoEra
exampleTransactionInBlock
    , sleHashHeader :: HashHeader
SLE.sleHashHeader = HashHeader
SLE.exampleHashHeader
    , sleTx :: Tx AlonzoEra
SLE.sleTx = AlonzoTx AlonzoEra
exampleTransactionInBlock
    , sleApplyTxError :: ApplyTxError AlonzoEra
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 @AlonzoEra (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 AlonzoEra
SLE.sleResultExamples = ShelleyResultExamples AlonzoEra
resultExamples
    , sleNewEpochState :: NewEpochState AlonzoEra
SLE.sleNewEpochState = NewEpochState AlonzoEra
exampleAlonzoNewEpochState
    , sleChainDepState :: ChainDepState
SLE.sleChainDepState = Word64 -> ChainDepState
SLE.exampleLedgerChainDepState Word64
1
    , sleTranslationContext :: TranslationContext AlonzoEra
SLE.sleTranslationContext = AlonzoGenesis
exampleAlonzoGenesis
    }
  where
    resultExamples :: ShelleyResultExamples AlonzoEra
resultExamples =
      SLE.ShelleyResultExamples
        { srePParams :: PParams AlonzoEra
SLE.srePParams = forall a. Default a => a
def
        , sreProposedPPUpdates :: ProposedPPUpdates AlonzoEra
SLE.sreProposedPPUpdates = ProposedPPUpdates AlonzoEra
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 AlonzoEra
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)

exampleTxBodyAlonzo :: AlonzoTxBody AlonzoEra
exampleTxBodyAlonzo :: AlonzoTxBody AlonzoEra
exampleTxBodyAlonzo =
  forall era.
(EraTxOut era, EraTxCert era) =>
Set TxIn
-> Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> Set (KeyHash 'Witness)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> AlonzoTxBody era
AlonzoTxBody
    (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (SafeHash EraIndependentTxBody -> TxId
TxId (forall a. Int -> SafeHash a
mkDummySafeHash Int
1)) Integer
0]) -- inputs
    (forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (SafeHash EraIndependentTxBody -> TxId
TxId (forall a. Int -> SafeHash a
mkDummySafeHash Int
2)) Integer
1]) -- collateral
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr -> Value era -> StrictMaybe DataHash -> AlonzoTxOut era
AlonzoTxOut
            ((KeyPair 'Payment, KeyPair 'Staking) -> Addr
mkAddr (KeyPair 'Payment
SLE.examplePayKey, KeyPair 'Staking
SLE.exampleStakeKey))
            (Int -> MaryValue
SLE.exampleMultiAssetValue Int
2)
            (forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$ forall a. Int -> SafeHash a
mkDummySafeHash Int
1) -- outputs
        ]
    )
    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
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
mkDummySafeHash Int
42) -- adHash
    (forall a. a -> StrictMaybe a
SJust Network
Mainnet) -- txnetworkid
  where
    MaryValue Coin
_ MultiAsset
exampleMultiAsset = Int -> MaryValue
SLE.exampleMultiAssetValue Int
3

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

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

exampleTx :: ShelleyTx AlonzoEra
exampleTx :: ShelleyTx AlonzoEra
exampleTx =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    AlonzoTxBody AlonzoEra
exampleTxBodyAlonzo
    ( 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 AlonzoTxBody AlonzoEra
exampleTxBodyAlonzo) [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 @AlonzoEra 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 AlonzoEra
datumExample) Data AlonzoEra
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 AlonzoEra
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 -- auxiliary data
          [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 AlonzoEra
exampleTransactionInBlock :: AlonzoTx AlonzoEra
exampleTransactionInBlock = forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx AlonzoTxBody AlonzoEra
b AlonzoTxWits AlonzoEra
w (Bool -> IsValid
IsValid Bool
True) StrictMaybe (AlonzoTxAuxData AlonzoEra)
a
  where
    ShelleyTx TxBody AlonzoEra
b TxWits AlonzoEra
w StrictMaybe (TxAuxData AlonzoEra)
a = ShelleyTx AlonzoEra
exampleTx

exampleAlonzoNewEpochState :: NewEpochState AlonzoEra
exampleAlonzoNewEpochState :: NewEpochState AlonzoEra
exampleAlonzoNewEpochState =
  forall era.
(EraTxOut era, EraGov era, Default (StashedAVVMAddresses era)) =>
Value era -> PParams era -> PParams era -> NewEpochState era
SLE.exampleNewEpochState
    (Int -> MaryValue
SLE.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.
(AlonzoEraPParams era, ExactEra AlonzoEra era) =>
Lens' (PParams era) CoinPerWord
ppCoinsPerUTxOWordL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> CoinPerWord
CoinPerWord (Integer -> Coin
Coin Integer
1))

exampleAlonzoGenesis :: AlonzoGenesis
exampleAlonzoGenesis :: AlonzoGenesis
exampleAlonzoGenesis =
  AlonzoGenesis
    { agCoinsPerUTxOWord :: CoinPerWord
agCoinsPerUTxOWord = Coin -> CoinPerWord
CoinPerWord forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1
    , agCostModels :: CostModels
agCostModels = Map Language CostModel -> CostModels
mkCostModels (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Language
PlutusV1, HasCallStack => CostModel
zeroTestingCostModelV1)])
    , agPrices :: Prices
agPrices = NonNegativeInterval -> NonNegativeInterval -> Prices
Prices (HasCallStack => Rational -> NonNegativeInterval
boundRational' Rational
90) (HasCallStack => Rational -> NonNegativeInterval
boundRational' Rational
91)
    , agMaxTxExUnits :: ExUnits
agMaxTxExUnits = Natural -> Natural -> ExUnits
ExUnits Natural
123 Natural
123
    , agMaxBlockExUnits :: ExUnits
agMaxBlockExUnits = Natural -> Natural -> ExUnits
ExUnits Natural
223 Natural
223
    , agMaxValSize :: Natural
agMaxValSize = Natural
1234
    , agCollateralPercentage :: Natural
agCollateralPercentage = Natural
20
    , agMaxCollateralInputs :: Natural
agMaxCollateralInputs = Natural
30
    }
  where
    boundRational' :: HasCallStack => Rational -> NonNegativeInterval
    boundRational' :: HasCallStack => Rational -> NonNegativeInterval
boundRational' Rational
x = case forall r. BoundedRational r => Rational -> Maybe r
boundRational Rational
x of
      Maybe NonNegativeInterval
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Expected non-negative value but got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Rational
x
      Just NonNegativeInterval
x' -> NonNegativeInterval
x'