{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Provides building blocks for Mutation testing of Contracts.
--
-- == Introduction
--
-- Traditional [Mutation testing](https://en.wikipedia.org/wiki/Mutation_testing) is a testing technique
-- that introduces small modifications like changing a comparison operator, or modifying constants, into
-- a program and checks whether or not the existing tests "kill" the produced mutants, eg. fail. Mutation
-- testing requires somewhat complex tooling because it needs to modify the source code, in limited and
-- semantically meaningful ways in order to generate code that won't be rejected by the compiler.
--
-- Recall that Plutus eUTxO validators are boolean expressions of the form:
--
-- @
-- validator : Datum -> Redeemer -> ScriptContext -> Bool
-- @
--
-- All things being equal, "mutating" a /validator/ so that it returns `False` instead of `True` can be done:
--
-- * Either by /mutating/ the code of the `validator` implementation,
-- * Or by /mutating/ its arguments.
--
-- This simple idea lead to the following strategy to test-drive validator scripts:
--
-- 1. Start with a validator that always return `True`,
-- 2. Write a /positive/ property test checking /valid/ transactions are accepted by the validator(s),
-- 3. Write a /negative/ property test checking /invalid/ transactions are rejected. This is where /mutations/
--    are introduced, each different mutation type representing some possible "attack",
-- 4. Watch one or the other properties fail and enhance the validators code to make them pass,
-- 5. Rinse and repeat.
--
-- == Generic Property and Mutations
--
-- Given a transaction with some UTxO context, and a function that generates `SomeMutation` from a valid
-- transaction and context pair, the generic 'propMutation' property checks applying any generated mutation
-- makes the mutated (hence expectedly invalid) transaction fail the validation stage.
--
-- @
-- propMutation :: (Tx, Utxo) -> ((Tx, Utxo) -> Gen SomeMutation) -> Property
-- propMutation (tx, utxo) genMutation =
--   forAll @_ @Property (genMutation (tx, utxo)) $ \SomeMutation{label, mutation} ->
--     (tx, utxo)
--       & applyMutation mutation
--       & propTransactionFailsPhase2
-- @
--
-- To this basic property definition we add a `checkCoverage` that ensures the set of generated mutations
-- covers a statistically significant share of each of the various possible mutations classified by their @label@.
--
-- The `SomeMutation` type is simply a wrapper that attaches a @label@ to a proper `Mutation` which is the interesting bit here.
--
-- The `Mutation` type enumerates various possible "atomic" mutations which preserve the structural correctness of the transaction but should make a validator fail.
--
-- @
-- data Mutation
--   = ChangeHeadRedeemer Head.Input
--   | ChangeInputHeadDatum Head.State
--   ...
--   | Changes [Mutation]
-- @
--
-- The constructors should hopefully be self-explaining but for the last one. Some interesting mutations we want
-- to make require more than one "atomic" change to represent a possible validator failure. For example,
-- we wanted to check that the `Commit` validator, in the context of a `CollectCom` transaction, verifies the
-- state (`Input`) of the `Head` validator is correct. But to be interesting, this mutation needs to ensure the
-- /transition/ verified by the `Head` state machine is valid, which requires changing /both/ the datum and the
-- redeemer of the consumed head output.
--
-- == Transaction-specific Mutations
--
-- To be run the `propMutation` requires a starting "healthy" (valid) transaction and a specialised generating
-- function. It is instantiated in the test runner by providing these two elements. For example, the "ContractSpec"
-- module has the following property check:
--
-- @
-- describe "CollectCom" $ do
--   prop "does not survive random adversarial mutations" $
--     propMutation healthyCollectComTx genCollectComMutation
-- @
--
-- The interesting part is the `genCollectComMutation` (details of the `Mutation` generators are omitted):
--
-- @
-- genCollectComMutation :: (Tx, Utxo) -> Gen SomeMutation
-- genCollectComMutation (tx, utxo) =
--   oneof
--     [ SomeMutation Nothing MutateOpenOutputValue . ChangeOutput ...
--     , SomeMutation Nothing MutateOpenUtxoHash . ChangeOutput ...
--     , SomeMutation Nothing MutateHeadTransition <$> do
--         changeRedeemer <- ChangeHeadRedeemer <$> ...
--         changeDatum <- ChangeInputHeadDatum <$> ...
--         pure $ Changes [changeRedeemer, changeDatum]
--     ]
-- @
--
-- Here we have defined four different type of mutations that are interesting for the "CollectCom" transaction
-- and represent possible /attack vectors/:
--
--   * Changing the `Head` output's value, which would imply some of the committed funds could be "stolen"
--     by the party posting the transaction,
--   * Tampering with the content of the UTxO committed to the Head,
--   * Trying to collect commits without running the `Head` validator,
--   * Trying to collect commits in another Head state machine transition.
--
-- == Running Properties
--
-- When such a property test succeeds we get the following report which shows the distribution of the various
-- mutations that were tested.
--
-- @
-- Hydra.Chain.Direct.Contract
--   CollectCom
--     does not survive random adversarial mutations
--       +++ OK, passed 200 tests.
--
--       CollectComMutation (100 in total):
--       23% MutateNumberOfParties
--       22% MutateHeadTransition
--       21% MutateHeadId
--       19% MutateOpenUTxOHash
--       15% MutateRequiredSigner
--
-- Finished in 18.1146 seconds
-- @
--
-- In the case of a failure we get a detailed report on the context of the failure.
module Hydra.Chain.Direct.Contract.Mutation where

import Hydra.Cardano.Api

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Alonzo.Scripts qualified as Ledger
import Cardano.Ledger.Alonzo.TxWits qualified as Ledger
import Cardano.Ledger.Api (AllegraEraTxBody (vldtTxBodyL), AlonzoPlutusPurpose (..), AsIndex (..), inputsTxBodyL, mintTxBodyL, outputsTxBodyL, reqSignerHashesTxBodyL)
import Cardano.Ledger.Core qualified as Ledger
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Mary.Value qualified as Ledger
import Cardano.Ledger.Plutus.Data qualified as Ledger
import Control.Exception (assert)
import Control.Lens (set, view, (.~), (^.))
import Data.Map qualified as Map
import Data.Sequence.Strict qualified as StrictSeq
import Data.Set qualified as Set
import Hydra.Cardano.Api.Pretty (renderTxWithUTxO)
import Hydra.Chain.Direct.Fixture (testPolicyId)
import Hydra.Chain.Direct.Fixture qualified as Fixture
import Hydra.Chain.Direct.Tx (findFirst, onChainIdToAssetName, verificationKeyToOnChainId)
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Data.ContestationPeriod
import Hydra.Data.Party qualified as Data (Party)
import Hydra.Ledger.Cardano (genKeyPair, genOutput)
import Hydra.Ledger.Cardano.Evaluate (evaluateTx)
import Hydra.Plutus.Orphans ()
import Hydra.Prelude hiding (label)
import PlutusLedgerApi.V2 (CurrencySymbol, POSIXTime, toData)
import PlutusLedgerApi.V2 qualified as Plutus
import System.Directory.Internal.Prelude qualified as Prelude
import Test.Hydra.Prelude
import Test.QuickCheck (
  Property,
  checkCoverage,
  counterexample,
  forAll,
  property,
  suchThat,
 )
import Test.QuickCheck.Instances ()

-- * Properties

-- | A 'Property' checking a mutation is not validated.
-- This property takes an initial (transaction, UTxO) pair that is supposedly valid,
-- passes it to a generator that produces some mutations, then assert the resulting
-- (transaction', UTxO') pair fails the validation process.
--
-- Note that only "level 2" validation is run, e.g the transaction is assume to be
-- structurally valid and having passed "level 1" checks.
propMutation :: (Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation :: (Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property
propMutation (Tx
tx, UTxO
utxo) (Tx, UTxO) -> Gen SomeMutation
genMutation =
  forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll @_ @Property ((Tx, UTxO) -> Gen SomeMutation
genMutation (Tx
tx, UTxO
utxo)) ((SomeMutation -> Property) -> Property)
-> (SomeMutation -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \SomeMutation{lbl
label :: lbl
$sel:label:SomeMutation :: ()
label, Mutation
mutation :: Mutation
$sel:mutation:SomeMutation :: SomeMutation -> Mutation
mutation, Maybe Text
expectedError :: Maybe Text
$sel:expectedError:SomeMutation :: SomeMutation -> Maybe Text
expectedError} ->
    (Tx
tx, UTxO
utxo)
      (Tx, UTxO) -> ((Tx, UTxO) -> (Tx, UTxO)) -> (Tx, UTxO)
forall a b. a -> (a -> b) -> b
& Mutation -> (Tx, UTxO) -> (Tx, UTxO)
applyMutation Mutation
mutation
      (Tx, UTxO) -> ((Tx, UTxO) -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Maybe Text -> (Tx, UTxO) -> Property
propTransactionFailsPhase2 Maybe Text
expectedError
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& [lbl] -> Property -> Property
forall a prop.
(Show a, Enum a, Bounded a, Typeable a, Testable prop) =>
[a] -> prop -> Property
genericCoverTable [lbl
label]
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage

-- | Expect a phase-2 evaluation failure of given 'Tx' and 'UTxO'.
propTransactionFailsPhase2 :: Maybe Text -> (Tx, UTxO) -> Property
propTransactionFailsPhase2 :: Maybe Text -> (Tx, UTxO) -> Property
propTransactionFailsPhase2 Maybe Text
mExpectedError (Tx
tx, UTxO
lookupUTxO) =
  case Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO
lookupUTxO of
    Left EvaluationError
err ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Mutated transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Phase-1 validation failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationError -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationError
err)
    Right EvaluationReport
redeemerReport ->
      let errors :: [ScriptExecutionError]
errors = [Either ScriptExecutionError ExecutionUnits]
-> [ScriptExecutionError]
forall a b. [Either a b] -> [a]
lefts ([Either ScriptExecutionError ExecutionUnits]
 -> [ScriptExecutionError])
-> [Either ScriptExecutionError ExecutionUnits]
-> [ScriptExecutionError]
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems EvaluationReport
redeemerReport
       in case Maybe Text
mExpectedError of
            Maybe Text
Nothing ->
              Bool -> Bool
not ([ScriptExecutionError] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ScriptExecutionError]
errors)
                Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Mutated transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Redeemer report: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationReport
redeemerReport)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Phase-2 validation should have failed"
            Just Text
expectedError ->
              (ScriptExecutionError -> Bool) -> [ScriptExecutionError] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> ScriptExecutionError -> Bool
matchesErrorMessage Text
expectedError) [ScriptExecutionError]
errors
                Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Mutated transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Redeemer report: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationReport
redeemerReport)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Phase-2 validation should have failed with error message: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
expectedError)
 where
  matchesErrorMessage :: Text -> ScriptExecutionError -> Bool
matchesErrorMessage Text
errMsg = \case
    ScriptErrorEvaluationFailed EvaluationError
_ [Text]
errList -> Text
errMsg Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Text]
errList
    ScriptExecutionError
_otherScriptExecutionError -> Bool
False

-- | Expect a given 'Tx' and 'UTxO' to pass evaluation.
propTransactionEvaluates :: (Tx, UTxO) -> Property
propTransactionEvaluates :: (Tx, UTxO) -> Property
propTransactionEvaluates (Tx
tx, UTxO
lookupUTxO) =
  case Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO
lookupUTxO of
    Left EvaluationError
err ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Phase-1 validation failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationError -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationError
err)
    Right EvaluationReport
redeemerReport ->
      (Either ScriptExecutionError ExecutionUnits -> Bool)
-> [Either ScriptExecutionError ExecutionUnits] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isRight (EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems EvaluationReport
redeemerReport)
        Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Redeemer report: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationReport
redeemerReport)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Phase-2 validation failed"

-- | Expect a given 'Tx' and 'UTxO' to fail phase 1 or phase 2 evaluation.
propTransactionFailsEvaluation :: (Tx, UTxO) -> Property
propTransactionFailsEvaluation :: (Tx, UTxO) -> Property
propTransactionFailsEvaluation (Tx
tx, UTxO
lookupUTxO) =
  case Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO
lookupUTxO of
    Left EvaluationError
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    Right EvaluationReport
redeemerReport ->
      (Either ScriptExecutionError ExecutionUnits -> Bool)
-> EvaluationReport -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isLeft EvaluationReport
redeemerReport
        Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Redeemer report: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationReport
redeemerReport)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Phase-2 validation should have failed"

-- * Mutations

-- | Existential wrapper 'SomeMutation' and some label type.
-- This type is useful to provide a "generic"  classification of mutation
-- that is controlled by some custom type. The 'label' field can be passed
-- to the 'genericCoverTable' function to construct and display a coverage
-- table showing the percentage of each mutation that's been applied and
-- ensure significant coverage of all possible mutations using 'checkCoverage'.
data SomeMutation = forall lbl.
  (Typeable lbl, Enum lbl, Bounded lbl, Show lbl) =>
  SomeMutation
  { SomeMutation -> Maybe Text
expectedError :: Maybe Text
  , ()
label :: lbl
  , SomeMutation -> Mutation
mutation :: Mutation
  }

deriving stock instance Show SomeMutation

-- | Basic mutations
data Mutation
  = -- | Changes the 'Head' script's redeemer to the given value.
    ChangeHeadRedeemer Head.Input
  | -- | Changes the spent 'Head' script datum to the given value. This assumes
    -- inline datums are used and replaces the datum in all matching UTxOs
    -- (there should only be one head txOut).
    ChangeInputHeadDatum Head.State
  | -- | Adds given output as first transaction output.
    PrependOutput (TxOut CtxTx)
  | -- | Adds given output as last transaction output.
    AppendOutput (TxOut CtxTx)
  | -- | Removes given output from the transaction's outputs.
    RemoveOutput Word
  | -- | Drops the given input from the transaction's inputs
    RemoveInput TxIn
  | -- | Adds given UTxO to the transaction's inputs and UTxO context.
    AddInput TxIn (TxOut CtxUTxO) (Maybe HashableScriptData)
  | -- | Add witness for the given script to the transaction.
    AddScript PlutusScript
  | -- | Change an input's 'TxOut' to something else.
    -- This mutation alters the redeemers of the transaction to ensure
    -- any matching redeemer for given input matches the new redeemer, otherwise
    -- the transaction would be invalid for the wrong reason (unused redeemer).
    --
    -- This expects 'Nothing' if the new input is not locked by any script, and
    -- it expects 'Just' with some potentially new redeemer if locked by a
    -- script.
    --
    -- XXX: This is super tricky to use. If passing 'Nothing' although it's a
    -- script tx out, the validator will actually not be run!
    --
    -- XXX: Likely incomplete as it can not add the datum for given txout.
    ChangeInput TxIn (TxOut CtxUTxO) (Maybe HashableScriptData)
  | -- | Change the transaction's output at given index to something else.
    ChangeOutput Word (TxOut CtxTx)
  | -- | Change the transaction's minted values if it is actually minting
    -- something. NOTE: If 'Value' is 'mempty' the redeemers will be wrong.
    ChangeMintedValue Value
  | -- | Change required signers on a transaction'
    ChangeRequiredSigners [Hash PaymentKey]
  | -- | Change the validity interval of the transaction.
    ChangeValidityInterval (TxValidityLowerBound, TxValidityUpperBound)
  | ChangeValidityLowerBound TxValidityLowerBound
  | ChangeValidityUpperBound TxValidityUpperBound
  | -- | Change the included minting policy (the first minted policy) and update
    -- minted/burned values of this policy.
    ChangeMintingPolicy PlutusScript
  | -- | Applies several mutations as a single atomic 'Mutation'.
    -- This is useful to enable specific mutations that require consistent
    -- change of more than one thing in the transaction and/or UTxO set, for
    -- example to change consistently the Head script's redeemer and datum.
    Changes [Mutation]
  deriving stock (Int -> Mutation -> String -> String
[Mutation] -> String -> String
Mutation -> String
(Int -> Mutation -> String -> String)
-> (Mutation -> String)
-> ([Mutation] -> String -> String)
-> Show Mutation
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Mutation -> String -> String
showsPrec :: Int -> Mutation -> String -> String
$cshow :: Mutation -> String
show :: Mutation -> String
$cshowList :: [Mutation] -> String -> String
showList :: [Mutation] -> String -> String
Show, (forall x. Mutation -> Rep Mutation x)
-> (forall x. Rep Mutation x -> Mutation) -> Generic Mutation
forall x. Rep Mutation x -> Mutation
forall x. Mutation -> Rep Mutation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Mutation -> Rep Mutation x
from :: forall x. Mutation -> Rep Mutation x
$cto :: forall x. Rep Mutation x -> Mutation
to :: forall x. Rep Mutation x -> Mutation
Generic)

-- | Apply a single 'Mutation' to the given (transaction, UTxO) pair.
-- '''NOTE''': This function is partial, it can raise 'error' when some preconditions
-- are not met by the transaction or UTxO set, for example if there's no
-- Head script input or no datums in the transaction.
applyMutation :: Mutation -> (Tx, UTxO) -> (Tx, UTxO)
applyMutation :: Mutation -> (Tx, UTxO) -> (Tx, UTxO)
applyMutation Mutation
mutation (tx :: Tx
tx@(Tx TxBody
body [KeyWitness]
wits), UTxO
utxo) = case Mutation
mutation of
  ChangeHeadRedeemer Input
newRedeemer ->
    (TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits, UTxO
utxo)
   where
    body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
redeemers' Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity

    redeemers' :: TxBodyScriptData
redeemers' = (PlutusPurpose AsIndex LedgerEra
 -> (Data LedgerEra, ExUnits) -> (Data LedgerEra, ExUnits))
-> TxBodyScriptData -> TxBodyScriptData
alterRedeemers AlonzoPlutusPurpose AsIndex StandardBabbage
-> (Data StandardBabbage, ExUnits)
-> (Data StandardBabbage, ExUnits)
PlutusPurpose AsIndex LedgerEra
-> (Data LedgerEra, ExUnits) -> (Data LedgerEra, ExUnits)
newHeadRedeemer TxBodyScriptData
scriptData

    newHeadRedeemer :: AlonzoPlutusPurpose AsIndex StandardBabbage
-> (Data StandardBabbage, ExUnits)
-> (Data StandardBabbage, ExUnits)
newHeadRedeemer AlonzoPlutusPurpose AsIndex StandardBabbage
ix (Data StandardBabbage
dat, ExUnits
units)
      | TxOut CtxUTxO -> Bool
isHeadOutput (AlonzoPlutusPurpose AsIndex StandardBabbage -> TxOut CtxUTxO
forall w. AlonzoPlutusPurpose AsIndex w -> TxOut CtxUTxO
resolveInput AlonzoPlutusPurpose AsIndex StandardBabbage
ix) = (Data -> Data StandardBabbage
forall era. Era era => Data -> Data era
Ledger.Data (Input -> Data
forall a. ToData a => a -> Data
toData Input
newRedeemer), ExUnits
units)
      | Bool
otherwise = (Data StandardBabbage
dat, ExUnits
units)

    resolveInput :: Ledger.AlonzoPlutusPurpose AsIndex w -> TxOut CtxUTxO
    resolveInput :: forall w. AlonzoPlutusPurpose AsIndex w -> TxOut CtxUTxO
resolveInput AlonzoPlutusPurpose AsIndex w
ix =
      let k :: Word32
k = case AlonzoPlutusPurpose AsIndex w
ix of
            AlonzoSpending AsIndex Word32 (TxIn (EraCrypto w))
i -> AsIndex Word32 (TxIn (EraCrypto w)) -> Word32
forall ix it. AsIndex ix it -> ix
unAsIndex AsIndex Word32 (TxIn (EraCrypto w))
i
            AlonzoCertifying AsIndex Word32 (TxCert w)
i -> AsIndex Word32 (TxCert w) -> Word32
forall ix it. AsIndex ix it -> ix
unAsIndex AsIndex Word32 (TxCert w)
i
            AlonzoRewarding AsIndex Word32 (RewardAcnt (EraCrypto w))
i -> AsIndex Word32 (RewardAcnt (EraCrypto w)) -> Word32
forall ix it. AsIndex ix it -> ix
unAsIndex AsIndex Word32 (RewardAcnt (EraCrypto w))
i
            AlonzoMinting AsIndex Word32 (PolicyID (EraCrypto w))
i -> AsIndex Word32 (PolicyID (EraCrypto w)) -> Word32
forall ix it. AsIndex ix it -> ix
unAsIndex AsIndex Word32 (PolicyID (EraCrypto w))
i
          txIn :: TxIn StandardCrypto
txIn = Int -> Set (TxIn StandardCrypto) -> TxIn StandardCrypto
forall a. Int -> Set a -> a
Set.elemAt (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
k) Set (TxIn StandardCrypto)
Set (TxIn (EraCrypto StandardBabbage))
ledgerInputs -- NOTE: calls 'error' if out of bounds
       in case TxIn -> UTxO -> Maybe (TxOut CtxUTxO)
forall out. TxIn -> UTxO' out -> Maybe out
UTxO.resolve (TxIn StandardCrypto -> TxIn
fromLedgerTxIn TxIn StandardCrypto
txIn) UTxO
utxo of
            Maybe (TxOut CtxUTxO)
Nothing -> Text -> TxOut CtxUTxO
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> TxOut CtxUTxO) -> Text -> TxOut CtxUTxO
forall a b. (a -> b) -> a -> b
$ Text
"txIn not resolvable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxIn StandardCrypto -> Text
forall b a. (Show a, IsString b) => a -> b
show TxIn StandardCrypto
txIn
            Just TxOut CtxUTxO
o -> TxOut CtxUTxO
o

    ledgerInputs :: Set (TxIn (EraCrypto StandardBabbage))
ledgerInputs = Getting
  (Set (TxIn (EraCrypto StandardBabbage)))
  (TxBody StandardBabbage)
  (Set (TxIn (EraCrypto StandardBabbage)))
-> BabbageTxBody StandardBabbage
-> Set (TxIn (EraCrypto StandardBabbage))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Set (TxIn (EraCrypto StandardBabbage)))
  (TxBody StandardBabbage)
  (Set (TxIn (EraCrypto StandardBabbage)))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
inputsTxBodyL TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody

    ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
  ChangeInputHeadDatum State
d' ->
    ( Tx
tx
    , TxOut CtxUTxO -> TxOut CtxUTxO
replaceHeadDatum (TxOut CtxUTxO -> TxOut CtxUTxO) -> UTxO -> UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO
utxo
    )
   where
    replaceHeadDatum :: TxOut CtxUTxO -> TxOut CtxUTxO
replaceHeadDatum o :: TxOut CtxUTxO
o@(TxOut AddressInEra
addr Value
value TxOutDatum CtxUTxO
_ ReferenceScript
refScript)
      | TxOut CtxUTxO -> Bool
isHeadOutput TxOut CtxUTxO
o =
          AddressInEra
-> Value -> TxOutDatum CtxUTxO -> ReferenceScript -> TxOut CtxUTxO
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
addr Value
value (State -> TxOutDatum CtxUTxO
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline State
d') ReferenceScript
refScript
      | Bool
otherwise = TxOut CtxUTxO
o
  PrependOutput TxOut CtxTx
txOut ->
    ( ([TxOut CtxTx] -> [TxOut CtxTx]) -> Tx -> Tx
alterTxOuts (TxOut CtxTx
txOut :) Tx
tx
    , UTxO
utxo
    )
  AppendOutput TxOut CtxTx
txOut ->
    ( ([TxOut CtxTx] -> [TxOut CtxTx]) -> Tx -> Tx
alterTxOuts ([TxOut CtxTx] -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. Semigroup a => a -> a -> a
<> [TxOut CtxTx
txOut]) Tx
tx
    , UTxO
utxo
    )
  RemoveOutput Word
ix ->
    ( ([TxOut CtxTx] -> [TxOut CtxTx]) -> Tx -> Tx
alterTxOuts (Word -> [TxOut CtxTx] -> [TxOut CtxTx]
forall {b} {b}. Integral b => b -> [b] -> [b]
removeAt Word
ix) Tx
tx
    , UTxO
utxo
    )
   where
    removeAt :: b -> [b] -> [b]
removeAt b
i [b]
es =
      if b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
es
        then Text -> [b]
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"trying to removeAt beyond end of list"
        else
          ((b, b) -> b) -> [(b, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, b) -> b
forall a b. (a, b) -> b
snd ([(b, b)] -> [b]) -> [(b, b)] -> [b]
forall a b. (a -> b) -> a -> b
$
            ((b, b) -> Bool) -> [(b, b)] -> [(b, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/= b
i) (b -> Bool) -> ((b, b) -> b) -> (b, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, b) -> b
forall a b. (a, b) -> a
fst) ([(b, b)] -> [(b, b)]) -> [(b, b)] -> [(b, b)]
forall a b. (a -> b) -> a -> b
$
              [b] -> [b] -> [(b, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [b
0 ..] [b]
es
  RemoveInput TxIn
txIn ->
    ( ([(TxIn, Maybe HashableScriptData)]
 -> [(TxIn, Maybe HashableScriptData)])
-> Tx -> Tx
alterTxIns (((TxIn, Maybe HashableScriptData) -> Bool)
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TxIn
i, Maybe HashableScriptData
_) -> TxIn
i TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
/= TxIn
txIn)) Tx
tx
    , UTxO
utxo
    )
  AddInput TxIn
i TxOut CtxUTxO
o Maybe HashableScriptData
newRedeemer ->
    ( ([(TxIn, Maybe HashableScriptData)]
 -> [(TxIn, Maybe HashableScriptData)])
-> Tx -> Tx
alterTxIns [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
addRedeemer Tx
tx
    , Map TxIn (TxOut CtxUTxO) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO) -> UTxO)
-> Map TxIn (TxOut CtxUTxO) -> UTxO
forall a b. (a -> b) -> a -> b
$ TxIn
-> TxOut CtxUTxO
-> Map TxIn (TxOut CtxUTxO)
-> Map TxIn (TxOut CtxUTxO)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
i TxOut CtxUTxO
o (UTxO -> Map TxIn (TxOut CtxUTxO)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap UTxO
utxo)
    )
   where
    addRedeemer :: [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
addRedeemer =
      ((TxIn, Maybe HashableScriptData)
 -> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> [a] -> [b]
map (((TxIn, Maybe HashableScriptData)
  -> (TxIn, Maybe HashableScriptData))
 -> [(TxIn, Maybe HashableScriptData)]
 -> [(TxIn, Maybe HashableScriptData)])
-> ((TxIn, Maybe HashableScriptData)
    -> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> a -> b
$ \(TxIn
txIn', Maybe HashableScriptData
mRedeemer) ->
        if TxIn
txIn' TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn
i then (TxIn
i, Maybe HashableScriptData
newRedeemer) else (TxIn
txIn', Maybe HashableScriptData
mRedeemer)
  AddScript PlutusScript
script ->
    (TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits, UTxO
utxo)
   where
    ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
    body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
[AlonzoScript StandardBabbage]
scripts' TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
    scripts' :: [AlonzoScript StandardBabbage]
scripts' = [Script LedgerEra]
[AlonzoScript StandardBabbage]
scripts [AlonzoScript StandardBabbage]
-> [AlonzoScript StandardBabbage] -> [AlonzoScript StandardBabbage]
forall a. Semigroup a => a -> a -> a
<> [PlutusScript -> AlonzoScript LedgerEra
forall lang era.
ToAlonzoScript lang era =>
PlutusScript lang -> AlonzoScript (ShelleyLedgerEra era)
toLedgerScript PlutusScript
script]
  ChangeInput TxIn
txIn TxOut CtxUTxO
txOut Maybe HashableScriptData
newRedeemer ->
    Bool -> (Tx, UTxO) -> (Tx, UTxO)
forall a. HasCallStack => Bool -> a -> a
assert
      Bool
redeemerGivenIfScriptTxOut
      ( ([(TxIn, Maybe HashableScriptData)]
 -> [(TxIn, Maybe HashableScriptData)])
-> Tx -> Tx
alterTxIns [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
replaceRedeemer Tx
tx
      , Map TxIn (TxOut CtxUTxO) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO) -> UTxO)
-> Map TxIn (TxOut CtxUTxO) -> UTxO
forall a b. (a -> b) -> a -> b
$ TxIn
-> TxOut CtxUTxO
-> Map TxIn (TxOut CtxUTxO)
-> Map TxIn (TxOut CtxUTxO)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
txIn TxOut CtxUTxO
txOut (UTxO -> Map TxIn (TxOut CtxUTxO)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap UTxO
utxo)
      )
   where
    redeemerGivenIfScriptTxOut :: Bool
redeemerGivenIfScriptTxOut =
      Bool -> Bool
not Bool
isScriptOutput Bool -> Bool -> Bool
|| Maybe HashableScriptData -> Bool
forall a. Maybe a -> Bool
isJust Maybe HashableScriptData
newRedeemer

    isScriptOutput :: Bool
isScriptOutput = case TxOut CtxUTxO -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO
txOut of
      ByronAddressInEra ByronAddress{} -> Bool
False
      ShelleyAddressInEra (ShelleyAddress Network
_ PaymentCredential StandardCrypto
cred StakeReference StandardCrypto
_) ->
        case PaymentCredential StandardCrypto
cred of
          KeyHashObj{} -> Bool
False
          ScriptHashObj{} -> Bool
True

    replaceRedeemer :: [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
replaceRedeemer =
      ((TxIn, Maybe HashableScriptData)
 -> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> [a] -> [b]
map (((TxIn, Maybe HashableScriptData)
  -> (TxIn, Maybe HashableScriptData))
 -> [(TxIn, Maybe HashableScriptData)]
 -> [(TxIn, Maybe HashableScriptData)])
-> ((TxIn, Maybe HashableScriptData)
    -> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> a -> b
$ \(TxIn
txIn', Maybe HashableScriptData
mRedeemer) ->
        if TxIn
txIn' TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn
txIn then (TxIn
txIn, Maybe HashableScriptData
newRedeemer) else (TxIn
txIn', Maybe HashableScriptData
mRedeemer)
  ChangeOutput Word
ix TxOut CtxTx
txOut ->
    ( ([TxOut CtxTx] -> [TxOut CtxTx]) -> Tx -> Tx
alterTxOuts [TxOut CtxTx] -> [TxOut CtxTx]
replaceAtIndex Tx
tx
    , UTxO
utxo
    )
   where
    replaceAtIndex :: [TxOut CtxTx] -> [TxOut CtxTx]
replaceAtIndex [TxOut CtxTx]
outs =
      ((Word, TxOut CtxTx) -> [TxOut CtxTx] -> [TxOut CtxTx])
-> [TxOut CtxTx] -> [(Word, TxOut CtxTx)] -> [TxOut CtxTx]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        ( \(Word
i, TxOut CtxTx
out) [TxOut CtxTx]
list ->
            if Word
i Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
ix then TxOut CtxTx
txOut TxOut CtxTx -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. a -> [a] -> [a]
: [TxOut CtxTx]
list else TxOut CtxTx
out TxOut CtxTx -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. a -> [a] -> [a]
: [TxOut CtxTx]
list
        )
        []
        ([Word] -> [TxOut CtxTx] -> [(Word, TxOut CtxTx)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0 ..] [TxOut CtxTx]
outs)
  ChangeMintedValue Value
v' ->
    (TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits, UTxO
utxo)
   where
    ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
    valueToMultiAsset :: MaryValue c -> MultiAsset c
valueToMultiAsset (Ledger.MaryValue Coin
_ MultiAsset c
multiAsset) = MultiAsset c
multiAsset
    ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' =
      TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody
        BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& ASetter
  (BabbageTxBody StandardBabbage)
  (BabbageTxBody StandardBabbage)
  (MultiAsset (EraCrypto StandardBabbage))
  (MultiAsset StandardCrypto)
-> MultiAsset StandardCrypto
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (BabbageTxBody StandardBabbage)
  (BabbageTxBody StandardBabbage)
  (MultiAsset (EraCrypto StandardBabbage))
  (MultiAsset StandardCrypto)
(MultiAsset (EraCrypto StandardBabbage)
 -> Identity (MultiAsset (EraCrypto StandardBabbage)))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
MaryEraTxBody era =>
Lens' (TxBody era) (MultiAsset (EraCrypto era))
Lens'
  (TxBody StandardBabbage) (MultiAsset (EraCrypto StandardBabbage))
mintTxBodyL (MaryValue StandardCrypto -> MultiAsset StandardCrypto
forall {c}. MaryValue c -> MultiAsset c
valueToMultiAsset (MaryValue StandardCrypto -> MultiAsset StandardCrypto)
-> MaryValue StandardCrypto -> MultiAsset StandardCrypto
forall a b. (a -> b) -> a -> b
$ Value -> MaryValue StandardCrypto
toLedgerValue Value
v')
    body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
scripts TxBodyScriptData
scriptData' Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
    -- Drop all Mint redeemer pointers when we don't mint/burn anymore
    scriptData' :: TxBodyScriptData
scriptData' =
      if Value
v' Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
forall a. Monoid a => a
mempty
        then TxBodyScriptData
scriptData
        else case TxBodyScriptData
scriptData of
          TxBodyScriptData
TxBodyNoScriptData -> TxBodyScriptData
TxBodyNoScriptData
          TxBodyScriptData TxDats LedgerEra
dats (Ledger.Redeemers Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
redeemers) ->
            let newRedeemers :: Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
newRedeemers =
                  (AlonzoPlutusPurpose AsIndex StandardBabbage
 -> (Data StandardBabbage, ExUnits) -> Bool)
-> Map
     (AlonzoPlutusPurpose AsIndex StandardBabbage)
     (Data StandardBabbage, ExUnits)
-> Map
     (AlonzoPlutusPurpose AsIndex StandardBabbage)
     (Data StandardBabbage, ExUnits)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
                    ( \AlonzoPlutusPurpose AsIndex StandardBabbage
x (Data StandardBabbage, ExUnits)
_ -> case AlonzoPlutusPurpose AsIndex StandardBabbage
x of
                        Ledger.AlonzoMinting AsIndex Word32 (PolicyID (EraCrypto StandardBabbage))
_ -> Bool
False
                        AlonzoPlutusPurpose AsIndex StandardBabbage
_ -> Bool
True
                    )
                    Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
redeemers
             in TxDats LedgerEra -> Redeemers LedgerEra -> TxBodyScriptData
TxBodyScriptData TxDats LedgerEra
dats (Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIndex era) (Data era, ExUnits)
-> Redeemers era
Ledger.Redeemers Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
newRedeemers)
  ChangeRequiredSigners [Hash PaymentKey]
newSigners ->
    (TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits, UTxO
utxo)
   where
    ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
    body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
    ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' =
      TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody
        BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& ASetter
  (BabbageTxBody StandardBabbage)
  (BabbageTxBody StandardBabbage)
  (Set (KeyHash 'Witness (EraCrypto StandardBabbage)))
  (Set (KeyHash 'Witness StandardCrypto))
-> Set (KeyHash 'Witness StandardCrypto)
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (BabbageTxBody StandardBabbage)
  (BabbageTxBody StandardBabbage)
  (Set (KeyHash 'Witness (EraCrypto StandardBabbage)))
  (Set (KeyHash 'Witness StandardCrypto))
(Set (KeyHash 'Witness (EraCrypto StandardBabbage))
 -> Identity (Set (KeyHash 'Witness (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (KeyHash 'Witness (EraCrypto era)))
Lens'
  (TxBody StandardBabbage)
  (Set (KeyHash 'Witness (EraCrypto StandardBabbage)))
reqSignerHashesTxBodyL ([KeyHash 'Witness StandardCrypto]
-> Set (KeyHash 'Witness StandardCrypto)
forall a. Ord a => [a] -> Set a
Set.fromList (Hash PaymentKey -> KeyHash 'Witness StandardCrypto
toLedgerKeyHash (Hash PaymentKey -> KeyHash 'Witness StandardCrypto)
-> [Hash PaymentKey] -> [KeyHash 'Witness StandardCrypto]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Hash PaymentKey]
newSigners))
  ChangeValidityInterval (TxValidityLowerBound
lowerBound, TxValidityUpperBound
upperBound) ->
    Maybe TxValidityLowerBound
-> Maybe TxValidityUpperBound -> (Tx, UTxO)
changeValidityInterval (TxValidityLowerBound -> Maybe TxValidityLowerBound
forall a. a -> Maybe a
Just TxValidityLowerBound
lowerBound) (TxValidityUpperBound -> Maybe TxValidityUpperBound
forall a. a -> Maybe a
Just TxValidityUpperBound
upperBound)
  ChangeValidityLowerBound TxValidityLowerBound
bound ->
    Maybe TxValidityLowerBound
-> Maybe TxValidityUpperBound -> (Tx, UTxO)
changeValidityInterval (TxValidityLowerBound -> Maybe TxValidityLowerBound
forall a. a -> Maybe a
Just TxValidityLowerBound
bound) Maybe TxValidityUpperBound
forall a. Maybe a
Nothing
  ChangeValidityUpperBound TxValidityUpperBound
bound ->
    Maybe TxValidityLowerBound
-> Maybe TxValidityUpperBound -> (Tx, UTxO)
changeValidityInterval Maybe TxValidityLowerBound
forall a. Maybe a
Nothing (TxValidityUpperBound -> Maybe TxValidityUpperBound
forall a. a -> Maybe a
Just TxValidityUpperBound
bound)
  ChangeMintingPolicy PlutusScript
pScript ->
    ( TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits
    , UTxO
utxo
    )
   where
    mutatedPid :: PolicyId
mutatedPid = Script PlutusScriptV2 -> PolicyId
forall lang. Script lang -> PolicyId
scriptPolicyId (Script PlutusScriptV2 -> PolicyId)
-> Script PlutusScriptV2 -> PolicyId
forall a b. (a -> b) -> a -> b
$ PlutusScript -> Script PlutusScriptV2
PlutusScript PlutusScript
pScript

    body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
[AlonzoScript StandardBabbage]
scripts' TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity

    valueToMultiAsset :: MaryValue c -> MultiAsset c
valueToMultiAsset (Ledger.MaryValue Coin
_ MultiAsset c
multiAsset) = MultiAsset c
multiAsset

    ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' =
      TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody
        BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& ASetter
  (BabbageTxBody StandardBabbage)
  (BabbageTxBody StandardBabbage)
  (MultiAsset (EraCrypto StandardBabbage))
  (MultiAsset StandardCrypto)
-> MultiAsset StandardCrypto
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
set
          ASetter
  (BabbageTxBody StandardBabbage)
  (BabbageTxBody StandardBabbage)
  (MultiAsset (EraCrypto StandardBabbage))
  (MultiAsset StandardCrypto)
(MultiAsset (EraCrypto StandardBabbage)
 -> Identity (MultiAsset (EraCrypto StandardBabbage)))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
MaryEraTxBody era =>
Lens' (TxBody era) (MultiAsset (EraCrypto era))
Lens'
  (TxBody StandardBabbage) (MultiAsset (EraCrypto StandardBabbage))
mintTxBodyL
          ( MaryValue StandardCrypto -> MultiAsset StandardCrypto
forall {c}. MaryValue c -> MultiAsset c
valueToMultiAsset (MaryValue StandardCrypto -> MultiAsset StandardCrypto)
-> (Value -> MaryValue StandardCrypto)
-> Value
-> MultiAsset StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> MaryValue StandardCrypto
toLedgerValue (Value -> MultiAsset StandardCrypto)
-> Value -> MultiAsset StandardCrypto
forall a b. (a -> b) -> a -> b
$
              PolicyId -> PolicyId -> Value -> Value
replacePolicyInValue PolicyId
selectedPid PolicyId
mutatedPid Value
mint
          )

    selectedPid :: PolicyId
selectedPid =
      PolicyId -> Maybe PolicyId -> PolicyId
forall a. a -> Maybe a -> a
fromMaybe (Text -> PolicyId
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"cannot mutate non minting transaction")
        (Maybe PolicyId -> PolicyId)
-> ([(AssetId, Quantity)] -> Maybe PolicyId)
-> [(AssetId, Quantity)]
-> PolicyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> Maybe PolicyId)
-> [(AssetId, Quantity)] -> Maybe PolicyId
forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
findFirst
          ( \case
              (AssetId PolicyId
pid AssetName
_, Quantity
_) -> PolicyId -> Maybe PolicyId
forall a. a -> Maybe a
Just PolicyId
pid
              (AssetId
AdaAssetId, Quantity
_) -> Maybe PolicyId
forall a. Maybe a
Nothing
          )
        ([(AssetId, Quantity)] -> PolicyId)
-> [(AssetId, Quantity)] -> PolicyId
forall a b. (a -> b) -> a -> b
$ Value -> [(AssetId, Quantity)]
valueToList Value
mint

    mint :: Value
mint = MultiAsset StandardCrypto -> Value
fromLedgerMultiAsset (MultiAsset StandardCrypto -> Value)
-> MultiAsset StandardCrypto -> Value
forall a b. (a -> b) -> a -> b
$ Getting
  (MultiAsset StandardCrypto)
  (TxBody StandardBabbage)
  (MultiAsset StandardCrypto)
-> BabbageTxBody StandardBabbage -> MultiAsset StandardCrypto
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (MultiAsset StandardCrypto)
  (TxBody StandardBabbage)
  (MultiAsset StandardCrypto)
(MultiAsset (EraCrypto StandardBabbage)
 -> Const
      (MultiAsset StandardCrypto)
      (MultiAsset (EraCrypto StandardBabbage)))
-> TxBody StandardBabbage
-> Const (MultiAsset StandardCrypto) (TxBody StandardBabbage)
forall era.
MaryEraTxBody era =>
Lens' (TxBody era) (MultiAsset (EraCrypto era))
Lens'
  (TxBody StandardBabbage) (MultiAsset (EraCrypto StandardBabbage))
mintTxBodyL TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody

    scripts' :: [AlonzoScript StandardBabbage]
scripts' =
      (AlonzoScript StandardBabbage -> AlonzoScript StandardBabbage)
-> [AlonzoScript StandardBabbage] -> [AlonzoScript StandardBabbage]
forall a b. (a -> b) -> [a] -> [b]
map
        ( \AlonzoScript StandardBabbage
s ->
            if ScriptHash StandardCrypto -> PolicyID StandardCrypto
forall c. ScriptHash c -> PolicyID c
Ledger.PolicyID (forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
Ledger.hashScript @LedgerEra Script LedgerEra
AlonzoScript StandardBabbage
s) PolicyID StandardCrypto -> PolicyID StandardCrypto -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId -> PolicyID StandardCrypto
toLedgerPolicyID PolicyId
selectedPid
              then PlutusScript -> AlonzoScript LedgerEra
forall lang era.
ToAlonzoScript lang era =>
PlutusScript lang -> AlonzoScript (ShelleyLedgerEra era)
toLedgerScript PlutusScript
pScript
              else AlonzoScript StandardBabbage
s
        )
        [Script LedgerEra]
[AlonzoScript StandardBabbage]
scripts

    ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
  Changes [Mutation]
mutations ->
    (Mutation -> (Tx, UTxO) -> (Tx, UTxO))
-> (Tx, UTxO) -> [Mutation] -> (Tx, UTxO)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Mutation -> (Tx, UTxO) -> (Tx, UTxO)
applyMutation (Tx
tx, UTxO
utxo) [Mutation]
mutations
 where
  changeValidityInterval :: Maybe TxValidityLowerBound
-> Maybe TxValidityUpperBound -> (Tx, UTxO)
changeValidityInterval Maybe TxValidityLowerBound
lowerBound' Maybe TxValidityUpperBound
upperBound' =
    (TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits, UTxO
utxo)
   where
    ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
    body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
    ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' =
      TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody
        BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& (ValidityInterval -> Identity ValidityInterval)
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
(ValidityInterval -> Identity ValidityInterval)
-> BabbageTxBody StandardBabbage
-> Identity (BabbageTxBody StandardBabbage)
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody StandardBabbage) ValidityInterval
vldtTxBodyL
          ((ValidityInterval -> Identity ValidityInterval)
 -> BabbageTxBody StandardBabbage
 -> Identity (BabbageTxBody StandardBabbage))
-> ValidityInterval
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (TxValidityLowerBound, TxValidityUpperBound) -> ValidityInterval
forall era.
(TxValidityLowerBound era, TxValidityUpperBound era)
-> ValidityInterval
toLedgerValidityInterval
            ( TxValidityLowerBound
-> Maybe TxValidityLowerBound -> TxValidityLowerBound
forall a. a -> Maybe a -> a
fromMaybe TxValidityLowerBound
lowerBound Maybe TxValidityLowerBound
lowerBound'
            , TxValidityUpperBound
-> Maybe TxValidityUpperBound -> TxValidityUpperBound
forall a. a -> Maybe a -> a
fromMaybe TxValidityUpperBound
upperBound Maybe TxValidityUpperBound
upperBound'
            )
    (TxValidityLowerBound
lowerBound, TxValidityUpperBound
upperBound) = ValidityInterval -> (TxValidityLowerBound, TxValidityUpperBound)
fromLedgerValidityInterval ValidityInterval
ledgerValidityInterval
    ledgerValidityInterval :: ValidityInterval
ledgerValidityInterval = TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody BabbageTxBody StandardBabbage
-> Getting
     ValidityInterval (BabbageTxBody StandardBabbage) ValidityInterval
-> ValidityInterval
forall s a. s -> Getting a s a -> a
^. (ValidityInterval -> Const ValidityInterval ValidityInterval)
-> TxBody StandardBabbage
-> Const ValidityInterval (TxBody StandardBabbage)
Getting
  ValidityInterval (BabbageTxBody StandardBabbage) ValidityInterval
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody StandardBabbage) ValidityInterval
vldtTxBodyL

-- * Orphans

deriving stock instance Eq Head.Input

instance Arbitrary Head.Input where
  arbitrary :: Gen Input
arbitrary = Gen Input
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

instance Arbitrary Head.State where
  arbitrary :: Gen State
arbitrary = Gen State
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

-- * Helpers

-- | Identify Head script's output.
isHeadOutput :: TxOut CtxUTxO -> Bool
isHeadOutput :: TxOut CtxUTxO -> Bool
isHeadOutput TxOut{txOutAddress :: forall ctx. TxOut ctx -> AddressInEra
txOutAddress = AddressInEra
addr} = AddressInEra
addr AddressInEra -> AddressInEra -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra
headAddress
 where
  headAddress :: AddressInEra
headAddress = forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
Fixture.testNetworkId PlutusScript
forall {lang}. PlutusScript lang
headScript
  headScript :: PlutusScript lang
headScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Head.validatorScript

-- | Adds given 'Datum' and corresponding hash to the transaction's scripts.
-- TODO: As we are creating the `TxOutDatum` from a known datum, passing a `TxOutDatum` is
-- pointless and requires more work than needed to check impossible variants.
addDatum :: TxOutDatum CtxTx -> TxBodyScriptData -> TxBodyScriptData
addDatum :: TxOutDatum CtxTx -> TxBodyScriptData -> TxBodyScriptData
addDatum TxOutDatum CtxTx
datum TxBodyScriptData
scriptData =
  case TxOutDatum CtxTx
datum of
    TxOutDatum CtxTx
TxOutDatumNone -> Text -> TxBodyScriptData
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected datum none"
    TxOutDatumHash Hash ScriptData
_ha -> Text -> TxBodyScriptData
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"hash only, expected full datum"
    TxOutDatumInline HashableScriptData
_sd -> Text -> TxBodyScriptData
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"not useful for inline datums"
    TxOutDatumInTx HashableScriptData
sd ->
      case TxBodyScriptData
scriptData of
        TxBodyScriptData
TxBodyNoScriptData -> Text -> TxBodyScriptData
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"TxBodyNoScriptData unexpected"
        TxBodyScriptData (Ledger.TxDats Map (DataHash (EraCrypto StandardBabbage)) (Data StandardBabbage)
dats) Redeemers LedgerEra
redeemers ->
          let dat :: Data StandardBabbage
dat = HashableScriptData -> Data StandardBabbage
forall era. Era era => HashableScriptData -> Data era
toLedgerData HashableScriptData
sd
              newDats :: TxDats StandardBabbage
newDats = Map (DataHash (EraCrypto StandardBabbage)) (Data StandardBabbage)
-> TxDats StandardBabbage
forall era.
Era era =>
Map (DataHash (EraCrypto era)) (Data era) -> TxDats era
Ledger.TxDats (Map (DataHash (EraCrypto StandardBabbage)) (Data StandardBabbage)
 -> TxDats StandardBabbage)
-> Map
     (DataHash (EraCrypto StandardBabbage)) (Data StandardBabbage)
-> TxDats StandardBabbage
forall a b. (a -> b) -> a -> b
$ DataHash StandardCrypto
-> Data StandardBabbage
-> Map (DataHash StandardCrypto) (Data StandardBabbage)
-> Map (DataHash StandardCrypto) (Data StandardBabbage)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Data StandardBabbage -> DataHash (EraCrypto StandardBabbage)
forall era. Era era => Data era -> DataHash (EraCrypto era)
Ledger.hashData Data StandardBabbage
dat) Data StandardBabbage
dat Map (DataHash StandardCrypto) (Data StandardBabbage)
Map (DataHash (EraCrypto StandardBabbage)) (Data StandardBabbage)
dats
           in TxDats LedgerEra -> Redeemers LedgerEra -> TxBodyScriptData
TxBodyScriptData TxDats LedgerEra
TxDats StandardBabbage
newDats Redeemers LedgerEra
redeemers

modifyInlineDatum :: (FromScriptData a, ToScriptData a) => (a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum :: forall a.
(FromScriptData a, ToScriptData a) =>
(a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum a -> a
fn TxOut CtxTx
txOut =
  case TxOut CtxTx -> TxOutDatum CtxTx
forall ctx. TxOut ctx -> TxOutDatum ctx
txOutDatum TxOut CtxTx
txOut of
    TxOutDatum CtxTx
TxOutDatumNone ->
      Text -> TxOut CtxTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Unexpected empty head datum"
    (TxOutDatumHash Hash ScriptData
_ha) ->
      Text -> TxOut CtxTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Unexpected hash-only datum"
    (TxOutDatumInTx HashableScriptData
_sd) ->
      Text -> TxOut CtxTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Unexpected in-tx datum"
    (TxOutDatumInline HashableScriptData
sd) ->
      case HashableScriptData -> Maybe a
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
sd of
        Just a
st ->
          TxOut CtxTx
txOut{txOutDatum = mkTxOutDatumInline $ fn st}
        Maybe a
Nothing ->
          Text -> TxOut CtxTx
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Invalid data"

addParticipationTokens :: [VerificationKey PaymentKey] -> TxOut CtxUTxO -> TxOut CtxUTxO
addParticipationTokens :: [VerificationKey PaymentKey] -> TxOut CtxUTxO -> TxOut CtxUTxO
addParticipationTokens [VerificationKey PaymentKey]
vks TxOut CtxUTxO
txOut =
  TxOut CtxUTxO
txOut{txOutValue = val'}
 where
  val' :: Value
val' =
    TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
txOut
      Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> [(AssetId, Quantity)] -> Value
valueFromList
        [ (PolicyId -> AssetName -> AssetId
AssetId PolicyId
testPolicyId (OnChainId -> AssetName
onChainIdToAssetName OnChainId
oid), Quantity
1)
        | OnChainId
oid <- [OnChainId]
participants
        ]

  participants :: [OnChainId]
participants = VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId (VerificationKey PaymentKey -> OnChainId)
-> [VerificationKey PaymentKey] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VerificationKey PaymentKey]
vks

-- | Ensures the included datums of given 'TxOut's are included in the transactions' 'TxBodyScriptData'.
ensureDatums :: [TxOut CtxTx] -> TxBodyScriptData -> TxBodyScriptData
ensureDatums :: [TxOut CtxTx] -> TxBodyScriptData -> TxBodyScriptData
ensureDatums [TxOut CtxTx]
outs TxBodyScriptData
scriptData =
  (TxOut CtxTx -> TxBodyScriptData -> TxBodyScriptData)
-> TxBodyScriptData -> [TxOut CtxTx] -> TxBodyScriptData
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TxOut CtxTx -> TxBodyScriptData -> TxBodyScriptData
ensureDatum TxBodyScriptData
scriptData [TxOut CtxTx]
outs
 where
  ensureDatum :: TxOut CtxTx -> TxBodyScriptData -> TxBodyScriptData
ensureDatum TxOut CtxTx
txOut TxBodyScriptData
sd =
    case TxOut CtxTx -> TxOutDatum CtxTx
forall ctx. TxOut ctx -> TxOutDatum ctx
txOutDatum TxOut CtxTx
txOut of
      d :: TxOutDatum CtxTx
d@(TxOutDatumInTx HashableScriptData
_) -> TxOutDatum CtxTx -> TxBodyScriptData -> TxBodyScriptData
addDatum TxOutDatum CtxTx
d TxBodyScriptData
sd
      TxOutDatum CtxTx
_ -> TxBodyScriptData
sd

-- | Alter a transaction's redeemers map given some mapping function.
alterRedeemers ::
  ( Ledger.PlutusPurpose Ledger.AsIndex LedgerEra ->
    (Ledger.Data LedgerEra, Ledger.ExUnits) ->
    (Ledger.Data LedgerEra, Ledger.ExUnits)
  ) ->
  TxBodyScriptData ->
  TxBodyScriptData
alterRedeemers :: (PlutusPurpose AsIndex LedgerEra
 -> (Data LedgerEra, ExUnits) -> (Data LedgerEra, ExUnits))
-> TxBodyScriptData -> TxBodyScriptData
alterRedeemers PlutusPurpose AsIndex LedgerEra
-> (Data LedgerEra, ExUnits) -> (Data LedgerEra, ExUnits)
fn = \case
  TxBodyScriptData
TxBodyNoScriptData -> Text -> TxBodyScriptData
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"TxBodyNoScriptData unexpected"
  TxBodyScriptData TxDats LedgerEra
dats (Ledger.Redeemers Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
redeemers) ->
    let newRedeemers :: Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
newRedeemers = (AlonzoPlutusPurpose AsIndex StandardBabbage
 -> (Data StandardBabbage, ExUnits)
 -> (Data StandardBabbage, ExUnits))
-> Map
     (AlonzoPlutusPurpose AsIndex StandardBabbage)
     (Data StandardBabbage, ExUnits)
-> Map
     (AlonzoPlutusPurpose AsIndex StandardBabbage)
     (Data StandardBabbage, ExUnits)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey AlonzoPlutusPurpose AsIndex StandardBabbage
-> (Data StandardBabbage, ExUnits)
-> (Data StandardBabbage, ExUnits)
PlutusPurpose AsIndex LedgerEra
-> (Data LedgerEra, ExUnits) -> (Data LedgerEra, ExUnits)
fn Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
redeemers
     in TxDats LedgerEra -> Redeemers LedgerEra -> TxBodyScriptData
TxBodyScriptData TxDats LedgerEra
dats (Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIndex era) (Data era, ExUnits)
-> Redeemers era
Ledger.Redeemers Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
newRedeemers)

-- | Alter the tx inputs in such way that redeemer pointer stay consistent. A
-- value of 'Nothing' for the redeemr means that this is not a script input.
-- NOTE: This will reset all the execution budgets to 0.
alterTxIns ::
  ([(TxIn, Maybe HashableScriptData)] -> [(TxIn, Maybe HashableScriptData)]) ->
  Tx ->
  Tx
alterTxIns :: ([(TxIn, Maybe HashableScriptData)]
 -> [(TxIn, Maybe HashableScriptData)])
-> Tx -> Tx
alterTxIns [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
fn Tx
tx =
  TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits
 where
  body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
scripts TxBodyScriptData
scriptData' Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity

  ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' = TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& ASetter
  (BabbageTxBody StandardBabbage)
  (BabbageTxBody StandardBabbage)
  (Set (TxIn (EraCrypto StandardBabbage)))
  (Set (TxIn StandardCrypto))
-> Set (TxIn StandardCrypto)
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (BabbageTxBody StandardBabbage)
  (BabbageTxBody StandardBabbage)
  (Set (TxIn (EraCrypto StandardBabbage)))
  (Set (TxIn StandardCrypto))
(Set (TxIn (EraCrypto StandardBabbage))
 -> Identity (Set (TxIn (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
inputsTxBodyL Set (TxIn StandardCrypto)
inputs'

  inputs' :: Set (TxIn StandardCrypto)
inputs' = [TxIn StandardCrypto] -> Set (TxIn StandardCrypto)
forall a. Ord a => [a] -> Set a
Set.fromList ([TxIn StandardCrypto] -> Set (TxIn StandardCrypto))
-> [TxIn StandardCrypto] -> Set (TxIn StandardCrypto)
forall a b. (a -> b) -> a -> b
$ TxIn -> TxIn StandardCrypto
toLedgerTxIn (TxIn -> TxIn StandardCrypto)
-> ((TxIn, Maybe HashableScriptData) -> TxIn)
-> (TxIn, Maybe HashableScriptData)
-> TxIn StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, Maybe HashableScriptData) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, Maybe HashableScriptData) -> TxIn StandardCrypto)
-> [(TxIn, Maybe HashableScriptData)] -> [TxIn StandardCrypto]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn, Maybe HashableScriptData)]
newSortedInputs

  scriptData' :: TxBodyScriptData
scriptData' = TxDats LedgerEra -> Redeemers LedgerEra -> TxBodyScriptData
TxBodyScriptData TxDats LedgerEra
TxDats StandardBabbage
dats Redeemers LedgerEra
Redeemers StandardBabbage
redeemers'

  redeemers' :: Redeemers StandardBabbage
redeemers' = Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIndex era) (Data era, ExUnits)
-> Redeemers era
Ledger.Redeemers (Map
   (PlutusPurpose AsIndex StandardBabbage)
   (Data StandardBabbage, ExUnits)
 -> Redeemers StandardBabbage)
-> Map
     (PlutusPurpose AsIndex StandardBabbage)
     (Data StandardBabbage, ExUnits)
-> Redeemers StandardBabbage
forall a b. (a -> b) -> a -> b
$ Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
forall {era}.
Map
  (AlonzoPlutusPurpose AsIndex era) (Data StandardBabbage, ExUnits)
rebuiltSpendingRedeemers Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
-> Map
     (AlonzoPlutusPurpose AsIndex StandardBabbage)
     (Data StandardBabbage, ExUnits)
-> Map
     (AlonzoPlutusPurpose AsIndex StandardBabbage)
     (Data StandardBabbage, ExUnits)
forall a. Semigroup a => a -> a -> a
<> Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
nonSpendingRedeemers

  nonSpendingRedeemers :: Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
nonSpendingRedeemers =
    (AlonzoPlutusPurpose AsIndex StandardBabbage
 -> (Data StandardBabbage, ExUnits) -> Bool)
-> Map
     (AlonzoPlutusPurpose AsIndex StandardBabbage)
     (Data StandardBabbage, ExUnits)
-> Map
     (AlonzoPlutusPurpose AsIndex StandardBabbage)
     (Data StandardBabbage, ExUnits)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
      ( \AlonzoPlutusPurpose AsIndex StandardBabbage
x (Data StandardBabbage, ExUnits)
_ -> case AlonzoPlutusPurpose AsIndex StandardBabbage
x of
          Ledger.AlonzoSpending AsIndex Word32 (TxIn (EraCrypto StandardBabbage))
_ -> Bool
False
          AlonzoPlutusPurpose AsIndex StandardBabbage
_ -> Bool
True
      )
      Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
redeemersMap

  rebuiltSpendingRedeemers :: Map
  (AlonzoPlutusPurpose AsIndex era) (Data StandardBabbage, ExUnits)
rebuiltSpendingRedeemers = [(AlonzoPlutusPurpose AsIndex era,
  (Data StandardBabbage, ExUnits))]
-> Map
     (AlonzoPlutusPurpose AsIndex era) (Data StandardBabbage, ExUnits)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(AlonzoPlutusPurpose AsIndex era,
   (Data StandardBabbage, ExUnits))]
 -> Map
      (AlonzoPlutusPurpose AsIndex era) (Data StandardBabbage, ExUnits))
-> [(AlonzoPlutusPurpose AsIndex era,
     (Data StandardBabbage, ExUnits))]
-> Map
     (AlonzoPlutusPurpose AsIndex era) (Data StandardBabbage, ExUnits)
forall a b. (a -> b) -> a -> b
$
    (((Word32, (TxIn, Maybe HashableScriptData))
  -> Maybe
       (AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits)))
 -> [(Word32, (TxIn, Maybe HashableScriptData))]
 -> [(AlonzoPlutusPurpose AsIndex era,
      (Data StandardBabbage, ExUnits))])
-> [(Word32, (TxIn, Maybe HashableScriptData))]
-> ((Word32, (TxIn, Maybe HashableScriptData))
    -> Maybe
         (AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits)))
-> [(AlonzoPlutusPurpose AsIndex era,
     (Data StandardBabbage, ExUnits))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Word32, (TxIn, Maybe HashableScriptData))
 -> Maybe
      (AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits)))
-> [(Word32, (TxIn, Maybe HashableScriptData))]
-> [(AlonzoPlutusPurpose AsIndex era,
     (Data StandardBabbage, ExUnits))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Word32]
-> [(TxIn, Maybe HashableScriptData)]
-> [(Word32, (TxIn, Maybe HashableScriptData))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0 ..] [(TxIn, Maybe HashableScriptData)]
newSortedInputs) (((Word32, (TxIn, Maybe HashableScriptData))
  -> Maybe
       (AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits)))
 -> [(AlonzoPlutusPurpose AsIndex era,
      (Data StandardBabbage, ExUnits))])
-> ((Word32, (TxIn, Maybe HashableScriptData))
    -> Maybe
         (AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits)))
-> [(AlonzoPlutusPurpose AsIndex era,
     (Data StandardBabbage, ExUnits))]
forall a b. (a -> b) -> a -> b
$ \(Word32
i, (TxIn
_, Maybe HashableScriptData
mRedeemer)) ->
      Maybe HashableScriptData
mRedeemer Maybe HashableScriptData
-> (HashableScriptData
    -> (AlonzoPlutusPurpose AsIndex era,
        (Data StandardBabbage, ExUnits)))
-> Maybe
     (AlonzoPlutusPurpose AsIndex era, (Data StandardBabbage, ExUnits))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \HashableScriptData
d ->
        (AsIndex Word32 (TxIn (EraCrypto era))
-> AlonzoPlutusPurpose AsIndex era
forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> AlonzoPlutusPurpose f era
Ledger.AlonzoSpending (Word32 -> AsIndex Word32 (TxIn (EraCrypto era))
forall ix it. ix -> AsIndex ix it
AsIndex Word32
i), (HashableScriptData -> Data StandardBabbage
forall era. Era era => HashableScriptData -> Data era
toLedgerData HashableScriptData
d, Nat -> Nat -> ExUnits
Ledger.ExUnits Nat
0 Nat
0))

  -- NOTE: This needs to be ordered, such that we can calculate the redeemer
  -- pointers correctly.
  newSortedInputs :: [(TxIn, Maybe HashableScriptData)]
  newSortedInputs :: [(TxIn, Maybe HashableScriptData)]
newSortedInputs =
    ((TxIn, Maybe HashableScriptData) -> TxIn)
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (TxIn, Maybe HashableScriptData) -> TxIn
forall a b. (a, b) -> a
fst
      ([(TxIn, Maybe HashableScriptData)]
 -> [(TxIn, Maybe HashableScriptData)])
-> [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> a -> b
$ [(TxIn, Maybe HashableScriptData)]
-> [(TxIn, Maybe HashableScriptData)]
fn
        ([(TxIn, Maybe HashableScriptData)]
 -> [(TxIn, Maybe HashableScriptData)])
-> (Set (TxIn StandardCrypto)
    -> [(TxIn, Maybe HashableScriptData)])
-> Set (TxIn StandardCrypto)
-> [(TxIn, Maybe HashableScriptData)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxIn] -> [(TxIn, Maybe HashableScriptData)]
resolveRedeemers
        ([TxIn] -> [(TxIn, Maybe HashableScriptData)])
-> (Set (TxIn StandardCrypto) -> [TxIn])
-> Set (TxIn StandardCrypto)
-> [(TxIn, Maybe HashableScriptData)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn StandardCrypto -> TxIn) -> [TxIn StandardCrypto] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxIn StandardCrypto -> TxIn
fromLedgerTxIn
        ([TxIn StandardCrypto] -> [TxIn])
-> (Set (TxIn StandardCrypto) -> [TxIn StandardCrypto])
-> Set (TxIn StandardCrypto)
-> [TxIn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (TxIn StandardCrypto) -> [TxIn StandardCrypto]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
      (Set (TxIn StandardCrypto) -> [(TxIn, Maybe HashableScriptData)])
-> Set (TxIn StandardCrypto) -> [(TxIn, Maybe HashableScriptData)]
forall a b. (a -> b) -> a -> b
$ Getting
  (Set (TxIn StandardCrypto))
  (TxBody StandardBabbage)
  (Set (TxIn StandardCrypto))
-> BabbageTxBody StandardBabbage -> Set (TxIn StandardCrypto)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Set (TxIn StandardCrypto))
  (TxBody StandardBabbage)
  (Set (TxIn StandardCrypto))
(Set (TxIn (EraCrypto StandardBabbage))
 -> Const
      (Set (TxIn StandardCrypto))
      (Set (TxIn (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage
-> Const (Set (TxIn StandardCrypto)) (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
inputsTxBodyL TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody

  resolveRedeemers :: [TxIn] -> [(TxIn, Maybe HashableScriptData)]
  resolveRedeemers :: [TxIn] -> [(TxIn, Maybe HashableScriptData)]
resolveRedeemers [TxIn]
txInputs =
    [TxIn] -> [Word32] -> [(TxIn, Word32)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxIn]
txInputs [Word32
0 ..] [(TxIn, Word32)]
-> ((TxIn, Word32) -> (TxIn, Maybe HashableScriptData))
-> [(TxIn, Maybe HashableScriptData)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(TxIn
txIn, Word32
i) ->
      case AlonzoPlutusPurpose AsIndex StandardBabbage
-> Map
     (AlonzoPlutusPurpose AsIndex StandardBabbage)
     (Data StandardBabbage, ExUnits)
-> Maybe (Data StandardBabbage, ExUnits)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (AsIndex Word32 (TxIn (EraCrypto StandardBabbage))
-> AlonzoPlutusPurpose AsIndex StandardBabbage
forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> AlonzoPlutusPurpose f era
Ledger.AlonzoSpending (Word32 -> AsIndex Word32 (TxIn StandardCrypto)
forall ix it. ix -> AsIndex ix it
AsIndex Word32
i)) Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
redeemersMap of
        Maybe (Data StandardBabbage, ExUnits)
Nothing -> (TxIn
txIn, Maybe HashableScriptData
forall a. Maybe a
Nothing)
        Just (Data StandardBabbage
redeemerData, ExUnits
_exUnits) -> (TxIn
txIn, HashableScriptData -> Maybe HashableScriptData
forall a. a -> Maybe a
Just (HashableScriptData -> Maybe HashableScriptData)
-> HashableScriptData -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ Data StandardBabbage -> HashableScriptData
forall era. Data era -> HashableScriptData
fromLedgerData Data StandardBabbage
redeemerData)

  (TxDats StandardBabbage
dats, Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
redeemersMap) = case TxBodyScriptData
scriptData of
    TxBodyScriptData
TxBodyNoScriptData -> (TxDats StandardBabbage
forall a. Monoid a => a
mempty, Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
forall a. Monoid a => a
mempty)
    TxBodyScriptData TxDats LedgerEra
d (Ledger.Redeemers Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
r) -> (TxDats LedgerEra
TxDats StandardBabbage
d, Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
r)

  ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body

  Tx TxBody
body [KeyWitness]
wits = Tx
tx

-- | Apply some mapping function over a transaction's outputs.
alterTxOuts ::
  ([TxOut CtxTx] -> [TxOut CtxTx]) ->
  Tx ->
  Tx
alterTxOuts :: ([TxOut CtxTx] -> [TxOut CtxTx]) -> Tx -> Tx
alterTxOuts [TxOut CtxTx] -> [TxOut CtxTx]
fn Tx
tx =
  TxBody -> [KeyWitness] -> Tx
Tx TxBody
body' [KeyWitness]
wits
 where
  body' :: TxBody
body' = TxBody LedgerEra
-> [Script LedgerEra]
-> TxBodyScriptData
-> Maybe (AlonzoTxAuxData LedgerEra)
-> TxScriptValidity
-> TxBody
ShelleyTxBody TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody' [Script LedgerEra]
scripts TxBodyScriptData
scriptData' Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity
  ledgerBody' :: BabbageTxBody StandardBabbage
ledgerBody' = TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut StandardBabbage)
 -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
-> BabbageTxBody StandardBabbage
-> Identity (BabbageTxBody StandardBabbage)
(StrictSeq (TxOut StandardBabbage)
 -> Identity (StrictSeq (TxOut StandardBabbage)))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody StandardBabbage) (StrictSeq (TxOut StandardBabbage))
outputsTxBodyL ((StrictSeq (TxOut StandardBabbage)
  -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
 -> BabbageTxBody StandardBabbage
 -> Identity (BabbageTxBody StandardBabbage))
-> StrictSeq (BabbageTxOut StandardBabbage)
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (BabbageTxOut StandardBabbage)
ledgerOutputs'

  ledgerOutputs' :: StrictSeq (BabbageTxOut StandardBabbage)
ledgerOutputs' = [BabbageTxOut StandardBabbage]
-> StrictSeq (BabbageTxOut StandardBabbage)
forall a. [a] -> StrictSeq a
StrictSeq.fromList ([BabbageTxOut StandardBabbage]
 -> StrictSeq (BabbageTxOut StandardBabbage))
-> ([TxOut CtxTx] -> [BabbageTxOut StandardBabbage])
-> [TxOut CtxTx]
-> StrictSeq (BabbageTxOut StandardBabbage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut CtxTx -> BabbageTxOut StandardBabbage)
-> [TxOut CtxTx] -> [BabbageTxOut StandardBabbage]
forall a b. (a -> b) -> [a] -> [b]
map (TxOut CtxUTxO -> BabbageTxOut StandardBabbage
TxOut CtxUTxO -> TxOut LedgerEra
toLedgerTxOut (TxOut CtxUTxO -> BabbageTxOut StandardBabbage)
-> (TxOut CtxTx -> TxOut CtxUTxO)
-> TxOut CtxTx
-> BabbageTxOut StandardBabbage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut) ([TxOut CtxTx] -> StrictSeq (BabbageTxOut StandardBabbage))
-> [TxOut CtxTx] -> StrictSeq (BabbageTxOut StandardBabbage)
forall a b. (a -> b) -> a -> b
$ [TxOut CtxTx]
outputs'

  outputs' :: [TxOut CtxTx]
outputs' = [TxOut CtxTx] -> [TxOut CtxTx]
fn ([TxOut CtxTx] -> [TxOut CtxTx])
-> (StrictSeq (BabbageTxOut StandardBabbage) -> [TxOut CtxTx])
-> StrictSeq (BabbageTxOut StandardBabbage)
-> [TxOut CtxTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BabbageTxOut StandardBabbage -> TxOut CtxTx)
-> [BabbageTxOut StandardBabbage] -> [TxOut CtxTx]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BabbageTxOut StandardBabbage -> TxOut CtxTx
TxOut LedgerEra -> TxOut CtxTx
forall ctx. TxOut LedgerEra -> TxOut ctx Era
fromLedgerTxOut ([BabbageTxOut StandardBabbage] -> [TxOut CtxTx])
-> (StrictSeq (BabbageTxOut StandardBabbage)
    -> [BabbageTxOut StandardBabbage])
-> StrictSeq (BabbageTxOut StandardBabbage)
-> [TxOut CtxTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (BabbageTxOut StandardBabbage)
-> [BabbageTxOut StandardBabbage]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (BabbageTxOut StandardBabbage) -> [TxOut CtxTx])
-> StrictSeq (BabbageTxOut StandardBabbage) -> [TxOut CtxTx]
forall a b. (a -> b) -> a -> b
$ TxBody LedgerEra
BabbageTxBody StandardBabbage
ledgerBody BabbageTxBody StandardBabbage
-> Getting
     (StrictSeq (BabbageTxOut StandardBabbage))
     (BabbageTxBody StandardBabbage)
     (StrictSeq (BabbageTxOut StandardBabbage))
-> StrictSeq (BabbageTxOut StandardBabbage)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (BabbageTxOut StandardBabbage))
  (BabbageTxBody StandardBabbage)
  (StrictSeq (BabbageTxOut StandardBabbage))
(StrictSeq (TxOut StandardBabbage)
 -> Const
      (StrictSeq (BabbageTxOut StandardBabbage))
      (StrictSeq (TxOut StandardBabbage)))
-> TxBody StandardBabbage
-> Const
     (StrictSeq (BabbageTxOut StandardBabbage)) (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody StandardBabbage) (StrictSeq (TxOut StandardBabbage))
outputsTxBodyL

  scriptData' :: TxBodyScriptData
scriptData' = [TxOut CtxTx] -> TxBodyScriptData -> TxBodyScriptData
ensureDatums [TxOut CtxTx]
outputs' TxBodyScriptData
scriptData

  ShelleyTxBody TxBody LedgerEra
ledgerBody [Script LedgerEra]
scripts TxBodyScriptData
scriptData Maybe (AlonzoTxAuxData LedgerEra)
mAuxData TxScriptValidity
scriptValidity = TxBody
body
  Tx TxBody
body [KeyWitness]
wits = Tx
tx

-- | Generates an output that pays to some arbitrary pubkey.
anyPayToPubKeyTxOut :: Gen (TxOut ctx)
anyPayToPubKeyTxOut :: forall ctx. Gen (TxOut ctx)
anyPayToPubKeyTxOut = Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey)
    -> Gen (TxOut ctx))
-> Gen (TxOut ctx)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VerificationKey PaymentKey -> Gen (TxOut ctx)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutput (VerificationKey PaymentKey -> Gen (TxOut ctx))
-> ((VerificationKey PaymentKey, SigningKey PaymentKey)
    -> VerificationKey PaymentKey)
-> (VerificationKey PaymentKey, SigningKey PaymentKey)
-> Gen (TxOut ctx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VerificationKey PaymentKey, SigningKey PaymentKey)
-> VerificationKey PaymentKey
forall a b. (a, b) -> a
fst

-- | Finds the Head script's input in given `UTxO` set.
-- '''NOTE''': This function is partial, it assumes the `UTxO` set contains a
-- Head script output.
headTxIn :: UTxO -> TxIn
headTxIn :: UTxO -> TxIn
headTxIn = (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, TxOut CtxUTxO) -> TxIn)
-> (UTxO -> (TxIn, TxOut CtxUTxO)) -> UTxO -> TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, TxOut CtxUTxO)] -> (TxIn, TxOut CtxUTxO)
forall a. HasCallStack => [a] -> a
Prelude.head ([(TxIn, TxOut CtxUTxO)] -> (TxIn, TxOut CtxUTxO))
-> (UTxO -> [(TxIn, TxOut CtxUTxO)])
-> UTxO
-> (TxIn, TxOut CtxUTxO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, TxOut CtxUTxO) -> Bool)
-> [(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxOut CtxUTxO -> Bool
isHeadOutput (TxOut CtxUTxO -> Bool)
-> ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO)
-> (TxIn, TxOut CtxUTxO)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO
forall a b. (a, b) -> b
snd) ([(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)])
-> (UTxO -> [(TxIn, TxOut CtxUTxO)])
-> UTxO
-> [(TxIn, TxOut CtxUTxO)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs

-- | A 'Mutation' that changes the minted/burnt quantity of all tokens to a
-- non-zero value different than the given one.
changeMintedValueQuantityFrom :: Tx -> Integer -> Gen Mutation
changeMintedValueQuantityFrom :: Tx -> Integer -> Gen Mutation
changeMintedValueQuantityFrom Tx
tx Integer
exclude =
  Value -> Mutation
ChangeMintedValue
    (Value -> Mutation) -> Gen Value -> Gen Mutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case TxMintValue ViewTx
mintedValue of
      TxMintValue ViewTx
TxMintValueNone ->
        Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
forall a. Monoid a => a
mempty
      TxMintValue Value
v BuildTxWith ViewTx (Map PolicyId (ScriptWitness WitCtxMint))
_ -> do
        Quantity
someQuantity <- Integer -> Quantity
forall a. Num a => Integer -> a
fromInteger (Integer -> Quantity) -> Gen Integer -> Gen Quantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. Arbitrary a => Gen a
arbitrary Gen Integer -> (Integer -> Bool) -> Gen Integer
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
exclude) Gen Integer -> (Integer -> Bool) -> Gen Integer
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0)
        Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Gen Value)
-> ([(AssetId, Quantity)] -> Value)
-> [(AssetId, Quantity)]
-> Gen Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AssetId, Quantity)] -> Value
valueFromList ([(AssetId, Quantity)] -> Gen Value)
-> [(AssetId, Quantity)] -> Gen Value
forall a b. (a -> b) -> a -> b
$ ((AssetId, Quantity) -> (AssetId, Quantity))
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> [a] -> [b]
map ((Quantity -> Quantity)
-> (AssetId, Quantity) -> (AssetId, Quantity)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Quantity -> Quantity)
 -> (AssetId, Quantity) -> (AssetId, Quantity))
-> (Quantity -> Quantity)
-> (AssetId, Quantity)
-> (AssetId, Quantity)
forall a b. (a -> b) -> a -> b
$ Quantity -> Quantity -> Quantity
forall a b. a -> b -> a
const Quantity
someQuantity) ([(AssetId, Quantity)] -> [(AssetId, Quantity)])
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> a -> b
$ Value -> [(AssetId, Quantity)]
valueToList Value
v
 where
  mintedValue :: TxMintValue ViewTx
mintedValue = TxBodyContent ViewTx -> TxMintValue ViewTx
forall buidl. TxBodyContent buidl -> TxMintValue buidl
txMintValue (TxBodyContent ViewTx -> TxMintValue ViewTx)
-> TxBodyContent ViewTx -> TxMintValue ViewTx
forall a b. (a -> b) -> a -> b
$ TxBody -> TxBodyContent ViewTx
txBodyContent (TxBody -> TxBodyContent ViewTx) -> TxBody -> TxBodyContent ViewTx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
txBody Tx
tx

-- | A 'Mutation' that changes the minted/burned quantity of tokens like this:
-- - when no value is being minted/burned -> add a value
-- - when tx is minting or burning values -> add more values on top of that
changeMintedTokens :: Tx -> Value -> Gen Mutation
changeMintedTokens :: Tx -> Value -> Gen Mutation
changeMintedTokens Tx
tx Value
mintValue =
  Value -> Mutation
ChangeMintedValue
    (Value -> Mutation) -> Gen Value -> Gen Mutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case TxMintValue ViewTx
mintedValue of
      TxMintValue ViewTx
TxMintValueNone ->
        Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
mintValue
      TxMintValue Value
v BuildTxWith ViewTx (Map PolicyId (ScriptWitness WitCtxMint))
_ ->
        Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Gen Value) -> Value -> Gen Value
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
mintValue
 where
  mintedValue :: TxMintValue ViewTx
mintedValue = TxBodyContent ViewTx -> TxMintValue ViewTx
forall buidl. TxBodyContent buidl -> TxMintValue buidl
txMintValue (TxBodyContent ViewTx -> TxMintValue ViewTx)
-> TxBodyContent ViewTx -> TxMintValue ViewTx
forall a b. (a -> b) -> a -> b
$ TxBody -> TxBodyContent ViewTx
txBodyContent (TxBody -> TxBodyContent ViewTx) -> TxBody -> TxBodyContent ViewTx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
txBody Tx
tx

-- | A `Mutation` that adds an `Arbitrary` participation token with some quantity.
-- As usual the quantity can be positive for minting, or negative for burning.
addPTWithQuantity :: Tx -> Quantity -> Gen Mutation
addPTWithQuantity :: Tx -> Quantity -> Gen Mutation
addPTWithQuantity Tx
tx Quantity
quantity =
  Value -> Mutation
ChangeMintedValue (Value -> Mutation) -> Gen Value -> Gen Mutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    case TxMintValue ViewTx
mintedValue of
      TxMintValue Value
v BuildTxWith ViewTx (Map PolicyId (ScriptWitness WitCtxMint))
_ -> do
        -- NOTE: We do not expect Ada or any other assets to be minted, so
        -- we can take the policy id from the head
        case [(AssetId, Quantity)] -> (AssetId, Quantity)
forall a. HasCallStack => [a] -> a
Prelude.head ([(AssetId, Quantity)] -> (AssetId, Quantity))
-> [(AssetId, Quantity)] -> (AssetId, Quantity)
forall a b. (a -> b) -> a -> b
$ Value -> [(AssetId, Quantity)]
valueToList Value
v of
          (AssetId
AdaAssetId, Quantity
_) -> Text -> Gen Value
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpected mint of Ada"
          (AssetId PolicyId
pid AssetName
_an, Quantity
_) -> do
            -- Some arbitrary token name, which could correspond to a pub key hash
            AssetName
pkh <- Gen AssetName
forall a. Arbitrary a => Gen a
arbitrary
            Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Gen Value) -> Value -> Gen Value
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> [(AssetId, Quantity)] -> Value
valueFromList [(PolicyId -> AssetName -> AssetId
AssetId PolicyId
pid AssetName
pkh, Quantity
quantity)]
      TxMintValue ViewTx
TxMintValueNone ->
        Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
forall a. Monoid a => a
mempty
 where
  mintedValue :: TxMintValue ViewTx
mintedValue = TxBodyContent ViewTx -> TxMintValue ViewTx
forall buidl. TxBodyContent buidl -> TxMintValue buidl
txMintValue (TxBodyContent ViewTx -> TxMintValue ViewTx)
-> TxBodyContent ViewTx -> TxMintValue ViewTx
forall a b. (a -> b) -> a -> b
$ TxBody -> TxBodyContent ViewTx
txBodyContent (TxBody -> TxBodyContent ViewTx) -> TxBody -> TxBodyContent ViewTx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
txBody Tx
tx

-- | Replace first given 'PolicyId' with the second argument in the whole 'TxOut' value.
replacePolicyIdWith :: PolicyId -> PolicyId -> TxOut a -> TxOut a
replacePolicyIdWith :: forall a. PolicyId -> PolicyId -> TxOut a -> TxOut a
replacePolicyIdWith PolicyId
original PolicyId
replacement =
  (Value -> Value) -> TxOut a Era -> TxOut a Era
forall era ctx.
(IsMaryEraOnwards era, IsShelleyBasedEra era) =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (PolicyId -> PolicyId -> Value -> Value
replacePolicyInValue PolicyId
original PolicyId
replacement)

-- | Replace first given 'PolicyId' with the second argument in the whole 'Value'.
replacePolicyInValue :: PolicyId -> PolicyId -> Value -> Value
replacePolicyInValue :: PolicyId -> PolicyId -> Value -> Value
replacePolicyInValue PolicyId
original PolicyId
replacement =
  [(AssetId, Quantity)] -> Value
valueFromList ([(AssetId, Quantity)] -> Value)
-> (Value -> [(AssetId, Quantity)]) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> (AssetId, Quantity))
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> [a] -> [b]
map (AssetId, Quantity) -> (AssetId, Quantity)
replaceAssetId ([(AssetId, Quantity)] -> [(AssetId, Quantity)])
-> (Value -> [(AssetId, Quantity)])
-> Value
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
valueToList
 where
  replaceAssetId :: (AssetId, Quantity) -> (AssetId, Quantity)
replaceAssetId (AssetId
aid, Quantity
q) = case AssetId
aid of
    AssetId PolicyId
pid AssetName
an
      | PolicyId
pid PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId
original -> (PolicyId -> AssetName -> AssetId
AssetId PolicyId
replacement AssetName
an, Quantity
q)
    AssetId
_ -> (AssetId
aid, Quantity
q)

replaceSnapshotNumber :: Head.SnapshotNumber -> Head.State -> Head.State
replaceSnapshotNumber :: Integer -> State -> State
replaceSnapshotNumber Integer
snapshotNumber = \case
  Head.Closed{[Party]
parties :: [Party]
$sel:parties:Initial :: State -> [Party]
parties, Signature
utxoHash :: Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash, POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline, CurrencySymbol
headId :: CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId, [PubKeyHash]
contesters :: [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod} ->
    Head.Closed
      { $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
      , $sel:snapshotNumber:Initial :: Integer
Head.snapshotNumber = Integer
snapshotNumber
      , $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
      , $sel:contestationDeadline:Initial :: POSIXTime
Head.contestationDeadline = POSIXTime
contestationDeadline
      , $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
      , $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
      , $sel:contesters:Initial :: [PubKeyHash]
Head.contesters = [PubKeyHash]
contesters
      }
  State
otherState -> State
otherState

replaceParties :: [Data.Party] -> Head.State -> Head.State
replaceParties :: [Party] -> State -> State
replaceParties [Party]
parties = \case
  Head.Initial{ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, TxOutRef
seed :: TxOutRef
$sel:seed:Initial :: State -> TxOutRef
seed} ->
    Head.Initial
      { $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
      , $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
      , $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
      , $sel:seed:Initial :: TxOutRef
Head.seed = TxOutRef
seed
      }
  Head.Open{ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId} ->
    Head.Open
      { $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
      , $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
      , $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
      , $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
      }
  Head.Closed{Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters :: [PubKeyHash]
contesters, ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
    Head.Closed
      { $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
      , $sel:snapshotNumber:Initial :: Integer
Head.snapshotNumber = Integer
snapshotNumber
      , $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
      , $sel:contestationDeadline:Initial :: POSIXTime
Head.contestationDeadline = POSIXTime
contestationDeadline
      , $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
      , $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
      , $sel:contesters:Initial :: [PubKeyHash]
Head.contesters = [PubKeyHash]
contesters
      }
  State
otherState -> State
otherState

replaceUtxoHash :: Head.Hash -> Head.State -> Head.State
replaceUtxoHash :: Signature -> State -> State
replaceUtxoHash Signature
utxoHash = \case
  Head.Open{ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId} ->
    Head.Open
      { $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
      , $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
      , $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
      , $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
      }
  Head.Closed{[Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters :: [PubKeyHash]
contesters, ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
    Head.Closed
      { $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
      , $sel:snapshotNumber:Initial :: Integer
Head.snapshotNumber = Integer
snapshotNumber
      , $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
      , $sel:contestationDeadline:Initial :: POSIXTime
Head.contestationDeadline = POSIXTime
contestationDeadline
      , $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
      , $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
      , $sel:contesters:Initial :: [PubKeyHash]
Head.contesters = [PubKeyHash]
contesters
      }
  State
otherState -> State
otherState

replaceContestationDeadline :: POSIXTime -> Head.State -> Head.State
replaceContestationDeadline :: POSIXTime -> State -> State
replaceContestationDeadline POSIXTime
contestationDeadline = \case
  Head.Closed{Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters :: [PubKeyHash]
contesters, ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
    Head.Closed
      { Integer
$sel:snapshotNumber:Initial :: Integer
snapshotNumber :: Integer
snapshotNumber
      , Signature
$sel:utxoHash:Initial :: Signature
utxoHash :: Signature
utxoHash
      , [Party]
$sel:parties:Initial :: [Party]
parties :: [Party]
parties
      , POSIXTime
$sel:contestationDeadline:Initial :: POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline
      , ContestationPeriod
$sel:contestationPeriod:Initial :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod
      , CurrencySymbol
$sel:headId:Initial :: CurrencySymbol
headId :: CurrencySymbol
headId
      , [PubKeyHash]
$sel:contesters:Initial :: [PubKeyHash]
contesters :: [PubKeyHash]
contesters
      }
  State
otherState -> State
otherState

replaceContestationPeriod :: ContestationPeriod -> Head.State -> Head.State
replaceContestationPeriod :: ContestationPeriod -> State -> State
replaceContestationPeriod ContestationPeriod
contestationPeriod = \case
  Head.Closed{Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters :: [PubKeyHash]
contesters, POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline} ->
    Head.Closed
      { Integer
$sel:snapshotNumber:Initial :: Integer
snapshotNumber :: Integer
snapshotNumber
      , Signature
$sel:utxoHash:Initial :: Signature
utxoHash :: Signature
utxoHash
      , [Party]
$sel:parties:Initial :: [Party]
parties :: [Party]
parties
      , POSIXTime
$sel:contestationDeadline:Initial :: POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline
      , ContestationPeriod
$sel:contestationPeriod:Initial :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod
      , CurrencySymbol
$sel:headId:Initial :: CurrencySymbol
headId :: CurrencySymbol
headId
      , [PubKeyHash]
$sel:contesters:Initial :: [PubKeyHash]
contesters :: [PubKeyHash]
contesters
      }
  State
otherState -> State
otherState

replaceHeadId :: CurrencySymbol -> Head.State -> Head.State
replaceHeadId :: CurrencySymbol -> State -> State
replaceHeadId CurrencySymbol
headId = \case
  Head.Initial{ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, TxOutRef
$sel:seed:Initial :: State -> TxOutRef
seed :: TxOutRef
seed} ->
    Head.Initial
      { $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
      , $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
      , $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
      , $sel:seed:Initial :: TxOutRef
Head.seed = TxOutRef
seed
      }
  Head.Open{ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties} ->
    Head.Open
      { $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
      , $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
      , $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
      , $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
      }
  Head.Closed{Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters :: [PubKeyHash]
contesters, ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
    Head.Closed
      { $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
      , $sel:snapshotNumber:Initial :: Integer
Head.snapshotNumber = Integer
snapshotNumber
      , $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
      , $sel:contestationDeadline:Initial :: POSIXTime
Head.contestationDeadline = POSIXTime
contestationDeadline
      , $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
      , $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
      , $sel:contesters:Initial :: [PubKeyHash]
Head.contesters = [PubKeyHash]
contesters
      }
  State
otherState -> State
otherState

replaceContesters :: [Plutus.PubKeyHash] -> Head.State -> Head.State
replaceContesters :: [PubKeyHash] -> State -> State
replaceContesters [PubKeyHash]
contesters = \case
  Head.Closed{Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, Signature
$sel:utxoHash:Initial :: State -> Signature
utxoHash :: Signature
utxoHash, POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, [Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, CurrencySymbol
$sel:headId:Initial :: State -> CurrencySymbol
headId :: CurrencySymbol
headId, ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} ->
    Head.Closed
      { $sel:parties:Initial :: [Party]
Head.parties = [Party]
parties
      , $sel:snapshotNumber:Initial :: Integer
Head.snapshotNumber = Integer
snapshotNumber
      , $sel:utxoHash:Initial :: Signature
Head.utxoHash = Signature
utxoHash
      , $sel:contestationDeadline:Initial :: POSIXTime
Head.contestationDeadline = POSIXTime
contestationDeadline
      , $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
contestationPeriod
      , $sel:headId:Initial :: CurrencySymbol
Head.headId = CurrencySymbol
headId
      , $sel:contesters:Initial :: [PubKeyHash]
Head.contesters = [PubKeyHash]
contesters
      }
  State
otherState -> State
otherState

removePTFromMintedValue :: TxOut CtxUTxO -> Tx -> Value
removePTFromMintedValue :: TxOut CtxUTxO -> Tx -> Value
removePTFromMintedValue TxOut CtxUTxO
output Tx
tx =
  case TxBodyContent ViewTx -> TxMintValue ViewTx
forall buidl. TxBodyContent buidl -> TxMintValue buidl
txMintValue (TxBodyContent ViewTx -> TxMintValue ViewTx)
-> TxBodyContent ViewTx -> TxMintValue ViewTx
forall a b. (a -> b) -> a -> b
$ TxBody -> TxBodyContent ViewTx
txBodyContent (TxBody -> TxBodyContent ViewTx) -> TxBody -> TxBodyContent ViewTx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
txBody Tx
tx of
    TxMintValue ViewTx
TxMintValueNone -> Text -> Value
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"expected minted value"
    TxMintValue Value
v BuildTxWith ViewTx (Map PolicyId (ScriptWitness WitCtxMint))
_ -> [(AssetId, Quantity)] -> Value
valueFromList ([(AssetId, Quantity)] -> Value) -> [(AssetId, Quantity)] -> Value
forall a b. (a -> b) -> a -> b
$ ((AssetId, Quantity) -> Bool)
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((AssetId, Quantity) -> Bool) -> (AssetId, Quantity) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AssetId, Quantity) -> Bool
isPT) ([(AssetId, Quantity)] -> [(AssetId, Quantity)])
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> a -> b
$ Value -> [(AssetId, Quantity)]
valueToList Value
v
 where
  outValue :: Value
outValue = TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
output
  assetNames :: [(PolicyId, AssetName)]
assetNames =
    [ (PolicyId
policyId, AssetName
pkh) | (AssetId PolicyId
policyId AssetName
pkh, Quantity
_) <- Value -> [(AssetId, Quantity)]
valueToList Value
outValue, PolicyId
policyId PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId
testPolicyId
    ]
  (PolicyId
headId, AssetName
assetName) =
    case [(PolicyId, AssetName)]
assetNames of
      [(PolicyId, AssetName)
assetId] -> (PolicyId, AssetName)
assetId
      [(PolicyId, AssetName)]
_ -> Text -> (PolicyId, AssetName)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"expected one assetId"
  isPT :: (AssetId, Quantity) -> Bool
isPT = \case
    (AssetId PolicyId
pid AssetName
asset, Quantity
_) ->
      PolicyId
pid PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId
headId Bool -> Bool -> Bool
&& AssetName
asset AssetName -> AssetName -> Bool
forall a. Eq a => a -> a -> Bool
== AssetName
assetName
    (AssetId, Quantity)
_ -> Bool
False