{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec (spec) where
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Plutus.Context (LedgerTxInfo (..), toPlutusTxInfo)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (
CollectError (NoCostModel),
TransactionScriptFailure (RedeemerPointsToUnknownScriptHash),
evalTxExUnits,
)
import Cardano.Ledger.Alonzo.Rules (
AlonzoUtxosPredFailure (..),
TagMismatchDescription (..),
)
import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), eraLanguages)
import Cardano.Ledger.Alonzo.TxWits (unRedeemersL)
import Cardano.Ledger.BaseTypes (
Globals (..),
ProtVer (..),
SlotNo (..),
StrictMaybe (..),
natVersion,
)
import Cardano.Ledger.Plutus.Data (Data (..))
import Cardano.Ledger.Plutus.Language (hashPlutusScript, withSLanguage)
import qualified Cardano.Ledger.Plutus.Language as L
import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL)
import Cardano.Slotting.Time (SystemStart (SystemStart))
import Control.Monad.Reader (asks)
import Data.Either (isLeft)
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (Proxy))
import qualified Data.Set as Set
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Lens.Micro (set, to, (%~), (&), (.~), (<>~), (^.), _2)
import Lens.Micro.Mtl (use)
import qualified PlutusLedgerApi.Common as P
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (
alwaysFailsWithDatum,
alwaysSucceedsWithDatum,
datumIsWellformed,
inputsOutputsAreNotEmptyWithDatum,
purposeIsWellformedWithDatum,
redeemerSameAsDatum,
)
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
"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
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
String
"transaction validity interval has closed upper bound when protocol version < 9 and open otherwise"
(ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
ei <- Getting
(EpochInfo (Either Text))
(ImpTestState era)
(EpochInfo (Either Text))
-> ImpM (LedgerSpec era) (EpochInfo (Either Text))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting
(EpochInfo (Either Text))
(ImpTestState era)
(EpochInfo (Either Text))
-> ImpM (LedgerSpec era) (EpochInfo (Either Text)))
-> Getting
(EpochInfo (Either Text))
(ImpTestState era)
(EpochInfo (Either Text))
-> ImpM (LedgerSpec era) (EpochInfo (Either Text))
forall a b. (a -> b) -> a -> b
$ (Globals -> Const (EpochInfo (Either Text)) Globals)
-> ImpTestState era
-> Const (EpochInfo (Either Text)) (ImpTestState era)
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL ((Globals -> Const (EpochInfo (Either Text)) Globals)
-> ImpTestState era
-> Const (EpochInfo (Either Text)) (ImpTestState era))
-> ((EpochInfo (Either Text)
-> Const (EpochInfo (Either Text)) (EpochInfo (Either Text)))
-> Globals -> Const (EpochInfo (Either Text)) Globals)
-> Getting
(EpochInfo (Either Text))
(ImpTestState era)
(EpochInfo (Either Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Globals -> EpochInfo (Either Text))
-> SimpleGetter Globals (EpochInfo (Either Text))
forall s a. (s -> a) -> SimpleGetter s a
to Globals -> EpochInfo (Either Text)
epochInfo
ss@(SystemStart sysStart) <- use $ impGlobalsL . to systemStart
SlotNo currentSlot <- use impCurSlotNoG
protVer <- getProtVer
utxo <- getUTxO
let txValidity = Word64
7200
interval = StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing (StrictMaybe SlotNo -> ValidityInterval)
-> StrictMaybe SlotNo -> ValidityInterval
forall a b. (a -> b) -> a -> b
$ SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (SlotNo -> StrictMaybe SlotNo) -> SlotNo -> StrictMaybe SlotNo
forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Word64
currentSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
txValidity
startPOSIX = POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Integer) -> POSIXTime -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
sysStart
expectedUpperBound = (Integer
startPOSIX Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
currentSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
txValidity)) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000
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))
-> ((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
.~ ValidityInterval
interval
lti =
LedgerTxInfo
{ ltiProtVer :: ProtVer
ltiProtVer = ProtVer
protVer
, ltiEpochInfo :: EpochInfo (Either Text)
ltiEpochInfo = EpochInfo (Either Text)
ei
, ltiSystemStart :: SystemStart
ltiSystemStart = SystemStart
ss
, ltiUTxO :: UTxO era
ltiUTxO = UTxO era
utxo
, ltiTx :: Tx TopTx era
ltiTx = Tx TopTx era
tx
}
case toPlutusTxInfo (Proxy @L.PlutusV1) lti of
Left ContextError era
e -> String -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpM (LedgerSpec era) ())
-> String -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ String
"No translation error was expected, but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ContextError era -> String
forall a. Show a => a -> String
show ContextError era
e
Right PlutusTxInfo 'PlutusV1
txInfo ->
TxInfo -> POSIXTimeRange
PV1.txInfoValidRange PlutusTxInfo 'PlutusV1
TxInfo
txInfo
POSIXTimeRange -> POSIXTimeRange -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` LowerBound POSIXTime -> UpperBound POSIXTime -> POSIXTimeRange
forall a. LowerBound a -> UpperBound a -> Interval a
PV1.Interval
(Extended POSIXTime -> Bool -> LowerBound POSIXTime
forall a. Extended a -> Bool -> LowerBound a
PV1.LowerBound Extended POSIXTime
forall a. Extended a
PV1.NegInf Bool
True)
( Extended POSIXTime -> Bool -> UpperBound POSIXTime
forall a. Extended a -> Bool -> UpperBound a
PV1.UpperBound
( POSIXTime -> Extended POSIXTime
forall a. a -> Extended a
PV1.Finite
(Integer -> POSIXTime
PV1.POSIXTime Integer
expectedUpperBound)
)
(ProtVer -> Version
pvMajor ProtVer
protVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9)
)
[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 ->
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
$
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 -> do
let redeemerSameAsDatumHash :: ScriptHash
redeemerSameAsDatumHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
slang
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
let scripts :: [(String, SLanguage l -> Plutus l)]
scripts =
[ (String
"redeemerSameAsDatum", SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum)
, (String
"purposeIsWellformedWithDatum", SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedWithDatum)
, (String
"datumIsWellformed", SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
datumIsWellformed)
, (String
"inputsOutputsAreNotEmptyWithDatum", SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
inputsOutputsAreNotEmptyWithDatum)
]
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ExUnits" (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
"Calculate ExUnits" (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
overrideExUnits :: Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
overrideExUnits Tx TopTx era
tx = do
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
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))
-> ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> 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
utxo <- getUTxO
Globals {epochInfo, systemStart} <- use impGlobalsL
purposeUnits <-
either (fail . show) pure . sequence $
evalTxExUnits pp tx utxo epochInfo systemStart
pure $ tx & witsTxL . rdmrsTxWitsL . unRedeemersL %~ spliceUnits purposeUnits
spliceUnits :: Map (PlutusPurpose AsIx era) ExUnits
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
spliceUnits =
SimpleWhenMissing
(PlutusPurpose AsIx era) ExUnits (Data era, ExUnits)
-> SimpleWhenMissing
(PlutusPurpose AsIx era) (Data era, ExUnits) (Data era, ExUnits)
-> SimpleWhenMatched
(PlutusPurpose AsIx era)
ExUnits
(Data era, ExUnits)
(Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) ExUnits
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
SimpleWhenMissing
(PlutusPurpose AsIx era) ExUnits (Data era, ExUnits)
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing
SimpleWhenMissing
(PlutusPurpose AsIx era) (Data era, ExUnits) (Data era, ExUnits)
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
Map.preserveMissing
((PlutusPurpose AsIx era
-> ExUnits -> (Data era, ExUnits) -> (Data era, ExUnits))
-> SimpleWhenMatched
(PlutusPurpose AsIx era)
ExUnits
(Data era, ExUnits)
(Data era, ExUnits)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched ((PlutusPurpose AsIx era
-> ExUnits -> (Data era, ExUnits) -> (Data era, ExUnits))
-> SimpleWhenMatched
(PlutusPurpose AsIx era)
ExUnits
(Data era, ExUnits)
(Data era, ExUnits))
-> (PlutusPurpose AsIx era
-> ExUnits -> (Data era, ExUnits) -> (Data era, ExUnits))
-> SimpleWhenMatched
(PlutusPurpose AsIx era)
ExUnits
(Data era, ExUnits)
(Data era, ExUnits)
forall a b. (a -> b) -> a -> b
$ \PlutusPurpose AsIx era
_ -> ASetter (Data era, ExUnits) (Data era, ExUnits) ExUnits ExUnits
-> ExUnits -> (Data era, ExUnits) -> (Data era, ExUnits)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Data era, ExUnits) (Data era, ExUnits) ExUnits ExUnits
forall s t a b. Field2 s t a b => Lens s t a b
Lens (Data era, ExUnits) (Data era, ExUnits) ExUnits ExUnits
_2)
redoAddrWits :: Tx l era -> ImpTestM era (Tx l era)
redoAddrWits = Tx l era -> ImpTestM era (Tx l era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
updateAddrTxWits (Tx l era -> ImpTestM era (Tx l era))
-> (Tx l era -> Tx l era) -> Tx l era -> ImpTestM era (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxWits era -> Identity (TxWits era))
-> Tx l era -> Identity (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
-> Tx l era -> Identity (Tx l era))
-> ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> TxWits era -> Identity (TxWits era))
-> (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey Witness))
Lens' (TxWits era) (Set (WitVKey Witness))
addrTxWitsL ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> Tx l era -> Identity (Tx l era))
-> Set (WitVKey Witness) -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey Witness)
forall a. Monoid a => a
mempty)
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
withPostFixup (overrideExUnits >=> fixupPPHash >=> redoAddrWits) $
submitTx_ $
mkBasicTx mkBasicTxBody & bodyTxL . inputsTxBodyL .~ [txIn]
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Attempt to calculate ExUnits with an invalid tx" (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
alwaysSucceedsWithDatumHash
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 (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]
txFixed <- (tx &) =<< asks iteFixup
logToExpr txFixed
let
twiddleIx (SJust (SpendingPurpose (AsIx Word32
0))) = AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
1)
twiddleIx StrictMaybe (PlutusPurpose AsIx era)
_ = AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0)
badPurpose =
StrictMaybe (PlutusPurpose AsIx era) -> PlutusPurpose AsIx era
forall {era} {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 ...),
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 ...),
AlonzoEraScript era, AlonzoEraScript era) =>
StrictMaybe (PlutusPurpose AsIx era) -> PlutusPurpose AsIx era
twiddleIx (StrictMaybe (PlutusPurpose AsIx era) -> PlutusPurpose AsIx era)
-> StrictMaybe (PlutusPurpose AsIx era) -> PlutusPurpose AsIx era
forall a b. (a -> b) -> a -> b
$
TxBody TopTx era
-> PlutusPurpose AsItem era -> StrictMaybe (PlutusPurpose AsIx era)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
TxBody l era
-> PlutusPurpose AsItem era -> StrictMaybe (PlutusPurpose AsIx era)
forall (l :: TxLevel).
TxBody l era
-> PlutusPurpose AsItem era -> StrictMaybe (PlutusPurpose AsIx era)
redeemerPointer (Tx TopTx era
txFixed Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody 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) (AsItem Word32 TxIn -> PlutusPurpose AsItem era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose (AsItem Word32 TxIn -> PlutusPurpose AsItem era)
-> AsItem Word32 TxIn -> PlutusPurpose AsItem era
forall a b. (a -> b) -> a -> b
$ TxIn -> AsItem Word32 TxIn
forall ix it. it -> AsItem ix it
AsItem TxIn
txIn)
du = (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
PV1.I Integer
42, Natural -> Natural -> ExUnits
ExUnits Natural
5000 Natural
5000)
txBorked =
Tx TopTx era
txFixed
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
badPurpose (Data era, ExUnits)
du
logToExpr txBorked
pp <- getsNES $ nesEsL . curPParamsEpochStateL
utxo <- getUTxO
Globals {epochInfo, systemStart} <- use impGlobalsL
let report = PParams era
-> Tx TopTx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> Map
(PlutusPurpose AsIx era)
(Either (TransactionScriptFailure era) ExUnits)
forall era.
(AlonzoEraTx era, EraUTxO era, EraPlutusContext era,
ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
PParams era
-> Tx TopTx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReport era
evalTxExUnits PParams era
pp Tx TopTx era
txBorked UTxO era
utxo EpochInfo (Either Text)
epochInfo SystemStart
systemStart
logToExpr report
Map.filter isLeft report
`shouldBe` Map.singleton badPurpose (Left (RedeemerPointsToUnknownScriptHash badPurpose))
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Spending scripts with 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
[(String, SLanguage l -> Plutus l)]
-> ((String, SLanguage l -> Plutus l)
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, SLanguage l -> Plutus l)]
scripts (((String, SLanguage l -> Plutus l)
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era)))
-> ((String, SLanguage l -> Plutus l)
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \(String
name, SLanguage l -> Plutus l
script) -> do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
name (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 sHash :: ScriptHash
sHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage l -> Plutus l
script SLanguage l
slang)
txIn0 <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
sHash
submitTxAnn_ "Submit a transaction that consumes the script output" $
mkBasicTx mkBasicTxBody
& bodyTxL . inputsTxBodyL
.~ Set.singleton txIn0
passEpoch
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Valid transaction marked as invalid" (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 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
& (IsValid -> Identity IsValid)
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL ((IsValid -> Identity IsValid)
-> Tx TopTx era -> Identity (Tx TopTx era))
-> IsValid -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> IsValid
IsValid Bool
False
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
tx [AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch (Bool -> IsValid
IsValid Bool
False) TagMismatchDescription
PassedUnexpectedly)]
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Invalid transaction marked as valid" (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 -> 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
alwaysFailsWithDatum SLanguage l
slang
submitPhase2Invalid_ $ mkBasicTx mkBasicTxBody & bodyTxL . inputsTxBodyL .~ [txIn]
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Invalid plutus script fails in phase 2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
txIn0 <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
redeemerSameAsDatumHash
exUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL
submitTxAnn_ "Submitting consuming transaction" $
mkBasicTx mkBasicTxBody
& bodyTxL . inputsTxBodyL .~ Set.singleton txIn0
& isValidTxL .~ IsValid False
& witsTxL . rdmrsTxWitsL . unRedeemersL
.~ Map.singleton (mkSpendingPurpose $ AsIx 0) (Data $ P.I 32, exUnits)
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Scripts pass in phase 2" (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 scripts' :: [(String, SLanguage l -> Plutus l)]
scripts' = Int
-> [(String, SLanguage l -> Plutus l)]
-> [(String, SLanguage l -> Plutus l)]
forall a. Int -> [a] -> [a]
drop Int
1 [(String, SLanguage l -> Plutus l)]
scripts
[(String, SLanguage l -> Plutus l)]
-> ((String, SLanguage l -> Plutus l)
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, SLanguage l -> Plutus l)]
scripts' (((String, SLanguage l -> Plutus l)
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era)))
-> ((String, SLanguage l -> Plutus l)
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \(String
name, SLanguage l -> Plutus l
script) -> do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
name (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 sHash :: ScriptHash
sHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage l -> Plutus l
script SLanguage l
slang)
txIn0 <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
sHash
submitTxAnn_ "Submitting consuming transaction" $
mkBasicTx mkBasicTxBody
& bodyTxL . inputsTxBodyL .~ Set.singleton txIn0
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"No cost model" (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
alwaysSucceedsWithDatumHash
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 (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
txIn]
modifyPParams $ ppCostModelsL .~ mempty
submitFailingTx
tx
[injectFailure (CollectErrors [NoCostModel lang])]