{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Examples.AlonzoCollectInputs (tests) where

import Cardano.Ledger.Alonzo (Alonzo)
import Cardano.Ledger.Alonzo.Plutus.Context (LedgerTxInfo (..), toPlutusArgs, toPlutusTxInfo)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..), collectPlutusScriptsWithContext)
import Cardano.Ledger.Alonzo.Scripts (
  AlonzoPlutusPurpose (..),
  AsIxItem (..),
  PlutusPurpose,
 )
import Cardano.Ledger.BaseTypes (ProtVer (..), natVersion)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Plutus (
  Data (..),
  ExUnits (..),
  Language (..),
  PlutusWithContext (..),
  hashPlutusScript,
 )
import Cardano.Ledger.SafeHash (hashAnnotated)
import Cardano.Ledger.UTxO (UTxO (..))
import Cardano.Ledger.Val (inject)
import Cardano.Slotting.EpochInfo (EpochInfo, fixedEpochInfo)
import Cardano.Slotting.Slot (EpochSize (..))
import Cardano.Slotting.Time (SystemStart (..), mkSlotLength)
import Data.Text (Text)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Lens.Micro
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Core.KeyPair (mkWitnessVKey)
import Test.Cardano.Ledger.Examples.STSTestUtils (
  initUTxO,
  mkGenesisTxIn,
  mkTxDats,
  someAddr,
  someKeys,
 )
import Test.Cardano.Ledger.Generic.Fields (
  PParamsField (..),
  TxBodyField (..),
  TxField (..),
  TxOutField (..),
  WitnessesField (..),
 )
import Test.Cardano.Ledger.Generic.GenState (PlutusPurposeTag (..), mkRedeemersFromTags)
import Test.Cardano.Ledger.Generic.PrettyCore ()
import Test.Cardano.Ledger.Generic.Proof
import Test.Cardano.Ledger.Generic.Scriptic (Scriptic (..))
import Test.Cardano.Ledger.Generic.Updaters
import Test.Cardano.Ledger.Plutus (
  alwaysSucceedsPlutus,
  zeroTestingCostModel,
  zeroTestingCostModels,
 )
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (Assertion, testCase, (@?=))

tests :: TestTree
tests :: TestTree
tests =
  TestName -> Assertion -> TestTree
testCase
    TestName
"collectTwoPhaseScriptInputs output order"
    Assertion
collectTwoPhaseScriptInputsOutputOrdering

-- Test for Plutus Data Ordering, using this strategy

-- | Never apply this to any Era but Alonzo or Babbage
collectTwoPhaseScriptInputsOutputOrdering ::
  Assertion
collectTwoPhaseScriptInputsOutputOrdering :: Assertion
collectTwoPhaseScriptInputsOutputOrdering = do
  forall era.
Proof era
-> EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext (EraCrypto era)]
collectInputs Proof (AlonzoEra StandardCrypto)
apf EpochInfo (Either Text)
testEpochInfo SystemStart
testSystemStart (forall era. EraPParams era => Proof era -> PParams era
pp Proof (AlonzoEra StandardCrypto)
apf) (forall era.
(Scriptic era, EraTx era, GoodCrypto (EraCrypto era)) =>
Proof era -> Tx era
validatingTx Proof (AlonzoEra StandardCrypto)
apf) (forall era.
(EraTxOut era, PostShelley era) =>
Proof era -> UTxO era
initUTxO Proof (AlonzoEra StandardCrypto)
apf)
    forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a b. b -> Either a b
Right
      [ PlutusWithContext
          { pwcProtocolVersion :: Version
pwcProtocolVersion = ProtVer -> Version
pvMajor (forall era. EraPParams era => Proof era -> PParams era
pp Proof (AlonzoEra StandardCrypto)
apf forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL)
          , pwcScript :: Either (Plutus 'PlutusV1) (PlutusRunnable 'PlutusV1)
pwcScript = forall a b. a -> Either a b
Left Plutus 'PlutusV1
plutus
          , pwcScriptHash :: ScriptHash StandardCrypto
pwcScriptHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript Plutus 'PlutusV1
plutus
          , pwcArgs :: PlutusArgs 'PlutusV1
pwcArgs = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => TestName -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> TestName
show) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ do
              TxInfo
txInfo <- forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> LedgerTxInfo era -> Either (ContextError era) (PlutusTxInfo l)
toPlutusTxInfo Plutus 'PlutusV1
plutus LedgerTxInfo (AlonzoEra StandardCrypto)
lti
              forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> ProtVer
-> PlutusTxInfo l
-> PlutusPurpose AsIxItem era
-> Maybe (Data era)
-> Data era
-> Either (ContextError era) (PlutusArgs l)
toPlutusArgs
                Plutus 'PlutusV1
plutus
                (forall era. EraPParams era => Proof era -> PParams era
pp Proof (AlonzoEra StandardCrypto)
apf forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL)
                TxInfo
txInfo
                (forall era. Proof era -> PlutusPurpose AsIxItem era
spendingPurpose1 Proof (AlonzoEra StandardCrypto)
apf)
                (forall a. a -> Maybe a
Just (forall era. Era era => Data era
datum @Alonzo))
                (forall era. Era era => Data era
redeemer @Alonzo)
          , pwcExUnits :: ExUnits
pwcExUnits = Natural -> Natural -> ExUnits
ExUnits Natural
5000 Natural
5000
          , pwcCostModel :: CostModel
pwcCostModel = HasCallStack => Language -> CostModel
zeroTestingCostModel Language
PlutusV1
          }
      ]
  where
    apf :: Proof (AlonzoEra StandardCrypto)
apf = Proof (AlonzoEra StandardCrypto)
Alonzo
    plutus :: Plutus 'PlutusV1
plutus = forall (l :: Language). Natural -> Plutus l
alwaysSucceedsPlutus @'PlutusV1 Natural
3
    lti :: LedgerTxInfo (AlonzoEra StandardCrypto)
lti =
      LedgerTxInfo
        { ltiProtVer :: ProtVer
ltiProtVer = forall era. EraPParams era => Proof era -> PParams era
pp Proof (AlonzoEra StandardCrypto)
apf forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
        , ltiEpochInfo :: EpochInfo (Either Text)
ltiEpochInfo = EpochInfo (Either Text)
testEpochInfo
        , ltiSystemStart :: SystemStart
ltiSystemStart = SystemStart
testSystemStart
        , ltiUTxO :: UTxO (AlonzoEra StandardCrypto)
ltiUTxO = forall era.
(EraTxOut era, PostShelley era) =>
Proof era -> UTxO era
initUTxO Proof (AlonzoEra StandardCrypto)
apf
        , ltiTx :: Tx (AlonzoEra StandardCrypto)
ltiTx = forall era.
(Scriptic era, EraTx era, GoodCrypto (EraCrypto era)) =>
Proof era -> Tx era
validatingTx Proof (AlonzoEra StandardCrypto)
apf
        }

-- ============================== DATA ===============================

datum :: Era era => Data era
datum :: forall era. Era era => Data era
datum = forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
123)

redeemer :: Era era => Data era
redeemer :: forall era. Era era => Data era
redeemer = forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
42)

spendingPurpose1 :: Proof era -> PlutusPurpose AsIxItem era
spendingPurpose1 :: forall era. Proof era -> PlutusPurpose AsIxItem era
spendingPurpose1 = \case
  Shelley {} -> forall a. HasCallStack => TestName -> a
error TestName
"Unsupported"
  Allegra {} -> forall a. HasCallStack => TestName -> a
error TestName
"Unsupported"
  Mary {} -> forall a. HasCallStack => TestName -> a
error TestName
"Unsupported"
  Alonzo {} -> forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> AlonzoPlutusPurpose f era
AlonzoSpending (forall ix it. ix -> it -> AsIxItem ix it
AsIxItem Word32
1 (forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
mkGenesisTxIn Integer
1))
  Babbage {} -> forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> AlonzoPlutusPurpose f era
AlonzoSpending (forall ix it. ix -> it -> AsIxItem ix it
AsIxItem Word32
1 (forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
mkGenesisTxIn Integer
1))
  Conway {} -> forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> ConwayPlutusPurpose f era
ConwaySpending (forall ix it. ix -> it -> AsIxItem ix it
AsIxItem Word32
1 (forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
mkGenesisTxIn Integer
1))

validatingTx ::
  forall era.
  ( Scriptic era
  , EraTx era
  , GoodCrypto (EraCrypto era)
  ) =>
  Proof era ->
  Tx era
validatingTx :: forall era.
(Scriptic era, EraTx era, GoodCrypto (EraCrypto era)) =>
Proof era -> Tx era
validatingTx Proof era
pf =
  forall era. Proof era -> [TxField era] -> Tx era
newTx
    Proof era
pf
    [ forall era. TxBody era -> TxField era
Body TxBody era
validatingBody
    , forall era. [WitnessesField era] -> TxField era
WitnessesI
        [ forall era.
Era era =>
[WitVKey 'Witness (EraCrypto era)] -> WitnessesField era
AddrWits' [forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
mkWitnessVKey (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
validatingBody) (forall era.
Era era =>
Proof era -> KeyPair 'Payment (EraCrypto era)
someKeys Proof era
pf)]
        , forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
3 Proof era
pf]
        , forall era. Era era => [Data era] -> WitnessesField era
DataWits' [forall era. Era era => Data era
datum]
        , forall era. Redeemers era -> WitnessesField era
RdmrWits Redeemers era
redeemers
        ]
    ]
  where
    validatingBody :: TxBody era
validatingBody =
      forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody
        Proof era
pf
        [ forall era. [TxIn (EraCrypto era)] -> TxBodyField era
Inputs' [forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
mkGenesisTxIn Integer
1]
        , forall era. [TxIn (EraCrypto era)] -> TxBodyField era
Collateral' [forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
mkGenesisTxIn Integer
11]
        , forall era. [TxOut era] -> TxBodyField era
Outputs' [forall era. Era era => Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr (EraCrypto era) -> TxOutField era
Address (forall era. Era era => Proof era -> Addr (EraCrypto era)
someAddr Proof era
pf), forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
4995)]]
        , forall era. Coin -> TxBodyField era
Txfee (Integer -> Coin
Coin Integer
5)
        , forall era.
StrictMaybe (ScriptIntegrityHash (EraCrypto era))
-> TxBodyField era
WppHash (forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe (ScriptIntegrityHash (EraCrypto era))
newScriptIntegrityHash Proof era
pf (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf) [Language
PlutusV1] Redeemers era
redeemers (forall era. Era era => Data era -> TxDats era
mkTxDats forall era. Era era => Data era
datum))
        ]
    redeemers :: Redeemers era
redeemers = forall era.
Proof era
-> [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
mkRedeemersFromTags Proof era
pf [((PlutusPurposeTag
Spending, Word32
0), (forall era. Era era => Data era
redeemer, Natural -> Natural -> ExUnits
ExUnits Natural
5000 Natural
5000))]

-- ============================== Helper functions ===============================

-- We have some tests that use plutus scripts, so they can only be run in
-- Babbage and Alonzo. How do we do that? We identify functions that are
-- only well typed in those Eras, and we make versions which are parameterized
-- by a proof. But which raise an error in other Eras.

collectInputs ::
  forall era.
  Proof era ->
  EpochInfo (Either Text) ->
  SystemStart ->
  PParams era ->
  Tx era ->
  UTxO era ->
  Either [CollectError era] [PlutusWithContext (EraCrypto era)]
collectInputs :: forall era.
Proof era
-> EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext (EraCrypto era)]
collectInputs Proof era
Alonzo = forall era.
(AlonzoEraTxBody era, AlonzoEraTxWits era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext (EraCrypto era)]
collectPlutusScriptsWithContext
collectInputs Proof era
Babbage = forall era.
(AlonzoEraTxBody era, AlonzoEraTxWits era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext (EraCrypto era)]
collectPlutusScriptsWithContext
collectInputs Proof era
Conway = forall era.
(AlonzoEraTxBody era, AlonzoEraTxWits era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext (EraCrypto era)]
collectPlutusScriptsWithContext
collectInputs Proof era
x = forall a. HasCallStack => TestName -> a
error (TestName
"collectInputs Not defined in era " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> TestName
show Proof era
x)

testEpochInfo :: EpochInfo (Either Text)
testEpochInfo :: EpochInfo (Either Text)
testEpochInfo = forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo (Word64 -> EpochSize
EpochSize Word64
100) (POSIXTime -> SlotLength
mkSlotLength POSIXTime
1)

testSystemStart :: SystemStart
testSystemStart :: SystemStart
testSystemStart = UTCTime -> SystemStart
SystemStart forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0

-- ============================== PParams ===============================

defaultPPs :: [PParamsField era]
defaultPPs :: forall era. [PParamsField era]
defaultPPs =
  [ forall era. CostModels -> PParamsField era
Costmdls forall a b. (a -> b) -> a -> b
$ HasCallStack => [Language] -> CostModels
zeroTestingCostModels [Language
PlutusV1]
  , forall era. Natural -> PParamsField era
MaxValSize Natural
1000000000
  , forall era. ExUnits -> PParamsField era
MaxTxExUnits forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> ExUnits
ExUnits Natural
1000000 Natural
1000000
  , forall era. ExUnits -> PParamsField era
MaxBlockExUnits forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> ExUnits
ExUnits Natural
1000000 Natural
1000000
  , forall era. ProtVer -> PParamsField era
ProtocolVersion forall a b. (a -> b) -> a -> b
$ Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @5) Natural
0
  , forall era. Natural -> PParamsField era
CollateralPercentage Natural
100
  ]

pp :: EraPParams era => Proof era -> PParams era
pp :: forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf = forall era.
EraPParams era =>
Proof era -> [PParamsField era] -> PParams era
newPParams Proof era
pf forall era. [PParamsField era]
defaultPPs