{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Babbage.Imp.UtxowSpec (spec) where

import Cardano.Ledger.Alonzo.Plutus.Context (ContextError)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..))
import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure (..), AlonzoUtxowPredFailure (..))
import Cardano.Ledger.Alonzo.Scripts
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..))
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.Rules (BabbageUtxowPredFailure (..))
import Cardano.Ledger.Babbage.TxInfo (BabbageContextError (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Plutus
import Cardano.Ledger.Shelley.Scripts (pattern RequireAnyOf)
import Cardano.Ledger.TxIn (mkTxInPartial)
import Data.Either (isRight)
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Alonzo.Arbitrary (mkPlutusScript')
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (redeemerSameAsDatum)

spec ::
  forall era.
  ( AlonzoEraImp era
  , InjectRuleFailure "LEDGER" BabbageUtxowPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
  , Inject (BabbageContextError era) (ContextError era)
  , BabbageEraTxBody era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era,
 InjectRuleFailure "LEDGER" BabbageUtxowPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era,
 Inject (BabbageContextError era) (ContextError era),
 BabbageEraTxBody era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXOW" forall a b. (a -> b) -> a -> b
$ do
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MalformedScriptWitnesses" forall a b. (a -> b) -> a -> b
$ do
    let scriptHash :: ScriptHash
scriptHash = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (forall (l :: Language). Plutus l
malformedPlutus @'PlutusV2)
    TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
    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)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
    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 a b. (a -> b) -> a -> b
$
          forall era. Set ScriptHash -> BabbageUtxowPredFailure era
MalformedScriptWitnesses [ScriptHash
scriptHash]
      ]

  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MalformedReferenceScripts" forall a b. (a -> b) -> a -> b
$ do
    let script :: Script era
script = forall era (l :: Language).
(HasCallStack, AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Script era
mkPlutusScript' @era (forall (l :: Language). Plutus l
malformedPlutus @'PlutusV2)
    let scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript Script era
script
    Addr
addr <- forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
    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) (StrictSeq (TxOut era))
outputsTxBodyL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Script era
script
                 ]
    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 a b. (a -> b) -> a -> b
$
          forall era. Set ScriptHash -> BabbageUtxowPredFailure era
MalformedReferenceScripts [ScriptHash
scriptHash]
      ]

  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ExtraRedeemers/RedeemerPointerPointsToNothing" forall a b. (a -> b) -> a -> b
$
    -- There is ExtraRedeemers test for PlutusV1 in Alonzo, thus we start with PlutusV2
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Language
PlutusV2 .. forall era. AlonzoEraScript era => Language
eraMaxLanguage @era] :: [Language]) forall a b. (a -> b) -> a -> b
$ \Language
lang -> do
      forall t. HasCallStack => String -> ImpM t ()
logString forall a b. (a -> b) -> a -> b
$ String
"Testing for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Language
lang
      let scriptHash :: ScriptHash
scriptHash = forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum)
      TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
      let prp :: PlutusPurpose AsIx era
prp = forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 PolicyID -> PlutusPurpose f era
MintingPurpose (forall ix it. ix -> AsIx ix it
AsIx Word32
2)
      Data era
dt <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      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)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
              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 a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers [(PlutusPurpose AsIx era
prp, (Data era
dt, Natural -> Natural -> ExUnits
ExUnits Natural
0 Natural
0))]
      let submit :: ImpM (LedgerSpec era) ()
submit =
            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 a b. (a -> b) -> a -> b
$ forall era. [PlutusPurpose AsIx era] -> AlonzoUtxowPredFailure era
ExtraRedeemers [PlutusPurpose AsIx era
prp]
              , forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
                  forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [forall era. ContextError era -> CollectError era
BadTranslation (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ forall era. PlutusPurpose AsIx era -> BabbageContextError era
RedeemerPointerPointsToNothing PlutusPurpose AsIx era
prp)]
              ]
      if forall era. Era era => Version
eraProtVerLow @era forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9
        then -- PlutusPurpose serialization was fixed in Conway
          forall era a. ImpTestM era a -> ImpTestM era a
withCborRoundTripFailures ImpM (LedgerSpec era) ()
submit
        else ImpM (LedgerSpec era) ()
submit

  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"P1 reference scripts must be witnessed" forall a b. (a -> b) -> a -> b
$ do
    (KeyHash 'Payment
_, Addr
addr) <- forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m (KeyHash 'Payment, Addr)
freshKeyAddr
    let
      timelock :: Script era
timelock = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript @era forall a b. (a -> b) -> a -> b
$ forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf []
      txOut :: TxOut era
txOut =
        forall era. EraTxOut era => Addr -> Coin -> TxOut era
mkCoinTxOut Addr
addr (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
15_000_000)
          forall a b. a -> (a -> b) -> b
& forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Script era
timelock
    Tx era
tx0 <-
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx 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) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton TxOut era
txOut
    let
      txIn :: TxIn
txIn = HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTx era => Tx era -> TxId
txIdTx Tx era
tx0) Integer
0
      tx1 :: Tx era
tx1 =
        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. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton TxIn
txIn
    Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
res <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx1
    Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
  (Tx era)
res forall (m :: * -> *) a.
(HasCallStack, MonadIO m, ToExpr a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfyExpr` forall a b. Either a b -> Bool
isRight