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

module Test.Cardano.Ledger.Alonzo.Tools (
  exUnitsTranslationRoundTrip,
  exampleExUnitCalc,
  exampleInvalidExUnitCalc,
) where

import Cardano.Ledger.Allegra.Scripts (AllegraEraScript)
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext, EraPlutusTxInfo)
import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose (..), eraLanguages)
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.Plutus (
  Data (..),
  ExUnits (..),
  Language (..),
  exBudgetToExUnits,
  transExUnits,
 )
import Cardano.Ledger.Shelley.LedgerState (UTxOState (..))
import Cardano.Ledger.Shelley.Rules (UtxoEnv (..))
import Cardano.Ledger.Shelley.State
import Cardano.Slotting.EpochInfo (EpochInfo, fixedEpochInfo)
import Cardano.Slotting.Slot (EpochSize (..), SlotNo (..))
import Cardano.Slotting.Time (SystemStart (..), mkSlotLength)
import Control.State.Transition.Extended (STS (..), TRC (TRC))
import Data.Default (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.Common (ToExpr, showExpr)
import Test.Cardano.Ledger.Core.KeyPair (mkWitnessVKey)
import Test.Cardano.Ledger.Examples.STSTestUtils (
  EraModel (..),
  initUTxO,
  mkGenesisTxIn,
  mkTxDats,
  someAddr,
  someKeys,
 )
import Test.Cardano.Ledger.Generic.GenState (EraGenericGen (..))
import Test.Cardano.Ledger.Plutus (zeroTestingCostModels)
import Test.Cardano.Ledger.Shelley.Utils (applySTSTest, runShelleyBase)
import Test.Tasty.HUnit (assertFailure, (@=?))
import Test.Tasty.QuickCheck (Gen, Property, arbitrary, counterexample)

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

testSystemStart :: SystemStart
testSystemStart :: SystemStart
testSystemStart = UTCTime -> SystemStart
SystemStart (UTCTime -> SystemStart) -> UTCTime -> 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
  , ToExpr (PredicateFailure (EraRule "UTXOS" era))
  , AlonzoEraTx era
  , STS (EraRule "UTXOS" era)
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , EraPlutusContext era
  , EraGenericGen era
  , ToExpr (TransactionScriptFailure 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,
 ToExpr (PredicateFailure (EraRule "UTXOS" era)), AlonzoEraTx era,
 STS (EraRule "UTXOS" era),
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraPlutusContext era,
 EraGenericGen era, ToExpr (TransactionScriptFailure 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' <- Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> (forall a. String -> m a)
-> m (Tx era)
forall era (m :: * -> *).
(MonadFail m, AlonzoEraTx era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraPlutusContext era,
 EraGenericGen era, ToExpr (TransactionScriptFailure 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 String -> m a
forall a. String -> m a
err
  UTxOState era
_ <-
    (String -> m (UTxOState era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOS" era))) (UTxOState era)
-> m (UTxOState era)
forall (m :: * -> *) e a.
(Monad m, ToExpr e) =>
(String -> m a) -> Either e a -> m a
failLeft String -> m (UTxOState era)
forall a. String -> m a
err (Either
   (NonEmpty (PredicateFailure (EraRule "UTXOS" era))) (UTxOState era)
 -> m (UTxOState era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOS" era))) (UTxOState era)
-> m (UTxOState era)
forall a b. (a -> b) -> a -> b
$
      ShelleyBase
  (Either
     (NonEmpty (PredicateFailure (EraRule "UTXOS" era)))
     (UTxOState era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOS" era))) (UTxOState era)
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either
      (NonEmpty (PredicateFailure (EraRule "UTXOS" era)))
      (UTxOState era))
 -> Either
      (NonEmpty (PredicateFailure (EraRule "UTXOS" era)))
      (UTxOState era))
-> ShelleyBase
     (Either
        (NonEmpty (PredicateFailure (EraRule "UTXOS" era)))
        (UTxOState era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOS" era))) (UTxOState era)
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) ((Environment (EraRule "UTXOS" era), State (EraRule "UTXOS" era),
 Signal (EraRule "UTXOS" era))
-> TRC (EraRule "UTXOS" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (EraRule "UTXOS" era)
ue, State (EraRule "UTXOS" era)
UTxOState era
utxoState, Tx era
Signal (EraRule "UTXOS" era)
tx'))
  () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    utxo :: UTxO era
utxo = UTxOState era -> UTxO era
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
  , Signal (EraRule "UTXOS" era) ~ Tx era
  , STS (EraRule "UTXOS" era)
  , AlonzoEraTx era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era
  , EraGenericGen era
  , EraPlutusTxInfo PlutusV1 era
  , ToExpr (PredicateFailure (EraRule "UTXOS" era))
  , ToExpr (TransactionScriptFailure era)
  ) =>
  IO ()
exampleExUnitCalc :: forall era.
(BaseM (EraRule "UTXOS" era) ~ ShelleyBase,
 State (EraRule "UTXOS" era) ~ UTxOState era,
 Environment (EraRule "UTXOS" era) ~ UtxoEnv era,
 Signal (EraRule "UTXOS" era) ~ Tx era, STS (EraRule "UTXOS" era),
 AlonzoEraTx era, ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraGenericGen era, EraPlutusTxInfo 'PlutusV1 era,
 ToExpr (PredicateFailure (EraRule "UTXOS" era)),
 ToExpr (TransactionScriptFailure era)) =>
IO ()
exampleExUnitCalc =
  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,
 ToExpr (PredicateFailure (EraRule "UTXOS" era)), AlonzoEraTx era,
 STS (EraRule "UTXOS" era),
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraPlutusContext era,
 EraGenericGen era, ToExpr (TransactionScriptFailure era)) =>
Tx era
-> UTxOState era
-> UtxoEnv era
-> EpochInfo (Either Text)
-> SystemStart
-> (forall a. String -> m a)
-> m ()
testExUnitCalculation @era
    (PlutusPurpose AsIx era -> Tx era
forall era.
(AlonzoEraTx era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraGenericGen era) =>
PlutusPurpose AsIx era -> Tx era
exampleTx (AsIx Word32 TxIn -> AlonzoPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 TxIn -> AlonzoPlutusPurpose f era
AlonzoSpending (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0)))
    UTxOState era
forall era.
(AllegraEraScript era, AlonzoEraTxOut era, EraModel era) =>
UTxOState era
ustate
    UtxoEnv era
forall era. (EraGenericGen era, AlonzoEraScript era) => UtxoEnv era
uenv
    EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
exampleEpochInfo
    SystemStart
testSystemStart
    String -> IO a
forall a. HasCallStack => String -> IO a
forall a. String -> IO a
assertFailure

exampleInvalidExUnitCalc ::
  forall era.
  ( AlonzoEraTx era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era
  , EraGenericGen era
  , EraPlutusTxInfo PlutusV1 era
  ) =>
  IO ()
exampleInvalidExUnitCalc :: forall era.
(AlonzoEraTx era, ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraGenericGen era, EraPlutusTxInfo 'PlutusV1 era) =>
IO ()
exampleInvalidExUnitCalc =
  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
          PParams era
forall era. (EraGenericGen era, AlonzoEraScript era) => PParams era
testPParams
          (PlutusPurpose AsIx era -> Tx era
forall era.
(AlonzoEraTx era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraGenericGen era) =>
PlutusPurpose AsIx era -> Tx era
exampleTx (AsIx Word32 TxIn -> AlonzoPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 TxIn -> AlonzoPlutusPurpose f era
AlonzoSpending (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
1)))
          UTxO era
forall era.
(AllegraEraScript era, AlonzoEraTxOut era, EraModel era) =>
UTxO era
initUTxO
          EpochInfo (Either Text)
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) <- Map
  (AlonzoPlutusPurpose AsIx era)
  (Either (TransactionScriptFailure era) ExUnits)
-> [(AlonzoPlutusPurpose AsIx era,
     Either (TransactionScriptFailure era) ExUnits)]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  (AlonzoPlutusPurpose AsIx era)
  (Either (TransactionScriptFailure era) ExUnits)
RedeemerReport era
report] of
        [] ->
          String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure String
"evalTxExUnits should have produced a failing report"
        [(AlonzoPlutusPurpose AsIx era
_, TransactionScriptFailure era
failure)] ->
          PlutusPurpose AsIx era -> TransactionScriptFailure era
forall era. PlutusPurpose AsIx era -> TransactionScriptFailure era
RedeemerPointsToUnknownScriptHash (AsIx Word32 TxIn -> AlonzoPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 TxIn -> AlonzoPlutusPurpose f era
AlonzoSpending (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
1))
            TransactionScriptFailure era
-> TransactionScriptFailure era -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@=? TransactionScriptFailure era
failure
        [(AlonzoPlutusPurpose AsIx era, TransactionScriptFailure era)]
failures ->
          String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"evalTxExUnits produce failing scripts with unexpected errors: "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(AlonzoPlutusPurpose AsIx era, TransactionScriptFailure era)]
-> String
forall a. Show a => a -> String
show [(AlonzoPlutusPurpose AsIx era, TransactionScriptFailure era)]
failures

exampleTx ::
  forall era.
  ( AlonzoEraTx era
  , PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era
  , EraGenericGen era
  ) =>
  PlutusPurpose AsIx era ->
  Tx era
exampleTx :: forall era.
(AlonzoEraTx era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraGenericGen era) =>
PlutusPurpose AsIx era -> Tx era
exampleTx PlutusPurpose AsIx era
ptr = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era.
(PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraGenericGen era, AlonzoEraScript era) =>
TxBody era
validatingBody Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> TxWits era -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
wits
  where
    wits :: TxWits era
wits =
      TxWits era
forall era. EraTxWits era => TxWits era
mkBasicTxWits
        TxWits era -> (TxWits era -> TxWits era) -> TxWits era
forall a b. a -> (a -> b) -> b
& (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)))
 -> TxWits era -> Identity (TxWits era))
-> Set (WitVKey 'Witness) -> TxWits era -> TxWits era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [WitVKey 'Witness] -> Set (WitVKey 'Witness)
forall a. Ord a => [a] -> Set a
Set.fromList [SafeHash EraIndependentTxBody
-> KeyPair 'Payment -> WitVKey 'Witness
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated (TxBody era -> SafeHash EraIndependentTxBody)
-> TxBody era -> SafeHash EraIndependentTxBody
forall a b. (a -> b) -> a -> b
$ forall era.
(PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraGenericGen era, AlonzoEraScript era) =>
TxBody era
validatingBody @era) KeyPair 'Payment
someKeys]
        TxWits era -> (TxWits era -> TxWits era) -> TxWits era
forall a b. a -> (a -> b) -> b
& (Map ScriptHash (Script era) -> Identity [Script era])
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens
  (TxWits era)
  (TxWits era)
  (Map ScriptHash (Script era))
  [Script era]
Lens
  (TxWits era)
  (TxWits era)
  (Map ScriptHash (Script era))
  [Script era]
hashScriptTxWitsL ((Map ScriptHash (Script era) -> Identity [Script era])
 -> TxWits era -> Identity (TxWits era))
-> [Script era] -> TxWits era -> TxWits era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Natural -> Script era
forall era. EraModel era => Natural -> Script era
always Natural
3]
        TxWits era -> (TxWits era -> TxWits era) -> TxWits era
forall a b. a -> (a -> b) -> b
& (TxDats era -> Identity [Data era])
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens (TxWits era) (TxWits era) (TxDats era) [Data era]
Lens (TxWits era) (TxWits era) (TxDats era) [Data era]
hashDataTxWitsL ((TxDats era -> Identity [Data era])
 -> TxWits era -> Identity (TxWits era))
-> [Data era] -> TxWits era -> TxWits era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
123)]
        TxWits era -> (TxWits era -> TxWits era) -> TxWits era
forall a b. a -> (a -> b) -> b
& (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)))
 -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> TxWits era
-> TxWits 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
ptr (Data -> Data era
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.
  ( PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era
  , EraGenericGen era
  , AlonzoEraScript era
  ) =>
  TxBody era
validatingBody :: forall era.
(PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraGenericGen era, AlonzoEraScript era) =>
TxBody era
validatingBody =
  TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
    TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
1]
    TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& Set TxIn -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
Set TxIn -> TxBody era -> TxBody era
setCollateralInputs ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
11])
    TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
      ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
SSeq.fromList [Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
someAddr (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
4995)]
    TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> Coin -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
5
    TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& StrictMaybe ScriptIntegrityHash -> TxBody era -> TxBody era
forall era.
EraGenericGen era =>
StrictMaybe ScriptIntegrityHash -> TxBody era -> TxBody era
setScriptIntegrityHash
      (PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
forall era.
EraModel era =>
PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash PParams era
forall era. (EraGenericGen era, AlonzoEraScript era) => PParams era
testPParams [Language
PlutusV1] Redeemers era
redeemers (Data era -> TxDats era
forall era. Era era => Data era -> TxDats era
mkTxDats (Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
123))))
  where
    redeemers :: Redeemers era
redeemers = [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
forall era.
EraModel era =>
[(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers [(forall (f :: * -> * -> *) era.
f Word32 TxIn -> AlonzoPlutusPurpose f era
AlonzoSpending @_ @era (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0), (Data -> Data era
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 = EpochSize -> SlotLength -> EpochInfo m
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo (Word64 -> EpochSize
EpochSize Word64
100) (POSIXTime -> SlotLength
mkSlotLength POSIXTime
1)

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

ustate ::
  ( AllegraEraScript era
  , AlonzoEraTxOut era
  , EraModel era
  ) =>
  UTxOState era
ustate :: forall era.
(AllegraEraScript era, AlonzoEraTxOut era, EraModel era) =>
UTxOState era
ustate =
  UTxOState
    { utxosUtxo :: UTxO era
utxosUtxo = UTxO era
forall era.
(AllegraEraScript era, AlonzoEraTxOut era, EraModel era) =>
UTxO era
initUTxO
    , utxosDeposited :: Coin
utxosDeposited = Integer -> Coin
Coin Integer
0
    , utxosFees :: Coin
utxosFees = Integer -> Coin
Coin Integer
0
    , utxosGovState :: GovState era
utxosGovState = GovState era
forall a. Default a => a
def
    , utxosInstantStake :: InstantStake era
utxosInstantStake = InstantStake era
forall a. Monoid a => a
mempty
    , utxosDonation :: Coin
utxosDonation = Coin
forall a. Monoid a => a
mempty
    }

updateTxExUnits ::
  forall era m.
  ( MonadFail m
  , AlonzoEraTx era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , EraPlutusContext era
  , EraGenericGen era
  , ToExpr (TransactionScriptFailure 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,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraPlutusContext era,
 EraGenericGen era, ToExpr (TransactionScriptFailure 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 = PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReport era
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 PParams era
forall era. (EraGenericGen era, AlonzoEraScript era) => PParams era
testPParams Tx era
tx UTxO era
utxo EpochInfo (Either Text)
ei SystemStart
ss
   in Tx era -> Map (PlutusPurpose AsIx era) ExUnits -> Tx era
forall era.
(AlonzoEraTxWits era, EraTx era) =>
Tx era -> Map (PlutusPurpose AsIx era) ExUnits -> Tx era
updateRdmrUnits Tx era
tx (Map (PlutusPurpose AsIx era) ExUnits -> Tx era)
-> m (Map (PlutusPurpose AsIx era) ExUnits) -> m (Tx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either (TransactionScriptFailure era) ExUnits -> m ExUnits)
-> RedeemerReport era -> m (Map (PlutusPurpose AsIx era) ExUnits)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> Map (PlutusPurpose AsIx era) a
-> f (Map (PlutusPurpose AsIx era) b)
traverse ((String -> m ExUnits)
-> Either (TransactionScriptFailure era) ExUnits -> m ExUnits
forall (m :: * -> *) e a.
(Monad m, ToExpr e) =>
(String -> m a) -> Either e a -> m a
failLeft String -> m ExUnits
forall a. String -> m a
err) RedeemerReport era
res

updateRdmrUnits ::
  forall era.
  (AlonzoEraTxWits era, EraTx era) =>
  Tx era ->
  Map (PlutusPurpose AsIx era) ExUnits ->
  Tx era
updateRdmrUnits :: forall era.
(AlonzoEraTxWits era, EraTx era) =>
Tx era -> Map (PlutusPurpose AsIx era) ExUnits -> Tx era
updateRdmrUnits Tx era
tx Map (PlutusPurpose AsIx era) ExUnits
rdmrs = Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx 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 era
-> Identity (Tx 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 era -> Identity (Tx era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Tx era
-> Tx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Map (PlutusPurpose AsIx era) ExUnits
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall {k} {f :: * -> *} {b}.
(Ord k, Functor f) =>
Map k b -> Map k (f b) -> Map k (f b)
updateFrom Map (PlutusPurpose AsIx era) ExUnits
rdmrs
  where
    -- Update only the keys that are already in the old map
    updateFrom :: Map k b -> Map k (f b) -> Map k (f b)
updateFrom Map k b
new Map k (f b)
old = (k -> b -> Map k (f b) -> Map k (f b))
-> Map k (f b) -> Map k b -> Map k (f b)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\k
k b
eu -> (f b -> f b) -> k -> Map k (f b) -> Map k (f b)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (b
eu b -> f b -> f b
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) k
k) Map k (f b)
old Map k b
new

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

testPParams :: forall era. (EraGenericGen era, AlonzoEraScript era) => PParams era
testPParams :: forall era. (EraGenericGen era, AlonzoEraScript era) => PParams era
testPParams =
  forall era. EraPParams era => PParams era
emptyPParams @era
    PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era)
forall era. EraGenericGen era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsT ((CostModels -> Identity CostModels)
 -> PParams era -> Identity (PParams era))
-> CostModels -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
[Language] -> CostModels
zeroTestingCostModels (forall era. AlonzoEraScript era => [Language]
eraLanguages @era)
    PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Natural -> Identity Natural)
-> PParams era -> Identity (PParams era)
forall era. EraGenericGen era => Lens' (PParams era) Natural
Lens' (PParams era) Natural
ppMaxValSizeT ((Natural -> Identity Natural)
 -> PParams era -> Identity (PParams era))
-> Natural -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
1000000000
    PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (ExUnits -> Identity ExUnits)
-> PParams era -> Identity (PParams era)
forall era. EraGenericGen era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
ppMaxTxExUnitsT ((ExUnits -> Identity ExUnits)
 -> PParams era -> Identity (PParams era))
-> ExUnits -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Natural -> ExUnits
ExUnits Natural
100000000 Natural
100000000
    PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (ExUnits -> Identity ExUnits)
-> PParams era -> Identity (PParams era)
forall era. EraGenericGen era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
ppMaxBlockExUnitsT ((ExUnits -> Identity ExUnits)
 -> PParams era -> Identity (PParams era))
-> ExUnits -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Natural -> ExUnits
ExUnits Natural
100000000 Natural
100000000
    PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (ProtVer -> Identity ProtVer)
-> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL ((ProtVer -> Identity ProtVer)
 -> PParams era -> Identity (PParams era))
-> ProtVer -> PParams era -> PParams era
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