{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

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

import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..), ExUnits (..))
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Alonzo.TxAuxData (mkAlonzoTxAuxData)
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..))
import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (mkSized)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..))
import Cardano.Ledger.Conway.Governance (VotingProcedures (..))
import Cardano.Ledger.Conway.Rules (ConwayDELEG, ConwayDelegPredFailure (..), ConwayLEDGER)
import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..))
import Cardano.Ledger.Conway.Translation ()
import Cardano.Ledger.Conway.Tx (AlonzoTx (..))
import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..))
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Conway.TxWits (AlonzoTxWits (..))
import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj))
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 (..),
  NewEpochState (..),
  ProposedPPUpdates (..),
  RewardAccount (..),
  TxId (..),
 )
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
 )
import Cardano.Ledger.Shelley.Tx (ShelleyTx (..))
import Cardano.Ledger.TxIn (mkTxInPartial)
import Control.State.Transition.Extended (Embed (..))
import Data.Default (Default (def))
import qualified Data.Map.Strict as Map
import qualified Data.OSet.Strict as OSet
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.Conway.Genesis (expectedConwayGenesis)
import Test.Cardano.Ledger.Core.KeyPair (mkAddr, mkWitnessesVKey)
import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash)
import qualified Test.Cardano.Ledger.Mary.Examples.Consensus as MarySLE
import Test.Cardano.Ledger.Shelley.Examples.Consensus (examplePoolParams)
import qualified Test.Cardano.Ledger.Shelley.Examples.Consensus as SLE

-- ==============================================================

-- | ShelleyLedgerExamples for Conway era
ledgerExamplesConway ::
  SLE.ShelleyLedgerExamples ConwayEra
ledgerExamplesConway :: ShelleyLedgerExamples ConwayEra
ledgerExamplesConway =
  SLE.ShelleyLedgerExamples
    { sleBlock :: Block (BHeader StandardCrypto) ConwayEra
SLE.sleBlock = forall era.
EraSegWits era =>
Tx era -> Block (BHeader StandardCrypto) era
SLE.exampleShelleyLedgerBlock AlonzoTx ConwayEra
exampleTransactionInBlock
    , sleHashHeader :: HashHeader
SLE.sleHashHeader = HashHeader
SLE.exampleHashHeader
    , sleTx :: Tx ConwayEra
SLE.sleTx = AlonzoTx ConwayEra
exampleTransactionInBlock
    , sleApplyTxError :: ApplyTxError ConwayEra
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 sub super.
Embed sub super =>
PredicateFailure sub -> PredicateFailure super
wrapFailed @(ConwayDELEG ConwayEra) @(ConwayLEDGER ConwayEra) forall a b. (a -> b) -> a -> b
$
              forall era. KeyHash 'StakePool -> ConwayDelegPredFailure era
DelegateeStakePoolNotRegisteredDELEG @ConwayEra (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 ConwayEra
SLE.sleResultExamples = ShelleyResultExamples ConwayEra
resultExamples
    , sleNewEpochState :: NewEpochState ConwayEra
SLE.sleNewEpochState = NewEpochState ConwayEra
exampleConwayNewEpochState
    , sleChainDepState :: ChainDepState
SLE.sleChainDepState = Word64 -> ChainDepState
SLE.exampleLedgerChainDepState Word64
1
    , sleTranslationContext :: TranslationContext ConwayEra
SLE.sleTranslationContext = ConwayGenesis
exampleConwayGenesis
    }
  where
    resultExamples :: ShelleyResultExamples ConwayEra
resultExamples =
      SLE.ShelleyResultExamples
        { srePParams :: PParams ConwayEra
SLE.srePParams = forall a. Default a => a
def
        , sreProposedPPUpdates :: ProposedPPUpdates ConwayEra
SLE.sreProposedPPUpdates = ProposedPPUpdates ConwayEra
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 ConwayEra
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 ConwayEra
collateralOutput :: BabbageTxOut ConwayEra
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

exampleConwayCerts :: OSet.OSet (ConwayTxCert era)
exampleConwayCerts :: forall era. OSet (ConwayTxCert era)
exampleConwayCerts =
  forall a. Ord a => [a] -> OSet a
OSet.fromList -- TODO should I add the new certs here?
    [ forall era. PoolCert -> ConwayTxCert era
ConwayTxCertPool (PoolParams -> PoolCert
RegPool PoolParams
examplePoolParams)
    ]

exampleTxBodyConway :: TxBody ConwayEra
exampleTxBodyConway :: TxBody ConwayEra
exampleTxBodyConway =
  forall era.
ConwayEraTxBody era =>
Set TxIn
-> Set TxIn
-> Set TxIn
-> StrictSeq (Sized (TxOut era))
-> StrictMaybe (Sized (TxOut era))
-> StrictMaybe Coin
-> OSet (ConwayTxCert era)
-> Withdrawals
-> Coin
-> ValidityInterval
-> Set (KeyHash 'Witness)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> VotingProcedures era
-> OSet (ProposalProcedure era)
-> StrictMaybe Coin
-> Coin
-> ConwayTxBody era
ConwayTxBody
    (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]) -- 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
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
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 @ConwayEra) 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 ConwayEra
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 @ConwayEra) BabbageTxOut ConwayEra
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. OSet (ConwayTxCert era)
exampleConwayCerts -- 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 -> 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
    (forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures forall a. Monoid a => a
mempty)
    forall a. Monoid a => a
mempty
    (forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
867530900000) -- current treasury value
    forall a. Monoid a => a
mempty
  where
    MaryValue Coin
_ MultiAsset
exampleMultiAsset = Int -> MaryValue
MarySLE.exampleMultiAssetValue Int
3

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

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

exampleTx :: ShelleyTx ConwayEra
exampleTx :: ShelleyTx ConwayEra
exampleTx =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    TxBody ConwayEra
exampleTxBodyConway
    ( 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 ConwayEra
exampleTxBodyConway) [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 @ConwayEra 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 ConwayEra
datumExample) Data ConwayEra
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 -> ConwayPlutusPurpose f era
ConwaySpending forall a b. (a -> b) -> a -> b
$ forall ix it. ix -> AsIx ix it
AsIx Word32
0) (Data ConwayEra
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 ConwayEra
exampleTransactionInBlock :: AlonzoTx ConwayEra
exampleTransactionInBlock = forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx ConwayTxBody ConwayEra
b AlonzoTxWits ConwayEra
w (Bool -> IsValid
IsValid Bool
True) StrictMaybe (AlonzoTxAuxData ConwayEra)
a
  where
    ShelleyTx TxBody ConwayEra
b TxWits ConwayEra
w StrictMaybe (TxAuxData ConwayEra)
a = ShelleyTx ConwayEra
exampleTx

exampleConwayNewEpochState :: NewEpochState ConwayEra
exampleConwayNewEpochState :: NewEpochState ConwayEra
exampleConwayNewEpochState =
  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))

exampleConwayGenesis :: ConwayGenesis
exampleConwayGenesis :: ConwayGenesis
exampleConwayGenesis = ConwayGenesis
expectedConwayGenesis