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

module Test.Cardano.Ledger.Dijkstra.Imp.SubUtxowSpec (spec) where

import Cardano.Ledger.Address (bootstrapKeyHash)
import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..))
import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
import Cardano.Ledger.Alonzo.TxWits (unRedeemersL, unTxDatsL)
import Cardano.Ledger.BaseTypes (Mismatch (..), SlotNo (..), StrictMaybe (..))
import Cardano.Ledger.Conway.Governance (
  GovAction (..),
  GovActionId,
  Vote (..),
  Voter (..),
  VotingProcedure (..),
  VotingProcedures (..),
 )
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), StakeReference (..), credKeyHashWitness)
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Rules (DijkstraSubUtxowPredFailure (..))
import Cardano.Ledger.Keys (asWitness, witVKeyHash)
import Cardano.Ledger.Plutus (
  Data (..),
  ExUnits (..),
  Language (..),
  SLanguage (..),
  hashData,
  hashPlutusScript,
  plutusBinary,
  withSLanguage,
 )
import Cardano.Ledger.Plutus.Language (asSLanguage)
import Cardano.Ledger.Shelley.Scripts (pattern RequireAllOf)
import Cardano.Ledger.State (StakePoolParams (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.OMap.Strict as OMap
import Data.Sequence.Strict (StrictSeq ((:<|)))
import qualified Data.Set as Set
import qualified Data.Set.NonEmpty as NES
import Lens.Micro ((%~), (&), (.~), (^.))
import qualified PlutusLedgerApi.Common as P
import Test.Cardano.Ledger.Core.KeyPair (mkWitnessesVKey)
import Test.Cardano.Ledger.Core.Utils (txInAt)
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum, redeemerSameAsDatum)

spec :: forall era. DijkstraEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
DijkstraEraImp era =>
SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SUBUTXOW" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  -- TODO: `SubUtxoFailure`, which embeds the SUBUTXO rule's failures,
  -- has no test here, and the SUBUTXO rule has no spec of its own, so
  -- nothing exercises the embedding.
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SubInvalidWitnessesUTXOW" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    keyHash <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @Payment
    keyPair <- getKeyPair $ asWitness keyHash
    txIn <- sendCoinTo (mkAddr keyHash StakeRefNull) mempty
    staleBodyHash <- arbitrary
    let subTx :: Tx SubTx era
        subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]
        plantStaleWitness =
          Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> Tx l era)
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxWits era -> Identity (TxWits era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (Tx l era))
-> ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
    -> TxWits era -> Identity (TxWits era))
-> (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey Witness))
Lens' (TxWits era) (Set (WitVKey Witness))
addrTxWitsL ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
 -> Tx l era -> Identity (Tx l era))
-> Set (WitVKey Witness) -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SafeHash EraIndependentTxBody
-> [KeyPair Witness] -> Set (WitVKey Witness)
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey Witness)
mkWitnessesVKey SafeHash EraIndependentTxBody
staleBodyHash [Item [KeyPair Witness]
KeyPair Witness
keyPair])
    withPostFixupSubTxs plantStaleWitness $
      submitFailingTx
        (mkTopTxWithSubTxs [subTx])
        [injectFailure . SubInvalidWitnessesUTXOW @era $ pure (vKey keyPair)]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubMissingVKeyWitnessesUTXOW" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    let withheldWitnessFails :: ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
-> ImpM (LedgerSpec era) ()
withheldWitnessFails ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
mkSubTx = do
          (subTx, keyHash) <- ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
mkSubTx
          let dropWitness =
                Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                  (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> Tx l era)
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxWits era -> Identity (TxWits era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (Tx l era))
-> ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
    -> TxWits era -> Identity (TxWits era))
-> (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey Witness))
Lens' (TxWits era) (Set (WitVKey Witness))
addrTxWitsL ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
 -> Tx l era -> Identity (Tx l era))
-> (Set (WitVKey Witness) -> Set (WitVKey Witness))
-> Tx l era
-> Tx l era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (WitVKey Witness -> Bool)
-> Set (WitVKey Witness) -> Set (WitVKey Witness)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((KeyHash Witness -> KeyHash Witness -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyHash Witness
keyHash) (KeyHash Witness -> Bool)
-> (WitVKey Witness -> KeyHash Witness) -> WitVKey Witness -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WitVKey Witness -> KeyHash Witness
forall (kr :: KeyRole). WitVKey kr -> KeyHash Witness
witVKeyHash))
                  (Tx l era -> Tx l era)
-> (Tx l era -> Tx l era) -> Tx l era -> Tx l era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxWits era -> Identity (TxWits era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (Tx l era))
-> ((Set BootstrapWitness -> Identity (Set BootstrapWitness))
    -> TxWits era -> Identity (TxWits era))
-> (Set BootstrapWitness -> Identity (Set BootstrapWitness))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set BootstrapWitness -> Identity (Set BootstrapWitness))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set BootstrapWitness)
Lens' (TxWits era) (Set BootstrapWitness)
bootAddrTxWitsL ((Set BootstrapWitness -> Identity (Set BootstrapWitness))
 -> Tx l era -> Identity (Tx l era))
-> Set BootstrapWitness -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set BootstrapWitness
forall a. Monoid a => a
mempty)
          withPostFixupSubTxs dropWitness $
            submitFailingTx
              (mkTopTxWithSubTxs [subTx])
              [injectFailure . SubMissingVKeyWitnessesUTXOW @era $ NES.singleton keyHash]

    [(String, ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness))]
-> ((String, ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness))
    -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era.
DijkstraEraImp era =>
[(String, ImpTestM era (Tx SubTx era, KeyHash Witness))]
missingVKeyWitnessSources @era) (((String, ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness))
  -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> ((String, ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness))
    -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \(String
sourceName, ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
mkSubTx) ->
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
sourceName (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
-> ImpM (LedgerSpec era) ()
withheldWitnessFails ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
mkSubTx

    -- The conformance translation has no representation for bootstrap addresses.
    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"spending a bootstrap address input" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
      ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
-> ImpM (LedgerSpec era) ()
withheldWitnessFails (ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
 -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
        bootAddr <- ImpM (LedgerSpec era) BootstrapAddress
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m BootstrapAddress
freshBootstapAddress
        txIn <- sendCoinTo (AddrBootstrap bootAddr) mempty
        pure
          ( mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn]
          , asWitness $ bootstrapKeyHash bootAddr
          )

    -- The spec accepts a pool registration whose owner witness is missing.
    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"registering a stake pool with an owner" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
      ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
-> ImpM (LedgerSpec era) ()
withheldWitnessFails (ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
 -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx SubTx era, KeyHash Witness)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
        poolKeyHash <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
        ownerKeyHash <- freshKeyHash
        accountAddress <- registerStakeCredential . KeyHashObj =<< freshKeyHash
        poolParams <- freshPoolParams poolKeyHash accountAddress
        pure
          ( mkBasicTx $
              mkBasicTxBody
                & certsTxBodyL
                  .~ [RegPoolTxCert poolParams {sppOwners = Set.singleton ownerKeyHash}]
          , asWitness ownerKeyHash
          )

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubScriptWitnessNotValidatingUTXOW" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    let failingScriptFails :: ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash)
-> ImpM (LedgerSpec era) ()
failingScriptFails ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash)
mkSubTx = do
          (subTx, scriptHash) <- ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash)
mkSubTx
          submitFailingTx
            (mkTopTxWithSubTxs [subTx])
            [injectFailure . SubScriptWitnessNotValidatingUTXOW @era $ NES.singleton scriptHash]

    [(String, ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash))]
-> ((String, ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash))
    -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era.
DijkstraEraImp era =>
[(String, ImpTestM era (Tx SubTx era, ScriptHash))]
failingNativeScriptPurposes @era) (((String, ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash))
  -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> ((String, ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash))
    -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \(String
purposeName, ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash)
mkSubTx) ->
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
purposeName (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash)
-> ImpM (LedgerSpec era) ()
failingScriptFails ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash)
mkSubTx

    -- The spec attributes a failing minting script to UTXOW, not SUBUTXOW.
    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"minting" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
      ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash)
-> ImpM (LedgerSpec era) ()
failingScriptFails (ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash)
 -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx SubTx era, ScriptHash)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
        scriptHash <- ImpTestM era ScriptHash
forall era. DijkstraEraImp era => ImpTestM era ScriptHash
unsatisfiableTimeLock
        subTx <- mkTokenMintingTx scriptHash
        pure (subTx, scriptHash)

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SubMissingTxMetadata" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    auxData <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @(TxAuxData era)
    let auxDataHash = TxAuxData era -> TxAuxDataHash
forall era. EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData TxAuxData era
AlonzoTxAuxData era
auxData
        subTx :: Tx SubTx era
        subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe TxAuxDataHash -> Identity (StrictMaybe TxAuxDataHash))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL ((StrictMaybe TxAuxDataHash
  -> Identity (StrictMaybe TxAuxDataHash))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictMaybe TxAuxDataHash
-> TxBody SubTx era
-> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxAuxDataHash -> StrictMaybe TxAuxDataHash
forall a. a -> StrictMaybe a
SJust TxAuxDataHash
auxDataHash
    submitFailingTx
      (mkTopTxWithSubTxs [subTx])
      [injectFailure $ SubMissingTxMetadata @era auxDataHash]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SubConflictingMetadataHash" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    auxData <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @(TxAuxData era)
    wrongAuxDataHash <- arbitrary @TxAuxDataHash
    let subTx :: Tx SubTx era
        subTx =
          TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
            Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx 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 SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((StrictMaybe TxAuxDataHash
     -> Identity (StrictMaybe TxAuxDataHash))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (StrictMaybe TxAuxDataHash
    -> Identity (StrictMaybe TxAuxDataHash))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash -> Identity (StrictMaybe TxAuxDataHash))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL ((StrictMaybe TxAuxDataHash
  -> Identity (StrictMaybe TxAuxDataHash))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> StrictMaybe TxAuxDataHash -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxAuxDataHash -> StrictMaybe TxAuxDataHash
forall a. a -> StrictMaybe a
SJust TxAuxDataHash
wrongAuxDataHash
            Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (TxAuxData era)))
-> Tx SubTx era -> Identity (Tx SubTx era)
(StrictMaybe (AlonzoTxAuxData era)
 -> Identity (StrictMaybe (AlonzoTxAuxData era)))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
auxDataTxL ((StrictMaybe (AlonzoTxAuxData era)
  -> Identity (StrictMaybe (AlonzoTxAuxData era)))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> StrictMaybe (AlonzoTxAuxData era)
-> Tx SubTx era
-> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AlonzoTxAuxData era -> StrictMaybe (AlonzoTxAuxData era)
forall a. a -> StrictMaybe a
SJust AlonzoTxAuxData era
auxData
    submitFailingTx
      (mkTopTxWithSubTxs [subTx])
      [ injectFailure . SubConflictingMetadataHash @era $
          Mismatch
            { mismatchSupplied = wrongAuxDataHash
            , mismatchExpected = hashTxAuxData auxData
            }
      ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SubMissingTxBodyMetadataHash" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    auxData <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @(TxAuxData era)
    let subTx :: Tx SubTx era
        subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (TxAuxData era)))
-> Tx SubTx era -> Identity (Tx SubTx era)
(StrictMaybe (AlonzoTxAuxData era)
 -> Identity (StrictMaybe (AlonzoTxAuxData era)))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
auxDataTxL ((StrictMaybe (AlonzoTxAuxData era)
  -> Identity (StrictMaybe (AlonzoTxAuxData era)))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> StrictMaybe (AlonzoTxAuxData era)
-> Tx SubTx era
-> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AlonzoTxAuxData era -> StrictMaybe (AlonzoTxAuxData era)
forall a. a -> StrictMaybe a
SJust AlonzoTxAuxData era
auxData
        dropAuxDataHash =
          Tx l era -> ImpTestM era (Tx l era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
rederiveAddrTxWits (Tx l era -> ImpTestM era (Tx l era))
-> (Tx l era -> Tx l era) -> Tx l era -> ImpTestM era (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((StrictMaybe TxAuxDataHash
     -> Identity (StrictMaybe TxAuxDataHash))
    -> TxBody l era -> Identity (TxBody l era))
-> (StrictMaybe TxAuxDataHash
    -> Identity (StrictMaybe TxAuxDataHash))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash -> Identity (StrictMaybe TxAuxDataHash))
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL ((StrictMaybe TxAuxDataHash
  -> Identity (StrictMaybe TxAuxDataHash))
 -> Tx l era -> Identity (Tx l era))
-> StrictMaybe TxAuxDataHash -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe TxAuxDataHash
forall a. StrictMaybe a
SNothing)
    withPostFixupSubTxs dropAuxDataHash $
      submitFailingTx
        (mkTopTxWithSubTxs [subTx])
        [injectFailure . SubMissingTxBodyMetadataHash @era $ hashTxAuxData auxData]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubExtraRedeemers" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"for a native script, which takes no redeemer" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      scriptHash <- NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (NativeScript era -> ImpTestM era ScriptHash)
-> NativeScript era -> ImpTestM era ScriptHash
forall a b. (a -> b) -> a -> b
$ StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf []
      txIn <- produceScript scriptHash
      collateralInput <- makeCollateralInput
      redeemerData <- arbitrary
      let extraPurpose = AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
forall (f :: * -> * -> *). f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose (AsIx Word32 TxIn -> PlutusPurpose AsIx era)
-> AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall a b. (a -> b) -> a -> b
$ Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0
          subTx :: Tx SubTx era
          subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]
          topTx =
            [Tx SubTx era] -> Tx TopTx era
forall era. DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs [Item [Tx SubTx era]
Tx SubTx era
subTx]
              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))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody TopTx era) (Set TxIn)
Lens' (TxBody TopTx era) (Set TxIn)
collateralInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Set TxIn -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
collateralInput]
          addExtraRedeemer =
            (Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupPPHash (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
rederiveAddrTxWits)
              (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> Tx l era)
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( (TxWits era -> Identity (TxWits era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (Tx l era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era -> Identity (Redeemers era)
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
unRedeemersL
                    ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
 -> Tx l era -> Identity (Tx l era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Tx l era
-> Tx l era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PlutusPurpose AsIx era
extraPurpose (Data era
redeemerData, Nat -> Nat -> ExUnits
ExUnits Nat
0 Nat
0)
                )
      withPostFixupSubTxs addExtraRedeemer $
        submitFailingTx topTx [injectFailure $ SubExtraRedeemers @era [extraPurpose]]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"at an index that points at no item" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      keyHash <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @Payment
      txIn <- sendCoinTo (mkAddr keyHash StakeRefNull) mempty
      collateralInput <- makeCollateralInput
      redeemerData <- arbitrary
      let extraPurpose = AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
forall (f :: * -> * -> *). f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose (AsIx Word32 TxIn -> PlutusPurpose AsIx era)
-> AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall a b. (a -> b) -> a -> b
$ Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
99
          subTx :: Tx SubTx era
          subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]
          topTx =
            [Tx SubTx era] -> Tx TopTx era
forall era. DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs [Item [Tx SubTx era]
Tx SubTx era
subTx]
              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))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody TopTx era) (Set TxIn)
Lens' (TxBody TopTx era) (Set TxIn)
collateralInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Set TxIn -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
collateralInput]
          addExtraRedeemer =
            (Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupPPHash (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
rederiveAddrTxWits)
              (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> Tx l era)
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( (TxWits era -> Identity (TxWits era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (Tx l era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era -> Identity (Redeemers era)
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
unRedeemersL
                    ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
 -> Tx l era -> Identity (Tx l era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Tx l era
-> Tx l era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PlutusPurpose AsIx era
extraPurpose (Data era
redeemerData, Nat -> Nat -> ExUnits
ExUnits Nat
0 Nat
0)
                )
      withPostFixupSubTxs addExtraRedeemer $
        submitFailingTx topTx [injectFailure $ SubExtraRedeemers @era [extraPurpose]]

  -- `SubPPViewHashesDontMatch` is the other failure
  -- `checkScriptIntegrityHash` can raise. It is unreachable in
  -- Dijkstra: it is selected only below protocol version 11, and
  -- Dijkstra is pinned to 12.
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubScriptIntegrityHashMismatch" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"when no script requires an integrity hash" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      badHash <- ImpM (LedgerSpec era) ScriptIntegrityHash
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      let subTx :: Tx SubTx era
          subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
          supplyIntegrityHash =
            Tx l era -> ImpTestM era (Tx l era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
rederiveAddrTxWits (Tx l era -> ImpTestM era (Tx l era))
-> (Tx l era -> Tx l era) -> Tx l era -> ImpTestM era (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((StrictMaybe ScriptIntegrityHash
     -> Identity (StrictMaybe ScriptIntegrityHash))
    -> TxBody l era -> Identity (TxBody l era))
-> (StrictMaybe ScriptIntegrityHash
    -> Identity (StrictMaybe ScriptIntegrityHash))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptIntegrityHash
 -> Identity (StrictMaybe ScriptIntegrityHash))
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe ScriptIntegrityHash)
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL ((StrictMaybe ScriptIntegrityHash
  -> Identity (StrictMaybe ScriptIntegrityHash))
 -> Tx l era -> Identity (Tx l era))
-> StrictMaybe ScriptIntegrityHash -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash
forall a. a -> StrictMaybe a
SJust ScriptIntegrityHash
badHash)
      withPostFixupSubTxs supplyIntegrityHash $
        submitFailingTx
          (mkTopTxWithSubTxs [subTx])
          [ injectFailure $
              SubScriptIntegrityHashMismatch @era
                Mismatch {mismatchSupplied = SJust badHash, mismatchExpected = SNothing}
                SNothing
          ]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubMalformedGuardDatums" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
    [(String,
  ImpTestM
    era
    (Credential Guard,
     Map (Credential Guard) (StrictMaybe (Data era))))]
-> ((String,
     ImpTestM
       era
       (Credential Guard,
        Map (Credential Guard) (StrictMaybe (Data era))))
    -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era.
DijkstraEraImp era =>
[(String,
  ImpTestM
    era
    (Credential Guard,
     Map (Credential Guard) (StrictMaybe (Data era))))]
malformedGuardDatumCases @era) (((String,
   ImpTestM
     era
     (Credential Guard,
      Map (Credential Guard) (StrictMaybe (Data era))))
  -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> ((String,
     ImpTestM
       era
       (Credential Guard,
        Map (Credential Guard) (StrictMaybe (Data era))))
    -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \(String
caseName, ImpTestM
  era
  (Credential Guard, Map (Credential Guard) (StrictMaybe (Data era)))
mkGuard) ->
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
caseName (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        (guardCred, requiredGuards) <- ImpTestM
  era
  (Credential Guard, Map (Credential Guard) (StrictMaybe (Data era)))
mkGuard
        let subTx :: Tx SubTx era
            subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Map (Credential Guard) (StrictMaybe (Data era))
 -> Identity (Map (Credential Guard) (StrictMaybe (Data era))))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens'
  (TxBody l era) (Map (Credential Guard) (StrictMaybe (Data era)))
forall (l :: TxLevel).
Lens'
  (TxBody l era) (Map (Credential Guard) (StrictMaybe (Data era)))
requiredTopLevelGuardsL ((Map (Credential Guard) (StrictMaybe (Data era))
  -> Identity (Map (Credential Guard) (StrictMaybe (Data era))))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Map (Credential Guard) (StrictMaybe (Data era))
-> TxBody SubTx era
-> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (Credential Guard) (StrictMaybe (Data era))
requiredGuards
            topTx =
              [Tx SubTx era] -> Tx TopTx era
forall era. DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs [Item [Tx SubTx era]
Tx SubTx era
subTx]
                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))
-> ((OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) (OSet (Credential Guard))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (Credential Guard))
guardsTxBodyL ((OSet (Credential Guard) -> Identity (OSet (Credential Guard)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OSet (Credential Guard) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (Credential Guard))
Credential Guard
guardCred]
        submitFailingTx
          topTx
          [injectFailure . SubMalformedGuardDatums @era $ NES.singleton guardCred]

  -- The filter mirrors the rule: `getInputDataHashesTxBody` records
  -- an input as unspendable only when its spending script is below
  -- PlutusV3, since CIP-0069 made spending datums optional from V3 on.
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubUnspendableUTxONoDatumHash, for languages that require a spending datum" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
    [Language]
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Language -> Bool) -> [Language] -> [Language]
forall a. (a -> Bool) -> [a] -> [a]
filter (Language -> Language -> Bool
forall a. Ord a => a -> a -> Bool
< Language
PlutusV3) (forall era. AlonzoEraScript era => [Language]
eraLanguages @era)) ((Language -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \Language
lang ->
      Language
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang ((forall (l :: Language).
  PlutusLanguage l =>
  SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \SLanguage l
slang ->
        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (Language -> String
forall a. Show a => a -> String
show Language
lang) (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          let scriptHash :: ScriptHash
scriptHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
slang
          txIn <- String -> ImpTestM era TxIn -> ImpTestM era TxIn
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Produce a script output with no datum hash" (ImpTestM era TxIn -> ImpTestM era TxIn)
-> ImpTestM era TxIn -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ do
            let addr :: Addr
addr = ScriptHash -> StakeReference -> Addr
forall p s.
(MakeCredential p Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
scriptHash StakeReference
StakeRefNull
                tx :: Tx TopTx era
tx =
                  TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                    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))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxOut era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
forall a. Monoid a => a
mempty]
                resetTxOutDataHash :: Tx l era -> Tx l era
resetTxOutDataHash =
                  (TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody l era -> Identity (TxBody l era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL
                    ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx l era -> Identity (Tx l era))
-> (StrictSeq (TxOut era) -> StrictSeq (TxOut era))
-> Tx l era
-> Tx l era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ( \case
                           TxOut era
h :<| StrictSeq (TxOut era)
r -> (TxOut era
h TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
-> TxOut era -> Identity (TxOut era)
forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL ((StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe DataHash -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe DataHash
forall a. StrictMaybe a
SNothing) TxOut era -> StrictSeq (TxOut era) -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a -> StrictSeq a
:<| StrictSeq (TxOut era)
r
                           StrictSeq (TxOut era)
_ -> String -> StrictSeq (TxOut era)
forall a. HasCallStack => String -> a
error String
"Expected non-empty outputs"
                       )
            Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt Int
0
              (Tx TopTx era -> TxIn)
-> ImpM (LedgerSpec era) (Tx TopTx era) -> ImpTestM era TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall era a.
(Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
rederiveAddrTxWits (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> (Tx TopTx era -> Tx TopTx era)
-> Tx TopTx era
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx TopTx era -> Tx TopTx era
forall {l :: TxLevel}. Tx l era -> Tx l era
resetTxOutDataHash) (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
submitTx Tx TopTx era
tx)
          submitFailingTx
            (mkTopTxWithSubTxs [mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn]])
            [injectFailure . SubUnspendableUTxONoDatumHash @era $ NES.singleton txIn]

  [Language]
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era. AlonzoEraScript era => [Language]
eraLanguages @era) ((Language -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \Language
lang ->
    Language
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang ((forall (l :: Language).
  PlutusLanguage l =>
  SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \SLanguage l
slang ->
      String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (Language -> String
forall a. Show a => a -> String
show Language
lang) (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
        let redeemerSameAsDatumHash :: ScriptHash
redeemerSameAsDatumHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
slang
            fixupResetAddrWits :: Tx l era -> ImpM (LedgerSpec era) (Tx l era)
fixupResetAddrWits = Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupPPHash (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
rederiveAddrTxWits
            scriptSpendingSubTx :: TxIn -> Tx l era
scriptSpendingSubTx TxIn
txIn = TxBody l era -> Tx l era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody l era -> Tx l era) -> TxBody l era -> Tx l era
forall a b. (a -> b) -> a -> b
$ TxBody l era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody l era -> (TxBody l era -> TxBody l era) -> TxBody l era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody l era -> Identity (TxBody l era))
-> Set TxIn -> TxBody l era -> TxBody l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SubMissingRequiredDatums" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
redeemerSameAsDatumHash
          let missingDatum = forall era. Data era -> DataHash
hashData @era (Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
3))
          withPostFixupSubTxs (fixupResetAddrWits . (witsTxL . datsTxWitsL .~ mempty)) $
            submitFailingTx
              (mkTopTxWithSubTxs [scriptSpendingSubTx txIn])
              [injectFailure $ SubMissingRequiredDatums @era (NES.singleton missingDatum) []]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SubNotAllowedSupplementalDatums" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
redeemerSameAsDatumHash
          let extraDatum = Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
30)
              extraDatumHash = forall era. Data era -> DataHash
hashData @era Data era
extraDatum
              addExtraDatum =
                Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall {l :: TxLevel}. Tx l era -> ImpM (LedgerSpec era) (Tx l era)
fixupResetAddrWits
                  (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> Tx l era)
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( (TxWits era -> Identity (TxWits era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (Tx l era))
-> ((Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
    -> TxWits era -> Identity (TxWits era))
-> (Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxDats era -> Identity (TxDats era))
-> TxWits era -> Identity (TxWits era)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits era) (TxDats era)
datsTxWitsL ((TxDats era -> Identity (TxDats era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
    -> TxDats era -> Identity (TxDats era))
-> (Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
-> TxDats era -> Identity (TxDats era)
forall era. Era era => Lens' (TxDats era) (Map DataHash (Data era))
Lens' (TxDats era) (Map DataHash (Data era))
unTxDatsL
                        ((Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
 -> Tx l era -> Identity (Tx l era))
-> (Map DataHash (Data era) -> Map DataHash (Data era))
-> Tx l era
-> Tx l era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ DataHash
-> Data era -> Map DataHash (Data era) -> Map DataHash (Data era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert DataHash
extraDatumHash Data era
extraDatum
                    )
          withPostFixupSubTxs addExtraDatum $
            submitFailingTx
              (mkTopTxWithSubTxs [scriptSpendingSubTx txIn])
              [ injectFailure $
                  SubNotAllowedSupplementalDatums @era (NES.singleton extraDatumHash) []
              ]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SubMissingRedeemers" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
redeemerSameAsDatumHash
          let missingRedeemer = AsItem Word32 TxIn -> PlutusPurpose AsItem era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
forall (f :: * -> * -> *). f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose (AsItem Word32 TxIn -> PlutusPurpose AsItem era)
-> AsItem Word32 TxIn -> PlutusPurpose AsItem era
forall a b. (a -> b) -> a -> b
$ TxIn -> AsItem Word32 TxIn
forall ix it. it -> AsItem ix it
AsItem TxIn
txIn
          withPostFixupSubTxs (fixupResetAddrWits . (witsTxL . rdmrsTxWitsL .~ mempty)) $
            submitFailingTx
              (mkTopTxWithSubTxs [scriptSpendingSubTx txIn])
              [ injectFailure $
                  SubMissingRedeemers @era [(missingRedeemer, redeemerSameAsDatumHash)]
              ]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SubExtraRedeemers, alongside a needed redeemer" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
redeemerSameAsDatumHash
          redeemerData <- arbitrary
          let extraPurpose = AsIx Word32 PolicyID -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 PolicyID -> PlutusPurpose f era
forall (f :: * -> * -> *). f Word32 PolicyID -> PlutusPurpose f era
mkMintingPurpose (AsIx Word32 PolicyID -> PlutusPurpose AsIx era)
-> AsIx Word32 PolicyID -> PlutusPurpose AsIx era
forall a b. (a -> b) -> a -> b
$ Word32 -> AsIx Word32 PolicyID
forall ix it. ix -> AsIx ix it
AsIx Word32
2
              addExtraRedeemer =
                Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall {l :: TxLevel}. Tx l era -> ImpM (LedgerSpec era) (Tx l era)
fixupResetAddrWits
                  (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> Tx l era)
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( (TxWits era -> Identity (TxWits era))
-> Tx l era -> Identity (Tx l 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 l era -> Identity (Tx l era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era -> Identity (Redeemers era)
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
unRedeemersL
                        ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
 -> Tx l era -> Identity (Tx l era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Tx l era
-> Tx l era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PlutusPurpose AsIx era
extraPurpose (Data era
redeemerData, Nat -> Nat -> ExUnits
ExUnits Nat
0 Nat
0)
                    )
          withPostFixupSubTxs addExtraRedeemer $
            submitFailingTx
              (mkTopTxWithSubTxs [scriptSpendingSubTx txIn])
              [injectFailure $ SubExtraRedeemers @era [extraPurpose]]

        String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SubScriptIntegrityHashMismatch" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          let testHashMismatch :: StrictMaybe ScriptIntegrityHash -> ImpM (LedgerSpec era) ()
testHashMismatch StrictMaybe ScriptIntegrityHash
badHash = do
                txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
redeemerSameAsDatumHash
                let topTx = [Tx SubTx era] -> Tx TopTx era
forall era. DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs [TxIn -> Tx SubTx era
forall {era} {l :: TxLevel}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTx era, Typeable l) =>
TxIn -> Tx l era
scriptSpendingSubTx TxIn
txIn]
                fixedUpTx <- fixupTx topTx
                let fixedUpSubTxs = OMap TxId (Tx SubTx era) -> [Tx SubTx era]
forall k v. Ord k => OMap k v -> [v]
OMap.elems (OMap TxId (Tx SubTx era) -> [Tx SubTx era])
-> OMap TxId (Tx SubTx era) -> [Tx SubTx era]
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
fixedUpTx Tx TopTx era
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
-> OMap TxId (Tx SubTx era)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (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
  -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
 -> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era
    -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era)
 -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era
-> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL
                fixedUpSubTx <- case fixedUpSubTxs of
                  [Item [Tx SubTx era]
subTx] -> Tx SubTx era -> ImpTestM era (Tx SubTx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Item [Tx SubTx era]
Tx SubTx era
subTx
                  [Tx SubTx era]
_ -> String -> ImpTestM era (Tx SubTx era)
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure String
"Expected exactly one sub-transaction"
                let goodHash = Tx SubTx era
fixedUpSubTx Tx SubTx era
-> Getting
     (StrictMaybe ScriptIntegrityHash)
     (Tx SubTx era)
     (StrictMaybe ScriptIntegrityHash)
-> StrictMaybe ScriptIntegrityHash
forall s a. s -> Getting a s a -> a
^. (TxBody SubTx era
 -> Const (StrictMaybe ScriptIntegrityHash) (TxBody SubTx era))
-> Tx SubTx era
-> Const (StrictMaybe ScriptIntegrityHash) (Tx SubTx 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 SubTx era
  -> Const (StrictMaybe ScriptIntegrityHash) (TxBody SubTx era))
 -> Tx SubTx era
 -> Const (StrictMaybe ScriptIntegrityHash) (Tx SubTx era))
-> ((StrictMaybe ScriptIntegrityHash
     -> Const
          (StrictMaybe ScriptIntegrityHash)
          (StrictMaybe ScriptIntegrityHash))
    -> TxBody SubTx era
    -> Const (StrictMaybe ScriptIntegrityHash) (TxBody SubTx era))
-> Getting
     (StrictMaybe ScriptIntegrityHash)
     (Tx SubTx era)
     (StrictMaybe ScriptIntegrityHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptIntegrityHash
 -> Const
      (StrictMaybe ScriptIntegrityHash)
      (StrictMaybe ScriptIntegrityHash))
-> TxBody SubTx era
-> Const (StrictMaybe ScriptIntegrityHash) (TxBody SubTx era)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe ScriptIntegrityHash)
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL
                expectedIntegrity <- impComputeScriptIntegrity fixedUpSubTx
                badSubTx <-
                  rederiveAddrTxWits $
                    fixedUpSubTx & bodyTxL . scriptIntegrityHashTxBodyL .~ badHash
                badTopTx <-
                  rederiveAddrTxWits $
                    fixedUpTx & bodyTxL . subTransactionsTxBodyL .~ OMap.singleton badSubTx
                withNoFixup $
                  submitFailingTx
                    badTopTx
                    [ injectFailure $
                        SubScriptIntegrityHashMismatch @era
                          Mismatch {mismatchSupplied = badHash, mismatchExpected = goodHash}
                          (originalBytes <$> expectedIntegrity)
                    ]
          String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"the supplied hash is wrong" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ StrictMaybe ScriptIntegrityHash -> ImpM (LedgerSpec era) ()
testHashMismatch (StrictMaybe ScriptIntegrityHash -> ImpM (LedgerSpec era) ())
-> (ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash)
-> ScriptIntegrityHash
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash
forall a. a -> StrictMaybe a
SJust (ScriptIntegrityHash -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ScriptIntegrityHash
-> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) ScriptIntegrityHash
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
          String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"the supplied hash is missing" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ StrictMaybe ScriptIntegrityHash -> ImpM (LedgerSpec era) ()
testHashMismatch StrictMaybe ScriptIntegrityHash
forall a. StrictMaybe a
SNothing

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SubMalformedScriptWitnesses" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          let scriptHash :: ScriptHash
scriptHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l -> Plutus l
forall (l :: Language) (proxy :: Language -> *).
SLanguage l -> proxy l -> proxy l
asSLanguage SLanguage l
slang Plutus l
forall (l :: Language). Plutus l
malformedPlutus
          txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
          submitFailingTx
            (mkTopTxWithSubTxs [scriptSpendingSubTx txIn])
            [injectFailure . SubMalformedScriptWitnesses @era $ NES.singleton scriptHash]

        String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"SubMalformedReferenceScripts" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          script <- PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript (PlutusScript era -> Script era)
-> ImpM (LedgerSpec era) (PlutusScript era)
-> ImpM (LedgerSpec era) (Script era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Plutus l -> ImpM (LedgerSpec era) (PlutusScript era)
forall era (l :: Language) (m :: * -> *).
(AlonzoEraScript era, PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
forall (l :: Language) (m :: * -> *).
(PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
mkPlutusScript (SLanguage l -> Plutus l -> Plutus l
forall (l :: Language) (proxy :: Language -> *).
SLanguage l -> proxy l -> proxy l
asSLanguage SLanguage l
slang Plutus l
forall (l :: Language). Plutus l
malformedPlutus)
          addr <- freshKeyAddr_
          let subTx :: Tx SubTx era
              subTx =
                TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
                  TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                    TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL
                      ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxOut era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
forall a. Monoid a => a
mempty TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
-> TxOut era -> Identity (TxOut era)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL ((StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe (Script era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Script era -> StrictMaybe (Script era)
forall a. a -> StrictMaybe a
SJust Script era
script]
          submitFailingTx
            (mkTopTxWithSubTxs [subTx])
            [ injectFailure . SubMalformedReferenceScripts @era . NES.singleton $
                hashScript script
            ]

        String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"SubInvalidMetadata" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          let auxData :: TxAuxData era
              auxData :: TxAuxData era
auxData =
                TxAuxData era
forall era. EraTxAuxData era => TxAuxData era
mkBasicTxAuxData
                  TxAuxData era
-> (TxAuxData era -> AlonzoTxAuxData era) -> AlonzoTxAuxData era
forall a b. a -> (a -> b) -> b
& (Map Language (NonEmpty PlutusBinary)
 -> Identity (Map Language (NonEmpty PlutusBinary)))
-> TxAuxData era -> Identity (TxAuxData era)
(Map Language (NonEmpty PlutusBinary)
 -> Identity (Map Language (NonEmpty PlutusBinary)))
-> TxAuxData era -> Identity (AlonzoTxAuxData era)
forall era.
AlonzoEraTxAuxData era =>
Lens' (TxAuxData era) (Map Language (NonEmpty PlutusBinary))
Lens' (TxAuxData era) (Map Language (NonEmpty PlutusBinary))
plutusScriptsTxAuxDataL
                    ((Map Language (NonEmpty PlutusBinary)
  -> Identity (Map Language (NonEmpty PlutusBinary)))
 -> TxAuxData era -> Identity (AlonzoTxAuxData era))
-> Map Language (NonEmpty PlutusBinary)
-> TxAuxData era
-> AlonzoTxAuxData era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Language
-> NonEmpty PlutusBinary -> Map Language (NonEmpty PlutusBinary)
forall k a. k -> a -> Map k a
Map.singleton Language
lang (PlutusBinary -> NonEmpty PlutusBinary
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PlutusBinary -> NonEmpty PlutusBinary)
-> (Plutus l -> PlutusBinary) -> Plutus l -> NonEmpty PlutusBinary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plutus l -> PlutusBinary
forall (l :: Language). Plutus l -> PlutusBinary
plutusBinary (Plutus l -> NonEmpty PlutusBinary)
-> Plutus l -> NonEmpty PlutusBinary
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l -> Plutus l
forall (l :: Language) (proxy :: Language -> *).
SLanguage l -> proxy l -> proxy l
asSLanguage SLanguage l
slang Plutus l
forall (l :: Language). Plutus l
malformedPlutus)
              subTx :: Tx SubTx era
              subTx :: Tx SubTx era
subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (TxAuxData era)))
-> Tx SubTx era -> Identity (Tx SubTx era)
(StrictMaybe (AlonzoTxAuxData era)
 -> Identity (StrictMaybe (AlonzoTxAuxData era)))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
auxDataTxL ((StrictMaybe (AlonzoTxAuxData era)
  -> Identity (StrictMaybe (AlonzoTxAuxData era)))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> StrictMaybe (AlonzoTxAuxData era)
-> Tx SubTx era
-> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AlonzoTxAuxData era -> StrictMaybe (AlonzoTxAuxData era)
forall a. a -> StrictMaybe a
SJust TxAuxData era
AlonzoTxAuxData era
auxData
          Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
            ([Tx SubTx era] -> Tx TopTx era
forall era. DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs [Item [Tx SubTx era]
Tx SubTx era
subTx])
            [DijkstraSubUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraSubUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> DijkstraSubUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ forall era. DijkstraSubUtxowPredFailure era
SubInvalidMetadata @era]

-- | Every distinct reason a sub-transaction requires a key witness,
-- paired with a sub-transaction that requires it and the key hash whose
-- witness is to be withheld.
missingVKeyWitnessSources ::
  forall era.
  DijkstraEraImp era =>
  [(String, ImpTestM era (Tx SubTx era, KeyHash Witness))]
missingVKeyWitnessSources :: forall era.
DijkstraEraImp era =>
[(String, ImpTestM era (Tx SubTx era, KeyHash Witness))]
missingVKeyWitnessSources =
  [
    ( String
"spending a key hash locked input"
    , do
        keyHash <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @Payment
        txIn <- sendCoinTo (mkAddr keyHash StakeRefNull) mempty
        pure (mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn], asWitness keyHash)
    )
  ,
    ( String
"unregistering a staking credential"
    , do
        keyHash <- ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
        void . registerStakeCredential $ KeyHashObj keyHash
        deposit <- getsPParams ppKeyDepositL
        pure
          ( mkBasicTx $
              mkBasicTxBody
                & certsTxBodyL .~ [UnRegDepositTxCert (KeyHashObj keyHash) deposit]
          , asWitness keyHash
          )
    )
  ,
    ( String
"withdrawing from an account"
    , do
        keyHash <- ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
        accountAddress <- registerStakeCredential $ KeyHashObj keyHash
        pure
          ( mkBasicTx $
              mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(accountAddress, mempty)]
          , asWitness keyHash
          )
    )
  ,
    ( String
"requiring a key hash guard"
    , do
        keyHash <- ImpM (LedgerSpec era) (KeyHash Guard)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
        pure
          ( mkBasicTx $ mkBasicTxBody & guardsTxBodyL .~ [KeyHashObj keyHash]
          , asWitness keyHash
          )
    )
  ,
    ( String
"voting as a DRep"
    , do
        (drepCredential, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
        govActionId <- submitGovAction InfoAction
        keyHash <- expectJust $ credKeyHashWitness drepCredential
        pure (voteSubTx (DRepVoter drepCredential) govActionId, keyHash)
    )
  ,
    ( String
"voting as a committee member"
    , do
        hotCredential <- NonEmpty (Credential HotCommitteeRole)
-> Credential HotCommitteeRole
forall a. NonEmpty a -> a
NE.head (NonEmpty (Credential HotCommitteeRole)
 -> Credential HotCommitteeRole)
-> ImpM (LedgerSpec era) (NonEmpty (Credential HotCommitteeRole))
-> ImpM (LedgerSpec era) (Credential HotCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
        govActionId <- submitGovAction InfoAction
        keyHash <- expectJust $ credKeyHashWitness hotCredential
        pure (voteSubTx (CommitteeVoter hotCredential) govActionId, keyHash)
    )
  ,
    ( String
"voting as a stake pool"
    , do
        poolKeyHash <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
        registerPool poolKeyHash
        govActionId <- submitGovAction InfoAction
        pure (voteSubTx (StakePoolVoter poolKeyHash) govActionId, asWitness poolKeyHash)
    )
  ]

-- | A sub-transaction that casts a single yes vote.
voteSubTx :: DijkstraEraImp era => Voter -> GovActionId -> Tx SubTx era
voteSubTx :: forall era.
DijkstraEraImp era =>
Voter -> GovActionId -> Tx SubTx era
voteSubTx Voter
voter GovActionId
govActionId =
  TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
    TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (VotingProcedures era -> Identity (VotingProcedures era))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (VotingProcedures era)
forall (l :: TxLevel). Lens' (TxBody l era) (VotingProcedures era)
votingProceduresTxBodyL
        ((VotingProcedures era -> Identity (VotingProcedures era))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> VotingProcedures era -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
          ( Voter
-> Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era))
forall k a. k -> a -> Map k a
Map.singleton Voter
voter (Map GovActionId (VotingProcedure era)
 -> Map Voter (Map GovActionId (VotingProcedure era)))
-> (VotingProcedure era -> Map GovActionId (VotingProcedure era))
-> VotingProcedure era
-> Map Voter (Map GovActionId (VotingProcedure era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GovActionId
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall k a. k -> a -> Map k a
Map.singleton GovActionId
govActionId (VotingProcedure era
 -> Map Voter (Map GovActionId (VotingProcedure era)))
-> VotingProcedure era
-> Map Voter (Map GovActionId (VotingProcedure era))
forall a b. (a -> b) -> a -> b
$
              VotingProcedure {vProcVote :: Vote
vProcVote = Vote
VoteYes, vProcAnchor :: StrictMaybe Anchor
vProcAnchor = StrictMaybe Anchor
forall a. StrictMaybe a
SNothing}
          )

-- | Every script purpose at which a sub-transaction can require a
-- native script, paired with a sub-transaction that needs a failing
-- script for that purpose and the hash of that script.
failingNativeScriptPurposes ::
  forall era.
  DijkstraEraImp era =>
  [(String, ImpTestM era (Tx SubTx era, ScriptHash))]
failingNativeScriptPurposes :: forall era.
DijkstraEraImp era =>
[(String, ImpTestM era (Tx SubTx era, ScriptHash))]
failingNativeScriptPurposes =
  [
    ( String
"spending"
    , do
        scriptHash <- ImpTestM era ScriptHash
forall era. DijkstraEraImp era => ImpTestM era ScriptHash
unsatisfiableTimeLock
        txIn <- produceScript scriptHash
        pure (mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn], scriptHash)
    )
  ,
    ( String
"certifying"
    , do
        scriptHash <- ImpTestM era ScriptHash
forall era. DijkstraEraImp era => ImpTestM era ScriptHash
unsatisfiableTimeLock
        deposit <- getsPParams ppKeyDepositL
        pure
          ( mkBasicTx $
              mkBasicTxBody
                & certsTxBodyL .~ [RegDepositTxCert (ScriptHashObj scriptHash) deposit]
          , scriptHash
          )
    )
  ,
    ( String
"guarding"
    , do
        scriptHash <- ImpTestM era ScriptHash
forall era. DijkstraEraImp era => ImpTestM era ScriptHash
unsatisfiableTimeLock
        pure
          ( mkBasicTx $ mkBasicTxBody & guardsTxBodyL .~ [ScriptHashObj scriptHash]
          , scriptHash
          )
    )
  ,
    ( String
"withdrawing"
    , do
        (scriptHash, accountAddress) <- ImpTestM era (ScriptHash, AccountAddress)
forall era.
DijkstraEraImp era =>
ImpTestM era (ScriptHash, AccountAddress)
registerLowerBoundTimeLockAccount
        pure
          ( mkBasicTx $
              mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(accountAddress, mempty)]
          , scriptHash
          )
    )
  ,
    ( String
"voting"
    , do
        scriptHash <- ImpTestM era ScriptHash
forall era. DijkstraEraImp era => ImpTestM era ScriptHash
registerLowerBoundTimeLockDRep
        govActionId <- submitGovAction InfoAction
        pure (voteSubTx (DRepVoter (ScriptHashObj scriptHash)) govActionId, scriptHash)
    )
  ]

-- | A time lock that no sub-transaction can satisfy.
unsatisfiableTimeLock :: DijkstraEraImp era => ImpTestM era ScriptHash
unsatisfiableTimeLock :: forall era. DijkstraEraImp era => ImpTestM era ScriptHash
unsatisfiableTimeLock = NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (NativeScript era -> ImpTestM era ScriptHash)
-> NativeScript era -> ImpTestM era ScriptHash
forall a b. (a -> b) -> a -> b
$ SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
mkTimeStart (Word64 -> SlotNo
SlotNo Word64
forall a. Bounded a => a
maxBound)

-- | A time lock that is satisfied only by a transaction that declares a
-- lower bound on its validity interval. Registering the credential that
-- it locks therefore succeeds, while a sub-transaction, which declares
-- no lower bound, fails to satisfy it.
lowerBoundTimeLock :: DijkstraEraImp era => ImpTestM era ScriptHash
lowerBoundTimeLock :: forall era. DijkstraEraImp era => ImpTestM era ScriptHash
lowerBoundTimeLock = NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (NativeScript era -> ImpTestM era ScriptHash)
-> NativeScript era -> ImpTestM era ScriptHash
forall a b. (a -> b) -> a -> b
$ SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
mkTimeStart SlotNo
lowerBoundSlot

lowerBoundSlot :: SlotNo
lowerBoundSlot :: SlotNo
lowerBoundSlot = Word64 -> SlotNo
SlotNo Word64
1

registerLowerBoundTimeLockAccount ::
  DijkstraEraImp era => ImpTestM era (ScriptHash, AccountAddress)
registerLowerBoundTimeLockAccount :: forall era.
DijkstraEraImp era =>
ImpTestM era (ScriptHash, AccountAddress)
registerLowerBoundTimeLockAccount = do
  scriptHash <- ImpTestM era ScriptHash
forall era. DijkstraEraImp era => ImpTestM era ScriptHash
lowerBoundTimeLock
  deposit <- getsPParams ppKeyDepositL
  submitTx_ $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL .~ [RegDepositTxCert (ScriptHashObj scriptHash) deposit]
      & bodyTxL . vldtTxBodyL .~ ValidityInterval (SJust lowerBoundSlot) SNothing
  accountAddress <- getAccountAddressFor $ ScriptHashObj scriptHash
  pure (scriptHash, accountAddress)

registerLowerBoundTimeLockDRep :: DijkstraEraImp era => ImpTestM era ScriptHash
registerLowerBoundTimeLockDRep :: forall era. DijkstraEraImp era => ImpTestM era ScriptHash
registerLowerBoundTimeLockDRep = do
  scriptHash <- ImpTestM era ScriptHash
forall era. DijkstraEraImp era => ImpTestM era ScriptHash
lowerBoundTimeLock
  deposit <- getsPParams ppDRepDepositL
  submitTx_ $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL .~ [RegDRepTxCert (ScriptHashObj scriptHash) deposit SNothing]
      & bodyTxL . vldtTxBodyL .~ ValidityInterval (SJust lowerBoundSlot) SNothing
  pure scriptHash

-- | The ways a guard credential can carry the wrong datum presence,
-- paired with the guard credential and the @requiredTopLevelGuards@
-- entry that makes it malformed.
malformedGuardDatumCases ::
  forall era.
  DijkstraEraImp era =>
  [ ( String
    , ImpTestM era (Credential Guard, Map.Map (Credential Guard) (StrictMaybe (Data era)))
    )
  ]
malformedGuardDatumCases :: forall era.
DijkstraEraImp era =>
[(String,
  ImpTestM
    era
    (Credential Guard,
     Map (Credential Guard) (StrictMaybe (Data era))))]
malformedGuardDatumCases =
  [
    ( String
"a key hash guard carrying a datum"
    , do
        guardCred <- KeyHash Guard -> Credential Guard
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Guard -> Credential Guard)
-> ImpM (LedgerSpec era) (KeyHash Guard)
-> ImpM (LedgerSpec era) (Credential Guard)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Guard)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
        datum <- arbitrary @(Data era)
        pure (guardCred, Map.singleton guardCred (SJust datum))
    )
  ,
    ( String
"a native script guard carrying a datum"
    , do
        guardCred <- ScriptHash -> Credential Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential Guard)
-> ImpM (LedgerSpec era) ScriptHash
-> ImpM (LedgerSpec era) (Credential Guard)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NativeScript era -> ImpM (LedgerSpec era) ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf [])
        datum <- arbitrary @(Data era)
        pure (guardCred, Map.singleton guardCred (SJust datum))
    )
  ,
    ( String
"a Plutus script guard without a datum"
    , do
        -- TODO: Plutus guards require PlutusV4, which `eraLanguages`
        -- does not reach while `eraMaxLanguage` is PlutusV3, so this
        -- row names the language directly instead of iterating.
        plutusScript <- Plutus 'PlutusV4 -> ImpM (LedgerSpec era) (PlutusScript era)
forall era (l :: Language) (m :: * -> *).
(AlonzoEraScript era, PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
forall (l :: Language) (m :: * -> *).
(PlutusLanguage l, MonadFail m) =>
Plutus l -> m (PlutusScript era)
mkPlutusScript (Plutus 'PlutusV4 -> ImpM (LedgerSpec era) (PlutusScript era))
-> Plutus 'PlutusV4 -> ImpM (LedgerSpec era) (PlutusScript era)
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV4 -> Plutus 'PlutusV4
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV4
SPlutusV4
        let guardScript = PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
plutusScript :: Script era
            guardCred = ScriptHash -> Credential kr
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential kr) -> ScriptHash -> Credential kr
forall a b. (a -> b) -> a -> b
$ Script era -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script era
guardScript
        pure (guardCred, Map.singleton guardCred SNothing)
    )
  ]