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

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

import qualified Cardano.Chain.Common as Byron
import Cardano.Ledger.Address (Addr (..), BootstrapAddress (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (StakeReference (..))
import Cardano.Ledger.Keys (asWitness, witVKeyHash)
import Cardano.Ledger.Keys.Bootstrap
import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..))
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireSignature,
 )
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Core.KeyPair (ByronKeyPair (..))
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.ImpTest

spec ::
  forall era.
  ( ShelleyEraImp era
  , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ShelleyEraImp era,
 InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure 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
"UTXOW" (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
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Bootstrap Witness" (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
"Valid Witnesses" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      BootstrapAddress
aliceBootAddr <- ImpM (LedgerSpec era) BootstrapAddress
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m BootstrapAddress
freshBootstapAddress
      TxIn
txIn <- Addr -> Coin -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo (BootstrapAddress -> Addr
AddrBootstrap BootstrapAddress
aliceBootAddr) Coin
forall a. Monoid a => a
mempty
      let txBody :: TxBody era
txBody = TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]
      Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody)
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"InvalidWitnessesUTXOW" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      aliceBootAddr :: BootstrapAddress
aliceBootAddr@(BootstrapAddress Address
aliceByronAddr) <- ImpM (LedgerSpec era) BootstrapAddress
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m BootstrapAddress
freshBootstapAddress
      ByronKeyPair
aliceByronKeyPair <- BootstrapAddress -> ImpM (LedgerSpec era) ByronKeyPair
forall s (m :: * -> *).
(HasCallStack, HasKeyPairs s, MonadState s m) =>
BootstrapAddress -> m ByronKeyPair
getByronKeyPair BootstrapAddress
aliceBootAddr
      TxIn
txIn <- Addr -> Coin -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo (BootstrapAddress -> Addr
AddrBootstrap BootstrapAddress
aliceBootAddr) Coin
forall a. Monoid a => a
mempty
      let (VKey 'Witness
aliceVKey, ChainCode
_) = VerificationKey -> (VKey 'Witness, ChainCode)
unpackByronVKey (ByronKeyPair -> VerificationKey
bkpVerificationKey ByronKeyPair
aliceByronKeyPair)
          txBody :: TxBody era
txBody = TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]

          -- below we use TxBody that was not fixed up, which means the hash for signing
          -- will be different thus resulting in a wrong signature
          aliceBadWitness :: BootstrapWitness
aliceBadWitness =
            Hash HASH EraIndependentTxBody
-> SigningKey -> Attributes AddrAttributes -> BootstrapWitness
makeBootstrapWitness
              (SafeHash EraIndependentTxBody -> Hash HASH EraIndependentTxBody
forall i. SafeHash i -> Hash HASH i
extractHash (TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody))
              (ByronKeyPair -> SigningKey
bkpSigningKey ByronKeyPair
aliceByronKeyPair)
              (Address -> Attributes AddrAttributes
Byron.addrAttributes Address
aliceByronAddr)

          txBad :: Tx era
txBad =
            TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody
              Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> (TxWits era -> TxWits era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((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))
 -> TxWits era -> Identity (TxWits era))
-> Set BootstrapWitness -> TxWits era -> TxWits era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set BootstrapWitness)
BootstrapWitness
aliceBadWitness]))
      Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
txBad [ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ [VKey 'Witness] -> ShelleyUtxowPredFailure era
forall era. [VKey 'Witness] -> ShelleyUtxowPredFailure era
InvalidWitnessesUTXOW [Item [VKey 'Witness]
VKey 'Witness
aliceVKey]]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MissingVKeyWitnessesUTXOW" (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 'Payment
aliceKh <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Payment
    TxIn
txIn <- Addr -> Coin -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo (KeyHash 'Payment -> StakeReference -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyHash 'Payment
aliceKh StakeReference
StakeRefNull) Coin
forall a. Monoid a => a
mempty
    let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$ TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [Item (Set TxIn)
TxIn
txIn]
    let isAliceWitness :: WitVKey kr -> Bool
isAliceWitness WitVKey kr
wit = WitVKey kr -> KeyHash 'Witness
forall (kr :: KeyRole). WitVKey kr -> KeyHash 'Witness
witVKeyHash WitVKey kr
wit KeyHash 'Witness -> KeyHash 'Witness -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash 'Payment -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash 'Payment
aliceKh
    (Tx era -> ImpTestM era (Tx era))
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (Tx era -> ImpTestM era (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpTestM era (Tx era))
-> (Tx era -> Tx era) -> Tx era -> ImpTestM era (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
    -> TxWits era -> Identity (TxWits era))
-> (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> Tx era
-> Identity (Tx 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 era -> Identity (Tx era))
-> (Set (WitVKey 'Witness) -> Set (WitVKey 'Witness))
-> Tx era
-> Tx 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 (Bool -> Bool
not (Bool -> Bool)
-> (WitVKey 'Witness -> Bool) -> WitVKey 'Witness -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WitVKey 'Witness -> Bool
forall {kr :: KeyRole}. WitVKey kr -> Bool
isAliceWitness))) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
      Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
        Tx era
tx
        [ ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
            Set (KeyHash 'Witness) -> ShelleyUtxowPredFailure era
forall era. Set (KeyHash 'Witness) -> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW [KeyHash 'Payment -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash 'Payment
aliceKh]
        ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MissingScriptWitnessesUTXOW" (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 'Witness
requiredKh <- ImpM (LedgerSpec era) (KeyHash 'Witness)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript (NativeScript era -> Script era) -> NativeScript era -> Script era
forall a b. (a -> b) -> a -> b
$ KeyHash 'Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature KeyHash 'Witness
requiredKh
    TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
    let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$ TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [Item (Set TxIn)
TxIn
txIn]
    Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
      Tx era
tx
      [ ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
          Set ScriptHash -> ShelleyUtxowPredFailure era
forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
MissingScriptWitnessesUTXOW [Item (Set ScriptHash)
ScriptHash
scriptHash]
      ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MissingTxBodyMetadataHash" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    -- We can't have the size of generated auxData change, since that would affect the
    -- hard coded fee. Therefore we fix the seed.
    Int -> ImpM (LedgerSpec era) ()
forall t. Int -> ImpM t ()
impSetSeed Int
12345
    TxAuxData era
auxData <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @(TxAuxData era)
    let auxDataHash :: TxAuxDataHash
auxDataHash = TxAuxData era -> TxAuxDataHash
forall era. EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData TxAuxData era
auxData
        tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$ TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> Coin -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
166249
        addAuxData :: Tx era -> f (Tx era)
addAuxData Tx era
fixedTx = Tx era -> f (Tx era)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era
fixedTx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (TxAuxData era)))
-> Tx era -> Identity (Tx era)
forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL ((StrictMaybe (TxAuxData era)
  -> Identity (StrictMaybe (TxAuxData era)))
 -> Tx era -> Identity (Tx era))
-> StrictMaybe (TxAuxData era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxAuxData era -> StrictMaybe (TxAuxData era)
forall a. a -> StrictMaybe a
SJust TxAuxData era
auxData)
    (Tx era -> ImpTestM era (Tx era))
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup Tx era -> ImpTestM era (Tx era)
forall {f :: * -> *}. Applicative f => Tx era -> f (Tx era)
addAuxData (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
      Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
        Tx era
tx
        [ ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
            TxAuxDataHash -> ShelleyUtxowPredFailure era
forall era. TxAuxDataHash -> ShelleyUtxowPredFailure era
MissingTxBodyMetadataHash TxAuxDataHash
auxDataHash
        ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MissingTxMetadata" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    TxAuxData era
auxData <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @(TxAuxData era)
    let auxDataHash :: TxAuxDataHash
auxDataHash = TxAuxData era -> TxAuxDataHash
forall era. EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData TxAuxData era
auxData
    let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictMaybe TxAuxDataHash
     -> Identity (StrictMaybe TxAuxDataHash))
    -> TxBody era -> Identity (TxBody era))
-> (StrictMaybe TxAuxDataHash
    -> Identity (StrictMaybe TxAuxDataHash))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash -> Identity (StrictMaybe TxAuxDataHash))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL ((StrictMaybe TxAuxDataHash
  -> Identity (StrictMaybe TxAuxDataHash))
 -> Tx era -> Identity (Tx era))
-> StrictMaybe TxAuxDataHash -> Tx era -> Tx 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
    Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
      Tx era
tx
      [ ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
          TxAuxDataHash -> ShelleyUtxowPredFailure era
forall era. TxAuxDataHash -> ShelleyUtxowPredFailure era
MissingTxMetadata TxAuxDataHash
auxDataHash
      ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ConflictingMetadataHash" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    TxAuxData era
auxData <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @(TxAuxData era)
    let auxDataHash :: TxAuxDataHash
auxDataHash = TxAuxData era -> TxAuxDataHash
forall era. EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData TxAuxData era
auxData
    TxAuxDataHash
wrongAuxDataHash <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @TxAuxDataHash
    let tx :: Tx era
tx =
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictMaybe TxAuxDataHash
     -> Identity (StrictMaybe TxAuxDataHash))
    -> TxBody era -> Identity (TxBody era))
-> (StrictMaybe TxAuxDataHash
    -> Identity (StrictMaybe TxAuxDataHash))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash -> Identity (StrictMaybe TxAuxDataHash))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL ((StrictMaybe TxAuxDataHash
  -> Identity (StrictMaybe TxAuxDataHash))
 -> Tx era -> Identity (Tx era))
-> StrictMaybe TxAuxDataHash -> Tx era -> Tx 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 era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (TxAuxData era)))
-> Tx era -> Identity (Tx era)
forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL ((StrictMaybe (TxAuxData era)
  -> Identity (StrictMaybe (TxAuxData era)))
 -> Tx era -> Identity (Tx era))
-> StrictMaybe (TxAuxData era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxAuxData era -> StrictMaybe (TxAuxData era)
forall a. a -> StrictMaybe a
SJust TxAuxData era
auxData
    Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
      Tx era
tx
      [ ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
          Mismatch 'RelEQ TxAuxDataHash -> ShelleyUtxowPredFailure era
forall era.
Mismatch 'RelEQ TxAuxDataHash -> ShelleyUtxowPredFailure era
ConflictingMetadataHash (Mismatch 'RelEQ TxAuxDataHash -> ShelleyUtxowPredFailure era)
-> Mismatch 'RelEQ TxAuxDataHash -> ShelleyUtxowPredFailure era
forall a b. (a -> b) -> a -> b
$
            Mismatch {mismatchSupplied :: TxAuxDataHash
mismatchSupplied = TxAuxDataHash
wrongAuxDataHash, mismatchExpected :: TxAuxDataHash
mismatchExpected = TxAuxDataHash
auxDataHash}
      ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ExtraneousScriptWitnessesUTXOW" (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 Any
requiredKh <- ImpM (LedgerSpec era) (KeyHash Any)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let script :: Script era
script = NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript (NativeScript era -> Script era) -> NativeScript era -> Script era
forall a b. (a -> b) -> a -> b
$ KeyHash 'Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature (KeyHash Any -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash Any
requiredKh)
    let scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
script
    let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Map ScriptHash (Script era)
     -> Identity (Map ScriptHash (Script era)))
    -> TxWits era -> Identity (TxWits era))
-> (Map ScriptHash (Script era)
    -> Identity (Map ScriptHash (Script era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era)
 -> Identity (Map ScriptHash (Script era)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL ((Map ScriptHash (Script era)
  -> Identity (Map ScriptHash (Script era)))
 -> Tx era -> Identity (Tx era))
-> Map ScriptHash (Script era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(ScriptHash
scriptHash, Script era
script)]
    Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
 -> ImpM (LedgerSpec era) ())
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
      -- We dropped validating scripts when they are not needed, starting with Babbage
      if forall era. Era era => Version
eraProtVerLow @era Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @6
        then
          [ ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ShelleyUtxowPredFailure era
forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
ExtraneousScriptWitnessesUTXOW [Item (Set ScriptHash)
ScriptHash
scriptHash]
          ]
        else
          [ ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ShelleyUtxowPredFailure era
forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [Item (Set ScriptHash)
ScriptHash
scriptHash]
          , ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ShelleyUtxowPredFailure era
forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
ExtraneousScriptWitnessesUTXOW [Item (Set ScriptHash)
ScriptHash
scriptHash]
          ]