{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

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

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Babbage.Tx (ScriptIntegrity (..), getLanguageView)
import Cardano.Ledger.BaseTypes (
  Inject (..),
  Mismatch (..),
  Network (..),
  StrictMaybe (..),
  TxIx (..),
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core (
  AlonzoEraTxBody (..),
  AlonzoEraTxWits (..),
  CoinPerByte (..),
  EraIndependentScriptIntegrity,
  EraTx (..),
  EraTxBody (..),
  EraTxOut (..),
  EraTxWits (..),
  InjectRuleFailure (..),
  SafeHash,
  SafeToHash (..),
  TxLevel (..),
  ppCoinsPerUTxOByteL,
  txIdTx,
 )
import Cardano.Ledger.Conway.Rules (ConwayUtxowPredFailure (..))
import Cardano.Ledger.Credential (Credential (..), StakeReference)
import Cardano.Ledger.Plutus (Language (..), SLanguage (..), hashPlutusScript)
import Cardano.Ledger.TxIn (TxIn (..))
import Lens.Micro ((&), (.~), (^.))
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsWithDatum)

spec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec = do
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Fails with PPViewHashesDontMatch before PV 11" (ImpTestM era () -> SpecM (ImpInit (LedgerSpec era)) ())
-> (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era ()
-> SpecM (ImpInit (LedgerSpec era)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtMost @10 (ImpTestM era () -> SpecM (ImpInit (LedgerSpec era)) ())
-> ImpTestM era () -> SpecM (ImpInit (LedgerSpec era)) ()
forall a b. (a -> b) -> a -> b
$ do
    fixedTx <- Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupTx (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era) -> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpTestM era (Tx TopTx era)
forall era. ConwayEraImp era => ImpTestM era (Tx TopTx era)
setupBadPPViewHashTx
    badScriptIntegrityHash <- arbitrary
    tx <- substituteIntegrityHashAndFixWits badScriptIntegrityHash fixedTx
    scriptIntegrityHash <- computeScriptIntegrityHash tx
    impAnn "Submit a transaction with an invalid script integrity hash"
      . withNoFixup
      $ submitFailingTx
        tx
        [ injectFailure . PPViewHashesDontMatch $
            Mismatch
              { mismatchSupplied = badScriptIntegrityHash
              , mismatchExpected = scriptIntegrityHash
              }
        ]
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Fails with PPViewHashesDontMatchInformative after PV 11" (ImpTestM era () -> SpecM (ImpInit (LedgerSpec era)) ())
-> (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era ()
-> SpecM (ImpInit (LedgerSpec era)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtLeast @11 (ImpTestM era () -> SpecM (ImpInit (LedgerSpec era)) ())
-> ImpTestM era () -> SpecM (ImpInit (LedgerSpec era)) ()
forall a b. (a -> b) -> a -> b
$ do
    fixedTx <- Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupTx (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era) -> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpTestM era (Tx TopTx era)
forall era. ConwayEraImp era => ImpTestM era (Tx TopTx era)
setupBadPPViewHashTx
    pp <- getsPParams id
    badScriptIntegrityHash <- arbitrary
    let
      langView = [PParams era -> Language -> LangDepView
forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams era
pp Language
PlutusV2]
      scriptIntegrity = forall era.
Redeemers era
-> TxDats era -> Set LangDepView -> ScriptIntegrity era
ScriptIntegrity @era Redeemers era
redeemers TxDats era
dats Set LangDepView
langView
      redeemers = Tx TopTx era
fixedTx Tx TopTx era
-> Getting (Redeemers era) (Tx TopTx era) (Redeemers era)
-> Redeemers era
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Redeemers era) (TxWits era))
-> Tx TopTx era -> Const (Redeemers era) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Const (Redeemers era) (TxWits era))
 -> Tx TopTx era -> Const (Redeemers era) (Tx TopTx era))
-> ((Redeemers era -> Const (Redeemers era) (Redeemers era))
    -> TxWits era -> Const (Redeemers era) (TxWits era))
-> Getting (Redeemers era) (Tx TopTx era) (Redeemers era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Const (Redeemers era) (Redeemers era))
-> TxWits era -> Const (Redeemers era) (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
      dats = Tx TopTx era
fixedTx Tx TopTx era
-> Getting (TxDats era) (Tx TopTx era) (TxDats era) -> TxDats era
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (TxDats era) (TxWits era))
-> Tx TopTx era -> Const (TxDats era) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Const (TxDats era) (TxWits era))
 -> Tx TopTx era -> Const (TxDats era) (Tx TopTx era))
-> ((TxDats era -> Const (TxDats era) (TxDats era))
    -> TxWits era -> Const (TxDats era) (TxWits era))
-> Getting (TxDats era) (Tx TopTx era) (TxDats era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxDats era -> Const (TxDats era) (TxDats era))
-> TxWits era -> Const (TxDats era) (TxWits era)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits era) (TxDats era)
datsTxWitsL
    tx <- substituteIntegrityHashAndFixWits badScriptIntegrityHash fixedTx
    scriptIntegrityHash <- computeScriptIntegrityHash tx
    let
      mismatch =
        Mismatch
          { mismatchSupplied :: StrictMaybe (SafeHash EraIndependentScriptIntegrity)
mismatchSupplied = StrictMaybe (SafeHash EraIndependentScriptIntegrity)
badScriptIntegrityHash
          , mismatchExpected :: StrictMaybe (SafeHash EraIndependentScriptIntegrity)
mismatchExpected = StrictMaybe (SafeHash EraIndependentScriptIntegrity)
scriptIntegrityHash
          }
    impAnn "Submit a transaction with an invalid script integrity hash"
      . withNoFixup
      $ submitFailingTx
        tx
        [ injectFailure $ ScriptIntegrityHashMismatch mismatch (SJust $ originalBytes scriptIntegrity)
        ]

setupBadPPViewHashTx ::
  forall era.
  ConwayEraImp era =>
  ImpTestM era (Tx TopTx era)
setupBadPPViewHashTx :: forall era. ConwayEraImp era => ImpTestM era (Tx TopTx era)
setupBadPPViewHashTx = do
  (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (CoinPerByte -> Identity CoinPerByte)
-> PParams era -> Identity (PParams era)
forall era.
BabbageEraPParams era =>
Lens' (PParams era) CoinPerByte
Lens' (PParams era) CoinPerByte
ppCoinsPerUTxOByteL ((CoinPerByte -> Identity CoinPerByte)
 -> PParams era -> Identity (PParams era))
-> CoinPerByte -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> CoinPerByte
CoinPerByte (Integer -> Coin
Coin Integer
1)
  someKeyHash <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @StakeReference
  let scriptTxOut =
        Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
          ( Network -> Credential Payment -> StakeReference -> Addr
Addr
              Network
Testnet
              (ScriptHash -> Credential Payment
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV2 -> ScriptHash) -> Plutus 'PlutusV2 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage 'PlutusV2
SPlutusV2))
              StakeReference
someKeyHash
          )
          (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000)
  scriptTxIn <-
    impAnn "Submit a transaction that has a script output"
      . submitTx
      $ mkBasicTx mkBasicTxBody
        & bodyTxL . outputsTxBodyL .~ [scriptTxOut]
  pure $
    mkBasicTx mkBasicTxBody
      & bodyTxL . inputsTxBodyL .~ [TxIn (txIdTx scriptTxIn) (TxIx 0)]

substituteIntegrityHashAndFixWits ::
  forall era.
  ConwayEraImp era =>
  StrictMaybe (SafeHash EraIndependentScriptIntegrity) ->
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
substituteIntegrityHashAndFixWits :: forall era.
ConwayEraImp era =>
StrictMaybe (SafeHash EraIndependentScriptIntegrity)
-> Tx TopTx era -> ImpTestM era (Tx TopTx era)
substituteIntegrityHashAndFixWits StrictMaybe (SafeHash EraIndependentScriptIntegrity)
hash Tx TopTx era
tx =
  let txWithNewHash :: Tx TopTx era
txWithNewHash =
        Tx TopTx era
tx
          Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictMaybe (SafeHash EraIndependentScriptIntegrity)
     -> Identity (StrictMaybe (SafeHash EraIndependentScriptIntegrity)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictMaybe (SafeHash EraIndependentScriptIntegrity)
    -> Identity (StrictMaybe (SafeHash EraIndependentScriptIntegrity)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (SafeHash EraIndependentScriptIntegrity)
 -> Identity (StrictMaybe (SafeHash EraIndependentScriptIntegrity)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens'
  (TxBody l era)
  (StrictMaybe (SafeHash EraIndependentScriptIntegrity))
forall (l :: TxLevel).
Lens'
  (TxBody l era)
  (StrictMaybe (SafeHash EraIndependentScriptIntegrity))
scriptIntegrityHashTxBodyL ((StrictMaybe (SafeHash EraIndependentScriptIntegrity)
  -> Identity (StrictMaybe (SafeHash EraIndependentScriptIntegrity)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictMaybe (SafeHash EraIndependentScriptIntegrity)
-> Tx TopTx era
-> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (SafeHash EraIndependentScriptIntegrity)
hash
          Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> TxWits era -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
forall era. EraTxWits era => TxWits era
mkBasicTxWits
   in Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupScriptWits Tx TopTx era
txWithNewHash
        ImpTestM era (Tx TopTx era)
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, AlonzoEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
fixupDatums
        ImpTestM era (Tx TopTx era)
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupRedeemers
        ImpTestM era (Tx TopTx era)
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
updateAddrTxWits