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

exampleConwayCerts :: Era era => OSet.OSet (ConwayTxCert era)
exampleConwayCerts :: forall era. Era 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 (EraCrypto era) -> ConwayTxCert era
ConwayTxCertPool (forall c. PoolParams c -> PoolCert c
RegPool forall c. Crypto c => PoolParams c
examplePoolParams)
    ]

exampleTxBodyConway :: TxBody Conway
exampleTxBodyConway :: TxBody Conway
exampleTxBodyConway =
  forall era.
ConwayEraTxBody era =>
Set (TxIn (EraCrypto era))
-> Set (TxIn (EraCrypto era))
-> Set (TxIn (EraCrypto era))
-> StrictSeq (Sized (TxOut era))
-> StrictMaybe (Sized (TxOut era))
-> StrictMaybe Coin
-> OSet (ConwayTxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> ValidityInterval
-> Set (KeyHash 'Witness (EraCrypto era))
-> MultiAsset (EraCrypto era)
-> StrictMaybe (ScriptIntegrityHash (EraCrypto era))
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> StrictMaybe Network
-> VotingProcedures era
-> OSet (ProposalProcedure era)
-> StrictMaybe Coin
-> Coin
-> ConwayTxBody era
ConwayTxBody
    (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]) -- 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
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
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 @Conway) 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 Conway
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 @Conway) BabbageTxOut Conway
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. Era era => OSet (ConwayTxCert era)
exampleConwayCerts -- 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 -> 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
    (forall era.
Map
  (Voter (EraCrypto era))
  (Map (GovActionId (EraCrypto era)) (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 StandardCrypto
exampleMultiAsset = forall c. Crypto c => Int -> MaryValue c
MarySLE.exampleMultiAssetValue Int
3

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

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

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

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

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