{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec (spec) where

import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (NoCostModel))
import Cardano.Ledger.Alonzo.Rules (
  AlonzoUtxosPredFailure (..),
  TagMismatchDescription (..),
 )
import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..))
import Cardano.Ledger.Plutus.Data (Data (..))
import Cardano.Ledger.Plutus.Language (hashPlutusScript, withSLanguage)
import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Lens.Micro ((&), (.~), (<>~))
import qualified PlutusLedgerApi.Common as P
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (
  alwaysFailsWithDatum,
  alwaysSucceedsWithDatum,
  datumIsWellformed,
  inputsOutputsAreNotEmptyWithDatum,
  purposeIsWellformedWithDatum,
  redeemerSameAsDatum,
 )

spec ::
  forall era.
  ( AlonzoEraImp era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  ) =>
  SpecWith (ImpTestState era)
spec :: forall era.
(AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
SpecWith (ImpTestState era)
spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXOS" forall a b. (a -> b) -> a -> b
$
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era. AlonzoEraScript era => [Language]
eraLanguages @era) forall a b. (a -> b) -> a -> b
$ \Language
lang ->
    forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang forall a b. (a -> b) -> a -> b
$ \SLanguage l
slang ->
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (forall a. Show a => a -> String
show Language
lang) forall a b. (a -> b) -> a -> b
$ do
        let redeemerSameAsDatumHash :: ScriptHash (EraCrypto era)
redeemerSameAsDatumHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
slang
            alwaysSucceedsWithDatumHash :: ScriptHash (EraCrypto era)
alwaysSucceedsWithDatumHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang

        let scripts :: [(String, SLanguage l -> Plutus l)]
scripts =
              [ (String
"redeemerSameAsDatum", forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum)
              , (String
"purposeIsWellformedWithDatum", forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedWithDatum)
              , (String
"datumIsWellformed", forall (l :: Language). SLanguage l -> Plutus l
datumIsWellformed)
              , (String
"inputsOutputsAreNotEmptyWithDatum", forall (l :: Language). SLanguage l -> Plutus l
inputsOutputsAreNotEmptyWithDatum)
              ]

        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Spending scripts with a Datum" forall a b. (a -> b) -> a -> b
$ do
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, SLanguage l -> Plutus l)]
scripts forall a b. (a -> b) -> a -> b
$ \(String
name, SLanguage l -> Plutus l
script) -> do
            forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
name forall a b. (a -> b) -> a -> b
$ do
              let sHash :: ScriptHash (EraCrypto era)
sHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript (SLanguage l -> Plutus l
script SLanguage l
slang)
              TxIn (EraCrypto era)
txIn0 <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
sHash
              forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ String
"Submit a transaction that consumes the script output" forall a b. (a -> b) -> a -> b
$
                forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                  forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL
                    forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton TxIn (EraCrypto era)
txIn0
              forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Valid transaction marked as invalid" forall a b. (a -> b) -> a -> b
$ do
          let tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> IsValid
IsValid Bool
False
          forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch (Bool -> IsValid
IsValid Bool
False) TagMismatchDescription
PassedUnexpectedly)]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Invalid transaction marked as valid" forall a b. (a -> b) -> a -> b
$ do
          TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage l
slang
          forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ forall a b. (a -> b) -> a -> b
$ forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
txIn]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Invalid plutus script fails in phase 2" forall a b. (a -> b) -> a -> b
$ do
          TxIn (EraCrypto era)
txIn0 <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
redeemerSameAsDatumHash
          ExUnits
exUnits <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
ppMaxTxExUnitsL
          forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ String
"Submitting consuming transaction" forall a b. (a -> b) -> a -> b
$
            forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton TxIn (EraCrypto era)
txIn0
              forall a b. a -> (a -> b) -> b
& forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> IsValid
IsValid Bool
False
              forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers
                  ( forall k a. k -> a -> Map k a
Map.singleton
                      (forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (TxIn (EraCrypto era)) -> PlutusPurpose f era
mkSpendingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. ix -> AsIx ix it
AsIx Word32
0)
                      (forall era. Era era => Data -> Data era
Data forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
32, ExUnits
exUnits)
                  )

        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Scripts pass in phase 2" forall a b. (a -> b) -> a -> b
$ do
          let scripts' :: [(String, SLanguage l -> Plutus l)]
scripts' = forall a. Int -> [a] -> [a]
drop Int
1 [(String, SLanguage l -> Plutus l)]
scripts
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, SLanguage l -> Plutus l)]
scripts' forall a b. (a -> b) -> a -> b
$ \(String
name, SLanguage l -> Plutus l
script) -> do
            forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
name forall a b. (a -> b) -> a -> b
$ do
              let sHash :: ScriptHash (EraCrypto era)
sHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript (SLanguage l -> Plutus l
script SLanguage l
slang)
              TxIn (EraCrypto era)
txIn0 <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
sHash
              forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ String
"Submitting consuming transaction" forall a b. (a -> b) -> a -> b
$
                forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                  forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton TxIn (EraCrypto era)
txIn0

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"No cost model" forall a b. (a -> b) -> a -> b
$ do
          TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
alwaysSucceedsWithDatumHash
          let tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn (EraCrypto era)
txIn]
          forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => a
mempty
          forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
            Tx era
tx
            [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [forall era. Language -> CollectError era
NoCostModel Language
lang])]