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

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

import Cardano.Ledger.Alonzo (Alonzo)
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 (AuxiliaryDataHash (..), 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.Crypto (StandardCrypto)
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.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 (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 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 Alonzo
ledgerExamplesAlonzo :: ShelleyLedgerExamples Alonzo
ledgerExamplesAlonzo =
  SLE.ShelleyLedgerExamples
    { sleBlock :: Block (BHeader (EraCrypto Alonzo)) Alonzo
SLE.sleBlock = forall era.
(EraSegWits era, PraosCrypto (EraCrypto era)) =>
Tx era -> Block (BHeader (EraCrypto era)) era
SLE.exampleShelleyLedgerBlock AlonzoTx Alonzo
exampleTransactionInBlock
    , sleHashHeader :: HashHeader (EraCrypto Alonzo)
SLE.sleHashHeader = forall era.
ShelleyBasedEra' era =>
Proxy era -> HashHeader (EraCrypto era)
SLE.exampleHashHeader (forall {k} (t :: k). Proxy t
Proxy @Alonzo)
    , sleTx :: Tx Alonzo
SLE.sleTx = AlonzoTx Alonzo
exampleTransactionInBlock
    , sleApplyTxError :: ApplyTxError Alonzo
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 @Alonzo (forall c (discriminator :: KeyRole).
Crypto c =>
Int -> KeyHash discriminator c
SLE.mkKeyHash Int
1)
    , sleRewardsCredentials :: Set (Either Coin (Credential 'Staking (EraCrypto Alonzo)))
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 Alonzo
SLE.sleResultExamples = ShelleyResultExamples Alonzo
resultExamples
    , sleNewEpochState :: NewEpochState Alonzo
SLE.sleNewEpochState = NewEpochState Alonzo
exampleAlonzoNewEpochState
    , sleChainDepState :: ChainDepState (EraCrypto Alonzo)
SLE.sleChainDepState = forall c. Crypto c => Word64 -> ChainDepState c
SLE.exampleLedgerChainDepState Word64
1
    , sleTranslationContext :: TranslationContext Alonzo
SLE.sleTranslationContext = AlonzoGenesis
exampleAlonzoGenesis
    }
  where
    resultExamples :: ShelleyResultExamples Alonzo
resultExamples =
      SLE.ShelleyResultExamples
        { srePParams :: PParams Alonzo
SLE.srePParams = forall a. Default a => a
def
        , sreProposedPPUpdates :: ProposedPPUpdates Alonzo
SLE.sreProposedPPUpdates = ProposedPPUpdates Alonzo
examplePPPU
        , srePoolDistr :: PoolDistr (EraCrypto Alonzo)
SLE.srePoolDistr = forall c. PraosCrypto c => PoolDistr c
SLE.examplePoolDistr
        , sreNonMyopicRewards :: Map
  (Either Coin (Credential 'Staking (EraCrypto Alonzo)))
  (Map (KeyHash 'StakePool (EraCrypto Alonzo)) Coin)
SLE.sreNonMyopicRewards = forall c.
Crypto c =>
Map
  (Either Coin (Credential 'Staking c))
  (Map (KeyHash 'StakePool c) Coin)
SLE.exampleNonMyopicRewards
        , sreShelleyGenesis :: ShelleyGenesis (EraCrypto Alonzo)
SLE.sreShelleyGenesis = forall c. Crypto c => ShelleyGenesis c
SLE.testShelleyGenesis
        }
    examplePPPU :: ProposedPPUpdates Alonzo
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)

exampleTxBodyAlonzo :: AlonzoTxBody Alonzo
exampleTxBodyAlonzo :: AlonzoTxBody Alonzo
exampleTxBodyAlonzo =
  forall era.
(EraTxOut era, EraTxCert era) =>
Set (TxIn (EraCrypto era))
-> Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> 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
-> AlonzoTxBody era
AlonzoTxBody
    (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
mkDummySafeHash forall {k} (t :: k). Proxy t
Proxy Int
1)) Integer
0]) -- 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
mkDummySafeHash forall {k} (t :: k). Proxy t
Proxy Int
2)) Integer
1]) -- collateral
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr (EraCrypto era)
-> Value era
-> StrictMaybe (DataHash (EraCrypto era))
-> AlonzoTxOut era
AlonzoTxOut
            (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
SLE.exampleMultiAssetValue Int
2)
            (forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$ forall c a. Crypto c => Proxy c -> Int -> SafeHash c a
mkDummySafeHash forall {k} (t :: k). Proxy t
Proxy Int
1) -- outputs
        ]
    )
    forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
StrictSeq (TxCert era)
SLE.exampleCerts -- txcerts
    ( forall c. Map (RewardAccount 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
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
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
SLE.exampleMultiAssetValue Int
3

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

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

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

exampleAlonzoNewEpochState :: NewEpochState Alonzo
exampleAlonzoNewEpochState :: NewEpochState Alonzo
exampleAlonzoNewEpochState =
  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
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'