{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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.Plutus
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
  , BabbageEraTxOut era
  , InjectRuleFailure "LEDGER" BabbageUtxowPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
  , Inject (BabbageContextError era) (ContextError era)
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era, BabbageEraTxOut era,
 InjectRuleFailure "LEDGER" BabbageUtxowPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era,
 Inject (BabbageContextError era) (ContextError 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 (EraCrypto era)
scriptHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript (forall (l :: Language). Plutus l
malformedPlutus @'PlutusV2)
    TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
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 (EraCrypto era)) -> BabbageUtxowPredFailure era
MalformedScriptWitnesses [ScriptHash (EraCrypto era)
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 (EraCrypto era)
scriptHash = forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript Script era
script
    Addr (EraCrypto era)
addr <- forall s c (m :: * -> *) g.
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (Addr c)
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 (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr (EraCrypto era)
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 (EraCrypto era)) -> BabbageUtxowPredFailure era
MalformedReferenceScripts [ScriptHash (EraCrypto era)
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 (EraCrypto era)
scriptHash = forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum)
      TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
scriptHash
      let prp :: PlutusPurpose AsIx era
prp = forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (PolicyID (EraCrypto era)) -> 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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
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 a b. (a -> b) -> a -> b
$
              [ 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