{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Alonzo.Tools (tests) where

import Cardano.Crypto.DSIGN
import qualified Cardano.Crypto.Hash as Crypto
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext)
import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose (..))
import Cardano.Ledger.Alonzo.TxWits
import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded)
import Cardano.Ledger.Api.Tx (RedeemerReport, TransactionScriptFailure (..), evalTxExUnits)
import Cardano.Ledger.BaseTypes (ProtVer (..), ShelleyBase, inject)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Crypto
import Cardano.Ledger.Plutus (
  Data (..),
  ExUnits (..),
  Language (..),
  exBudgetToExUnits,
  transExUnits,
 )
import Cardano.Ledger.SafeHash (hashAnnotated)
import Cardano.Ledger.Shelley.LedgerState (IncrementalStake (..), UTxOState (..))
import Cardano.Ledger.Shelley.Rules (UtxoEnv (..))
import Cardano.Ledger.Shelley.UTxO (EraUTxO (..), UTxO (..))
import Cardano.Slotting.EpochInfo (EpochInfo, fixedEpochInfo)
import Cardano.Slotting.Slot (EpochSize (..), SlotNo (..))
import Cardano.Slotting.Time (SystemStart (..), mkSlotLength)
import Control.State.Transition.Extended (STS (BaseM, Environment, Signal, State), TRC (TRC))
import Data.Default.Class (Default (..))
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Lens.Micro
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
import Test.Cardano.Ledger.Babbage.Serialisation.Generators ()
import Test.Cardano.Ledger.Core.KeyPair (mkWitnessVKey)
import Test.Cardano.Ledger.Examples.STSTestUtils (
  initUTxO,
  mkGenesisTxIn,
  mkTxDats,
  someAddr,
  someKeys,
 )
import Test.Cardano.Ledger.Generic.Proof (Proof (Alonzo, Babbage))
import Test.Cardano.Ledger.Generic.Scriptic (PostShelley, Scriptic, always)
import Test.Cardano.Ledger.Generic.Updaters
import Test.Cardano.Ledger.Plutus (zeroTestingCostModels)
import Test.Cardano.Ledger.Shelley.Utils (applySTSTest, runShelleyBase)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertFailure, testCase, (@=?))
import Test.Tasty.QuickCheck (Gen, Property, arbitrary, counterexample, testProperty)

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"ExUnit tools"
    [ forall a. Testable a => String -> a -> TestTree
testProperty String
"Plutus ExUnit translation round-trip" Gen Property
exUnitsTranslationRoundTrip
    , String -> [TestTree] -> TestTree
testGroup
        String
"Alonzo"
        [ String -> Assertion -> TestTree
testCase String
"calculate ExUnits" (forall era.
(BaseM (EraRule "UTXOS" era) ~ ShelleyBase,
 State (EraRule "UTXOS" era) ~ UTxOState era,
 Environment (EraRule "UTXOS" era) ~ UtxoEnv era,
 Signable
   (DSIGN (EraCrypto era))
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody),
 Signal (EraRule "UTXOS" era) ~ Tx era, STS (EraRule "UTXOS" era),
 AlonzoEraTx era, PostShelley era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraPlutusContext era, EraGov era) =>
Proof era -> Assertion
exampleExUnitCalc Proof (AlonzoEra StandardCrypto)
Alonzo)
        , String -> Assertion -> TestTree
testCase String
"attempt calculate ExUnits with invalid tx" (forall era.
(PostShelley era, AlonzoEraTx era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 Signable
   (DSIGN (EraCrypto era))
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody),
 EraPlutusContext era) =>
Proof era -> Assertion
exampleInvalidExUnitCalc Proof (AlonzoEra StandardCrypto)
Alonzo)
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"Babbage"
        [ String -> Assertion -> TestTree
testCase String
"calculate ExUnits" (forall era.
(BaseM (EraRule "UTXOS" era) ~ ShelleyBase,
 State (EraRule "UTXOS" era) ~ UTxOState era,
 Environment (EraRule "UTXOS" era) ~ UtxoEnv era,
 Signable
   (DSIGN (EraCrypto era))
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody),
 Signal (EraRule "UTXOS" era) ~ Tx era, STS (EraRule "UTXOS" era),
 AlonzoEraTx era, PostShelley era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraPlutusContext era, EraGov era) =>
Proof era -> Assertion
exampleExUnitCalc Proof (BabbageEra StandardCrypto)
Babbage)
        , String -> Assertion -> TestTree
testCase String
"attempt calculate ExUnits with invalid tx" (forall era.
(PostShelley era, AlonzoEraTx era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 Signable
   (DSIGN (EraCrypto era))
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody),
 EraPlutusContext era) =>
Proof era -> Assertion
exampleInvalidExUnitCalc Proof (BabbageEra StandardCrypto)
Babbage)
        ]
    ]

-- ExUnits should remain intact when translating to and from the plutus type
exUnitsTranslationRoundTrip :: Gen Property
exUnitsTranslationRoundTrip :: Gen Property
exUnitsTranslationRoundTrip = do
  ExUnits
e <- forall a. Arbitrary a => Gen a
arbitrary
  let result :: Maybe ExUnits
result = ExBudget -> Maybe ExUnits
exBudgetToExUnits (ExUnits -> ExBudget
transExUnits ExUnits
e)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ forall prop. Testable prop => String -> prop -> Property
counterexample
      ( String
"Before: "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ExUnits
e
          forall a. Semigroup a => a -> a -> a
<> String
"\n After: "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Maybe ExUnits
result
      )
    forall a b. (a -> b) -> a -> b
$ Maybe ExUnits
result forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ExUnits
e

testSystemStart :: SystemStart
testSystemStart :: SystemStart
testSystemStart = UTCTime -> SystemStart
SystemStart forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0

-- checks plutus script validation against a tx which has had
-- its ex units replaced by the output of evalTxExUnits
testExUnitCalculation ::
  forall era m.
  ( MonadFail m
  , BaseM (EraRule "UTXOS" era) ~ ShelleyBase
  , State (EraRule "UTXOS" era) ~ UTxOState era
  , Environment (EraRule "UTXOS" era) ~ UtxoEnv era
  , Signal (EraRule "UTXOS" era) ~ Tx era
  , AlonzoEraTx era
  , STS (EraRule "UTXOS" era)
  , EraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , EraPlutusContext era
  ) =>
  Tx era ->
  UTxOState era ->
  UtxoEnv era ->
  EpochInfo (Either Text) ->
  SystemStart ->
  (forall a. String -> m a) ->
  m ()
testExUnitCalculation :: forall era (m :: * -> *).
(MonadFail m, BaseM (EraRule "UTXOS" era) ~ ShelleyBase,
 State (EraRule "UTXOS" era) ~ UTxOState era,
 Environment (EraRule "UTXOS" era) ~ UtxoEnv era,
 Signal (EraRule "UTXOS" era) ~ Tx era, AlonzoEraTx era,
 STS (EraRule "UTXOS" era), EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
Tx era
-> UTxOState era
-> UtxoEnv era
-> EpochInfo (Either Text)
-> SystemStart
-> (forall a. String -> m a)
-> m ()
testExUnitCalculation Tx era
tx UTxOState era
utxoState UtxoEnv era
ue EpochInfo (Either Text)
ei SystemStart
ss forall a. String -> m a
err = do
  Tx era
tx' <- forall era (m :: * -> *).
(MonadFail m, AlonzoEraTx era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> (forall a. String -> m a)
-> m (Tx era)
updateTxExUnits Tx era
tx UTxO era
utxo EpochInfo (Either Text)
ei SystemStart
ss forall a. String -> m a
err
  UTxOState era
_ <-
    forall (m :: * -> *) e a.
(Monad m, Show e) =>
(String -> m a) -> Either e a -> m a
failLeft forall a. String -> m a
err forall a b. (a -> b) -> a -> b
$
      forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$
        forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTSTest @(EraRule "UTXOS" era) (forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
ue, UTxOState era
utxoState, Tx era
tx'))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    utxo :: UTxO era
utxo = forall era. UTxOState era -> UTxO era
utxosUtxo UTxOState era
utxoState

exampleExUnitCalc ::
  forall era.
  ( BaseM (EraRule "UTXOS" era) ~ ShelleyBase
  , State (EraRule "UTXOS" era) ~ UTxOState era
  , Environment (EraRule "UTXOS" era) ~ UtxoEnv era
  , Signable (DSIGN (EraCrypto era)) (Crypto.Hash (HASH (EraCrypto era)) EraIndependentTxBody)
  , Signal (EraRule "UTXOS" era) ~ Tx era
  , STS (EraRule "UTXOS" era)
  , AlonzoEraTx era
  , PostShelley era
  , EraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era
  , EraPlutusContext era
  , EraGov era
  ) =>
  Proof era ->
  IO ()
exampleExUnitCalc :: forall era.
(BaseM (EraRule "UTXOS" era) ~ ShelleyBase,
 State (EraRule "UTXOS" era) ~ UTxOState era,
 Environment (EraRule "UTXOS" era) ~ UtxoEnv era,
 Signable
   (DSIGN (EraCrypto era))
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody),
 Signal (EraRule "UTXOS" era) ~ Tx era, STS (EraRule "UTXOS" era),
 AlonzoEraTx era, PostShelley era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraPlutusContext era, EraGov era) =>
Proof era -> Assertion
exampleExUnitCalc Proof era
proof =
  forall era (m :: * -> *).
(MonadFail m, BaseM (EraRule "UTXOS" era) ~ ShelleyBase,
 State (EraRule "UTXOS" era) ~ UTxOState era,
 Environment (EraRule "UTXOS" era) ~ UtxoEnv era,
 Signal (EraRule "UTXOS" era) ~ Tx era, AlonzoEraTx era,
 STS (EraRule "UTXOS" era), EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
Tx era
-> UTxOState era
-> UtxoEnv era
-> EpochInfo (Either Text)
-> SystemStart
-> (forall a. String -> m a)
-> m ()
testExUnitCalculation
    (forall era.
(Scriptic era, AlonzoEraTx era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 Signable
   (DSIGN (EraCrypto era))
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody)) =>
Proof era -> PlutusPurpose AsIx era -> Tx era
exampleTx Proof era
proof (forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> AlonzoPlutusPurpose f era
AlonzoSpending (forall ix it. ix -> AsIx ix it
AsIx Word32
0)))
    (forall era.
(EraTxOut era, PostShelley era, EraGov era) =>
Proof era -> UTxOState era
ustate Proof era
proof)
    forall era. AlonzoEraPParams era => UtxoEnv era
uenv
    forall (m :: * -> *). Monad m => EpochInfo m
exampleEpochInfo
    SystemStart
testSystemStart
    forall a. HasCallStack => String -> IO a
assertFailure

exampleInvalidExUnitCalc ::
  forall era.
  ( PostShelley era
  , AlonzoEraTx era
  , EraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era
  , Signable
      (DSIGN (EraCrypto era))
      (Crypto.Hash (HASH (EraCrypto era)) EraIndependentTxBody)
  , EraPlutusContext era
  ) =>
  Proof era ->
  IO ()
exampleInvalidExUnitCalc :: forall era.
(PostShelley era, AlonzoEraTx era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 Signable
   (DSIGN (EraCrypto era))
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody),
 EraPlutusContext era) =>
Proof era -> Assertion
exampleInvalidExUnitCalc Proof era
proof =
  let report :: RedeemerReport era
report =
        forall era.
(AlonzoEraTx era, EraUTxO era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReport era
evalTxExUnits @era
          forall era. AlonzoEraPParams era => PParams era
testPParams
          (forall era.
(Scriptic era, AlonzoEraTx era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 Signable
   (DSIGN (EraCrypto era))
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody)) =>
Proof era -> PlutusPurpose AsIx era -> Tx era
exampleTx Proof era
proof (forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> AlonzoPlutusPurpose f era
AlonzoSpending (forall ix it. ix -> AsIx ix it
AsIx Word32
1)))
          (forall era.
(EraTxOut era, PostShelley era) =>
Proof era -> UTxO era
initUTxO Proof era
proof)
          forall (m :: * -> *). Monad m => EpochInfo m
exampleEpochInfo
          SystemStart
testSystemStart
   in case [(AlonzoPlutusPurpose AsIx era
rdmrPtr, TransactionScriptFailure era
failure) | (AlonzoPlutusPurpose AsIx era
rdmrPtr, Left TransactionScriptFailure era
failure) <- forall k a. Map k a -> [(k, a)]
Map.toList RedeemerReport era
report] of
        [] ->
          forall a. HasCallStack => String -> IO a
assertFailure String
"evalTxExUnits should have produced a failing report"
        [(AlonzoPlutusPurpose AsIx era
_, TransactionScriptFailure era
failure)] ->
          forall era. PlutusPurpose AsIx era -> TransactionScriptFailure era
RedeemerPointsToUnknownScriptHash (forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> AlonzoPlutusPurpose f era
AlonzoSpending (forall ix it. ix -> AsIx ix it
AsIx Word32
1))
            forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@=? TransactionScriptFailure era
failure
        [(AlonzoPlutusPurpose AsIx era, TransactionScriptFailure era)]
failures ->
          forall a. HasCallStack => String -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$
            String
"evalTxExUnits produce failing scripts with unexpected errors: "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [(AlonzoPlutusPurpose AsIx era, TransactionScriptFailure era)]
failures

exampleTx ::
  ( Scriptic era
  , AlonzoEraTx era
  , PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era
  , Signable (DSIGN (EraCrypto era)) (Crypto.Hash (HASH (EraCrypto era)) EraIndependentTxBody)
  ) =>
  Proof era ->
  PlutusPurpose AsIx era ->
  Tx era
exampleTx :: forall era.
(Scriptic era, AlonzoEraTx era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 Signable
   (DSIGN (EraCrypto era))
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody)) =>
Proof era -> PlutusPurpose AsIx era -> Tx era
exampleTx Proof era
pf PlutusPurpose AsIx era
ptr =
  forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (forall era.
(Scriptic era, AlonzoEraTxBody era, AlonzoEraScript era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Proof era -> TxBody era
validatingBody Proof era
pf)
    forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
wits
  where
    wits :: TxWits era
wits =
      forall era. EraTxWits era => TxWits era
mkBasicTxWits
        forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
addrTxWitsL
          forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList [forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
mkWitnessVKey (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated (forall era.
(Scriptic era, AlonzoEraTxBody era, AlonzoEraScript era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Proof era -> TxBody era
validatingBody Proof era
pf)) (forall era.
Era era =>
Proof era -> KeyPair 'Payment (EraCrypto era)
someKeys Proof era
pf)]
        forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens
  (TxWits era)
  (TxWits era)
  (Map (ScriptHash (EraCrypto era)) (Script era))
  [Script era]
hashScriptTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
3 Proof era
pf]
        forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraTxWits era =>
Lens (TxWits era) (TxWits era) (TxDats era) [Data era]
hashDataTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
123)]
        forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
          forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (forall k a. k -> a -> Map k a
Map.singleton PlutusPurpose AsIx era
ptr (forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
42), Natural -> Natural -> ExUnits
ExUnits Natural
5000 Natural
5000))

validatingBody ::
  forall era.
  ( Scriptic era
  , AlonzoEraTxBody era
  , AlonzoEraScript era
  , PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era
  ) =>
  Proof era ->
  TxBody era
validatingBody :: forall era.
(Scriptic era, AlonzoEraTxBody era, AlonzoEraScript era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Proof era -> TxBody era
validatingBody Proof era
pf =
  forall era. EraTxBody era => TxBody era
mkBasicTxBody
    forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList [forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
mkGenesisTxIn Integer
1]
    forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
collateralInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList [forall c.
(HashAlgorithm (HASH c), HasCallStack) =>
Integer -> TxIn c
mkGenesisTxIn Integer
11]
    forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
      forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList [forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut (forall era. Era era => Proof era -> Addr (EraCrypto era)
someAddr Proof era
pf) (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
4995)]
    forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
5
    forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraTxBody era =>
Lens'
  (TxBody era) (StrictMaybe (ScriptIntegrityHash (EraCrypto era)))
scriptIntegrityHashTxBodyL
      forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe (ScriptIntegrityHash (EraCrypto era))
newScriptIntegrityHash Proof era
pf forall era. AlonzoEraPParams era => PParams era
testPParams [Language
PlutusV1] Redeemers era
redeemers (forall era. Era era => Data era -> TxDats era
mkTxDats (forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
123)))
  where
    redeemers :: Redeemers era
redeemers =
      forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers forall a b. (a -> b) -> a -> b
$
        forall k a. k -> a -> Map k a
Map.singleton (forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> AlonzoPlutusPurpose f era
AlonzoSpending @_ @era (forall ix it. ix -> AsIx ix it
AsIx Word32
0)) (forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
42), Natural -> Natural -> ExUnits
ExUnits Natural
5000 Natural
5000)

exampleEpochInfo :: Monad m => EpochInfo m
exampleEpochInfo :: forall (m :: * -> *). Monad m => EpochInfo m
exampleEpochInfo = forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo (Word64 -> EpochSize
EpochSize Word64
100) (POSIXTime -> SlotLength
mkSlotLength POSIXTime
1)

uenv :: AlonzoEraPParams era => UtxoEnv era
uenv :: forall era. AlonzoEraPParams era => UtxoEnv era
uenv = forall era. SlotNo -> PParams era -> CertState era -> UtxoEnv era
UtxoEnv (Word64 -> SlotNo
SlotNo Word64
0) forall era. AlonzoEraPParams era => PParams era
testPParams forall a. Default a => a
def

ustate ::
  ( EraTxOut era
  , PostShelley era
  , EraGov era
  ) =>
  Proof era ->
  UTxOState era
ustate :: forall era.
(EraTxOut era, PostShelley era, EraGov era) =>
Proof era -> UTxOState era
ustate Proof era
pf =
  UTxOState
    { utxosUtxo :: UTxO era
utxosUtxo = forall era.
(EraTxOut era, PostShelley era) =>
Proof era -> UTxO era
initUTxO Proof era
pf
    , utxosDeposited :: Coin
utxosDeposited = Integer -> Coin
Coin Integer
0
    , utxosFees :: Coin
utxosFees = Integer -> Coin
Coin Integer
0
    , utxosGovState :: GovState era
utxosGovState = forall a. Default a => a
def
    , utxosStakeDistr :: IncrementalStake (EraCrypto era)
utxosStakeDistr = forall c.
Map (Credential 'Staking c) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> IncrementalStake c
IStake forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    , utxosDonation :: Coin
utxosDonation = forall a. Monoid a => a
mempty
    }

updateTxExUnits ::
  forall era m.
  ( MonadFail m
  , AlonzoEraTx era
  , EraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , EraPlutusContext era
  ) =>
  Tx era ->
  UTxO era ->
  EpochInfo (Either Text) ->
  SystemStart ->
  (forall a. String -> m a) ->
  m (Tx era)
updateTxExUnits :: forall era (m :: * -> *).
(MonadFail m, AlonzoEraTx era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> (forall a. String -> m a)
-> m (Tx era)
updateTxExUnits Tx era
tx UTxO era
utxo EpochInfo (Either Text)
ei SystemStart
ss forall a. String -> m a
err =
  let res :: RedeemerReport era
      res :: RedeemerReport era
res = forall era.
(AlonzoEraTx era, EraUTxO era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReport era
evalTxExUnits forall era. AlonzoEraPParams era => PParams era
testPParams Tx era
tx UTxO era
utxo EpochInfo (Either Text)
ei SystemStart
ss
   in forall era.
(AlonzoEraTxWits era, EraTx era) =>
Tx era -> Map (PlutusPurpose AsIx era) ExUnits -> Tx era
replaceRdmrs Tx era
tx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *) e a.
(Monad m, Show e) =>
(String -> m a) -> Either e a -> m a
failLeft forall a. String -> m a
err) RedeemerReport era
res

replaceRdmrs ::
  forall era.
  (AlonzoEraTxWits era, EraTx era) =>
  Tx era ->
  Map (PlutusPurpose AsIx era) ExUnits ->
  Tx era
replaceRdmrs :: forall era.
(AlonzoEraTxWits era, EraTx era) =>
Tx era -> Map (PlutusPurpose AsIx era) ExUnits -> Tx era
replaceRdmrs Tx era
tx Map (PlutusPurpose AsIx era) ExUnits
rdmrs = Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers era
newRdmrs
  where
    newRdmrs :: Redeemers era
newRdmrs = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey PlutusPurpose AsIx era -> ExUnits -> Redeemers era -> Redeemers era
replaceRdmr (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL) Map (PlutusPurpose AsIx era) ExUnits
rdmrs

    replaceRdmr :: PlutusPurpose AsIx era -> ExUnits -> Redeemers era -> Redeemers era
    replaceRdmr :: PlutusPurpose AsIx era -> ExUnits -> Redeemers era -> Redeemers era
replaceRdmr PlutusPurpose AsIx era
ptr ExUnits
ex x :: Redeemers era
x@(Redeemers Map (PlutusPurpose AsIx era) (Data era, ExUnits)
r) =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PlutusPurpose AsIx era
ptr Map (PlutusPurpose AsIx era) (Data era, ExUnits)
r of
        Just (Data era
dat, ExUnits
_ex) -> forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PlutusPurpose AsIx era
ptr (Data era
dat, ExUnits
ex) Map (PlutusPurpose AsIx era) (Data era, ExUnits)
r
        Maybe (Data era, ExUnits)
Nothing -> Redeemers era
x

failLeft :: (Monad m, Show e) => (String -> m a) -> Either e a -> m a
failLeft :: forall (m :: * -> *) e a.
(Monad m, Show e) =>
(String -> m a) -> Either e a -> m a
failLeft String -> m a
_ (Right a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
failLeft String -> m a
err (Left e
e) = String -> m a
err (forall a. Show a => a -> String
show e
e)

testPParams :: forall era. AlonzoEraPParams era => PParams era
testPParams :: forall era. AlonzoEraPParams era => PParams era
testPParams =
  forall era. EraPParams era => PParams era
emptyPParams
    forall a b. a -> (a -> b) -> b
& forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
zeroTestingCostModels [Language
PlutusV1]
    forall a b. a -> (a -> b) -> b
& forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
ppMaxValSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
1000000000
    forall a b. a -> (a -> b) -> b
& forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
ppMaxTxExUnitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Natural -> ExUnits
ExUnits Natural
100000000 Natural
100000000
    forall a b. a -> (a -> b) -> b
& forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
ppMaxBlockExUnitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Natural -> ExUnits
ExUnits Natural
100000000 Natural
100000000
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Version -> Natural -> ProtVer
ProtVer (forall era. Era era => Version
eraProtVerHigh @era) Natural
0