module Hydra.Chain.Direct.Contract.Commit where
import Hydra.Cardano.Api
import Hydra.Prelude
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)
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
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
=
NonContinuousHeadId
|
MutateCommitOutputValue
|
MutateCommittedValue
|
MutateCommittedAddress
|
RecordAllCommittedUTxO
|
MutateRequiredSigner
|
UsePTFromDifferentHead
|
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
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]
,
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