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

module Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Valid (spec, alonzoToConwaySpec) where

import Cardano.Ledger.Address
import Cardano.Ledger.Allegra.Scripts (
  pattern RequireTimeExpire,
 )
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
import Cardano.Ledger.Alonzo.TxWits (unTxDatsL)
import Cardano.Ledger.BaseTypes (Globals (networkId), StrictMaybe (..), inject, natVersion)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..), StakeReference (..), credToText)
import Cardano.Ledger.Mary.Value (AssetName (..), MaryValue (..), MultiAsset (..), PolicyID (..))
import Cardano.Ledger.Plutus (
  Data (..),
  hashData,
  hashPlutusScript,
  withSLanguage,
 )
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
  pattern RequireSignature,
 )
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Text as T
import Data.Typeable (Typeable)
import GHC.Exts (fromList)
import Lens.Micro (to, (%~), (&), (.~))
import Lens.Micro.Mtl (use)
import qualified PlutusLedgerApi.Common as P
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Core.Utils
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples

spec :: forall era. AlonzoEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. AlonzoEraImp 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
"Valid transactions" (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
"Non-script output with datum" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Attach a datum (hash) to a non-script output and then spend it.
    -- Note that the datum cannot be supplied when spending the output,
    -- because it's considered extraneous.
    addr <- KeyHash Payment -> StakeReference -> Addr
forall p s.
(MakeCredential p Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr (KeyHash Payment -> StakeReference -> Addr)
-> ImpM (LedgerSpec era) (KeyHash Payment)
-> ImpM (LedgerSpec era) (StakeReference -> Addr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @Payment ImpM (LedgerSpec era) (StakeReference -> Addr)
-> ImpM (LedgerSpec era) StakeReference
-> ImpM (LedgerSpec era) Addr
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StakeReference -> ImpM (LedgerSpec era) StakeReference
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StakeReference
StakeRefNull
    amount <- Coin <$> choose (2_000_000, 8_000_000)
    let
      datumHash = 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 (Integer -> Data
P.I Integer
123)
      txOut = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
amount) 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 DataHash
datumHash
      tx1 = TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxOut era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
txOut]
    txIn <- txInAt 0 <$> submitTx tx1
    submitAnyTx_ $ mkBasicTx mkBasicTxBody & bodyTxL . inputsTxBodyL .~ [txIn]

  [Language]
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era. AlonzoEraScript era => [Language]
eraLanguages @era) ((Language -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \Language
lang ->
    Language
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang ((forall (l :: Language).
  PlutusLanguage l =>
  SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (forall (l :: Language).
    PlutusLanguage l =>
    SLanguage l -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \SLanguage l
slang ->
      String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (Language -> String
forall a. Show a => a -> String
show Language
lang) (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
        let
          alwaysSucceedsWithDatumHash :: ScriptHash
alwaysSucceedsWithDatumHash = 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
alwaysSucceedsWithDatum SLanguage l
slang :: ScriptHash
          alwaysSucceedsNoDatumHash :: ScriptHash
alwaysSucceedsNoDatumHash = 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
alwaysSucceedsNoDatum SLanguage l
slang :: ScriptHash
          alwaysFailsWithDatumHash :: ScriptHash
alwaysFailsWithDatumHash = 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
alwaysFailsWithDatum SLanguage l
slang :: ScriptHash
          alwaysFailsNoDatumHash :: ScriptHash
alwaysFailsNoDatumHash = 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
alwaysFailsNoDatum SLanguage l
slang :: ScriptHash

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating SPEND script" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          txIn <- ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
          submitAnyTx_ $
            mkBasicTx $
              mkBasicTxBody & inputsTxBodyL .~ [txIn]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating SPEND script" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          txIn <- ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysFailsWithDatumHash
          submitPhase2Invalid_ $
            mkBasicTx $
              mkBasicTxBody & inputsTxBodyL .~ [txIn]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating CERT script" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          txIn <- ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
          txCert <- genRegTxCert $ ScriptHashObj alwaysSucceedsNoDatumHash
          -- TODO: Switch to `submitAnyTx_` once the Dijkstra sub-transaction fixup estimates
          -- execution units instead of assigning the maximum to every redeemer. With two scripts
          -- in a sub-transaction the total exceeds the maximum execution units of a transaction
          submitTx_ $
            mkBasicTx $
              mkBasicTxBody
                & inputsTxBodyL .~ [txIn]
                & certsTxBodyL .~ [txCert]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating WITHDRAWAL script" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          account <- Credential Staking -> ImpTestM era AccountAddress
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era AccountAddress
registerStakeCredential (Credential Staking -> ImpTestM era AccountAddress)
-> Credential Staking -> ImpTestM era AccountAddress
forall a b. (a -> b) -> a -> b
$ ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
alwaysSucceedsNoDatumHash
          submitAnyTx_ $
            mkBasicTx $
              mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)]

        -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/1279
        -- TODO: Re-enable after issues are 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
"Validating MINT script" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          AnyLevelTx tx <- ScriptHash -> ImpTestM era (AnyLevelTx era)
forall era.
AlonzoEraImp era =>
ScriptHash -> ImpTestM era (AnyLevelTx era)
mkTokenMintingTx ScriptHash
alwaysSucceedsNoDatumHash
          submitAnyTx_ tx

        -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/1279
        -- TODO: Re-enable after issues are 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
"Not validating MINT script" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          AnyLevelTx tx <- ScriptHash -> ImpTestM era (AnyLevelTx era)
forall era.
AlonzoEraImp era =>
ScriptHash -> ImpTestM era (AnyLevelTx era)
mkTokenMintingTx ScriptHash
alwaysFailsNoDatumHash
          submitPhase2Invalid_ tx

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Acceptable supplementary datum" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          inputAddr <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @Payment
          amount <- Coin <$> choose (2_000_000, 8_000_000)
          txIn <- sendCoinTo (mkAddr inputAddr StakeRefNull) amount
          let
            datum = Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
123)
            datumHash = Data era -> DataHash
forall era. Data era -> DataHash
hashData Data era
datum
            txOut =
              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
alwaysSucceedsWithDatumHash StakeReference
StakeRefNull)
                (Coin -> MultiAsset -> MaryValue
MaryValue Coin
amount MultiAsset
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 DataHash
datumHash
          submitAnyTx_ $
            mkBasicTx
              ( mkBasicTxBody
                  & inputsTxBodyL .~ [txIn]
                  & outputsTxBodyL .~ [txOut]
              )
              & witsTxL . datsTxWitsL . unTxDatsL %~ Map.insert datumHash datum

alonzoToConwaySpec ::
  forall era.
  (AlonzoEraImp era, ShelleyEraTxCert era) =>
  SpecWith (ImpInit (LedgerSpec era))
alonzoToConwaySpec :: forall era.
(AlonzoEraImp era, ShelleyEraTxCert era) =>
SpecWith (ImpInit (LedgerSpec era))
alonzoToConwaySpec = do
  [Language]
-> (Language -> SpecM (ImpInit (LedgerSpec era)) ())
-> SpecM (ImpInit (LedgerSpec era)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era. AlonzoEraScript era => [Language]
eraLanguages @era) ((Language -> 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
        let
          alwaysSucceedsWithDatumHash :: ScriptHash
alwaysSucceedsWithDatumHash = 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
alwaysSucceedsWithDatum SLanguage l
slang :: ScriptHash
          alwaysSucceedsNoDatumHash :: ScriptHash
alwaysSucceedsNoDatumHash = 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
alwaysSucceedsNoDatum SLanguage l
slang :: ScriptHash
          alwaysFailsWithDatumHash :: ScriptHash
alwaysFailsWithDatumHash = 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
alwaysFailsWithDatum SLanguage l
slang :: ScriptHash
          alwaysFailsNoDatumHash :: ScriptHash
alwaysFailsNoDatumHash = 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
alwaysFailsNoDatum SLanguage l
slang :: ScriptHash

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating CERT script" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysFailsWithDatumHash
          let txCert = Credential Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential Staking -> TxCert era
RegTxCert (Credential Staking -> TxCert era)
-> Credential Staking -> TxCert era
forall a b. (a -> b) -> a -> b
$ ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
alwaysSucceedsNoDatumHash
          submitPhase2Invalid_ $
            mkBasicTx $
              mkBasicTxBody
                & inputsTxBodyL .~ [txIn]
                & certsTxBodyL .~ [txCert]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating WITHDRAWAL script" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          account <- Credential Staking -> ImpM (LedgerSpec era) AccountAddress
forall {era}.
(Event (EraRule "LEDGER" era) ~ EraRuleEvent "LEDGER" era,
 Event (EraRule "TICK" era) ~ EraRuleEvent "TICK" era,
 PredicateFailure (EraRule "BBODY" era)
 ~ EraRuleFailure "BBODY" era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ EraRuleFailure "LEDGER" era,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ProtVerIsInBounds
   "at most"
   era
   11
   (OrdCond (CmpNat (ProtVerLow era) 11) 'True 'True 'False),
 ShelleyEraTxCert era, ShelleyEraImp era,
 ToExpr (EraRuleFailure "BBODY" era),
 ToExpr (EraRuleFailure "LEDGER" era),
 EncCBOR (EraRuleFailure "BBODY" era),
 EncCBOR (EraRuleFailure "LEDGER" era),
 Ord (EraRuleFailure "BBODY" era),
 Ord (EraRuleFailure "LEDGER" era),
 NFData (EraRuleFailure "BBODY" era),
 NFData (EraRuleFailure "LEDGER" era),
 Show (EraRuleFailure "BBODY" era),
 Show (EraRuleFailure "LEDGER" era),
 DecCBOR (EraRuleFailure "BBODY" era),
 DecCBOR (EraRuleFailure "LEDGER" era)) =>
Credential Staking -> ImpM (LedgerSpec era) AccountAddress
registerStakeCredentialNoDeposit (Credential Staking -> ImpM (LedgerSpec era) AccountAddress)
-> Credential Staking -> ImpM (LedgerSpec era) AccountAddress
forall a b. (a -> b) -> a -> b
$ ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
alwaysFailsNoDatumHash
          submitPhase2Invalid_ $
            mkBasicTx $
              mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(account, mempty)]

        --  Process a transaction with a succeeding script in every place possible,
        --  and also with succeeding timelock scripts.
        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating scripts everywhere" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          slotNo <- Getting SlotNo (ImpTestState era) SlotNo
-> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting SlotNo (ImpTestState era) SlotNo
forall era r. Getting r (ImpTestState era) SlotNo
impCurSlotNoG
          let
            timelockScriptHash SlotNo
i = do
              addr <- ImpM (LedgerSpec era) (KeyHash Witness)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
              impAddNativeScript $
                RequireAllOf [RequireSignature addr, RequireTimeExpire (slotNo + 100 + i)]
            scriptAsset ScriptHash
scriptHash = do
              Positive amount <- m (Positive b)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
              pure (PolicyID scriptHash, fromList [(AssetName "Test Asset", amount)])
          timelockScriptHash0 <- timelockScriptHash 0
          timelockScriptHash1 <- timelockScriptHash 1
          timelockScriptHash2 <- timelockScriptHash 2
          let
            inputScriptHashes = [Item [ScriptHash]
ScriptHash
alwaysSucceedsWithDatumHash, Item [ScriptHash]
ScriptHash
timelockScriptHash0]
            assetScriptHashes = [Item [ScriptHash]
ScriptHash
alwaysSucceedsNoDatumHash, Item [ScriptHash]
ScriptHash
timelockScriptHash1]
            rewardScriptHashes = [Item [ScriptHash]
ScriptHash
alwaysSucceedsNoDatumHash, Item [ScriptHash]
ScriptHash
timelockScriptHash2]
          txIns <- traverse produceScript inputScriptHashes
          multiAsset <- MultiAsset . fromList <$> traverse scriptAsset assetScriptHashes
          rewardAccounts <- traverse (registerStakeCredentialNoDeposit . ScriptHashObj) rewardScriptHashes
          outputAddr <- freshKeyHash @Payment
          let
            txOut =
              Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                (KeyHash Payment -> StakeReference -> Addr
forall p s.
(MakeCredential p Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyHash Payment
outputAddr StakeReference
StakeRefNull)
                (Coin -> MultiAsset -> MaryValue
MaryValue Coin
forall a. Monoid a => a
mempty MultiAsset
multiAsset)
          submitAnyTx_ $
            mkBasicTx $
              mkBasicTxBody
                & inputsTxBodyL .~ fromList txIns
                & vldtTxBodyL .~ ValidityInterval SNothing (SJust $ slotNo + 1)
                & mintTxBodyL .~ multiAsset
                & withdrawalsTxBodyL .~ Withdrawals (fromList [(acct, mempty) | acct <- rewardAccounts])
                & certsTxBodyL .~ fromList (UnRegTxCert . ScriptHashObj <$> rewardScriptHashes)
                & outputsTxBodyL .~ [txOut]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Multiple identical certificates" (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 = ScriptHash
alwaysSucceedsNoDatumHash
          ImpM (LedgerSpec era) AccountAddress -> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) AccountAddress -> ImpM (LedgerSpec era) ())
-> (Credential Staking -> ImpM (LedgerSpec era) AccountAddress)
-> Credential Staking
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential Staking -> ImpM (LedgerSpec era) AccountAddress
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era AccountAddress
registerStakeCredential (Credential Staking -> ImpM (LedgerSpec era) ())
-> Credential Staking -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash
          let tx :: forall l. Typeable l => Tx l era
              tx :: forall (l :: TxLevel). 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
                  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
.~ [Item (StrictSeq (TxCert era))] -> StrictSeq (TxCert era)
forall l. IsList l => [Item l] -> l
fromList (Credential Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential Staking -> TxCert era
UnRegTxCert (Credential Staking -> TxCert era)
-> (ScriptHash -> Credential Staking) -> ScriptHash -> TxCert era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> TxCert era) -> [ScriptHash] -> [TxCert era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ScriptHash -> [ScriptHash]
forall a. Int -> a -> [a]
replicate Int
2 ScriptHash
scriptHash)
          if forall era. Era era => Version
eraProtVerLow @era Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Nat).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9
            then
              -- This passes UTXOW rules but not DELEG rules; however, we care about only UTXOW rules here
              Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
                Tx TopTx era
forall (l :: TxLevel). Typeable l => Tx l era
tx
                [ShelleyDelegPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyDelegPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyDelegPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Credential Staking -> ShelleyDelegPredFailure era
forall era. Credential Staking -> ShelleyDelegPredFailure era
Shelley.StakeKeyNotRegisteredDELEG (ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash)]
            else
              -- Conway fixed the bug that was causing DELEG to fail
              (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ Tx l era
forall (l :: TxLevel). Typeable l => Tx l era
tx
  where
    -- NOTE: certain tests somehow require certificates without deposits
    -- otherwise, they will yield a Plutus failure
    -- TODO: figure out what's the problem, this might be of interest:
    -- https://github.com/IntersectMBO/cardano-ledger/issues/4571
    registerStakeCredentialNoDeposit :: Credential Staking -> ImpM (LedgerSpec era) AccountAddress
registerStakeCredentialNoDeposit Credential Staking
cred = do
      String -> Tx TopTx era -> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx TopTx era -> ImpTestM era ()
submitTxAnn_ (String
"Register Staking Address: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Credential Staking -> Text
forall (kr :: KeyRole). Credential kr -> Text
credToText Credential Staking
cred)) (Tx TopTx era -> ImpTestM era ())
-> Tx TopTx era -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
        TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
          Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx 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 TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxCert era) -> Tx TopTx era -> Tx TopTx 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.fromList [Credential Staking -> TxCert era
forall era.
ShelleyEraTxCert era =>
Credential Staking -> TxCert era
RegTxCert Credential Staking
cred]
      nId <- Getting Network (ImpTestState era) Network
-> ImpM (LedgerSpec era) Network
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((Globals -> Const Network Globals)
-> ImpTestState era -> Const Network (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL ((Globals -> Const Network Globals)
 -> ImpTestState era -> Const Network (ImpTestState era))
-> ((Network -> Const Network Network)
    -> Globals -> Const Network Globals)
-> Getting Network (ImpTestState era) Network
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Globals -> Network) -> SimpleGetter Globals Network
forall s a. (s -> a) -> SimpleGetter s a
to Globals -> Network
networkId)
      pure $ AccountAddress nId (AccountId cred)