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

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

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.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 (BaseM, Environment, Signal, State), 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.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"
    [ String -> Gen Property -> TestTree
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" (Proof AlonzoEra -> Assertion
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, PostShelley era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraPlutusContext era, EraGov era, EraStake era,
 EraCertState era) =>
Proof era -> Assertion
exampleExUnitCalc Proof AlonzoEra
Alonzo)
        , String -> Assertion -> TestTree
testCase String
"attempt calculate ExUnits with invalid tx" (Proof AlonzoEra -> Assertion
forall era.
(PostShelley era, AlonzoEraTx era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraPlutusContext era) =>
Proof era -> Assertion
exampleInvalidExUnitCalc Proof AlonzoEra
Alonzo)
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"Babbage"
        [ String -> Assertion -> TestTree
testCase String
"calculate ExUnits" (Proof BabbageEra -> Assertion
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, PostShelley era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraPlutusContext era, EraGov era, EraStake era,
 EraCertState era) =>
Proof era -> Assertion
exampleExUnitCalc Proof BabbageEra
Babbage)
        , String -> Assertion -> TestTree
testCase String
"attempt calculate ExUnits with invalid tx" (Proof BabbageEra -> Assertion
forall era.
(PostShelley era, AlonzoEraTx era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraPlutusContext era) =>
Proof era -> Assertion
exampleInvalidExUnitCalc Proof BabbageEra
Babbage)
        ]
    ]

-- 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
  , 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' <- Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> (forall a. String -> m a)
-> m (Tx era)
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 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, Show 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
  , PostShelley era
  , EraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era
  , EraPlutusContext era
  , EraGov era
  , EraStake era
  , EraCertState era
  ) =>
  Proof 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, PostShelley era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 EraPlutusContext era, EraGov era, EraStake era,
 EraCertState era) =>
Proof era -> Assertion
exampleExUnitCalc Proof era
proof =
  Tx era
-> UTxOState era
-> UtxoEnv era
-> EpochInfo (Either Text)
-> SystemStart
-> (forall a. String -> IO a)
-> Assertion
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
    (Proof era -> PlutusPurpose AsIx era -> Tx era
forall era.
(Scriptic era, AlonzoEraTx era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Proof era -> PlutusPurpose AsIx era -> Tx era
exampleTx Proof era
proof (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)))
    (Proof era -> UTxOState era
forall era.
(EraTxOut era, PostShelley era, EraStake era, EraGov era) =>
Proof era -> UTxOState era
ustate Proof era
proof)
    UtxoEnv era
forall era. (AlonzoEraPParams era, EraCertState 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.
  ( PostShelley era
  , AlonzoEraTx era
  , EraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era
  , EraPlutusContext era
  ) =>
  Proof era ->
  IO ()
exampleInvalidExUnitCalc :: forall era.
(PostShelley era, AlonzoEraTx era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era,
 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
          PParams era
forall era. AlonzoEraPParams era => PParams era
testPParams
          (Proof era -> PlutusPurpose AsIx era -> Tx era
forall era.
(Scriptic era, AlonzoEraTx era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Proof era -> PlutusPurpose AsIx era -> Tx era
exampleTx Proof era
proof (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)))
          (Proof era -> UTxO era
forall era.
(EraTxOut era, PostShelley era) =>
Proof era -> UTxO era
initUTxO Proof era
proof)
          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 -> Assertion
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 -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@=? TransactionScriptFailure era
failure
        [(AlonzoPlutusPurpose AsIx era, TransactionScriptFailure era)]
failures ->
          String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
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 ::
  ( Scriptic era
  , AlonzoEraTx era
  , PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era
  ) =>
  Proof era ->
  PlutusPurpose AsIx era ->
  Tx era
exampleTx :: forall era.
(Scriptic era, AlonzoEraTx era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Proof era -> PlutusPurpose AsIx era -> Tx era
exampleTx Proof era
pf PlutusPurpose AsIx era
ptr =
  TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (Proof era -> TxBody era
forall era.
(Scriptic era, AlonzoEraTxBody era, AlonzoEraScript era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Proof era -> TxBody era
validatingBody Proof era
pf)
    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 (Proof era -> TxBody era
forall era.
(Scriptic era, AlonzoEraTxBody era, AlonzoEraScript era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Proof era -> TxBody era
validatingBody Proof era
pf)) (Proof era -> KeyPair 'Payment
forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf)]
        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 -> Proof era -> Script era
forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
3 Proof era
pf]
        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 (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity
          (Map (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity
         (Map (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity
      (Map (AlonzoPlutusPurpose 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)))
-> 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 (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity
       (Map (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits)))
 -> TxWits era -> Identity (TxWits era))
-> (Map (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits)
    -> Map (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits))
-> TxWits era
-> TxWits era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ AlonzoPlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Map (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AlonzoPlutusPurpose AsIx era
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.
  ( 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 =
  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 -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL ((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
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 (Proof era -> Addr
forall era. Proof era -> Addr
someAddr Proof era
pf) (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
 -> Identity (StrictMaybe ScriptIntegrityHash))
-> TxBody era -> Identity (TxBody era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL
      ((StrictMaybe ScriptIntegrityHash
  -> Identity (StrictMaybe ScriptIntegrityHash))
 -> TxBody era -> Identity (TxBody era))
-> StrictMaybe ScriptIntegrityHash -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash Proof era
pf PParams era
forall era. AlonzoEraPParams 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 =
      Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Redeemers era
forall a b. (a -> b) -> a -> b
$
        AlonzoPlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Map (AlonzoPlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. k -> a -> Map k a
Map.singleton (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 :: (AlonzoEraPParams era, EraCertState era) => UtxoEnv era
uenv :: forall era. (AlonzoEraPParams era, EraCertState 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. AlonzoEraPParams era => PParams era
testPParams CertState era
forall a. Default a => a
def

ustate ::
  ( EraTxOut era
  , PostShelley era
  , EraStake era
  , EraGov era
  ) =>
  Proof era ->
  UTxOState era
ustate :: forall era.
(EraTxOut era, PostShelley era, EraStake era, EraGov era) =>
Proof era -> UTxOState era
ustate Proof era
pf =
  UTxOState
    { utxosUtxo :: UTxO era
utxosUtxo = Proof era -> UTxO era
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 = 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
  , 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 = 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. AlonzoEraPParams 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, Show 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, 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) = 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. Show a => a -> String
show e
e)

testPParams :: forall era. AlonzoEraPParams era => PParams era
testPParams :: forall era. AlonzoEraPParams era => PParams era
testPParams =
  PParams era
forall era. EraPParams era => PParams era
emptyPParams
    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. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL ((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 [Language
PlutusV1]
    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. AlonzoEraPParams era => Lens' (PParams era) Natural
Lens' (PParams era) Natural
ppMaxValSizeL ((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. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
ppMaxTxExUnitsL ((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. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
ppMaxBlockExUnitsL ((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