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

module Test.Cardano.Ledger.Alonzo.Imp.UtxoSpec (spec) where

import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Rules
import Cardano.Ledger.Alonzo.Scripts
import Cardano.Ledger.Alonzo.TxAuxData
import Cardano.Ledger.Alonzo.TxWits
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Credential
import qualified Cardano.Ledger.Metadata as M
import Cardano.Ledger.Plutus
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Tools
import Cardano.Ledger.TxIn
import Control.Monad (forM)
import qualified Data.Map.NonEmpty as NEM
import qualified Data.Map.Strict as Map
import Data.Ratio ((%))
import qualified Data.Set as Set
import qualified Data.Set.NonEmpty as NES
import Lens.Micro (to, (%~), (&), (.~), (<>~), (^.))
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
"UTXO" (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
"Wrong network ID" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ do
    Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
      (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))
-> ((StrictMaybe Network -> Identity (StrictMaybe Network))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictMaybe Network -> Identity (StrictMaybe Network))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe Network -> Identity (StrictMaybe Network))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe Network)
forall (l :: TxLevel). Lens' (TxBody l era) (StrictMaybe Network)
networkIdTxBodyL ((StrictMaybe Network -> Identity (StrictMaybe Network))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictMaybe Network -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Network -> StrictMaybe Network
forall a. a -> StrictMaybe a
SJust Network
Mainnet)
      [ AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
          Mismatch RelEQ Network -> AlonzoUtxoPredFailure era
forall era. Mismatch RelEQ Network -> AlonzoUtxoPredFailure era
WrongNetworkInTxBody Mismatch {mismatchSupplied :: Network
mismatchSupplied = Network
Mainnet, mismatchExpected :: Network
mismatchExpected = Network
Testnet}
      ]

  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Collateral input not in UTxO" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ do
    let neverSubmittedTx :: Tx TopTx era
neverSubmittedTx = 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
        bogusCollateralTxIn :: TxIn
bogusCollateralTxIn = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial (Tx TopTx era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx Tx TopTx era
neverSubmittedTx) Integer
0
        tx :: Tx TopTx era
tx =
          TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
            Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody TopTx era) (Set TxIn)
Lens' (TxBody TopTx era) (Set TxIn)
collateralInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Set TxIn -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
bogusCollateralTxIn]
    Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
      Tx TopTx era
tx
      [AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ NonEmptySet TxIn -> AlonzoUtxoPredFailure era
forall era. NonEmptySet TxIn -> AlonzoUtxoPredFailure era
BadInputsUTxO (TxIn -> NonEmptySet TxIn
forall a. a -> NonEmptySet a
NES.singleton TxIn
bogusCollateralTxIn)]

  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Collateral input already spent" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ do
    addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
    spentTxIn <- sendCoinTo addr (Coin 10_000_000)
    submitAnyTx_ $
      mkBasicTx mkBasicTxBody & bodyTxL . inputsTxBodyL .~ [spentTxIn]
    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))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody TopTx era) (Set TxIn)
Lens' (TxBody TopTx era) (Set TxIn)
collateralInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Set TxIn -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
spentTxIn]
    submitFailingTx
      tx
      [injectFailure $ BadInputsUTxO (NES.singleton spentTxIn)]

  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"OutputTooBigUTxO" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ do
    ImpTestM era ()
forall era. AlonzoEraImp era => ImpTestM era ()
restrictMaxValSizeToAdaOnly
    pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
    (multiAsset, txOut) <- freshAssetOutput
    let tooBigTxOut = PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp TxOut era
txOut
    submitFailingTx
      ( mkBasicTx mkBasicTxBody
          & bodyTxL . mintTxBodyL .~ multiAsset
          & bodyTxL . outputsTxBodyL .~ [tooBigTxOut]
      )
      [injectFailure $ OutputTooBigUTxO [outputTooBigEntry pp tooBigTxOut]]

  -- The formal specification does not check the number of collateral inputs
  -- TODO: Re-enable once it does, by removing this override
  String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"TooManyCollateralInputs" (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    maxCollateralInputs <- Lens' (PParams era) Word16 -> ImpTestM era Word16
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (Word16 -> f Word16) -> PParams era -> f (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
ppMaxCollateralInputsL
    collateralInputs <- replicateM (fromIntegral maxCollateralInputs + 1) freshFundedTxIn
    submitFailingTx
      ( mkBasicTx mkBasicTxBody
          & bodyTxL . collateralInputsTxBodyL .~ Set.fromList collateralInputs
      )
      [ injectFailure $
          TooManyCollateralInputs
            Mismatch
              { mismatchSupplied = maxCollateralInputs + 1
              , mismatchExpected = maxCollateralInputs
              }
      ]

  [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
        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Too many execution units for tx" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM 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 -> ImpTestM era TxIn)
-> (Plutus l -> ScriptHash) -> Plutus l -> ImpTestM era TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ImpTestM era TxIn) -> Plutus l -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang
          maxExUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
          let
            txExUnits = ExUnits
maxExUnits ExUnits -> ExUnits -> ExUnits
forall a. Semigroup a => a -> a -> a
<> Nat -> Nat -> ExUnits
ExUnits Nat
1 Nat
1
            prp = AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
forall (f :: * -> * -> *). f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0)
            dat = Data -> Data era
forall era. Era era => Data -> Data era
Data (Data -> Data era) -> Data -> Data era
forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
32
            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))
-> ((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
.~ [Item (Set TxIn)
TxIn
txIn]
                Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era -> Identity (Redeemers era)
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
unRedeemersL ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Tx TopTx era
-> Tx TopTx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PlutusPurpose AsIx era
prp (Data era
dat, ExUnits
txExUnits)
          submitFailingTx
            tx
            [ injectFailure $
                ExUnitsTooBigUTxO
                  Mismatch {mismatchSupplied = OrdExUnits txExUnits, mismatchExpected = OrdExUnits maxExUnits}
            ]

        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Insufficient collateral" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ do
          scriptInput <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (ScriptHash -> ImpTestM era TxIn)
-> ScriptHash -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ 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
          collateralAddr <- freshKeyAddr_
          collateralInput <- sendCoinTo collateralAddr mempty -- 0 will be changed to MinUTxO
          collateral <- (^. coinTxOutL) <$> impGetUTxO collateralInput
          -- We need to artificially blow up the fee to increase the required collateral.
          -- Unfortunately we do not have expensive enough scripts yet, so one other way
          -- to achieve the same thing is by increasing the size of the transactions by
          -- including random garbage. Auxiliary data fits the bill quite nicely
          metadata <-
            Map.fromList
              <$> forM
                [1 .. (12 * 1024 `div` 64)]
                (\Word64
ix -> (,) Word64
ix (Metadatum -> (Word64, Metadatum))
-> (ByteArray -> Metadatum) -> ByteArray -> (Word64, Metadatum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteArray -> Metadatum
M.B (ByteArray -> (Word64, Metadatum))
-> ImpM (LedgerSpec era) ByteArray
-> ImpM (LedgerSpec era) (Word64, Metadatum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ImpM (LedgerSpec era) ByteArray
forall a (m :: * -> *). HasStatefulGen a m => Int -> m ByteArray
uniformByteArrayM Int
64)
          let auxData = forall (f :: * -> *) era.
(Foldable f, AlonzoEraScript era) =>
Map Word64 Metadatum -> f (AlonzoScript era) -> AlonzoTxAuxData era
mkAlonzoTxAuxData @[] @era Map Word64 Metadatum
metadata []
              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))
-> ((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 a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [Item (Set TxIn)
TxIn
scriptInput]
                  Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody TopTx era) (Set TxIn)
Lens' (TxBody TopTx era) (Set TxIn)
collateralInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Set TxIn -> Tx TopTx era -> Tx TopTx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [Item (Set TxIn)
TxIn
collateralInput]
                  Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (TxAuxData era)))
-> Tx TopTx era -> Identity (Tx TopTx era)
(StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (AlonzoTxAuxData era)))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
auxDataTxL ((StrictMaybe (TxAuxData era)
  -> Identity (StrictMaybe (AlonzoTxAuxData era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictMaybe (AlonzoTxAuxData era)
-> Tx TopTx era
-> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AlonzoTxAuxData era -> StrictMaybe (AlonzoTxAuxData era)
forall a. a -> StrictMaybe a
SJust AlonzoTxAuxData era
auxData
          percentage <-
            getsNES $ nesEsL . curPParamsEpochStateL . ppCollateralPercentageL . to toInteger
          submitFailingTxM tx $ \Tx TopTx era
txFixed -> do
            let expectedCollateral :: Coin
expectedCollateral =
                  Integer -> Coin
Coin (Integer -> Coin)
-> (Ratio Integer -> Integer) -> Ratio Integer -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Integer -> Integer
forall b. Integral b => Ratio Integer -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Ratio Integer -> Coin) -> Ratio Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
txFixed Tx TopTx era -> Getting Integer (Tx TopTx era) Integer -> Integer
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const Integer (TxBody TopTx era))
-> Tx TopTx era -> Const Integer (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const Integer (TxBody TopTx era))
 -> Tx TopTx era -> Const Integer (Tx TopTx era))
-> ((Integer -> Const Integer Integer)
    -> TxBody TopTx era -> Const Integer (TxBody TopTx era))
-> Getting Integer (Tx TopTx era) Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Integer Coin)
-> TxBody TopTx era -> Const Integer (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((Coin -> Const Integer Coin)
 -> TxBody TopTx era -> Const Integer (TxBody TopTx era))
-> ((Integer -> Const Integer Integer)
    -> Coin -> Const Integer Coin)
-> (Integer -> Const Integer Integer)
-> TxBody TopTx era
-> Const Integer (TxBody TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Integer) -> SimpleGetter Coin Integer
forall s a. (s -> a) -> SimpleGetter s a
to Coin -> Integer
unCoin Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
percentage Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer
100
            NonEmpty (EraRuleFailure "LEDGER" era)
-> ImpM (LedgerSpec era) (NonEmpty (EraRuleFailure "LEDGER" era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ DeltaCoin -> Coin -> AlonzoUtxoPredFailure era
forall era. DeltaCoin -> Coin -> AlonzoUtxoPredFailure era
InsufficientCollateral (Coin -> DeltaCoin
toDeltaCoin Coin
collateral) Coin
expectedCollateral]

        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ScriptsNotPaidUTxO" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ do
          let scriptHash :: ScriptHash
scriptHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang
          scriptInput <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
          collateralInput <- sendCoinTo (mkAddr scriptHash StakeRefNull) (Coin 30_000_000)
          collateralTxOut <- impGetUTxO collateralInput
          submitFailingTx
            ( mkBasicTx mkBasicTxBody
                & bodyTxL . inputsTxBodyL .~ [scriptInput]
                & bodyTxL . collateralInputsTxBodyL .~ [collateralInput]
            )
            [injectFailure . ScriptsNotPaidUTxO $ NEM.singleton collateralInput collateralTxOut]

        -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/1279
        -- 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
"CollateralContainsNonADA" (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          scriptInput <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (ScriptHash -> ImpTestM era TxIn)
-> (Plutus l -> ScriptHash) -> Plutus l -> ImpTestM era TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ImpTestM era TxIn) -> Plutus l -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang
          (multiAsset, txOut) <- freshAssetOutput
          let collateralTxOut = TxOut era
txOut TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxOut era -> Identity (TxOut era)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL ((Coin -> Identity Coin) -> TxOut era -> Identity (TxOut era))
-> Coin -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
30_000_000
          collateralInput <-
            txInAt 0
              <$> submitTx
                ( mkBasicTx mkBasicTxBody
                    & bodyTxL . mintTxBodyL .~ multiAsset
                    & bodyTxL . outputsTxBodyL .~ [collateralTxOut]
                )
          submitFailingTx
            ( mkBasicTx mkBasicTxBody
                & bodyTxL . inputsTxBodyL .~ [scriptInput]
                & bodyTxL . collateralInputsTxBodyL .~ [collateralInput]
            )
            [injectFailure $ CollateralContainsNonADA (collateralTxOut ^. valueTxOutL)]

        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"NoCollateralInputs" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ do
          scriptInput <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (ScriptHash -> ImpTestM era TxIn)
-> (Plutus l -> ScriptHash) -> Plutus l -> ImpTestM era TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ImpTestM era TxIn) -> Plutus l -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang
          percentage <- toInteger <$> getsPParams ppCollateralPercentageL
          withPostFixup (rederiveAddrTxWits . (bodyTxL . collateralInputsTxBodyL .~ mempty)) $
            submitFailingTxM (mkBasicTx mkBasicTxBody & bodyTxL . inputsTxBodyL .~ [scriptInput]) $
              \Tx TopTx era
txFixed -> do
                let expectedCollateral :: Coin
expectedCollateral =
                      Integer -> Coin
Coin (Integer -> Coin)
-> (Ratio Integer -> Integer) -> Ratio Integer -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Integer -> Integer
forall b. Integral b => Ratio Integer -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Ratio Integer -> Coin) -> Ratio Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
txFixed Tx TopTx era -> Getting Integer (Tx TopTx era) Integer -> Integer
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const Integer (TxBody TopTx era))
-> Tx TopTx era -> Const Integer (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const Integer (TxBody TopTx era))
 -> Tx TopTx era -> Const Integer (Tx TopTx era))
-> ((Integer -> Const Integer Integer)
    -> TxBody TopTx era -> Const Integer (TxBody TopTx era))
-> Getting Integer (Tx TopTx era) Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Integer Coin)
-> TxBody TopTx era -> Const Integer (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((Coin -> Const Integer Coin)
 -> TxBody TopTx era -> Const Integer (TxBody TopTx era))
-> ((Integer -> Const Integer Integer)
    -> Coin -> Const Integer Coin)
-> (Integer -> Const Integer Integer)
-> TxBody TopTx era
-> Const Integer (TxBody TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Integer) -> SimpleGetter Coin Integer
forall s a. (s -> a) -> SimpleGetter s a
to Coin -> Integer
unCoin Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
percentage Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer
100
                NonEmpty (EraRuleFailure "LEDGER" era)
-> ImpM (LedgerSpec era) (NonEmpty (EraRuleFailure "LEDGER" era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                  [ AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ DeltaCoin -> Coin -> AlonzoUtxoPredFailure era
forall era. DeltaCoin -> Coin -> AlonzoUtxoPredFailure era
InsufficientCollateral (Integer -> DeltaCoin
DeltaCoin Integer
0) Coin
expectedCollateral
                  , AlonzoUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure AlonzoUtxoPredFailure era
forall era. AlonzoUtxoPredFailure era
NoCollateralInputs
                  ]