{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Hydra.Chain.Direct.Contract.Abort where
import Hydra.Cardano.Api
import Hydra.Prelude
import Cardano.Api.UTxO qualified as UTxO
import Data.List qualified as List
import Data.Map qualified as Map
import Hydra.Chain (HeadParameters (..))
import Hydra.Chain.Direct.Contract.Gen (genForParty)
import Hydra.Chain.Direct.Contract.Mutation (
Mutation (..),
SomeMutation (..),
addPTWithQuantity,
changeMintedTokens,
changeMintedValueQuantityFrom,
isHeadOutput,
removePTFromMintedValue,
replacePolicyIdWith,
)
import Hydra.Chain.Direct.Fixture (testNetworkId, testPolicyId, testSeedInput)
import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO)
import Hydra.Chain.Direct.Tx (
abortTx,
hydraHeadV1AssetName,
mkHeadOutputInitial,
)
import Hydra.Chain.Direct.TxSpec (genAbortableOutputs)
import Hydra.ContestationPeriod (toChain)
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.CommitError (CommitError (..))
import Hydra.Contract.Error (toErrorCode)
import Hydra.Contract.HeadError (HeadError (..))
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.HeadTokens (headPolicyId, mkHeadTokenScript)
import Hydra.Contract.HeadTokensError (HeadTokensError (..))
import Hydra.Contract.Initial qualified as Initial
import Hydra.Contract.InitialError (InitialError (STNotBurned))
import Hydra.Ledger.Cardano (genAddressInEra, genVerificationKey)
import Hydra.Party (Party, partyToChain)
import Test.Hydra.Fixture (cperiod)
import Test.QuickCheck (Property, choose, counterexample, elements, oneof, shuffle, suchThat)
healthyAbortTx :: HasCallStack => (Tx, UTxO)
healthyAbortTx :: HasCallStack => (Tx, UTxO)
healthyAbortTx =
(Tx
tx, UTxO
lookupUTxO)
where
lookupUTxO :: UTxO
lookupUTxO =
(TxIn, TxOut CtxUTxO Era) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn
healthyHeadInput, 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
headOutput)
UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> Map TxIn (TxOut CtxUTxO Era) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO ([(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxIn, TxOut CtxUTxO Era)]
healthyInitials)
UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> Map TxIn (TxOut CtxUTxO Era) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO ([(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((TxIn, TxOut CtxUTxO Era, UTxO) -> (TxIn, TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era, UTxO)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a b. (a -> b) -> [a] -> [b]
map (\(TxIn
i, TxOut CtxUTxO Era
o, UTxO
_) -> (TxIn
i, TxOut CtxUTxO Era
o)) [(TxIn, TxOut CtxUTxO Era, UTxO)]
healthyCommits))
UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ScriptRegistry -> UTxO
registryUTxO ScriptRegistry
scriptRegistry
tx :: Tx
tx =
(AbortTxError -> Tx) -> (Tx -> Tx) -> Either AbortTxError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (AbortTxError -> Text) -> AbortTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbortTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either AbortTxError Tx -> Tx) -> Either AbortTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$
UTxO
-> ScriptRegistry
-> VerificationKey PaymentKey
-> (TxIn, TxOut CtxUTxO Era)
-> PlutusScript
-> Map TxIn (TxOut CtxUTxO Era)
-> Map TxIn (TxOut CtxUTxO Era)
-> Either AbortTxError Tx
abortTx
UTxO
committedUTxO
ScriptRegistry
scriptRegistry
VerificationKey PaymentKey
somePartyCardanoVerificationKey
(TxIn
healthyHeadInput, 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
headOutput)
PlutusScript
headTokenScript
([(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxIn, TxOut CtxUTxO Era)]
healthyInitials)
([(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((TxIn, TxOut CtxUTxO Era, UTxO) -> (TxIn, TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era, UTxO)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a b. (a -> b) -> [a] -> [b]
map (\(TxIn
i, TxOut CtxUTxO Era
o, UTxO
_) -> (TxIn
i, TxOut CtxUTxO Era
o)) [(TxIn, TxOut CtxUTxO Era, UTxO)]
healthyCommits))
committedUTxO :: UTxO
committedUTxO = ((TxIn, TxOut CtxUTxO Era, UTxO) -> UTxO)
-> [(TxIn, TxOut CtxUTxO Era, UTxO)] -> UTxO
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(TxIn
_, TxOut CtxUTxO Era
_, UTxO
u) -> UTxO
u) [(TxIn, TxOut CtxUTxO Era, UTxO)]
healthyCommits
scriptRegistry :: ScriptRegistry
scriptRegistry = Gen ScriptRegistry
genScriptRegistry Gen ScriptRegistry -> Int -> ScriptRegistry
forall a. Gen a -> Int -> a
`generateWith` Int
42
somePartyCardanoVerificationKey :: VerificationKey PaymentKey
somePartyCardanoVerificationKey = (Gen (VerificationKey PaymentKey)
-> Int -> VerificationKey PaymentKey)
-> Int
-> Gen (VerificationKey PaymentKey)
-> VerificationKey PaymentKey
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gen (VerificationKey PaymentKey)
-> Int -> VerificationKey PaymentKey
forall a. Gen a -> Int -> a
generateWith Int
42 (Gen (VerificationKey PaymentKey) -> VerificationKey PaymentKey)
-> Gen (VerificationKey PaymentKey) -> VerificationKey PaymentKey
forall a b. (a -> b) -> a -> b
$ do
Gen (VerificationKey PaymentKey)
-> Party -> VerificationKey PaymentKey
forall a. Gen a -> Party -> a
genForParty Gen (VerificationKey PaymentKey)
genVerificationKey (Party -> VerificationKey PaymentKey)
-> Gen Party -> Gen (VerificationKey PaymentKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party] -> Gen Party
forall a. [a] -> Gen a
elements [Party]
healthyParties
headTokenScript :: PlutusScript
headTokenScript = TxIn -> PlutusScript
mkHeadTokenScript TxIn
testSeedInput
headOutput :: TxOut CtxTx Era
headOutput = NetworkId -> TxIn -> HeadParameters -> TxOut CtxTx Era
mkHeadOutputInitial NetworkId
testNetworkId TxIn
testSeedInput HeadParameters
healthyHeadParameters
healthyHeadInput :: TxIn
healthyHeadInput :: TxIn
healthyHeadInput = Gen TxIn -> Int -> TxIn
forall a. Gen a -> Int -> a
generateWith Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary Int
42
healthyHeadParameters :: HeadParameters
healthyHeadParameters :: HeadParameters
healthyHeadParameters =
HeadParameters
{ $sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod = ContestationPeriod
cperiod
, $sel:parties:HeadParameters :: [Party]
parties = [Party]
healthyParties
}
healthyInitials :: [(TxIn, TxOut CtxUTxO)]
healthyCommits :: [(TxIn, TxOut CtxUTxO, UTxO)]
([(TxIn, TxOut CtxUTxO Era)]
healthyInitials, [(TxIn, TxOut CtxUTxO Era, UTxO)]
healthyCommits) =
Gen
([(TxIn, TxOut CtxUTxO Era)], [(TxIn, TxOut CtxUTxO Era, UTxO)])
-> Int
-> ([(TxIn, TxOut CtxUTxO Era)], [(TxIn, TxOut CtxUTxO Era, UTxO)])
forall a. Gen a -> Int -> a
generateWith ([Party]
-> Gen
([(TxIn, TxOut CtxUTxO Era)], [(TxIn, TxOut CtxUTxO Era, UTxO)])
genAbortableOutputs [Party]
healthyParties Gen
([(TxIn, TxOut CtxUTxO Era)], [(TxIn, TxOut CtxUTxO Era, UTxO)])
-> (([(TxIn, TxOut CtxUTxO Era)],
[(TxIn, TxOut CtxUTxO Era, UTxO)])
-> Bool)
-> Gen
([(TxIn, TxOut CtxUTxO Era)], [(TxIn, TxOut CtxUTxO Era, UTxO)])
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` ([(TxIn, TxOut CtxUTxO Era)], [(TxIn, TxOut CtxUTxO Era, UTxO)])
-> Bool
forall {t :: * -> *} {t :: * -> *} {a} {a}.
(Foldable t, Foldable t) =>
(t a, t a) -> Bool
thereIsTwoEach) Int
42
where
thereIsTwoEach :: (t a, t a) -> Bool
thereIsTwoEach (t a
is, t a
cs) = t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
is Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
healthyParties :: [Party]
healthyParties :: [Party]
healthyParties =
[ Gen Party -> Int -> Party
forall a. Gen a -> Int -> a
generateWith Gen Party
forall a. Arbitrary a => Gen a
arbitrary Int
i | Int
i <- [Int
1 .. Int
4]
]
propHasInitial :: (Tx, UTxO) -> Property
propHasInitial :: (Tx, UTxO) -> Property
propHasInitial (Tx
_, UTxO
utxo) =
(TxOut CtxUTxO Era -> Bool) -> UTxO -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TxOut CtxUTxO Era -> Bool
paysToInitialScript UTxO
utxo
Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"UTxO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (UTxO -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty UTxO
utxo))
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Looking for Initial Script: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AddressInEra -> String
forall b a. (Show a, IsString b) => a -> b
show AddressInEra
addr)
where
addr :: AddressInEra
addr = forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
testNetworkId (SerialisedScript -> PlutusScript
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Initial.validatorScript)
paysToInitialScript :: TxOut CtxUTxO Era -> Bool
paysToInitialScript TxOut CtxUTxO Era
txOut =
TxOut CtxUTxO Era -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO Era
txOut AddressInEra -> AddressInEra -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra
addr
propHasCommit :: (Tx, UTxO) -> Property
propHasCommit :: (Tx, UTxO) -> Property
propHasCommit (Tx
_, UTxO
utxo) =
(TxOut CtxUTxO Era -> Bool) -> UTxO -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TxOut CtxUTxO Era -> Bool
paysToCommitScript UTxO
utxo
Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"UTxO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (UTxO -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty UTxO
utxo))
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Looking for Commit Script: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AddressInEra -> String
forall b a. (Show a, IsString b) => a -> b
show AddressInEra
addr)
where
addr :: AddressInEra
addr = forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
testNetworkId (SerialisedScript -> PlutusScript
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Commit.validatorScript)
paysToCommitScript :: TxOut CtxUTxO Era -> Bool
paysToCommitScript TxOut CtxUTxO Era
txOut =
TxOut CtxUTxO Era -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO Era
txOut AddressInEra -> AddressInEra -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra
addr
data AbortMutation
=
MutateParties
|
DropCollectedInput
|
DropOneCommitOutput
|
BurnOneTokenMore
|
MutateThreadTokenQuantity
|
MutateRequiredSigner
|
MutateUseDifferentHeadToAbort
|
UseInputFromOtherHead
|
ReorderCommitOutputs
|
MintOnAbort
|
|
DoNotBurnST
|
DoNotBurnSTInitial
deriving stock ((forall x. AbortMutation -> Rep AbortMutation x)
-> (forall x. Rep AbortMutation x -> AbortMutation)
-> Generic AbortMutation
forall x. Rep AbortMutation x -> AbortMutation
forall x. AbortMutation -> Rep AbortMutation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AbortMutation -> Rep AbortMutation x
from :: forall x. AbortMutation -> Rep AbortMutation x
$cto :: forall x. Rep AbortMutation x -> AbortMutation
to :: forall x. Rep AbortMutation x -> AbortMutation
Generic, Int -> AbortMutation -> String -> String
[AbortMutation] -> String -> String
AbortMutation -> String
(Int -> AbortMutation -> String -> String)
-> (AbortMutation -> String)
-> ([AbortMutation] -> String -> String)
-> Show AbortMutation
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AbortMutation -> String -> String
showsPrec :: Int -> AbortMutation -> String -> String
$cshow :: AbortMutation -> String
show :: AbortMutation -> String
$cshowList :: [AbortMutation] -> String -> String
showList :: [AbortMutation] -> String -> String
Show, Int -> AbortMutation
AbortMutation -> Int
AbortMutation -> [AbortMutation]
AbortMutation -> AbortMutation
AbortMutation -> AbortMutation -> [AbortMutation]
AbortMutation -> AbortMutation -> AbortMutation -> [AbortMutation]
(AbortMutation -> AbortMutation)
-> (AbortMutation -> AbortMutation)
-> (Int -> AbortMutation)
-> (AbortMutation -> Int)
-> (AbortMutation -> [AbortMutation])
-> (AbortMutation -> AbortMutation -> [AbortMutation])
-> (AbortMutation -> AbortMutation -> [AbortMutation])
-> (AbortMutation
-> AbortMutation -> AbortMutation -> [AbortMutation])
-> Enum AbortMutation
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 :: AbortMutation -> AbortMutation
succ :: AbortMutation -> AbortMutation
$cpred :: AbortMutation -> AbortMutation
pred :: AbortMutation -> AbortMutation
$ctoEnum :: Int -> AbortMutation
toEnum :: Int -> AbortMutation
$cfromEnum :: AbortMutation -> Int
fromEnum :: AbortMutation -> Int
$cenumFrom :: AbortMutation -> [AbortMutation]
enumFrom :: AbortMutation -> [AbortMutation]
$cenumFromThen :: AbortMutation -> AbortMutation -> [AbortMutation]
enumFromThen :: AbortMutation -> AbortMutation -> [AbortMutation]
$cenumFromTo :: AbortMutation -> AbortMutation -> [AbortMutation]
enumFromTo :: AbortMutation -> AbortMutation -> [AbortMutation]
$cenumFromThenTo :: AbortMutation -> AbortMutation -> AbortMutation -> [AbortMutation]
enumFromThenTo :: AbortMutation -> AbortMutation -> AbortMutation -> [AbortMutation]
Enum, AbortMutation
AbortMutation -> AbortMutation -> Bounded AbortMutation
forall a. a -> a -> Bounded a
$cminBound :: AbortMutation
minBound :: AbortMutation
$cmaxBound :: AbortMutation
maxBound :: AbortMutation
Bounded)
genAbortMutation :: (Tx, UTxO) -> Gen SomeMutation
genAbortMutation :: (Tx, UTxO) -> Gen SomeMutation
genAbortMutation (Tx
tx, UTxO
utxo) =
[Gen SomeMutation] -> Gen SomeMutation
forall a. [Gen a] -> Gen a
oneof
[ Maybe Text -> AbortMutation -> 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
$ HeadError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode HeadError
BurntTokenNumberMismatch) AbortMutation
MutateParties (Mutation -> SomeMutation)
-> (State -> Mutation) -> State -> SomeMutation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Mutation
ChangeInputHeadDatum (State -> SomeMutation) -> Gen State -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
[Party]
moreParties <- (Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
healthyParties) (Party -> [Party]) -> Gen Party -> Gen [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Party
forall a. Arbitrary a => Gen a
arbitrary
ContestationPeriod
c <- Gen ContestationPeriod
forall a. Arbitrary a => Gen a
arbitrary
State -> Gen State
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (State -> Gen State) -> State -> Gen State
forall a b. (a -> b) -> a -> b
$
ContestationPeriod
-> [Party] -> CurrencySymbol -> TxOutRef -> State
Head.Initial
ContestationPeriod
c
(Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
moreParties)
(PolicyId -> CurrencySymbol
toPlutusCurrencySymbol (PolicyId -> CurrencySymbol) -> PolicyId -> CurrencySymbol
forall a b. (a -> b) -> a -> b
$ TxIn -> PolicyId
headPolicyId TxIn
testSeedInput)
(TxIn -> TxOutRef
toPlutusTxOutRef TxIn
testSeedInput)
, Maybe Text -> AbortMutation -> 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
$ HeadError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode HeadError
BurntTokenNumberMismatch) AbortMutation
DropCollectedInput (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
let abortableInputs :: [(TxIn, TxOut CtxUTxO Era)]
abortableInputs = UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs (UTxO -> [(TxIn, TxOut CtxUTxO Era)])
-> UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall a b. (a -> b) -> a -> b
$ (TxOut CtxUTxO Era -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
UTxO.filter (Bool -> Bool
not (Bool -> Bool)
-> (TxOut CtxUTxO Era -> Bool) -> TxOut CtxUTxO Era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Bool
isHeadOutput) (UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx)
(TxIn
toDropTxIn, TxOut CtxUTxO Era
toDropTxOut) <- [(TxIn, TxOut CtxUTxO Era)] -> Gen (TxIn, TxOut CtxUTxO Era)
forall a. [a] -> Gen a
elements [(TxIn, TxOut CtxUTxO Era)]
abortableInputs
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
toDropTxIn
, Value -> Mutation
ChangeMintedValue (Value -> Mutation) -> Value -> Mutation
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO Era -> Tx -> Value
removePTFromMintedValue TxOut CtxUTxO Era
toDropTxOut Tx
tx
]
, Maybe Text -> AbortMutation -> 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
$ HeadError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode HeadError
ReimbursedOutputsDontMatch) AbortMutation
DropOneCommitOutput (Mutation -> SomeMutation)
-> (Word -> Mutation) -> Word -> SomeMutation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Mutation
RemoveOutput (Word -> SomeMutation) -> Gen Word -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
0, Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([TxOut CtxTx Era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
, Maybe Text -> AbortMutation -> 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
$ HeadError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode HeadError
BurntTokenNumberMismatch) AbortMutation
MutateThreadTokenQuantity (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx -> Integer -> Gen Mutation
changeMintedValueQuantityFrom Tx
tx (-Integer
1)
, Maybe Text -> AbortMutation -> 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
$ HeadError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode HeadError
BurntTokenNumberMismatch) AbortMutation
BurnOneTokenMore (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx -> Quantity -> Gen Mutation
addPTWithQuantity Tx
tx (-Quantity
1)
, Maybe Text -> AbortMutation -> 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
$ HeadError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode HeadError
SignerIsNotAParticipant) AbortMutation
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 -> AbortMutation -> 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
$ HeadError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode HeadError
BurntTokenNumberMismatch) AbortMutation
MutateUseDifferentHeadToAbort (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
TxIn
mutatedSeed <- 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
testSeedInput)
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
$
State -> Mutation
ChangeInputHeadDatum
Head.Initial
{ $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod -> ContestationPeriod
toChain (ContestationPeriod -> ContestationPeriod)
-> ContestationPeriod -> ContestationPeriod
forall a b. (a -> b) -> a -> b
$ HeadParameters -> ContestationPeriod
contestationPeriod HeadParameters
healthyHeadParameters
, $sel:parties:Initial :: [Party]
Head.parties = (Party -> Party) -> [Party] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map Party -> Party
partyToChain (HeadParameters -> [Party]
parties HeadParameters
healthyHeadParameters)
, $sel:headId:Initial :: CurrencySymbol
Head.headId = PolicyId -> CurrencySymbol
toPlutusCurrencySymbol (PolicyId -> CurrencySymbol) -> PolicyId -> CurrencySymbol
forall a b. (a -> b) -> a -> b
$ TxIn -> PolicyId
headPolicyId TxIn
mutatedSeed
, $sel:seed:Initial :: TxOutRef
Head.seed = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
mutatedSeed
}
, Maybe Text -> AbortMutation -> 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
$ HeadError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode HeadError
BurntTokenNumberMismatch) AbortMutation
UseInputFromOtherHead (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
(TxIn
txIn, TxOut CtxUTxO Era
txOut) <- [(TxIn, TxOut CtxUTxO Era)] -> Gen (TxIn, TxOut CtxUTxO Era)
forall a. [a] -> Gen a
elements [(TxIn, TxOut CtxUTxO Era)]
healthyInitials
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
testSeedInput))
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 -> TxOut CtxUTxO Era -> Maybe HashableScriptData -> Mutation
ChangeInput TxIn
txIn (PolicyId -> PolicyId -> TxOut CtxUTxO Era -> TxOut CtxUTxO Era
forall a. PolicyId -> PolicyId -> TxOut a -> TxOut a
replacePolicyIdWith PolicyId
testPolicyId PolicyId
otherHeadId TxOut CtxUTxO Era
txOut) (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
Initial.ViaAbort)
, Value -> Mutation
ChangeMintedValue (TxOut CtxUTxO Era -> Tx -> Value
removePTFromMintedValue TxOut CtxUTxO Era
txOut Tx
tx)
]
, Maybe Text -> AbortMutation -> 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
$ HeadError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode HeadError
ReimbursedOutputsDontMatch) AbortMutation
ReorderCommitOutputs (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
let outputs :: [TxOut CtxTx Era]
outputs = Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx
[TxOut CtxTx Era]
outputs' <- [TxOut CtxTx Era] -> Gen [TxOut CtxTx Era]
forall a. [a] -> Gen [a]
shuffle [TxOut CtxTx Era]
outputs Gen [TxOut CtxTx Era]
-> ([TxOut CtxTx Era] -> Bool) -> Gen [TxOut CtxTx Era]
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` ([TxOut CtxTx Era] -> [TxOut CtxTx Era] -> Bool
forall a. Eq a => a -> a -> Bool
/= [TxOut CtxTx Era]
outputs)
let reorderedOutputs :: [Mutation]
reorderedOutputs = (Word -> TxOut CtxTx Era -> Mutation)
-> (Word, TxOut CtxTx Era) -> Mutation
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word -> TxOut CtxTx Era -> Mutation
ChangeOutput ((Word, TxOut CtxTx Era) -> Mutation)
-> [(Word, TxOut CtxTx Era)] -> [Mutation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word] -> [TxOut CtxTx Era] -> [(Word, TxOut CtxTx Era)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0 ..] [TxOut CtxTx Era]
outputs'
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 [Mutation]
reorderedOutputs
, Maybe Text -> AbortMutation -> 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
$ HeadTokensError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode HeadTokensError
MintingNotAllowed) AbortMutation
MintOnAbort (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Mutation
mintAPT <- Tx -> Quantity -> Gen Mutation
addPTWithQuantity Tx
tx Quantity
1
let onePartyLess :: [Party]
onePartyLess = [Party] -> [Party]
forall a. HasCallStack => [a] -> [a]
List.tail [Party]
healthyParties
let removeOneParty :: Mutation
removeOneParty =
State -> Mutation
ChangeInputHeadDatum (State -> Mutation) -> State -> Mutation
forall a b. (a -> b) -> a -> b
$
Head.Initial
{ $sel:contestationPeriod:Initial :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod -> ContestationPeriod
toChain (ContestationPeriod -> ContestationPeriod)
-> ContestationPeriod -> ContestationPeriod
forall a b. (a -> b) -> a -> b
$ HeadParameters -> ContestationPeriod
contestationPeriod HeadParameters
healthyHeadParameters
, $sel:parties:Initial :: [Party]
Head.parties = (Party -> Party) -> [Party] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map Party -> Party
partyToChain [Party]
onePartyLess
, $sel:headId:Initial :: CurrencySymbol
Head.headId = PolicyId -> CurrencySymbol
toPlutusCurrencySymbol (PolicyId -> CurrencySymbol) -> PolicyId -> CurrencySymbol
forall a b. (a -> b) -> a -> b
$ TxIn -> PolicyId
headPolicyId TxIn
testSeedInput
, $sel:seed:Initial :: TxOutRef
Head.seed = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
testSeedInput
}
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 [Mutation
mintAPT, Mutation
removeOneParty]
, Maybe Text -> AbortMutation -> Mutation -> SomeMutation
forall lbl.
(Typeable lbl, Enum lbl, Bounded lbl, Show lbl) =>
Maybe Text -> lbl -> Mutation -> SomeMutation
SomeMutation Maybe Text
forall a. Maybe a
Nothing AbortMutation
ExtractValue (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
[Mutation]
divertFunds <- do
let allValue :: Value
allValue = (TxOut CtxTx Era -> Value) -> [TxOut CtxTx Era] -> Value
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxTx Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue ([TxOut CtxTx Era] -> Value) -> [TxOut CtxTx Era] -> Value
forall a b. (a -> b) -> a -> b
$ Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx
TxOut CtxTx Era
extractionTxOut <- do
AddressInEra
someAddress <- NetworkId -> Gen AddressInEra
genAddressInEra NetworkId
testNetworkId
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
$ AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
someAddress Value
allValue TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone
[Mutation] -> Gen [Mutation]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Word -> Mutation
RemoveOutput Word
0
, Word -> Mutation
RemoveOutput Word
1
, TxOut CtxTx Era -> Mutation
AppendOutput TxOut CtxTx Era
extractionTxOut
]
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 ([Mutation] -> Mutation) -> [Mutation] -> Mutation
forall a b. (a -> b) -> a -> b
$
[ Value -> Mutation
ChangeMintedValue Value
forall a. Monoid a => a
mempty
, TxIn -> Mutation
RemoveInput TxIn
healthyHeadInput
]
[Mutation] -> [Mutation] -> [Mutation]
forall a. [a] -> [a] -> [a]
++ [Mutation]
divertFunds
, Maybe Text -> AbortMutation -> 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
$ CommitError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode CommitError
STNotBurnedError) AbortMutation
DoNotBurnST
(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 ([(AssetId, Quantity)] -> Value
valueFromList [(PolicyId -> AssetName -> AssetId
AssetId (TxIn -> PolicyId
headPolicyId TxIn
testSeedInput) AssetName
hydraHeadV1AssetName, Quantity
1)])
, Maybe Text -> AbortMutation -> 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
STNotBurned) AbortMutation
DoNotBurnSTInitial
(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 ([(AssetId, Quantity)] -> Value
valueFromList [(PolicyId -> AssetName -> AssetId
AssetId (TxIn -> PolicyId
headPolicyId TxIn
testSeedInput) AssetName
hydraHeadV1AssetName, Quantity
1)])
]