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

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

import Cardano.Ledger.Allegra.Scripts (
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..))
import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..))
import qualified Cardano.Ledger.Alonzo.Plutus.TxInfo as Alonzo
import qualified Cardano.Ledger.Alonzo.Rules as Alonzo
import Cardano.Ledger.Alonzo.Scripts (eraLanguages, plutusScriptLanguage)
import Cardano.Ledger.Babbage (BabbageEra)
import qualified Cardano.Ledger.Babbage.Rules as Babbage
import Cardano.Ledger.Babbage.TxInfo (BabbageContextError (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Conway.TxInfo
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.DRep
import Cardano.Ledger.Plutus
import Cardano.Ledger.Shelley.LedgerState
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.TxIn (TxId (..), mkTxInPartial)
import Data.Default (def)
import Data.Foldable (for_)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as Map
import qualified Data.OSet.Strict as OSet
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import qualified Data.Set.NonEmpty as NES
import Data.Typeable (Typeable)
import Lens.Micro
import qualified PlutusLedgerApi.V1 as P1
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus (testingCostModels)
import Test.Cardano.Ledger.Plutus.Examples (
  alwaysFailsNoDatum,
  alwaysSucceedsNoDatum,
  evenRedeemerNoDatum,
  purposeIsWellformedNoDatum,
  redeemerSameAsDatum,
 )

spec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp 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
"UTXOS" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
govPolicySpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
costModelsSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
datumAndReferenceInputsSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
conwayFeaturesPlutusV1V2FailureSpec
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Spending script without a Datum" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    [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_ ([Item [Language]
Language
forall a. Bounded a => a
minBound .. forall era. AlonzoEraScript era => Language
eraMaxLanguage @era] :: [Language]) ((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 -> do
      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 = Language
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> ScriptHash)
-> ScriptHash
forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang (Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash)
-> (SLanguage l -> Plutus l) -> SLanguage l -> ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum)
            addr :: Addr
addr = Network -> Credential Payment -> StakeReference -> Addr
Addr Network
Testnet (ScriptHash -> Credential Payment
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash) StakeReference
StakeRefNull
        amount <- (Coin, Coin) -> ImpM (LedgerSpec era) Coin
forall a g (m :: * -> *).
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer -> Coin
Coin Integer
10_000_000, Integer -> Coin
Coin Integer
100_000_000)
        txIn <- sendCoinTo addr amount
        let tx :: forall l. Typeable l => Tx l era
            tx = 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
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])
        if lang >= PlutusV3
          then submitAnyTx_ tx
          else
            submitFailingTx
              tx
              [ injectFailure $ Alonzo.UnspendableUTxONoDatumHash $ NES.singleton txIn
              ]
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"purposeIsWellformedNoDatum" (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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Language
l | Language
l <- forall era. AlonzoEraScript era => [Language]
eraLanguages @era, Language
l Language -> Language -> Bool
forall a. Ord a => a -> a -> Bool
>= Language
PlutusV3] ((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 -> do
      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 (SLanguage l -> String
forall a. Show a => a -> String
show SLanguage l
slang) (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
        -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/1349
        -- TODO: Re-enable this after issue is resolved, by removing this override
        String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Passes with voting purpose" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          let sh :: ScriptHash
sh = 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
purposeIsWellformedNoDatum SLanguage l
slang
          coldCred : _ <- Set (Credential ColdCommitteeRole)
-> [Credential ColdCommitteeRole]
forall a. Set a -> [a]
Set.toList (Set (Credential ColdCommitteeRole)
 -> [Credential ColdCommitteeRole])
-> ImpM (LedgerSpec era) (Set (Credential ColdCommitteeRole))
-> ImpM (LedgerSpec era) [Credential ColdCommitteeRole]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (Set (Credential ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential ColdCommitteeRole))
getCommitteeMembers
          hotCred :| _ <- registerCommitteeHotKeys (pure $ ScriptHashObj sh) (coldCred :| [])
          gaId <- submitGovAction InfoAction
          submitYesVote_ (CommitteeVoter hotCred) gaId
        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Passes with proposing purpose" (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) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
          let sh :: ScriptHash
sh = 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
purposeIsWellformedNoDatum SLanguage l
slang
          committee <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
          (dRep, _, _) <- setupSingleDRep 1_000_000
          anchor <- arbitrary
          void $ enactConstitution SNothing (Constitution anchor (SJust sh)) dRep committee
          account <- registerAccountAddress
          proposal <- mkProposal $ TreasuryWithdrawals (Map.singleton account (Coin 1000)) (SJust sh)
          submitProposal_ proposal

datumAndReferenceInputsSpec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
datumAndReferenceInputsSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
datumAndReferenceInputsSpec = do
  [Language]
-> (Language -> SpecM (ImpInit (LedgerSpec era)) ())
-> SpecM (ImpInit (LedgerSpec era)) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall era. AlonzoEraScript era => [Language]
eraLanguages @era) ((Language -> SpecM (ImpInit (LedgerSpec era)) ())
 -> SpecM (ImpInit (LedgerSpec era)) ())
-> (Language -> SpecM (ImpInit (LedgerSpec era)) ())
-> SpecM (ImpInit (LedgerSpec era)) ()
forall a b. (a -> b) -> a -> b
$ \Language
lang ->
    Language
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> SpecM (ImpInit (LedgerSpec era)) ())
-> SpecM (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 -> SpecM (ImpInit (LedgerSpec era)) ())
 -> SpecM (ImpInit (LedgerSpec era)) ())
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> SpecM (ImpInit (LedgerSpec era)) ())
-> SpecM (ImpInit (LedgerSpec era)) ()
forall a b. (a -> b) -> a -> b
$ \SLanguage l
slang ->
      String
-> SpecM (ImpInit (LedgerSpec era)) ()
-> SpecM (ImpInit (LedgerSpec era)) ()
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (Language -> String
forall a. Show a => a -> String
show Language
lang) (SpecM (ImpInit (LedgerSpec era)) ()
 -> SpecM (ImpInit (LedgerSpec era)) ())
-> SpecM (ImpInit (LedgerSpec era)) ()
-> SpecM (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
"can use reference scripts" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          producingTx <- SLanguage l -> ImpTestM era TxId
forall era (l :: Language).
(BabbageEraTxOut era, AlonzoEraImp era, PlutusLanguage l) =>
SLanguage l -> ImpTestM era TxId
setupRefTx SLanguage l
slang
          referringTx <-
            submitTxAnn "Transaction that refers to the script" $
              mkBasicTx mkBasicTxBody
                & bodyTxL . inputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 1)
                & bodyTxL . referenceInputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 0)
          (referringTx ^. witsTxL . scriptTxWitsL) `shouldBe` mempty
        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"can use regular inputs for reference" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          producingTx <- SLanguage l -> ImpTestM era TxId
forall era (l :: Language).
(BabbageEraTxOut era, AlonzoEraImp era, PlutusLanguage l) =>
SLanguage l -> ImpTestM era TxId
setupRefTx SLanguage l
slang
          referringTx <-
            submitTxAnn "Consuming transaction" $
              mkBasicTx mkBasicTxBody
                & bodyTxL . inputsTxBodyL
                  .~ Set.fromList
                    [ mkTxInPartial producingTx 0
                    , mkTxInPartial producingTx 1
                    ]
          (referringTx ^. witsTxL . scriptTxWitsL) `shouldBe` mempty
        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails with same txIn in regular inputs and reference inputs" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          -- Note: the success cases are tested in Babbage.Imp.UtxosSpec
          producingTx <- SLanguage l -> ImpTestM era TxId
forall era (l :: Language).
(BabbageEraTxOut era, AlonzoEraImp era, PlutusLanguage l) =>
SLanguage l -> ImpTestM era TxId
setupRefTx SLanguage l
slang
          let
            consumingTx =
              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))
-> ((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 (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))
 -> 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
.~ [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList
                    [ HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0
                    , HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
1
                    ]
                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 (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
referenceInputsTxBodyL ((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
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0)
          let badTxIns = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0 TxIn -> [TxIn] -> NonEmpty TxIn
forall a. a -> [a] -> NonEmpty a
:| []
          whenMajorVersionAtMost @10 $
            submitFailingTx
              consumingTx
              (pure . injectFailure $ Babbage.BabbageNonDisjointRefInputs badTxIns)
          whenMajorVersionAtLeast @11 $
            when (lang > eraMaxLanguage @BabbageEra) $
              submitFailingTx @era
                consumingTx
                [ injectFailure $
                    Alonzo.CollectErrors [BadTranslation . inject $ ReferenceInputsNotDisjointFromInputs @era badTxIns]
                ]
        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"using inline datums" (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 shSpending :: ScriptHash
shSpending = 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
          refTxOut <- ScriptHash -> ImpM (LedgerSpec era) (TxOut era)
forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash
shSpending
          producingTxId <-
            fmap txIdTx . submitTxAnn "Producing transaction" $
              mkBasicTx mkBasicTxBody
                & bodyTxL . outputsTxBodyL
                  .~ SSeq.fromList
                    [ refTxOut
                    , scriptLockedTxOut shSpending & dataTxOutL .~ SJust (Data spendDatum)
                    ]
          let
            lockedTxIn = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTxId Integer
1
            consumingTx =
              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))
-> ((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 (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))
 -> 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
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
lockedTxIn
                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 (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
referenceInputsTxBodyL ((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
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTxId Integer
0)
          if lang < PlutusV2
            then
              submitFailingTx
                consumingTx
                ( pure . injectFailure $
                    Alonzo.CollectErrors
                      [BadTranslation . inject . InlineDatumsNotSupported @era $ TxOutFromInput lockedTxIn]
                )
            else
              submitTxAnn_ "Consuming transaction" consumingTx

conwayFeaturesPlutusV1V2FailureSpec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
conwayFeaturesPlutusV1V2FailureSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
conwayFeaturesPlutusV1V2FailureSpec = do
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Conway features fail in Plutus" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ @[] [Item [Language]
Language
PlutusV1 .. Item [Language]
Language
PlutusV2] ((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 (SLanguage l -> String
forall a. Show a => a -> String
show SLanguage l
slang) (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
"Unsupported Fields" (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
"CurrentTreasuryValue" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
            donation <- ImpM (LedgerSpec era) Coin
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
            submitAnyTx_ $ mkBasicTx (mkBasicTxBody & treasuryDonationTxBodyL .~ donation)
            passEpoch
            testPlutusV1V2Failure
              (hashPlutusScript $ redeemerSameAsDatum slang)
              (SJust donation)
              currentTreasuryValueTxBodyL
              $ inject (CurrentTreasuryFieldNotSupported @era donation)
          String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"VotingProcedures" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
            action <- StrictMaybe GovActionId -> ImpTestM era (GovAction era)
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction StrictMaybe GovActionId
forall a. StrictMaybe a
SNothing
            (ccCred :| _) <- registerInitialCommittee
            proposal <- submitGovAction action
            let badField =
                  Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
                    (Map Voter (Map GovActionId (VotingProcedure era))
 -> VotingProcedures era)
-> Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall a b. (a -> b) -> a -> b
$ Voter
-> Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era))
forall k a. k -> a -> Map k a
Map.singleton
                      (Credential HotCommitteeRole -> Voter
CommitteeVoter Credential HotCommitteeRole
ccCred)
                    (Map GovActionId (VotingProcedure era)
 -> Map Voter (Map GovActionId (VotingProcedure era)))
-> Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era))
forall a b. (a -> b) -> a -> b
$ GovActionId
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall k a. k -> a -> Map k a
Map.singleton GovActionId
proposal
                    (VotingProcedure era -> Map GovActionId (VotingProcedure era))
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall a b. (a -> b) -> a -> b
$ Vote -> StrictMaybe Anchor -> VotingProcedure era
forall era. Vote -> StrictMaybe Anchor -> VotingProcedure era
VotingProcedure Vote
VoteYes StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
            testPlutusV1V2Failure
              (hashPlutusScript $ redeemerSameAsDatum slang)
              badField
              votingProceduresTxBodyL
              $ inject
              $ VotingProceduresFieldNotSupported badField
          String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ProposalProcedures" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
            deposit <- SimpleGetter (NewEpochState era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin
 -> ImpM (LedgerSpec era) Coin)
-> SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era.
(ConwayEraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL
            accountAddress <- registerAccountAddress
            let badField = ProposalProcedure era -> OSet (ProposalProcedure era)
forall a. a -> OSet a
OSet.singleton (ProposalProcedure era -> OSet (ProposalProcedure era))
-> ProposalProcedure era -> OSet (ProposalProcedure era)
forall a b. (a -> b) -> a -> b
$ Coin
-> AccountAddress
-> GovAction era
-> Anchor
-> ProposalProcedure era
forall era.
Coin
-> AccountAddress
-> GovAction era
-> Anchor
-> ProposalProcedure era
ProposalProcedure Coin
deposit AccountAddress
accountAddress GovAction era
forall era. GovAction era
InfoAction Anchor
forall a. Default a => a
def
            testPlutusV1V2Failure
              (hashPlutusScript $ redeemerSameAsDatum slang)
              badField
              proposalProceduresTxBodyL
              $ inject
              $ ProposalProceduresFieldNotSupported badField
          String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"TreasuryDonation"
            (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ ScriptHash
-> Coin
-> Lens' (TxBody TopTx era) Coin
-> ContextError era
-> ImpM (LedgerSpec era) ()
forall era a.
(HasCallStack, ConwayEraImp era) =>
ScriptHash
-> a
-> Lens' (TxBody TopTx era) a
-> ContextError era
-> ImpTestM era ()
testPlutusV1V2Failure
              (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)
              (Integer -> Coin
Coin Integer
10_000)
              (Coin -> f Coin) -> TxBody TopTx era -> f (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) Coin
forall (l :: TxLevel). Lens' (TxBody l era) Coin
Lens' (TxBody TopTx era) Coin
treasuryDonationTxBodyL
            (ContextError era -> ImpM (LedgerSpec era) ())
-> ContextError era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject
            (ConwayContextError era -> ContextError era)
-> ConwayContextError era -> ContextError era
forall a b. (a -> b) -> a -> b
$ forall era. Coin -> ConwayContextError era
TreasuryDonationFieldNotSupported @era
            (Coin -> ConwayContextError era) -> Coin -> ConwayContextError era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
10_000
        String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Certificates" (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
"Translated" (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 testCertificateTranslated :: TxCert era -> TxIn -> ImpTestM era ()
testCertificateTranslated TxCert era
okCert TxIn
txIn = do
                  (forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_
                    ( 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
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                        Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (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))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody l era -> Identity (TxBody l era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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))
 -> Tx l era -> Identity (Tx l era))
-> Set TxIn -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn
                        Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (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 (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody l era -> Identity (TxBody l era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                          ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx l era -> Identity (Tx l era))
-> StrictSeq (TxCert era) -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxCert era -> StrictSeq (TxCert era)
forall a. a -> StrictSeq a
SSeq.singleton TxCert era
okCert
                    )
            String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"RegDepositTxCert" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
              stakingC <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
              deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
              let regDepositTxCert = Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
RegDepositTxCert Credential Staking
stakingC Coin
deposit
              testCertificateTranslated regDepositTxCert
                =<< produceScript (hashPlutusScript $ redeemerSameAsDatum slang)
            String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"UnRegDepositTxCert" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
              (_poolKH, _spendingC, stakingC) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000
              deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
              let unRegDepositTxCert = Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
stakingC Coin
deposit
              testCertificateTranslated unRegDepositTxCert
                =<< produceScript (hashPlutusScript $ redeemerSameAsDatum slang)
          String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Unsupported" (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 testCertificateNotSupported :: TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupported TxCert era
badCert = do
                  txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript @era (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)
                  submitFailingTx
                    ( mkBasicTx mkBasicTxBody
                        & bodyTxL . inputsTxBodyL
                          .~ Set.singleton txIn
                        & bodyTxL . certsTxBodyL
                          .~ SSeq.singleton badCert
                    )
                    ( pure . injectFailure $
                        Alonzo.CollectErrors
                          [ BadTranslation $
                              inject $
                                Alonzo.CertificateNotSupported badCert
                          ]
                    )
            String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DelegTxCert" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
              (drep, delegator, _) <- 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_000
              let delegTxCert =
                    forall era.
ConwayEraTxCert era =>
Credential Staking -> Delegatee -> TxCert era
DelegTxCert @era
                      Credential Staking
delegator
                      (DRep -> Delegatee
DelegVote (Credential DRepRole -> DRep
DRepCredential Credential DRepRole
drep))
              testCertificateNotSupported delegTxCert
            String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"RegDepositDelegTxCert" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
              (drep, _, _) <- 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_000
              unregisteredDelegatorKH <- freshKeyHash
              pp <- getsNES $ nesEsL . curPParamsEpochStateL
              let regDepositDelegTxCert =
                    forall era.
ConwayEraTxCert era =>
Credential Staking -> Delegatee -> Coin -> TxCert era
RegDepositDelegTxCert @era
                      (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
unregisteredDelegatorKH)
                      (DRep -> Delegatee
DelegVote (Credential DRepRole -> DRep
DRepCredential Credential DRepRole
drep))
                      (PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL)
              testCertificateNotSupported regDepositDelegTxCert
            String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"AuthCommitteeHotKeyTxCert" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
              coldKey <- [Credential ColdCommitteeRole]
-> ImpM (LedgerSpec era) (Credential ColdCommitteeRole)
forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements ([Credential ColdCommitteeRole]
 -> ImpM (LedgerSpec era) (Credential ColdCommitteeRole))
-> (Set (Credential ColdCommitteeRole)
    -> [Credential ColdCommitteeRole])
-> Set (Credential ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential ColdCommitteeRole)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Credential ColdCommitteeRole)
-> [Credential ColdCommitteeRole]
forall a. Set a -> [a]
Set.toList (Set (Credential ColdCommitteeRole)
 -> ImpM (LedgerSpec era) (Credential ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Set (Credential ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Credential ColdCommitteeRole)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Set (Credential ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential ColdCommitteeRole))
getCommitteeMembers
              hotKey <- KeyHashObj <$> freshKeyHash
              let authCommitteeHotKeyTxCert = forall era.
ConwayEraTxCert era =>
Credential ColdCommitteeRole
-> Credential HotCommitteeRole -> TxCert era
AuthCommitteeHotKeyTxCert @era Credential ColdCommitteeRole
coldKey Credential HotCommitteeRole
hotKey
              testCertificateNotSupported authCommitteeHotKeyTxCert
            String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ResignCommitteeColdTxCert" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
              coldKey <- [Credential ColdCommitteeRole]
-> ImpM (LedgerSpec era) (Credential ColdCommitteeRole)
forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements ([Credential ColdCommitteeRole]
 -> ImpM (LedgerSpec era) (Credential ColdCommitteeRole))
-> (Set (Credential ColdCommitteeRole)
    -> [Credential ColdCommitteeRole])
-> Set (Credential ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential ColdCommitteeRole)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Credential ColdCommitteeRole)
-> [Credential ColdCommitteeRole]
forall a. Set a -> [a]
Set.toList (Set (Credential ColdCommitteeRole)
 -> ImpM (LedgerSpec era) (Credential ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Set (Credential ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Credential ColdCommitteeRole)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Set (Credential ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential ColdCommitteeRole))
getCommitteeMembers
              let resignCommitteeColdTxCert = forall era.
ConwayEraTxCert era =>
Credential ColdCommitteeRole -> StrictMaybe Anchor -> TxCert era
ResignCommitteeColdTxCert @era Credential ColdCommitteeRole
coldKey StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
              testCertificateNotSupported resignCommitteeColdTxCert
            String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"RegDRepTxCert" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
              unregisteredDRepKH <- ImpM (LedgerSpec era) (KeyHash DRepRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
              pp <- getsNES $ nesEsL . curPParamsEpochStateL
              testCertificateNotSupported $
                RegDRepTxCert @era (KeyHashObj unregisteredDRepKH) (pp ^. ppDRepDepositL) SNothing
            String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"UnRegDRepTxCert" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
              (drepKH, _, _) <- 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_000
              pp <- getsNES $ nesEsL . curPParamsEpochStateL
              let unRegDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential DRepRole -> Coin -> TxCert era
UnRegDRepTxCert @era Credential DRepRole
drepKH (PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppDRepDepositL)
              testCertificateNotSupported unRegDRepTxCert
            String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"UpdateDRepTxCert" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
              (drepKH, _, _) <- 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_000
              let updateDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential DRepRole -> StrictMaybe Anchor -> TxCert era
UpdateDRepTxCert @era Credential DRepRole
drepKH StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
              testCertificateNotSupported updateDRepTxCert

govPolicySpec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
govPolicySpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
govPolicySpec = do
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Gov policy scripts" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    -- These tests rely on the script in the constitution, but we can only change the constitution after bootstrap.
    -- So we cannot run these tests during bootstrap
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"failing native script govPolicy" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
      (dRep, _, _) <- setupSingleDRep 1_000_000
      scriptHash <- impAddNativeScript $ RequireTimeStart (SlotNo 1)
      anchor <- arbitrary
      void $
        enactConstitution SNothing (Constitution anchor (SJust scriptHash)) dRep committeeMembers'
      impAnn "ParameterChange" $ do
        let pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Word16 -> Identity (StrictMaybe Word16))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Word16)
Lens' (PParamsUpdate era) (StrictMaybe Word16)
ppuCommitteeMinSizeL ((StrictMaybe Word16 -> Identity (StrictMaybe Word16))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Word16 -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word16 -> StrictMaybe Word16
forall a. a -> StrictMaybe a
SJust Word16
1
        let govAction = StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
scriptHash)
        proposal <- mkProposal govAction
        let 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))
-> ((OSet (ProposalProcedure era)
     -> Identity (OSet (ProposalProcedure era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OSet (ProposalProcedure era)
    -> Identity (OSet (ProposalProcedure era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
 -> Identity (OSet (ProposalProcedure era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (OSet (ProposalProcedure era))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
  -> Identity (OSet (ProposalProcedure era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OSet (ProposalProcedure era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))
ProposalProcedure era
proposal]
                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))
-> ((ValidityInterval -> Identity ValidityInterval)
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (ValidityInterval -> Identity ValidityInterval)
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidityInterval -> Identity ValidityInterval)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
AllegraEraTxBody era =>
Lens' (TxBody l era) ValidityInterval
forall (l :: TxLevel). Lens' (TxBody l era) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ValidityInterval -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
        submitFailingTx
          tx
          [injectFailure $ Shelley.ScriptWitnessNotValidatingUTXOW $ NES.singleton scriptHash]

      impAnn "TreasuryWithdrawals" $ do
        accountAddress <- registerAccountAddress
        let withdrawals = [(AccountAddress, Coin)] -> Map AccountAddress Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AccountAddress
accountAddress, Integer -> Coin
Coin Integer
1000)]
        let govAction = Map AccountAddress Coin -> StrictMaybe ScriptHash -> GovAction era
forall era.
Map AccountAddress Coin -> StrictMaybe ScriptHash -> GovAction era
TreasuryWithdrawals Map AccountAddress Coin
withdrawals (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
scriptHash)
        proposal <- mkProposal govAction
        let 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))
-> ((OSet (ProposalProcedure era)
     -> Identity (OSet (ProposalProcedure era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OSet (ProposalProcedure era)
    -> Identity (OSet (ProposalProcedure era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
 -> Identity (OSet (ProposalProcedure era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (OSet (ProposalProcedure era))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
  -> Identity (OSet (ProposalProcedure era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OSet (ProposalProcedure era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))
ProposalProcedure era
proposal]
                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))
-> ((ValidityInterval -> Identity ValidityInterval)
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (ValidityInterval -> Identity ValidityInterval)
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidityInterval -> Identity ValidityInterval)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
AllegraEraTxBody era =>
Lens' (TxBody l era) ValidityInterval
forall (l :: TxLevel). Lens' (TxBody l era) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ValidityInterval -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
        submitFailingTx
          tx
          [injectFailure $ Shelley.ScriptWitnessNotValidatingUTXOW $ NES.singleton scriptHash]

    [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
l | Language
l <- forall era. AlonzoEraScript era => [Language]
eraLanguages @era, Language
l Language -> Language -> Bool
forall a. Ord a => a -> a -> Bool
>= Language
PlutusV3] ((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 (SLanguage l -> String
forall a. Show a => a -> String
show SLanguage l
slang) (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 -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"alwaysSucceeds Plutus govPolicy validates" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          let alwaysSucceedsSh :: ScriptHash
alwaysSucceedsSh = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage l
slang)
          committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
          (dRep, _, _) <- setupSingleDRep 1_000_000
          anchor <- arbitrary
          void $
            enactConstitution
              SNothing
              (Constitution anchor (SJust alwaysSucceedsSh))
              dRep
              committeeMembers'
          accountAddress <- registerAccountAddress

          impAnn "ParameterChange" $ do
            let pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Word16 -> Identity (StrictMaybe Word16))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Word16)
Lens' (PParamsUpdate era) (StrictMaybe Word16)
ppuCommitteeMinSizeL ((StrictMaybe Word16 -> Identity (StrictMaybe Word16))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Word16 -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word16 -> StrictMaybe Word16
forall a. a -> StrictMaybe a
SJust Word16
1
            let govAction = StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh)
            mkProposal govAction >>= submitProposal_
          impAnn "TreasuryWithdrawals" $ do
            let withdrawals = [(AccountAddress, Coin)] -> Map AccountAddress Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AccountAddress
accountAddress, Integer -> Coin
Coin Integer
1000)]
            let govAction = Map AccountAddress Coin -> StrictMaybe ScriptHash -> GovAction era
forall era.
Map AccountAddress Coin -> StrictMaybe ScriptHash -> GovAction era
TreasuryWithdrawals Map AccountAddress Coin
withdrawals (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh)
            mkProposal govAction >>= submitProposal_

        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"alwaysFails Plutus govPolicy does not validate" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          let alwaysFailsSh :: ScriptHash
alwaysFailsSh = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage l
slang)
          committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
          (dRep, _, _) <- setupSingleDRep 1_000_000
          anchor <- arbitrary
          void $
            enactConstitution SNothing (Constitution anchor (SJust alwaysFailsSh)) dRep committeeMembers'

          impAnn "ParameterChange" $ do
            let pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Word16 -> Identity (StrictMaybe Word16))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Word16)
Lens' (PParamsUpdate era) (StrictMaybe Word16)
ppuCommitteeMinSizeL ((StrictMaybe Word16 -> Identity (StrictMaybe Word16))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Word16 -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word16 -> StrictMaybe Word16
forall a. a -> StrictMaybe a
SJust Word16
1
            let govAction = StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh)
            proposal <- mkProposal govAction
            let 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))
-> ((OSet (ProposalProcedure era)
     -> Identity (OSet (ProposalProcedure era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OSet (ProposalProcedure era)
    -> Identity (OSet (ProposalProcedure era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
 -> Identity (OSet (ProposalProcedure era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (OSet (ProposalProcedure era))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
  -> Identity (OSet (ProposalProcedure era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OSet (ProposalProcedure era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))
ProposalProcedure era
proposal]
            submitPhase2Invalid_ tx

          impAnn "TreasuryWithdrawals" $ do
            accountAddress <- registerAccountAddress
            let withdrawals = [(AccountAddress, Coin)] -> Map AccountAddress Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AccountAddress
accountAddress, Integer -> Coin
Coin Integer
1000)]
            let govAction = Map AccountAddress Coin -> StrictMaybe ScriptHash -> GovAction era
forall era.
Map AccountAddress Coin -> StrictMaybe ScriptHash -> GovAction era
TreasuryWithdrawals Map AccountAddress Coin
withdrawals (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh)
            proposal <- mkProposal govAction
            let 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))
-> ((OSet (ProposalProcedure era)
     -> Identity (OSet (ProposalProcedure era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OSet (ProposalProcedure era)
    -> Identity (OSet (ProposalProcedure era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
 -> Identity (OSet (ProposalProcedure era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (OSet (ProposalProcedure era))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
  -> Identity (OSet (ProposalProcedure era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OSet (ProposalProcedure era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))
ProposalProcedure era
proposal]
            submitPhase2Invalid_ tx

costModelsSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
costModelsSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
costModelsSpec =
  -- These tests rely on the script in the constitution, but we can only change the constitution after bootstrap.
  -- So we cannot run these tests during bootstrap
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"PlutusV3 Initialization" (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 -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Updating CostModels with alwaysFails govPolicy does not validate" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      -- no initial PlutusV3 CostModels
      (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL ((CostModels -> Identity CostModels)
 -> PParams era -> Identity (PParams era))
-> CostModels -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV1 .. Item [Language]
Language
PlutusV2]

      committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
      (dRep, _, _) <- setupSingleDRep 1_000_000
      anchor <- arbitrary
      govIdConstitution1 <-
        enactConstitution SNothing (Constitution anchor SNothing) dRep committeeMembers'
      -- propose and enact PlutusV3 Costmodels
      govIdPPUpdate1 <-
        enactCostModels SNothing (testingCostModels [PlutusV3]) dRep committeeMembers'

      let alwaysFailsSh = Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage 'PlutusV3
SPlutusV3)
      void $
        enactConstitution
          (SJust (GovPurposeId govIdConstitution1))
          (Constitution anchor (SJust alwaysFailsSh))
          dRep
          committeeMembers'

      impAnn "Fail to update V3 Costmodels" $ do
        let pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL ((StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe CostModels -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CostModels -> StrictMaybe CostModels
forall a. a -> StrictMaybe a
SJust (HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV3])
        let govAction = StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange (GovPurposeId 'PParamUpdatePurpose
-> StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. a -> StrictMaybe a
SJust GovPurposeId 'PParamUpdatePurpose
govIdPPUpdate1) PParamsUpdate era
pparamsUpdate (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh)
        proposal <- mkProposal govAction
        let 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))
-> ((OSet (ProposalProcedure era)
     -> Identity (OSet (ProposalProcedure era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OSet (ProposalProcedure era)
    -> Identity (OSet (ProposalProcedure era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
 -> Identity (OSet (ProposalProcedure era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (OSet (ProposalProcedure era))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
  -> Identity (OSet (ProposalProcedure era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OSet (ProposalProcedure era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))
ProposalProcedure era
proposal]
        submitPhase2Invalid_ tx

    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Updating CostModels with alwaysSucceeds govPolicy but no PlutusV3 CostModels fails" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$
      ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL ((CostModels -> Identity CostModels)
 -> PParams era -> Identity (PParams era))
-> CostModels -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV1 .. Item [Language]
Language
PlutusV2]

        committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
        (dRep, _, _) <- setupSingleDRep 1_000_000
        anchor <- arbitrary
        let alwaysSucceedsSh = Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3)
        void $
          enactConstitution
            SNothing
            (Constitution anchor (SJust alwaysSucceedsSh))
            dRep
            committeeMembers'

        let pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL ((StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe CostModels -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CostModels -> StrictMaybe CostModels
forall a. a -> StrictMaybe a
SJust (HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV3])
        let govAction = StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh)

        submitFailingGovAction govAction [injectFailure $ Alonzo.CollectErrors [NoCostModel PlutusV3]]

    -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/1104
    -- TODO: Re-enable after issue is resolved, by removing this override
    String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Updating CostModels and setting the govPolicy afterwards succeeds" (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL ((CostModels -> Identity CostModels)
 -> PParams era -> Identity (PParams era))
-> CostModels -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV1 .. Item [Language]
Language
PlutusV2]

      committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
      (dRep, _, _) <- setupSingleDRep 1_000_000_000
      anchor <- arbitrary
      govIdConstitution1 <-
        enactConstitution SNothing (Constitution anchor SNothing) dRep committeeMembers'

      AnyLevelTx mintingTokenTx <- mkTokenMintingTx $ hashPlutusScript (evenRedeemerNoDatum SPlutusV3)

      impAnn "Minting token fails" $ do
        submitFailingTx mintingTokenTx [injectFailure $ Alonzo.CollectErrors [NoCostModel PlutusV3]]

      govIdPPUpdate1 <-
        enactCostModels
          SNothing
          (testingCostModels [PlutusV3])
          dRep
          committeeMembers'

      let alwaysSucceedsSh = Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3)
      void $
        enactConstitution
          (SJust (GovPurposeId govIdConstitution1))
          (Constitution anchor (SJust alwaysSucceedsSh))
          dRep
          committeeMembers'

      impAnn "Minting token succeeds" $ do
        submitAnyTx_ mintingTokenTx

      impAnn "Updating CostModels succeeds" $ do
        void $
          enactCostModels
            (SJust govIdPPUpdate1)
            (testingCostModels [PlutusV3])
            dRep
            committeeMembers'

scriptLockedTxOut ::
  forall era.
  AlonzoEraTxOut era =>
  ScriptHash ->
  TxOut era
scriptLockedTxOut :: forall era. AlonzoEraTxOut era => ScriptHash -> TxOut era
scriptLockedTxOut ScriptHash
shSpending =
  Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
    (ScriptHash -> StakeReference -> Addr
forall p s.
(MakeCredential p Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
shSpending StakeReference
StakeRefNull)
    Value era
forall a. Monoid a => a
mempty
    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
.~ DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust (forall era. Data era -> DataHash
hashData @era (Data era -> DataHash) -> Data era -> DataHash
forall a b. (a -> b) -> a -> b
$ Data -> Data era
forall era. Era era => Data -> Data era
Data Data
spendDatum)

mkRefTxOut ::
  ( BabbageEraTxOut era
  , AlonzoEraImp era
  ) =>
  ScriptHash ->
  ImpTestM era (TxOut era)
mkRefTxOut :: forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash
sh = do
  let mbyPlutusScript :: Maybe (PlutusScript era)
mbyPlutusScript = ScriptHash -> Maybe (PlutusScript era)
forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScript ScriptHash
sh
  addr <- case Maybe (PlutusScript era)
mbyPlutusScript of
    Just PlutusScript era
plutusScript
      | PlutusScript era -> Language
forall era. AlonzoEraScript era => PlutusScript era -> Language
plutusScriptLanguage PlutusScript era
plutusScript Language -> Language -> Bool
forall a. Ord a => a -> a -> Bool
>= Language
PlutusV4 -> ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddrNoPtr_
    Maybe (PlutusScript era)
_ -> ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
  pure $
    mkBasicTxOut addr mempty
      & referenceScriptTxOutL .~ maybeToStrictMaybe (fromPlutusScript <$> mbyPlutusScript)

setupRefTx ::
  forall era l.
  ( BabbageEraTxOut era
  , AlonzoEraImp era
  , PlutusLanguage l
  ) =>
  SLanguage l ->
  ImpTestM era TxId
setupRefTx :: forall era (l :: Language).
(BabbageEraTxOut era, AlonzoEraImp era, PlutusLanguage l) =>
SLanguage l -> ImpTestM era TxId
setupRefTx SLanguage l
lang = do
  let shSpending :: ScriptHash
shSpending = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
lang)
  refTxOut <- ScriptHash -> ImpM (LedgerSpec era) (TxOut era)
forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash
shSpending
  fmap txIdTx . submitTxAnn "Producing transaction" $
    mkBasicTx mkBasicTxBody
      & bodyTxL . outputsTxBodyL
        .~ SSeq.fromList
          [ refTxOut
          , scriptLockedTxOut shSpending
          , scriptLockedTxOut shSpending
          ]

testPlutusV1V2Failure ::
  forall era a.
  ( HasCallStack
  , ConwayEraImp era
  ) =>
  ScriptHash ->
  a ->
  Lens' (TxBody TopTx era) a ->
  ContextError era ->
  ImpTestM era ()
testPlutusV1V2Failure :: forall era a.
(HasCallStack, ConwayEraImp era) =>
ScriptHash
-> a
-> Lens' (TxBody TopTx era) a
-> ContextError era
-> ImpTestM era ()
testPlutusV1V2Failure ScriptHash
sh a
badField Lens' (TxBody TopTx era) a
lenz ContextError era
errorField = do
  txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript @era ScriptHash
sh
  submitFailingTx
    ( mkBasicTx mkBasicTxBody
        & bodyTxL . inputsTxBodyL .~ Set.singleton txIn
        & bodyTxL . lenz .~ badField
    )
    ( pure . injectFailure $
        Alonzo.CollectErrors [BadTranslation errorField]
    )

enactCostModels ::
  ConwayEraImp era =>
  StrictMaybe (GovPurposeId 'PParamUpdatePurpose) ->
  CostModels ->
  Credential DRepRole ->
  NonEmpty (Credential HotCommitteeRole) ->
  ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
enactCostModels :: forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> CostModels
-> Credential DRepRole
-> NonEmpty (Credential HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
enactCostModels StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
prevGovId CostModels
cms Credential DRepRole
dRep NonEmpty (Credential HotCommitteeRole)
committeeMembers' = do
  initialCms <- SimpleGetter (NewEpochState era) CostModels
-> ImpTestM era CostModels
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) CostModels
 -> ImpTestM era CostModels)
-> SimpleGetter (NewEpochState era) CostModels
-> ImpTestM era CostModels
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((CostModels -> Const r CostModels)
    -> EpochState era -> Const r (EpochState era))
-> (CostModels -> Const r CostModels)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((CostModels -> Const r CostModels)
    -> PParams era -> Const r (PParams era))
-> (CostModels -> Const r CostModels)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CostModels -> Const r CostModels)
-> PParams era -> Const r (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL
  let pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL ((StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe CostModels -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CostModels -> StrictMaybe CostModels
forall a. a -> StrictMaybe a
SJust CostModels
cms
  govId <- submitParameterChange (unGovPurposeId <$> prevGovId) pparamsUpdate
  submitYesVote_ (DRepVoter dRep) govId
  submitYesVoteCCs_ committeeMembers' govId
  passNEpochs 2
  enactedCms <- getsNES $ nesEsL . curPParamsEpochStateL . ppCostModelsL
  enactedCms `shouldBe` updateCostModels initialCms (CostModelsUpdate cms)
  pure $ GovPurposeId govId

spendDatum :: P1.Data
spendDatum :: Data
spendDatum = Integer -> Data
P1.I Integer
3