{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | Mutation-based script validator tests for the abort transaction where a
-- 'healthyAbortTx' gets mutated by an arbitrary 'AbortMutation'.
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)

--
-- AbortTx
--

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) =
  -- TODO: Refactor this to be an AbortTx generator because we actually want
  -- to test healthy abort txs with varied combinations of inital and commit
  -- outputs
  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
  = -- | Add one more party to the hydra keys. This is essentialy the same as
    -- not collecting all inputs.
    MutateParties
  | -- | Not collect one committed UTxO by removing the input and not burn the
    -- corresponding PT.
    DropCollectedInput
  | -- | Not reimburse one of the parties.
    DropOneCommitOutput
  | -- | Burning one PT more. This should be an impossible situation, but it is
    -- tested nontheless.
    BurnOneTokenMore
  | -- | Meant to test that the minting policy is burning all PTs present in tx
    MutateThreadTokenQuantity
  | -- | Check an arbitrary key cannot authenticate abort.
    MutateRequiredSigner
  | -- | Use a different head output to abort.
    MutateUseDifferentHeadToAbort
  | -- | Spend some abortable output from a different Head e.g. replace a commit
    -- by another commit from a different Head.
    UseInputFromOtherHead
  | -- | Re-ordering outputs would not be a big deal, but it is still prevented.
    ReorderCommitOutputs
  | -- | Only burning should be allowed in abort (by the minting policy).
    MintOnAbort
  | -- | Not spend from v_head and also not burn anything to extract value.
    ExtractValue
  | -- | State token is not burned
    DoNotBurnST
  | -- | Here we want to check that the initial validator also fails on abort.
    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
            [ -- XXX: This is changing the PT of the initial, but not the
              -- datum; it's an impossible situation as the minting policy would
              -- not allow non-matching datum & PT
              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
        -- We need to also remove one party to make sure the vHead validator
        -- still thinks it's the right number of tokens getting burned.
        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)])
    ]