-- | Mutation-based script validator tests for the commit transaction where a
-- 'healthyCommitTx' gets mutated by an arbitrary 'CommitMutation'.
module Hydra.Chain.Direct.Contract.Commit where

import Hydra.Cardano.Api
import Hydra.Prelude

-- Arbitrary VerificationKey instance
import Hydra.Chain.Direct.TxSpec ()

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Api (bodyTxL)
import Cardano.Ledger.Api.Tx.Body (EraTxBody (outputsTxBodyL), setMinCoinTxOut)
import Control.Lens (mapped, (%~))
import Data.List qualified as List
import Data.Maybe (fromJust)
import Hydra.Chain.Direct.Contract.Gen (genMintedOrBurnedValue)
import Hydra.Chain.Direct.Contract.Mutation (
  Mutation (..),
  SomeMutation (..),
  changeMintedTokens,
  modifyInlineDatum,
  replacePolicyIdWith,
 )
import Hydra.Chain.Direct.Fixture qualified as Fixture
import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO)
import Hydra.Chain.Direct.Tx (commitTx, mkHeadId, mkInitialOutput, verificationKeyToOnChainId)
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Error (toErrorCode)
import Hydra.Contract.HeadTokens (headPolicyId)
import Hydra.Contract.Initial qualified as Initial
import Hydra.Contract.InitialError (InitialError (..))
import Hydra.Ledger.Cardano (
  genAddressInEra,
  genUTxOAdaOnlyOfSize,
  genValue,
  genVerificationKey,
 )
import Hydra.Party (Party)
import Test.QuickCheck (elements, oneof, scale, suchThat)

--
-- CommitTx
--

healthyCommitTx :: (Tx, UTxO)
healthyCommitTx :: (Tx, UTxO)
healthyCommitTx =
  (Tx
tx', UTxO
lookupUTxO)
 where
  lookupUTxO :: UTxO
lookupUTxO =
    (TxIn, TxOut CtxUTxO Era) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn
healthyIntialTxIn, TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext TxOut CtxTx Era
healthyInitialTxOut)
      UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
healthyCommittedUTxO
      UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ScriptRegistry -> UTxO
registryUTxO ScriptRegistry
scriptRegistry

  tx' :: Tx
tx' = AlonzoTx StandardBabbage -> Tx
Tx (ShelleyLedgerEra Era) -> Tx
fromLedgerTx (AlonzoTx StandardBabbage -> Tx)
-> (AlonzoTx StandardBabbage -> AlonzoTx StandardBabbage)
-> AlonzoTx StandardBabbage
-> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx StandardBabbage -> AlonzoTx StandardBabbage
setOutputsMinValue (AlonzoTx StandardBabbage -> Tx) -> AlonzoTx StandardBabbage -> Tx
forall a b. (a -> b) -> a -> b
$ Tx -> Tx (ShelleyLedgerEra Era)
forall era.
(EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto,
 AlonzoEraTx (ShelleyLedgerEra era)) =>
Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx

  setOutputsMinValue :: Tx StandardBabbage -> Tx StandardBabbage
setOutputsMinValue =
    (TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> Tx StandardBabbage -> Identity (Tx StandardBabbage)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardBabbage) (TxBody StandardBabbage)
bodyTxL ((TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
 -> Tx StandardBabbage -> Identity (Tx StandardBabbage))
-> ((TxOut StandardBabbage -> Identity (TxOut StandardBabbage))
    -> TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> (TxOut StandardBabbage -> Identity (TxOut StandardBabbage))
-> Tx StandardBabbage
-> Identity (Tx StandardBabbage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 (TxOut StandardBabbage)))
 -> TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> ((TxOut StandardBabbage -> Identity (TxOut StandardBabbage))
    -> StrictSeq (TxOut StandardBabbage)
    -> Identity (StrictSeq (TxOut StandardBabbage)))
-> (TxOut StandardBabbage -> Identity (TxOut StandardBabbage))
-> TxBody StandardBabbage
-> Identity (TxBody StandardBabbage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut StandardBabbage -> Identity (TxOut StandardBabbage))
-> StrictSeq (TxOut StandardBabbage)
-> Identity (StrictSeq (TxOut StandardBabbage))
Setter
  (StrictSeq (TxOut StandardBabbage))
  (StrictSeq (TxOut StandardBabbage))
  (TxOut StandardBabbage)
  (TxOut StandardBabbage)
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((TxOut StandardBabbage -> Identity (TxOut StandardBabbage))
 -> Tx StandardBabbage -> Identity (Tx StandardBabbage))
-> (TxOut StandardBabbage -> TxOut StandardBabbage)
-> Tx StandardBabbage
-> Tx StandardBabbage
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PParams StandardBabbage
-> TxOut StandardBabbage -> TxOut StandardBabbage
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams (ShelleyLedgerEra Era)
PParams StandardBabbage
Fixture.pparams

  tx :: Tx
tx =
    NetworkId
-> ScriptRegistry
-> HeadId
-> Party
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
-> (TxIn, TxOut CtxUTxO Era, Hash PaymentKey)
-> Tx
commitTx
      NetworkId
Fixture.testNetworkId
      ScriptRegistry
scriptRegistry
      (PolicyId -> HeadId
mkHeadId PolicyId
Fixture.testPolicyId)
      Party
commitParty
      (UTxO
healthyCommittedUTxO UTxO
-> (TxOut CtxUTxO Era -> (TxOut CtxUTxO Era, Witness WitCtxTxIn))
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (,KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending))
      (TxIn
healthyIntialTxIn, TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext TxOut CtxTx Era
healthyInitialTxOut, Hash PaymentKey
initialPubKeyHash)

  scriptRegistry :: ScriptRegistry
scriptRegistry = Gen ScriptRegistry
genScriptRegistry Gen ScriptRegistry -> Int -> ScriptRegistry
forall a. Gen a -> Int -> a
`generateWith` Int
42

  initialPubKeyHash :: Hash PaymentKey
initialPubKeyHash = VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
commitVerificationKey

  commitParty :: Party
  commitParty :: Party
commitParty = Gen Party -> Int -> Party
forall a. Gen a -> Int -> a
generateWith Gen Party
forall a. Arbitrary a => Gen a
arbitrary Int
42

commitVerificationKey :: VerificationKey PaymentKey
commitVerificationKey :: VerificationKey PaymentKey
commitVerificationKey = Gen (VerificationKey PaymentKey)
-> Int -> VerificationKey PaymentKey
forall a. Gen a -> Int -> a
generateWith Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary Int
42

healthyIntialTxIn :: TxIn
healthyIntialTxIn :: TxIn
healthyIntialTxIn = Gen TxIn -> Int -> TxIn
forall a. Gen a -> Int -> a
generateWith Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary Int
42

healthyInitialTxOut :: TxOut CtxTx
healthyInitialTxOut :: TxOut CtxTx Era
healthyInitialTxOut =
  PParams (ShelleyLedgerEra Era)
-> TxOut CtxUTxO Era -> TxOut CtxTx Era
forall ctx.
PParams (ShelleyLedgerEra Era)
-> TxOut CtxUTxO Era -> TxOut ctx Era
setMinUTxOValue PParams (ShelleyLedgerEra Era)
Fixture.pparams (TxOut CtxUTxO Era -> TxOut CtxTx Era)
-> (TxOut CtxTx Era -> TxOut CtxUTxO Era)
-> TxOut CtxTx Era
-> TxOut CtxTx Era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext (TxOut CtxTx Era -> TxOut CtxTx Era)
-> TxOut CtxTx Era -> TxOut CtxTx Era
forall a b. (a -> b) -> a -> b
$
    NetworkId -> TxIn -> OnChainId -> TxOut CtxTx Era
mkInitialOutput NetworkId
Fixture.testNetworkId TxIn
Fixture.testSeedInput (OnChainId -> TxOut CtxTx Era) -> OnChainId -> TxOut CtxTx Era
forall a b. (a -> b) -> a -> b
$
      VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId VerificationKey PaymentKey
commitVerificationKey

-- NOTE: A UTxO of length 2 is picked to mutate it into cases where committing a
-- single and empty UTxO.
healthyCommittedUTxO :: UTxO
healthyCommittedUTxO :: UTxO
healthyCommittedUTxO =
  (Gen UTxO -> Int -> UTxO) -> Int -> Gen UTxO -> UTxO
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gen UTxO -> Int -> UTxO
forall a. Gen a -> Int -> a
generateWith Int
42 (Gen UTxO -> UTxO) -> Gen UTxO -> UTxO
forall a b. (a -> b) -> a -> b
$
    Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
2

data CommitMutation
  = -- | The headId in the output datum must match the one from the input datum.
    NonContinuousHeadId
  | -- | Invalidates the transaction by changing the committed output value.
    MutateCommitOutputValue
  | -- | Invalidates the transaction by changing the value of the committed utxo
    -- on the input side of the transaction.
    MutateCommittedValue
  | -- | Ensures the datum recording the commit is consistent with the UTxO
    -- being committed.
    MutateCommittedAddress
  | -- | Ensures a commit cannot be left out when "declared" in the commit
    -- transaction output datum.
    RecordAllCommittedUTxO
  | -- | Ensures commit is authenticated by a Head party by changing the signer
    -- used on the transaction to be the one in the PT.
    MutateRequiredSigner
  | -- | Change the head policy id to simulate commit using a PT and signer from
    -- a different head. The signer shows a correct signature but from a
    -- different head. This will cause the signer to not be present in the
    -- participation tokens.
    UsePTFromDifferentHead
  | -- | Minting or burning of the tokens should not be possible in commit.
    MutateTokenMintingOrBurning
  deriving stock ((forall x. CommitMutation -> Rep CommitMutation x)
-> (forall x. Rep CommitMutation x -> CommitMutation)
-> Generic CommitMutation
forall x. Rep CommitMutation x -> CommitMutation
forall x. CommitMutation -> Rep CommitMutation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CommitMutation -> Rep CommitMutation x
from :: forall x. CommitMutation -> Rep CommitMutation x
$cto :: forall x. Rep CommitMutation x -> CommitMutation
to :: forall x. Rep CommitMutation x -> CommitMutation
Generic, Int -> CommitMutation -> ShowS
[CommitMutation] -> ShowS
CommitMutation -> String
(Int -> CommitMutation -> ShowS)
-> (CommitMutation -> String)
-> ([CommitMutation] -> ShowS)
-> Show CommitMutation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommitMutation -> ShowS
showsPrec :: Int -> CommitMutation -> ShowS
$cshow :: CommitMutation -> String
show :: CommitMutation -> String
$cshowList :: [CommitMutation] -> ShowS
showList :: [CommitMutation] -> ShowS
Show, Int -> CommitMutation
CommitMutation -> Int
CommitMutation -> [CommitMutation]
CommitMutation -> CommitMutation
CommitMutation -> CommitMutation -> [CommitMutation]
CommitMutation
-> CommitMutation -> CommitMutation -> [CommitMutation]
(CommitMutation -> CommitMutation)
-> (CommitMutation -> CommitMutation)
-> (Int -> CommitMutation)
-> (CommitMutation -> Int)
-> (CommitMutation -> [CommitMutation])
-> (CommitMutation -> CommitMutation -> [CommitMutation])
-> (CommitMutation -> CommitMutation -> [CommitMutation])
-> (CommitMutation
    -> CommitMutation -> CommitMutation -> [CommitMutation])
-> Enum CommitMutation
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: CommitMutation -> CommitMutation
succ :: CommitMutation -> CommitMutation
$cpred :: CommitMutation -> CommitMutation
pred :: CommitMutation -> CommitMutation
$ctoEnum :: Int -> CommitMutation
toEnum :: Int -> CommitMutation
$cfromEnum :: CommitMutation -> Int
fromEnum :: CommitMutation -> Int
$cenumFrom :: CommitMutation -> [CommitMutation]
enumFrom :: CommitMutation -> [CommitMutation]
$cenumFromThen :: CommitMutation -> CommitMutation -> [CommitMutation]
enumFromThen :: CommitMutation -> CommitMutation -> [CommitMutation]
$cenumFromTo :: CommitMutation -> CommitMutation -> [CommitMutation]
enumFromTo :: CommitMutation -> CommitMutation -> [CommitMutation]
$cenumFromThenTo :: CommitMutation
-> CommitMutation -> CommitMutation -> [CommitMutation]
enumFromThenTo :: CommitMutation
-> CommitMutation -> CommitMutation -> [CommitMutation]
Enum, CommitMutation
CommitMutation -> CommitMutation -> Bounded CommitMutation
forall a. a -> a -> Bounded a
$cminBound :: CommitMutation
minBound :: CommitMutation
$cmaxBound :: CommitMutation
maxBound :: CommitMutation
Bounded)

genCommitMutation :: (Tx, UTxO) -> Gen SomeMutation
genCommitMutation :: (Tx, UTxO) -> Gen SomeMutation
genCommitMutation (Tx
tx, UTxO
_utxo) =
  [Gen SomeMutation] -> Gen SomeMutation
forall a. [Gen a] -> Gen a
oneof
    [ Maybe Text -> CommitMutation -> Mutation -> SomeMutation
forall lbl.
(Typeable lbl, Enum lbl, Bounded lbl, Show lbl) =>
Maybe Text -> lbl -> Mutation -> SomeMutation
SomeMutation (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ InitialError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode InitialError
WrongHeadIdInCommitDatum) CommitMutation
NonContinuousHeadId (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        PolicyId
otherHeadId <- (TxIn -> PolicyId) -> Gen TxIn -> Gen PolicyId
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxIn -> PolicyId
headPolicyId (Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary Gen TxIn -> (TxIn -> Bool) -> Gen TxIn
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
/= TxIn
healthyIntialTxIn))
        let mutateHeadId :: TxOut CtxTx Era -> TxOut CtxTx Era
mutateHeadId =
              (DatumType -> DatumType) -> TxOut CtxTx Era -> TxOut CtxTx Era
forall a.
(FromScriptData a, ToScriptData a) =>
(a -> a) -> TxOut CtxTx Era -> TxOut CtxTx Era
modifyInlineDatum ((DatumType -> DatumType) -> TxOut CtxTx Era -> TxOut CtxTx Era)
-> (DatumType -> DatumType) -> TxOut CtxTx Era -> TxOut CtxTx Era
forall a b. (a -> b) -> a -> b
$
                \((Party
party, [Commit]
mCommit, CurrencySymbol
_headId) :: Commit.DatumType) ->
                  (Party
party, [Commit]
mCommit, PolicyId -> CurrencySymbol
toPlutusCurrencySymbol PolicyId
otherHeadId)
        Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Mutation -> Gen Mutation) -> Mutation -> Gen Mutation
forall a b. (a -> b) -> a -> b
$ Word -> TxOut CtxTx Era -> Mutation
ChangeOutput Word
0 (TxOut CtxTx Era -> Mutation) -> TxOut CtxTx Era -> Mutation
forall a b. (a -> b) -> a -> b
$ TxOut CtxTx Era -> TxOut CtxTx Era
mutateHeadId TxOut CtxTx Era
commitTxOut
    , Maybe Text -> CommitMutation -> Mutation -> SomeMutation
forall lbl.
(Typeable lbl, Enum lbl, Bounded lbl, Show lbl) =>
Maybe Text -> lbl -> Mutation -> SomeMutation
SomeMutation (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ InitialError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode InitialError
LockedValueDoesNotMatch) CommitMutation
MutateCommitOutputValue (Mutation -> SomeMutation)
-> (TxOut CtxTx Era -> Mutation) -> TxOut CtxTx Era -> SomeMutation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> TxOut CtxTx Era -> Mutation
ChangeOutput Word
0 (TxOut CtxTx Era -> SomeMutation)
-> Gen (TxOut CtxTx Era) -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Value
mutatedValue <- (Int -> Int) -> Gen Value -> Gen Value
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Gen Value
genValue Gen Value -> (Value -> Bool) -> Gen Value
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
commitOutputValue)
        TxOut CtxTx Era -> Gen (TxOut CtxTx Era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut CtxTx Era -> Gen (TxOut CtxTx Era))
-> TxOut CtxTx Era -> Gen (TxOut CtxTx Era)
forall a b. (a -> b) -> a -> b
$ TxOut CtxTx Era
commitTxOut{txOutValue = mutatedValue}
    , Maybe Text -> CommitMutation -> Mutation -> SomeMutation
forall lbl.
(Typeable lbl, Enum lbl, Bounded lbl, Show lbl) =>
Maybe Text -> lbl -> Mutation -> SomeMutation
SomeMutation (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ InitialError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode InitialError
LockedValueDoesNotMatch) CommitMutation
MutateCommittedValue (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Value
mutatedValue <- (Int -> Int) -> Gen Value -> Gen Value
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Gen Value
genValue Gen Value -> (Value -> Bool) -> Gen Value
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
aCommittedOutputValue)
        let mutatedOutput :: TxOut CtxUTxO Era
mutatedOutput = (Value -> Value) -> TxOut CtxUTxO Era -> TxOut CtxUTxO Era
forall era ctx.
(IsMaryEraOnwards era, IsShelleyBasedEra era) =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value -> Value -> Value
forall a b. a -> b -> a
const Value
mutatedValue) TxOut CtxUTxO Era
aCommittedTxOut
        Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Mutation -> Gen Mutation) -> Mutation -> Gen Mutation
forall a b. (a -> b) -> a -> b
$ TxIn -> TxOut CtxUTxO Era -> Maybe HashableScriptData -> Mutation
ChangeInput TxIn
aCommittedTxIn TxOut CtxUTxO Era
mutatedOutput Maybe HashableScriptData
forall a. Maybe a
Nothing
    , Maybe Text -> CommitMutation -> Mutation -> SomeMutation
forall lbl.
(Typeable lbl, Enum lbl, Bounded lbl, Show lbl) =>
Maybe Text -> lbl -> Mutation -> SomeMutation
SomeMutation (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ InitialError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode InitialError
MismatchCommittedTxOutInDatum) CommitMutation
MutateCommittedAddress (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        AddressInEra
mutatedAddress <- NetworkId -> Gen AddressInEra
genAddressInEra NetworkId
Fixture.testNetworkId Gen AddressInEra -> (AddressInEra -> Bool) -> Gen AddressInEra
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (AddressInEra -> AddressInEra -> Bool
forall a. Eq a => a -> a -> Bool
/= AddressInEra
aCommittedAddress)
        let mutatedOutput :: TxOut CtxUTxO Era
mutatedOutput = (AddressInEra -> AddressInEra)
-> TxOut CtxUTxO Era -> TxOut CtxUTxO Era
forall era ctx.
(AddressInEra era -> AddressInEra era)
-> TxOut ctx era -> TxOut ctx era
modifyTxOutAddress (AddressInEra -> AddressInEra -> AddressInEra
forall a b. a -> b -> a
const AddressInEra
mutatedAddress) TxOut CtxUTxO Era
aCommittedTxOut
        Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Mutation -> Gen Mutation) -> Mutation -> Gen Mutation
forall a b. (a -> b) -> a -> b
$ TxIn -> TxOut CtxUTxO Era -> Maybe HashableScriptData -> Mutation
ChangeInput TxIn
aCommittedTxIn TxOut CtxUTxO Era
mutatedOutput Maybe HashableScriptData
forall a. Maybe a
Nothing
    , Maybe Text -> CommitMutation -> Mutation -> SomeMutation
forall lbl.
(Typeable lbl, Enum lbl, Bounded lbl, Show lbl) =>
Maybe Text -> lbl -> Mutation -> SomeMutation
SomeMutation (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ InitialError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode InitialError
MissingCommittedTxOutInOutputDatum) CommitMutation
RecordAllCommittedUTxO (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        (TxIn
removedTxIn, TxOut CtxUTxO Era
removedTxOut) <- [(TxIn, TxOut CtxUTxO Era)] -> Gen (TxIn, TxOut CtxUTxO Era)
forall a. [a] -> Gen a
elements ([(TxIn, TxOut CtxUTxO Era)] -> Gen (TxIn, TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> Gen (TxIn, TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO
healthyCommittedUTxO
        -- Leave out not-committed value
        let mutatedCommitTxOut :: TxOut CtxTx Era
mutatedCommitTxOut = (Value -> Value) -> TxOut CtxTx Era -> TxOut CtxTx Era
forall era ctx.
(IsMaryEraOnwards era, IsShelleyBasedEra era) =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (\Value
v -> Value -> Value
negateValue (TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO Era
removedTxOut) Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
v) TxOut CtxTx Era
commitTxOut
        Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Mutation -> Gen Mutation) -> Mutation -> Gen Mutation
forall a b. (a -> b) -> a -> b
$
          [Mutation] -> Mutation
Changes
            [ TxIn -> Mutation
RemoveInput TxIn
removedTxIn
            , Word -> TxOut CtxTx Era -> Mutation
ChangeOutput Word
0 TxOut CtxTx Era
mutatedCommitTxOut
            , TxIn -> TxOut CtxUTxO Era -> Maybe HashableScriptData -> Mutation
ChangeInput
                TxIn
healthyIntialTxIn
                (TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext TxOut CtxTx Era
healthyInitialTxOut)
                (HashableScriptData -> Maybe HashableScriptData
forall a. a -> Maybe a
Just (HashableScriptData -> Maybe HashableScriptData)
-> HashableScriptData -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ InitialRedeemer -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (InitialRedeemer -> HashableScriptData)
-> InitialRedeemer -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ [TxOutRef] -> InitialRedeemer
Initial.ViaCommit (TxIn
removedTxIn TxIn -> [TxIn] -> [TxIn]
forall a. Eq a => a -> [a] -> [a]
`List.delete` [TxIn]
allComittedTxIn [TxIn] -> (TxIn -> TxOutRef) -> [TxOutRef]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> TxIn -> TxOutRef
toPlutusTxOutRef))
            ]
    , Maybe Text -> CommitMutation -> Mutation -> SomeMutation
forall lbl.
(Typeable lbl, Enum lbl, Bounded lbl, Show lbl) =>
Maybe Text -> lbl -> Mutation -> SomeMutation
SomeMutation (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ InitialError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode InitialError
MissingOrInvalidCommitAuthor) CommitMutation
MutateRequiredSigner (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Hash PaymentKey
newSigner <- VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (VerificationKey PaymentKey -> Hash PaymentKey)
-> Gen (VerificationKey PaymentKey) -> Gen (Hash PaymentKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (VerificationKey PaymentKey)
genVerificationKey
        Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Mutation -> Gen Mutation) -> Mutation -> Gen Mutation
forall a b. (a -> b) -> a -> b
$ [Hash PaymentKey] -> Mutation
ChangeRequiredSigners [Hash PaymentKey
newSigner]
    , -- XXX: This is a bit confusing and not giving much value. Maybe we can remove this.
      -- This also seems to be covered by MutateRequiredSigner
      Maybe Text -> CommitMutation -> Mutation -> SomeMutation
forall lbl.
(Typeable lbl, Enum lbl, Bounded lbl, Show lbl) =>
Maybe Text -> lbl -> Mutation -> SomeMutation
SomeMutation (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ InitialError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode InitialError
CouldNotFindTheCorrectCurrencySymbolInTokens) CommitMutation
UsePTFromDifferentHead (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        PolicyId
otherHeadId <- (TxIn -> PolicyId) -> Gen TxIn -> Gen PolicyId
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxIn -> PolicyId
headPolicyId (Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary Gen TxIn -> (TxIn -> Bool) -> Gen TxIn
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
/= TxIn
healthyIntialTxIn))
        Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Mutation -> Gen Mutation) -> Mutation -> Gen Mutation
forall a b. (a -> b) -> a -> b
$
          [Mutation] -> Mutation
Changes
            [ Word -> TxOut CtxTx Era -> Mutation
ChangeOutput Word
0 (PolicyId -> PolicyId -> TxOut CtxTx Era -> TxOut CtxTx Era
forall a. PolicyId -> PolicyId -> TxOut a -> TxOut a
replacePolicyIdWith PolicyId
Fixture.testPolicyId PolicyId
otherHeadId TxOut CtxTx Era
commitTxOut)
            , TxIn -> TxOut CtxUTxO Era -> Maybe HashableScriptData -> Mutation
ChangeInput
                TxIn
healthyIntialTxIn
                (TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext (TxOut CtxTx Era -> TxOut CtxUTxO Era)
-> TxOut CtxTx Era -> TxOut CtxUTxO Era
forall a b. (a -> b) -> a -> b
$ PolicyId -> PolicyId -> TxOut CtxTx Era -> TxOut CtxTx Era
forall a. PolicyId -> PolicyId -> TxOut a -> TxOut a
replacePolicyIdWith PolicyId
Fixture.testPolicyId PolicyId
otherHeadId TxOut CtxTx Era
healthyInitialTxOut)
                (HashableScriptData -> Maybe HashableScriptData
forall a. a -> Maybe a
Just (HashableScriptData -> Maybe HashableScriptData)
-> HashableScriptData -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ InitialRedeemer -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (InitialRedeemer -> HashableScriptData)
-> InitialRedeemer -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ [TxOutRef] -> InitialRedeemer
Initial.ViaCommit ([TxIn]
allComittedTxIn [TxIn] -> (TxIn -> TxOutRef) -> [TxOutRef]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> TxIn -> TxOutRef
toPlutusTxOutRef))
            ]
    , Maybe Text -> CommitMutation -> Mutation -> SomeMutation
forall lbl.
(Typeable lbl, Enum lbl, Bounded lbl, Show lbl) =>
Maybe Text -> lbl -> Mutation -> SomeMutation
SomeMutation (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ InitialError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode InitialError
MintingOrBurningIsForbidden) CommitMutation
MutateTokenMintingOrBurning
        (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tx -> Value -> Gen Mutation
changeMintedTokens Tx
tx (Value -> Gen Mutation) -> Gen Value -> Gen Mutation
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen Value
genMintedOrBurnedValue)
    ]
 where
  TxOut{txOutValue :: forall ctx. TxOut ctx -> Value
txOutValue = Value
commitOutputValue} = TxOut CtxTx Era
commitTxOut

  commitTxOut :: TxOut CtxTx Era
commitTxOut = Maybe (TxOut CtxTx Era) -> TxOut CtxTx Era
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (TxOut CtxTx Era) -> TxOut CtxTx Era)
-> Maybe (TxOut CtxTx Era) -> TxOut CtxTx Era
forall a b. (a -> b) -> a -> b
$ Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx [TxOut CtxTx Era] -> Int -> Maybe (TxOut CtxTx Era)
forall a. [a] -> Int -> Maybe a
!!? Int
0

  allComittedTxIn :: [TxIn]
allComittedTxIn = UTxO -> Set TxIn
forall out. UTxO' out -> Set TxIn
UTxO.inputSet UTxO
healthyCommittedUTxO Set TxIn -> (Set TxIn -> [TxIn]) -> [TxIn]
forall a b. a -> (a -> b) -> b
& Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

  (TxIn
aCommittedTxIn, TxOut CtxUTxO Era
aCommittedTxOut) = [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a. HasCallStack => [a] -> a
List.head ([(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO
healthyCommittedUTxO

  aCommittedAddress :: AddressInEra
aCommittedAddress = TxOut CtxUTxO Era -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO Era
aCommittedTxOut

  aCommittedOutputValue :: Value
aCommittedOutputValue = TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO Era
aCommittedTxOut