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

module Hydra.Chain.Direct.Contract.Contest where

import Hydra.Cardano.Api
import Hydra.Prelude hiding (label)

import Data.Maybe (fromJust)

import Cardano.Api.UTxO as UTxO
import Hydra.Chain.Direct.Contract.Gen (genForParty, genHash, genMintedOrBurnedValue)
import Hydra.Chain.Direct.Contract.Mutation (
  Mutation (..),
  SomeMutation (..),
  addParticipationTokens,
  changeMintedTokens,
  modifyInlineDatum,
  replaceContestationDeadline,
  replaceContestationPeriod,
  replaceContesters,
  replaceHeadId,
  replaceParties,
  replacePolicyIdWith,
  replaceSnapshotNumber,
  replaceUtxoHash,
 )
import Hydra.Chain.Direct.Fixture (slotLength, systemStart, testNetworkId, testPolicyId)
import Hydra.Chain.Direct.Fixture qualified as Fixture
import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO)
import Hydra.Chain.Direct.Tx (ClosedThreadOutput (..), contestTx, mkHeadId, mkHeadOutput)
import Hydra.ContestationPeriod (ContestationPeriod, fromChain)
import Hydra.Contract.Error (toErrorCode)
import Hydra.Contract.HeadError (HeadError (..))
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.HeadTokens (headPolicyId)
import Hydra.Contract.Util (UtilError (MintingOrBurningIsForbidden))
import Hydra.Crypto (HydraKey, MultiSignature, aggregate, sign, toPlutusSignatures)
import Hydra.Data.ContestationPeriod qualified as OnChain
import Hydra.Data.Party (partyFromVerificationKeyBytes)
import Hydra.Data.Party qualified as OnChain
import Hydra.Ledger (hashUTxO)
import Hydra.Ledger.Cardano (genAddressInEra, genOneUTxOFor, genValue, genVerificationKey)
import Hydra.Ledger.Cardano.Time (slotNoToUTCTime)
import Hydra.Party (Party, deriveParty, partyToChain)
import Hydra.Plutus.Extras (posixFromUTCTime)
import Hydra.Plutus.Orphans ()
import Hydra.Snapshot (Snapshot (..), SnapshotNumber)
import PlutusLedgerApi.V2 (BuiltinByteString, toBuiltin)
import PlutusLedgerApi.V2 qualified as Plutus
import Test.Hydra.Fixture (aliceSk, bobSk, carolSk)
import Test.QuickCheck (arbitrarySizedNatural, elements, listOf, listOf1, oneof, suchThat, vectorOf)
import Test.QuickCheck.Gen (choose)
import Test.QuickCheck.Instances ()

--
-- ContestTx
--

-- | Healthy contest tx where the contester is the first one to contest and
-- correctly pushing out the deadline by the contestation period.
healthyContestTx :: (Tx, UTxO)
healthyContestTx :: (Tx, UTxO)
healthyContestTx =
  (Tx
tx, UTxO
lookupUTxO)
 where
  lookupUTxO :: UTxO
lookupUTxO =
    (TxIn, TxOut CtxUTxO Era) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn
healthyClosedHeadTxIn, TxOut CtxUTxO Era
healthyClosedHeadTxOut)
      UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ScriptRegistry -> UTxO
registryUTxO ScriptRegistry
scriptRegistry

  tx :: Tx
tx =
    ScriptRegistry
-> VerificationKey PaymentKey
-> Snapshot Tx
-> MultiSignature (Snapshot Tx)
-> PointInTime
-> ClosedThreadOutput
-> HeadId
-> ContestationPeriod
-> Tx
contestTx
      ScriptRegistry
scriptRegistry
      VerificationKey PaymentKey
healthyContesterVerificationKey
      Snapshot Tx
healthyContestSnapshot
      (SnapshotNumber -> MultiSignature (Snapshot Tx)
healthySignature SnapshotNumber
healthyContestSnapshotNumber)
      (SlotNo
healthySlotNo, SystemStart -> SlotLength -> SlotNo -> UTCTime
slotNoToUTCTime SystemStart
systemStart SlotLength
slotLength SlotNo
healthySlotNo)
      ClosedThreadOutput
closedThreadOutput
      (PolicyId -> HeadId
mkHeadId PolicyId
testPolicyId)
      ContestationPeriod
healthyContestationPeriod

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

  closedThreadOutput :: ClosedThreadOutput
closedThreadOutput =
    ClosedThreadOutput
      { $sel:closedThreadUTxO:ClosedThreadOutput :: (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO = (TxIn
healthyClosedHeadTxIn, TxOut CtxUTxO Era
healthyClosedHeadTxOut)
      , $sel:closedParties:ClosedThreadOutput :: [Party]
closedParties =
          [Party]
healthyOnChainParties
      , $sel:closedContestationDeadline:ClosedThreadOutput :: POSIXTime
closedContestationDeadline = UTCTime -> POSIXTime
posixFromUTCTime UTCTime
healthyContestationDeadline
      , $sel:closedContesters:ClosedThreadOutput :: [PubKeyHash]
closedContesters = []
      }

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

healthyClosedHeadTxOut :: TxOut CtxUTxO
healthyClosedHeadTxOut :: TxOut CtxUTxO Era
healthyClosedHeadTxOut =
  NetworkId -> PolicyId -> TxOutDatum CtxUTxO -> TxOut CtxUTxO Era
forall ctx. NetworkId -> PolicyId -> TxOutDatum ctx -> TxOut ctx
mkHeadOutput NetworkId
testNetworkId PolicyId
testPolicyId TxOutDatum CtxUTxO
headTxOutDatum
    TxOut CtxUTxO Era
-> (TxOut CtxUTxO Era -> TxOut CtxUTxO Era) -> TxOut CtxUTxO Era
forall a b. a -> (a -> b) -> b
& [VerificationKey PaymentKey]
-> TxOut CtxUTxO Era -> TxOut CtxUTxO Era
addParticipationTokens [VerificationKey PaymentKey]
healthyParticipants
 where
  headTxOutDatum :: TxOutDatum CtxUTxO
headTxOutDatum = TxOutDatum CtxTx Era -> TxOutDatum CtxUTxO
forall era. TxOutDatum CtxTx era -> TxOutDatum CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext (State -> TxOutDatum CtxTx Era
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline State
healthyClosedState)

healthyContestSnapshot :: Snapshot Tx
healthyContestSnapshot :: Snapshot Tx
healthyContestSnapshot =
  Snapshot
    { $sel:headId:Snapshot :: HeadId
headId = PolicyId -> HeadId
mkHeadId PolicyId
testPolicyId
    , $sel:number:Snapshot :: SnapshotNumber
number = SnapshotNumber
healthyContestSnapshotNumber
    , $sel:utxo:Snapshot :: UTxOType Tx
utxo = UTxO
UTxOType Tx
healthyContestUTxO
    , $sel:confirmed:Snapshot :: [TxIdType Tx]
confirmed = []
    }

healthyContestSnapshotNumber :: SnapshotNumber
healthyContestSnapshotNumber :: SnapshotNumber
healthyContestSnapshotNumber = SnapshotNumber
4

healthyContestUTxO :: UTxO
healthyContestUTxO :: UTxO
healthyContestUTxO =
  (VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor VerificationKey PaymentKey
healthyContesterVerificationKey Gen UTxO -> (UTxO -> Bool) -> Gen UTxO
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (UTxO -> UTxO -> Bool
forall a. Eq a => a -> a -> Bool
/= UTxO
healthyClosedUTxO))
    Gen UTxO -> Int -> UTxO
forall a. Gen a -> Int -> a
`generateWith` Int
42

healthyContestUTxOHash :: BuiltinByteString
healthyContestUTxOHash :: BuiltinByteString
healthyContestUTxOHash =
  ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> ByteString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxO
UTxOType Tx
healthyContestUTxO

healthyClosedState :: Head.State
healthyClosedState :: State
healthyClosedState =
  Head.Closed
    { $sel:snapshotNumber:Initial :: SnapshotNumber
snapshotNumber = SnapshotNumber -> SnapshotNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral SnapshotNumber
healthyClosedSnapshotNumber
    , $sel:utxoHash:Initial :: BuiltinByteString
utxoHash = BuiltinByteString
healthyClosedUTxOHash
    , $sel:parties:Initial :: [Party]
parties = [Party]
healthyOnChainParties
    , $sel:contestationDeadline:Initial :: POSIXTime
contestationDeadline = UTCTime -> POSIXTime
posixFromUTCTime UTCTime
healthyContestationDeadline
    , $sel:contestationPeriod:Initial :: ContestationPeriod
contestationPeriod = ContestationPeriod
healthyOnChainContestationPeriod
    , $sel:headId:Initial :: CurrencySymbol
headId = PolicyId -> CurrencySymbol
toPlutusCurrencySymbol PolicyId
testPolicyId
    , $sel:contesters:Initial :: [PubKeyHash]
contesters = []
    }

healthySlotNo :: SlotNo
healthySlotNo :: SlotNo
healthySlotNo = Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary Gen SlotNo -> Int -> SlotNo
forall a. Gen a -> Int -> a
`generateWith` Int
42

healthyContestationDeadline :: UTCTime
healthyContestationDeadline :: UTCTime
healthyContestationDeadline =
  NominalDiffTime -> UTCTime -> UTCTime
addUTCTime
    (SnapshotNumber -> NominalDiffTime
forall a. Num a => SnapshotNumber -> a
fromInteger SnapshotNumber
healthyContestationPeriodSeconds)
    (SystemStart -> SlotLength -> SlotNo -> UTCTime
slotNoToUTCTime SystemStart
systemStart SlotLength
slotLength SlotNo
healthySlotNo)

healthyOnChainContestationPeriod :: OnChain.ContestationPeriod
healthyOnChainContestationPeriod :: ContestationPeriod
healthyOnChainContestationPeriod = NominalDiffTime -> ContestationPeriod
OnChain.contestationPeriodFromDiffTime (NominalDiffTime -> ContestationPeriod)
-> NominalDiffTime -> ContestationPeriod
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> NominalDiffTime
forall a. Num a => SnapshotNumber -> a
fromInteger SnapshotNumber
healthyContestationPeriodSeconds

healthyContestationPeriod :: ContestationPeriod
healthyContestationPeriod :: ContestationPeriod
healthyContestationPeriod = ContestationPeriod -> ContestationPeriod
fromChain ContestationPeriod
healthyOnChainContestationPeriod

healthyContestationPeriodSeconds :: Integer
healthyContestationPeriodSeconds :: SnapshotNumber
healthyContestationPeriodSeconds = SnapshotNumber
10

healthyClosedSnapshotNumber :: SnapshotNumber
healthyClosedSnapshotNumber :: SnapshotNumber
healthyClosedSnapshotNumber = SnapshotNumber
3

healthyClosedUTxOHash :: BuiltinByteString
healthyClosedUTxOHash :: BuiltinByteString
healthyClosedUTxOHash =
  ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> ByteString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxO
UTxOType Tx
healthyClosedUTxO

healthyClosedUTxO :: UTxO
healthyClosedUTxO :: UTxO
healthyClosedUTxO =
  VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor VerificationKey PaymentKey
healthyContesterVerificationKey Gen UTxO -> Int -> UTxO
forall a. Gen a -> Int -> a
`generateWith` Int
42

healthyParticipants :: [VerificationKey PaymentKey]
healthyParticipants :: [VerificationKey PaymentKey]
healthyParticipants =
  Gen (VerificationKey PaymentKey)
-> Party -> VerificationKey PaymentKey
forall a. Gen a -> Party -> a
genForParty Gen (VerificationKey PaymentKey)
genVerificationKey (Party -> VerificationKey PaymentKey)
-> [Party] -> [VerificationKey PaymentKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
healthyParties

healthyContesterVerificationKey :: VerificationKey PaymentKey
healthyContesterVerificationKey :: VerificationKey PaymentKey
healthyContesterVerificationKey =
  [VerificationKey PaymentKey] -> Gen (VerificationKey PaymentKey)
forall a. [a] -> Gen a
elements [VerificationKey PaymentKey]
healthyParticipants Gen (VerificationKey PaymentKey)
-> Int -> VerificationKey PaymentKey
forall a. Gen a -> Int -> a
`generateWith` Int
42

healthySigningKeys :: [SigningKey HydraKey]
healthySigningKeys :: [SigningKey HydraKey]
healthySigningKeys = [SigningKey HydraKey
aliceSk, SigningKey HydraKey
bobSk, SigningKey HydraKey
carolSk]

healthyParties :: [Party]
healthyParties :: [Party]
healthyParties = SigningKey HydraKey -> Party
deriveParty (SigningKey HydraKey -> Party) -> [SigningKey HydraKey] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SigningKey HydraKey]
healthySigningKeys

healthyOnChainParties :: [OnChain.Party]
healthyOnChainParties :: [Party]
healthyOnChainParties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
healthyParties

healthySignature :: SnapshotNumber -> MultiSignature (Snapshot Tx)
healthySignature :: SnapshotNumber -> MultiSignature (Snapshot Tx)
healthySignature SnapshotNumber
number =
  [Signature (Snapshot Tx)] -> MultiSignature (Snapshot Tx)
forall {k} (a :: k). [Signature a] -> MultiSignature a
aggregate [SigningKey HydraKey -> Snapshot Tx -> Signature (Snapshot Tx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk Snapshot Tx
snapshot | SigningKey HydraKey
sk <- [SigningKey HydraKey]
healthySigningKeys]
 where
  snapshot :: Snapshot Tx
snapshot = Snapshot Tx
healthyContestSnapshot{number}

-- FIXME: Should try to mutate the 'closedAt' recorded time to something else
data ContestMutation
  = -- | Ensures collectCom does not allow any output address but νHead.
    NotContinueContract
  | -- | Invalidates the tx by changing the redeemer signature but not the
    -- snapshot number in resulting head output.
    --
    -- Ensures the snapshot signature is multisigned by all valid Head
    -- participants.
    MutateSignatureButNotSnapshotNumber
  | -- | Invalidates the tx by changing the snapshot number in resulting head
    -- output but not the redeemer signature.
    --
    -- Ensures the snapshot signature is aligned with snapshot number.
    MutateSnapshotNumberButNotSignature
  | -- | Invalidates the tx by changing the contest snapshot number too old.
    --
    -- This is achieved by updating the head input datum to be older, so the
    -- healthy snapshot number becomes too old.
    MutateToNonNewerSnapshot
  | -- | Ensures close is authenticated by one of the Head members by changing the signer
    -- used on the tx to be not one of PTs.
    MutateRequiredSigner
  | -- | Ensures close is authenticated by one of the Head members by changing the signer
    -- used on the tx to be empty.
    MutateNoRequiredSigner
  | -- | Ensures close is authenticated by one of the Head members by changing the signer
    -- used on the tx to have multiple signers (including the signer to not fail for
    -- SignerIsNotAParticipant).
    MutateMultipleRequiredSigner
  | -- | Invalidates the tx by changing the utxo hash in resulting head output.
    --
    -- Ensures the output state is consistent with the redeemer.
    MutateContestUTxOHash
  | -- | Ensures the contest snapshot is multisigned by all Head participants by
    -- changing the parties in the input head datum. If they do not align the
    -- multisignature will not be valid anymore.
    SnapshotNotSignedByAllParties
  | -- | Invalidates the tx by changing the upper bound to be beyond
    -- contestation deadline from head input (stored state).
    MutateValidityPastDeadline
  | -- | Change the head policy id to simulate contestation using a ST and
    -- signer from a different head. The signer shows a correct signature but
    -- from a different head. This will cause the signer to not be present in
    -- the participation tokens.
    ContestFromDifferentHead
  | -- | Minting or burning of tokens should not be possible in contest.
    MutateTokenMintingOrBurning
  | -- | Ensures a participant can only contest once by changing the head input
    -- datum to already include the signer.
    MutateInputContesters
  | -- | Ensures a the signer needs to be added to the head output datum.
    MutateContesters
  | -- | Invalidates the tx by changing the output values arbitrarily to be
    -- different (not preserved) from the head.
    --
    -- Ensures values are preserved between head input and output.
    MutateValueInOutput
  | -- | Not pushing the contestation deadline in head output datum should not
    -- be allowed.
    NotUpdateDeadlineAlthoughItShould
  | -- | Pushes the deadline although this is the last contest. Instead of
    -- creating another healthy case and mutate that one, this mutation just
    -- changes the starting situation so that everyone else already contested.
    -- Remember the 'healthyContestTx' is already pushing out the deadline.
    PushDeadlineAlthoughItShouldNot
  | -- | Ensures contestation period does not change between head input datum
    -- and head output datum.
    MutateOutputContestationPeriod
  | -- | Ensures parties do not change between head input datum and head output
    --  datum.
    MutatePartiesInOutput
  | -- | Ensures headId do not change between head input datum and head output
    -- datum.
    MutateHeadIdInOutput
  deriving stock ((forall x. ContestMutation -> Rep ContestMutation x)
-> (forall x. Rep ContestMutation x -> ContestMutation)
-> Generic ContestMutation
forall x. Rep ContestMutation x -> ContestMutation
forall x. ContestMutation -> Rep ContestMutation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ContestMutation -> Rep ContestMutation x
from :: forall x. ContestMutation -> Rep ContestMutation x
$cto :: forall x. Rep ContestMutation x -> ContestMutation
to :: forall x. Rep ContestMutation x -> ContestMutation
Generic, Int -> ContestMutation -> ShowS
[ContestMutation] -> ShowS
ContestMutation -> String
(Int -> ContestMutation -> ShowS)
-> (ContestMutation -> String)
-> ([ContestMutation] -> ShowS)
-> Show ContestMutation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContestMutation -> ShowS
showsPrec :: Int -> ContestMutation -> ShowS
$cshow :: ContestMutation -> String
show :: ContestMutation -> String
$cshowList :: [ContestMutation] -> ShowS
showList :: [ContestMutation] -> ShowS
Show, Int -> ContestMutation
ContestMutation -> Int
ContestMutation -> [ContestMutation]
ContestMutation -> ContestMutation
ContestMutation -> ContestMutation -> [ContestMutation]
ContestMutation
-> ContestMutation -> ContestMutation -> [ContestMutation]
(ContestMutation -> ContestMutation)
-> (ContestMutation -> ContestMutation)
-> (Int -> ContestMutation)
-> (ContestMutation -> Int)
-> (ContestMutation -> [ContestMutation])
-> (ContestMutation -> ContestMutation -> [ContestMutation])
-> (ContestMutation -> ContestMutation -> [ContestMutation])
-> (ContestMutation
    -> ContestMutation -> ContestMutation -> [ContestMutation])
-> Enum ContestMutation
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 :: ContestMutation -> ContestMutation
succ :: ContestMutation -> ContestMutation
$cpred :: ContestMutation -> ContestMutation
pred :: ContestMutation -> ContestMutation
$ctoEnum :: Int -> ContestMutation
toEnum :: Int -> ContestMutation
$cfromEnum :: ContestMutation -> Int
fromEnum :: ContestMutation -> Int
$cenumFrom :: ContestMutation -> [ContestMutation]
enumFrom :: ContestMutation -> [ContestMutation]
$cenumFromThen :: ContestMutation -> ContestMutation -> [ContestMutation]
enumFromThen :: ContestMutation -> ContestMutation -> [ContestMutation]
$cenumFromTo :: ContestMutation -> ContestMutation -> [ContestMutation]
enumFromTo :: ContestMutation -> ContestMutation -> [ContestMutation]
$cenumFromThenTo :: ContestMutation
-> ContestMutation -> ContestMutation -> [ContestMutation]
enumFromThenTo :: ContestMutation
-> ContestMutation -> ContestMutation -> [ContestMutation]
Enum, ContestMutation
ContestMutation -> ContestMutation -> Bounded ContestMutation
forall a. a -> a -> Bounded a
$cminBound :: ContestMutation
minBound :: ContestMutation
$cmaxBound :: ContestMutation
maxBound :: ContestMutation
Bounded)

genContestMutation :: (Tx, UTxO) -> Gen SomeMutation
genContestMutation :: (Tx, UTxO) -> Gen SomeMutation
genContestMutation (Tx
tx, UTxO
_utxo) =
  [Gen SomeMutation] -> Gen SomeMutation
forall a. [Gen a] -> Gen a
oneof
    [ Maybe Text -> ContestMutation -> 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
NotPayingToHead) ContestMutation
NotContinueContract (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
testNetworkId
        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 -> Mutation
ChangeOutput Word
0 ((AddressInEra -> AddressInEra) -> TxOut CtxTx -> TxOut CtxTx
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 CtxTx
headTxOut)
    , Maybe Text -> ContestMutation -> 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
SignatureVerificationFailed) ContestMutation
MutateSignatureButNotSnapshotNumber (Mutation -> SomeMutation)
-> (Input -> Mutation) -> Input -> SomeMutation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Mutation
ChangeHeadRedeemer (Input -> SomeMutation) -> Gen Input -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        MultiSignature (Snapshot Tx)
mutatedSignature <- Gen (MultiSignature (Snapshot Tx))
forall a. Arbitrary a => Gen a
arbitrary :: Gen (MultiSignature (Snapshot Tx))
        Input -> Gen Input
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Input -> Gen Input) -> Input -> Gen Input
forall a b. (a -> b) -> a -> b
$
          Head.Contest
            { $sel:signature:CollectCom :: [BuiltinByteString]
signature = MultiSignature (Snapshot Tx) -> [BuiltinByteString]
forall {k} (a :: k). MultiSignature a -> [BuiltinByteString]
toPlutusSignatures MultiSignature (Snapshot Tx)
mutatedSignature
            }
    , Maybe Text -> ContestMutation -> 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
SignatureVerificationFailed) ContestMutation
MutateSnapshotNumberButNotSignature (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        SnapshotNumber
mutatedSnapshotNumber <- Gen SnapshotNumber
forall a. Integral a => Gen a
arbitrarySizedNatural Gen SnapshotNumber
-> (SnapshotNumber -> Bool) -> Gen SnapshotNumber
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (SnapshotNumber -> SnapshotNumber -> Bool
forall a. Ord a => a -> a -> Bool
> SnapshotNumber
healthyContestSnapshotNumber)
        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 -> Mutation
ChangeOutput Word
0 (TxOut CtxTx -> Mutation) -> TxOut CtxTx -> Mutation
forall a b. (a -> b) -> a -> b
$ (State -> State) -> TxOut CtxTx -> TxOut CtxTx
forall a.
(FromScriptData a, ToScriptData a) =>
(a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum (SnapshotNumber -> State -> State
replaceSnapshotNumber (SnapshotNumber -> State -> State)
-> SnapshotNumber -> State -> State
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> SnapshotNumber
forall a. Integral a => a -> SnapshotNumber
toInteger SnapshotNumber
mutatedSnapshotNumber) TxOut CtxTx
headTxOut
    , Maybe Text -> ContestMutation -> 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
TooOldSnapshot) ContestMutation
MutateToNonNewerSnapshot (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        SnapshotNumber
mutatedSnapshotNumber <- (SnapshotNumber, SnapshotNumber) -> Gen SnapshotNumber
forall a. Random a => (a, a) -> Gen a
choose (SnapshotNumber -> SnapshotNumber
forall a. Integral a => a -> SnapshotNumber
toInteger SnapshotNumber
healthyContestSnapshotNumber, SnapshotNumber -> SnapshotNumber
forall a. Integral a => a -> SnapshotNumber
toInteger SnapshotNumber
healthyContestSnapshotNumber SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1)
        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
            [ State -> Mutation
ChangeInputHeadDatum (State -> Mutation) -> State -> Mutation
forall a b. (a -> b) -> a -> b
$
                State
healthyClosedState State -> (State -> State) -> State
forall a b. a -> (a -> b) -> b
& SnapshotNumber -> State -> State
replaceSnapshotNumber SnapshotNumber
mutatedSnapshotNumber
            , Input -> Mutation
ChangeHeadRedeemer (Input -> Mutation) -> Input -> Mutation
forall a b. (a -> b) -> a -> b
$
                Head.Contest
                  { $sel:signature:CollectCom :: [BuiltinByteString]
signature =
                      MultiSignature (Snapshot Tx) -> [BuiltinByteString]
forall {k} (a :: k). MultiSignature a -> [BuiltinByteString]
toPlutusSignatures (MultiSignature (Snapshot Tx) -> [BuiltinByteString])
-> MultiSignature (Snapshot Tx) -> [BuiltinByteString]
forall a b. (a -> b) -> a -> b
$
                        SnapshotNumber -> MultiSignature (Snapshot Tx)
healthySignature (SnapshotNumber -> SnapshotNumber
forall a. Num a => SnapshotNumber -> a
fromInteger SnapshotNumber
mutatedSnapshotNumber)
                  }
            ]
    , Maybe Text -> ContestMutation -> 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) ContestMutation
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 Gen (VerificationKey PaymentKey)
-> (VerificationKey PaymentKey -> Bool)
-> Gen (VerificationKey PaymentKey)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (VerificationKey PaymentKey -> VerificationKey PaymentKey -> Bool
forall a. Eq a => a -> a -> Bool
/= VerificationKey PaymentKey
healthyContesterVerificationKey)
        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 -> ContestMutation -> 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
NoSigners) ContestMutation
MutateNoRequiredSigner (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        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 []
    , Maybe Text -> ContestMutation -> 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
TooManySigners) ContestMutation
MutateMultipleRequiredSigner (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        [VerificationKey PaymentKey]
otherSigners <- Gen (VerificationKey PaymentKey)
-> Gen [VerificationKey PaymentKey]
forall a. Gen a -> Gen [a]
listOf1 (Gen (VerificationKey PaymentKey)
genVerificationKey Gen (VerificationKey PaymentKey)
-> (VerificationKey PaymentKey -> Bool)
-> Gen (VerificationKey PaymentKey)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (VerificationKey PaymentKey -> VerificationKey PaymentKey -> Bool
forall a. Eq a => a -> a -> Bool
/= VerificationKey PaymentKey
healthyContesterVerificationKey))
        let signerAndOthers :: [VerificationKey PaymentKey]
signerAndOthers = VerificationKey PaymentKey
healthyContesterVerificationKey VerificationKey PaymentKey
-> [VerificationKey PaymentKey] -> [VerificationKey PaymentKey]
forall a. a -> [a] -> [a]
: [VerificationKey PaymentKey]
otherSigners
        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 (VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (VerificationKey PaymentKey -> Hash PaymentKey)
-> [VerificationKey PaymentKey] -> [Hash PaymentKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VerificationKey PaymentKey]
signerAndOthers)
    , Maybe Text -> ContestMutation -> 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
SignatureVerificationFailed) ContestMutation
MutateContestUTxOHash (Mutation -> SomeMutation)
-> (TxOut CtxTx -> Mutation) -> TxOut CtxTx -> SomeMutation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> TxOut CtxTx -> Mutation
ChangeOutput Word
0 (TxOut CtxTx -> SomeMutation)
-> Gen (TxOut CtxTx) -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        ByteString
mutatedUTxOHash <- Gen ByteString
genHash Gen ByteString -> (ByteString -> Bool) -> Gen ByteString
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` ((BuiltinByteString -> BuiltinByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= BuiltinByteString
healthyContestUTxOHash) (BuiltinByteString -> Bool)
-> (ByteString -> BuiltinByteString) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin)
        TxOut CtxTx -> Gen (TxOut CtxTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut CtxTx -> Gen (TxOut CtxTx))
-> TxOut CtxTx -> Gen (TxOut CtxTx)
forall a b. (a -> b) -> a -> b
$
          (State -> State) -> TxOut CtxTx -> TxOut CtxTx
forall a.
(FromScriptData a, ToScriptData a) =>
(a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum
            (BuiltinByteString -> State -> State
replaceUtxoHash (ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin ByteString
mutatedUTxOHash))
            TxOut CtxTx
headTxOut
    , Maybe Text -> ContestMutation -> 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
SignatureVerificationFailed) ContestMutation
SnapshotNotSignedByAllParties (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]
mutatedParties <- Gen [Party]
forall a. Arbitrary a => Gen a
arbitrary Gen [Party] -> ([Party] -> Bool) -> Gen [Party]
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` ([Party] -> [Party] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Party]
healthyOnChainParties)
        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
$
          State
healthyClosedState State -> (State -> State) -> State
forall a b. a -> (a -> b) -> b
& [Party] -> State -> State
replaceParties [Party]
mutatedParties
    , Maybe Text -> ContestMutation -> 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
UpperBoundBeyondContestationDeadline) ContestMutation
MutateValidityPastDeadline (Mutation -> SomeMutation)
-> ((TxValidityLowerBound, TxValidityUpperBound) -> Mutation)
-> (TxValidityLowerBound, TxValidityUpperBound)
-> SomeMutation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxValidityLowerBound, TxValidityUpperBound) -> Mutation
ChangeValidityInterval ((TxValidityLowerBound, TxValidityUpperBound) -> SomeMutation)
-> Gen (TxValidityLowerBound, TxValidityUpperBound)
-> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        TxValidityLowerBound
lb <- Gen TxValidityLowerBound
forall a. Arbitrary a => Gen a
arbitrary
        TxValidityUpperBound
ub <- SlotNo -> TxValidityUpperBound
TxValidityUpperBound (SlotNo -> TxValidityUpperBound)
-> Gen SlotNo -> Gen TxValidityUpperBound
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary Gen SlotNo -> (SlotNo -> Bool) -> Gen SlotNo
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` SlotNo -> Bool
slotOverContestationDeadline
        (TxValidityLowerBound, TxValidityUpperBound)
-> Gen (TxValidityLowerBound, TxValidityUpperBound)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxValidityLowerBound
lb, TxValidityUpperBound
ub)
    , -- XXX: This is a bit confusing and not giving much value. Maybe we can remove this.
      -- This also seems to be covered by MutateRequiredSigner
      Maybe Text -> ContestMutation -> 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) ContestMutation
ContestFromDifferentHead (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        PolicyId
otherHeadId <- TxIn -> PolicyId
headPolicyId (TxIn -> PolicyId) -> Gen TxIn -> Gen PolicyId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
healthyClosedHeadTxIn)
        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 -> Mutation
ChangeOutput Word
0 (PolicyId -> PolicyId -> TxOut CtxTx -> TxOut CtxTx
forall a. PolicyId -> PolicyId -> TxOut a -> TxOut a
replacePolicyIdWith PolicyId
testPolicyId PolicyId
otherHeadId TxOut CtxTx
headTxOut)
            , TxIn -> TxOut CtxUTxO Era -> Maybe HashableScriptData -> Mutation
ChangeInput
                TxIn
healthyClosedHeadTxIn
                (PolicyId -> PolicyId -> TxOut CtxUTxO Era -> TxOut CtxUTxO Era
forall a. PolicyId -> PolicyId -> TxOut a -> TxOut a
replacePolicyIdWith PolicyId
testPolicyId PolicyId
otherHeadId TxOut CtxUTxO Era
healthyClosedHeadTxOut)
                ( HashableScriptData -> Maybe HashableScriptData
forall a. a -> Maybe a
Just (HashableScriptData -> Maybe HashableScriptData)
-> HashableScriptData -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$
                    Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData
                      ( Head.Contest
                          { $sel:signature:CollectCom :: [BuiltinByteString]
signature =
                              MultiSignature (Snapshot Tx) -> [BuiltinByteString]
forall {k} (a :: k). MultiSignature a -> [BuiltinByteString]
toPlutusSignatures (MultiSignature (Snapshot Tx) -> [BuiltinByteString])
-> MultiSignature (Snapshot Tx) -> [BuiltinByteString]
forall a b. (a -> b) -> a -> b
$
                                SnapshotNumber -> MultiSignature (Snapshot Tx)
healthySignature SnapshotNumber
healthyContestSnapshotNumber
                          }
                      )
                )
            ]
    , Maybe Text -> ContestMutation -> 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
$ UtilError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode UtilError
MintingOrBurningIsForbidden) ContestMutation
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)
    , Maybe Text -> ContestMutation -> 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
SignerAlreadyContested) ContestMutation
MutateInputContesters (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
        let contester :: PubKeyHash
contester = Hash PaymentKey -> PubKeyHash
toPlutusKeyHash (VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
healthyContesterVerificationKey)
            contesterAndSomeOthers :: Gen [PubKeyHash]
contesterAndSomeOthers = do
              [PubKeyHash]
contesters <- Gen PubKeyHash -> Gen [PubKeyHash]
forall a. Gen a -> Gen [a]
listOf (Gen PubKeyHash -> Gen [PubKeyHash])
-> Gen PubKeyHash -> Gen [PubKeyHash]
forall a b. (a -> b) -> a -> b
$ BuiltinByteString -> PubKeyHash
Plutus.PubKeyHash (BuiltinByteString -> PubKeyHash)
-> (ByteString -> BuiltinByteString) -> ByteString -> PubKeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> PubKeyHash) -> Gen ByteString -> Gen PubKeyHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
genHash
              [PubKeyHash] -> Gen [PubKeyHash]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PubKeyHash
contester PubKeyHash -> [PubKeyHash] -> [PubKeyHash]
forall a. a -> [a] -> [a]
: [PubKeyHash]
contesters)
        [PubKeyHash]
mutatedContesters <-
          [Gen [PubKeyHash]] -> Gen [PubKeyHash]
forall a. [Gen a] -> Gen a
oneof
            [ [PubKeyHash] -> Gen [PubKeyHash]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PubKeyHash
contester]
            , Gen [PubKeyHash]
contesterAndSomeOthers
            ]
        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
$
          State
healthyClosedState State -> (State -> State) -> State
forall a b. a -> (a -> b) -> b
& [PubKeyHash] -> State -> State
replaceContesters [PubKeyHash]
mutatedContesters
    , Maybe Text -> ContestMutation -> 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
ContesterNotIncluded) ContestMutation
MutateContesters (Mutation -> SomeMutation)
-> (TxOut CtxTx -> Mutation) -> TxOut CtxTx -> SomeMutation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> TxOut CtxTx -> Mutation
ChangeOutput Word
0 (TxOut CtxTx -> SomeMutation)
-> Gen (TxOut CtxTx) -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        [ByteString]
hashes <- Gen ByteString -> Gen [ByteString]
forall a. Gen a -> Gen [a]
listOf Gen ByteString
genHash
        let mutatedContesters :: [PubKeyHash]
mutatedContesters = BuiltinByteString -> PubKeyHash
Plutus.PubKeyHash (BuiltinByteString -> PubKeyHash)
-> (ByteString -> BuiltinByteString) -> ByteString -> PubKeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> PubKeyHash) -> [ByteString] -> [PubKeyHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
hashes
        TxOut CtxTx -> Gen (TxOut CtxTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut CtxTx -> Gen (TxOut CtxTx))
-> TxOut CtxTx -> Gen (TxOut CtxTx)
forall a b. (a -> b) -> a -> b
$ (State -> State) -> TxOut CtxTx -> TxOut CtxTx
forall a.
(FromScriptData a, ToScriptData a) =>
(a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum ([PubKeyHash] -> State -> State
replaceContesters [PubKeyHash]
mutatedContesters) TxOut CtxTx
headTxOut
    , Maybe Text -> ContestMutation -> 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
HeadValueIsNotPreserved) ContestMutation
MutateValueInOutput (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Value
newValue <- Gen Value
genValue
        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 -> Mutation
ChangeOutput Word
0 (TxOut CtxTx
headTxOut{txOutValue = newValue})
    , Maybe Text -> ContestMutation -> 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
MustPushDeadline) ContestMutation
NotUpdateDeadlineAlthoughItShould (Mutation -> SomeMutation)
-> (TxOut CtxTx -> Mutation) -> TxOut CtxTx -> SomeMutation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> TxOut CtxTx -> Mutation
ChangeOutput Word
0 (TxOut CtxTx -> SomeMutation)
-> Gen (TxOut CtxTx) -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        let deadline :: POSIXTime
deadline = UTCTime -> POSIXTime
posixFromUTCTime UTCTime
healthyContestationDeadline
        -- Here we are replacing the contestationDeadline using the previous so we are not _pushing it_ further
        -- Remember the 'healthyContestTx' is already pushing out the deadline.
        TxOut CtxTx -> Gen (TxOut CtxTx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut CtxTx -> Gen (TxOut CtxTx))
-> TxOut CtxTx -> Gen (TxOut CtxTx)
forall a b. (a -> b) -> a -> b
$ TxOut CtxTx
headTxOut TxOut CtxTx -> (TxOut CtxTx -> TxOut CtxTx) -> TxOut CtxTx
forall a b. a -> (a -> b) -> b
& (State -> State) -> TxOut CtxTx -> TxOut CtxTx
forall a.
(FromScriptData a, ToScriptData a) =>
(a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum (POSIXTime -> State -> State
replaceContestationDeadline POSIXTime
deadline)
    , Maybe Text -> ContestMutation -> 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
MustNotPushDeadline) ContestMutation
PushDeadlineAlthoughItShouldNot (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        [PubKeyHash]
alreadyContested <- Int -> Gen PubKeyHash -> Gen [PubKeyHash]
forall a. Int -> Gen a -> Gen [a]
vectorOf ([Party] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Party]
healthyParties Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Gen PubKeyHash -> Gen [PubKeyHash])
-> Gen PubKeyHash -> Gen [PubKeyHash]
forall a b. (a -> b) -> a -> b
$ BuiltinByteString -> PubKeyHash
Plutus.PubKeyHash (BuiltinByteString -> PubKeyHash)
-> (ByteString -> BuiltinByteString) -> ByteString -> PubKeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> PubKeyHash) -> Gen ByteString -> Gen PubKeyHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
genHash
        let contester :: PubKeyHash
contester = Hash PaymentKey -> PubKeyHash
toPlutusKeyHash (Hash PaymentKey -> PubKeyHash) -> Hash PaymentKey -> PubKeyHash
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
healthyContesterVerificationKey
        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 -> Mutation
ChangeOutput Word
0 (TxOut CtxTx
headTxOut TxOut CtxTx -> (TxOut CtxTx -> TxOut CtxTx) -> TxOut CtxTx
forall a b. a -> (a -> b) -> b
& (State -> State) -> TxOut CtxTx -> TxOut CtxTx
forall a.
(FromScriptData a, ToScriptData a) =>
(a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum ([PubKeyHash] -> State -> State
replaceContesters (PubKeyHash
contester PubKeyHash -> [PubKeyHash] -> [PubKeyHash]
forall a. a -> [a] -> [a]
: [PubKeyHash]
alreadyContested)))
            , State -> Mutation
ChangeInputHeadDatum (State
healthyClosedState State -> (State -> State) -> State
forall a b. a -> (a -> b) -> b
& [PubKeyHash] -> State -> State
replaceContesters [PubKeyHash]
alreadyContested)
            ]
    , Maybe Text -> ContestMutation -> 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
ChangedParameters) ContestMutation
MutateOutputContestationPeriod (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        ContestationPeriod
randomCP <- Gen ContestationPeriod
forall a. Arbitrary a => Gen a
arbitrary Gen ContestationPeriod
-> (ContestationPeriod -> Bool) -> Gen ContestationPeriod
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (ContestationPeriod -> ContestationPeriod -> Bool
forall a. Eq a => a -> a -> Bool
/= ContestationPeriod
healthyOnChainContestationPeriod)
        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 -> Mutation
ChangeOutput Word
0 (TxOut CtxTx
headTxOut TxOut CtxTx -> (TxOut CtxTx -> TxOut CtxTx) -> TxOut CtxTx
forall a b. a -> (a -> b) -> b
& (State -> State) -> TxOut CtxTx -> TxOut CtxTx
forall a.
(FromScriptData a, ToScriptData a) =>
(a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum (ContestationPeriod -> State -> State
replaceContestationPeriod ContestationPeriod
randomCP))
    , Maybe Text -> ContestMutation -> 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
ChangedParameters) ContestMutation
MutatePartiesInOutput (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        [Party]
mutatedParties <-
          -- The length of mutatedParties must be the same as
          -- healthyOnChainParties so to not fail because of
          -- `must not push contestation deadline`.
          Int -> Gen Party -> Gen [Party]
forall a. Int -> Gen a -> Gen [a]
vectorOf
            ([Party] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Party]
healthyOnChainParties)
            ( ByteString -> Party
partyFromVerificationKeyBytes (ByteString -> Party) -> Gen ByteString -> Gen Party
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
genHash
            )
            Gen [Party] -> ([Party] -> Bool) -> Gen [Party]
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` ([Party] -> [Party] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Party]
healthyOnChainParties)
        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 -> Mutation
ChangeOutput Word
0 (TxOut CtxTx -> Mutation) -> TxOut CtxTx -> Mutation
forall a b. (a -> b) -> a -> b
$ (State -> State) -> TxOut CtxTx -> TxOut CtxTx
forall a.
(FromScriptData a, ToScriptData a) =>
(a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum ([Party] -> State -> State
replaceParties [Party]
mutatedParties) TxOut CtxTx
headTxOut
    , Maybe Text -> ContestMutation -> 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
ChangedParameters) ContestMutation
MutateHeadIdInOutput (Mutation -> SomeMutation) -> Gen Mutation -> Gen SomeMutation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        CurrencySymbol
otherHeadId <- PolicyId -> CurrencySymbol
toPlutusCurrencySymbol (PolicyId -> CurrencySymbol)
-> (TxIn -> PolicyId) -> TxIn -> CurrencySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> PolicyId
headPolicyId (TxIn -> CurrencySymbol) -> Gen TxIn -> Gen CurrencySymbol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
Fixture.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
$ Word -> TxOut CtxTx -> Mutation
ChangeOutput Word
0 (TxOut CtxTx -> Mutation) -> TxOut CtxTx -> Mutation
forall a b. (a -> b) -> a -> b
$ (State -> State) -> TxOut CtxTx -> TxOut CtxTx
forall a.
(FromScriptData a, ToScriptData a) =>
(a -> a) -> TxOut CtxTx -> TxOut CtxTx
modifyInlineDatum (CurrencySymbol -> State -> State
replaceHeadId CurrencySymbol
otherHeadId) TxOut CtxTx
headTxOut
    ]
 where
  headTxOut :: TxOut CtxTx
headTxOut = Maybe (TxOut CtxTx) -> TxOut CtxTx
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (TxOut CtxTx) -> TxOut CtxTx)
-> Maybe (TxOut CtxTx) -> TxOut CtxTx
forall a b. (a -> b) -> a -> b
$ Tx -> [TxOut CtxTx]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx [TxOut CtxTx] -> Int -> Maybe (TxOut CtxTx)
forall a. [a] -> Int -> Maybe a
!!? Int
0

  slotOverContestationDeadline :: SlotNo -> Bool
slotOverContestationDeadline SlotNo
slotNo =
    SystemStart -> SlotLength -> SlotNo -> UTCTime
slotNoToUTCTime SystemStart
systemStart SlotLength
slotLength SlotNo
slotNo UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
healthyContestationDeadline