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

module Hydra.Chain.Direct.StateSpec where

import Hydra.Prelude hiding (label)
import Test.Hydra.Prelude hiding (HydraTestnet (..))

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Binary (serialize)
import Data.ByteString.Lazy qualified as LBS
import Data.Map.Strict qualified as Map
import GHC.IsList qualified as IsList
import Hydra.Cardano.Api (
  ExecutionUnits (..),
  SlotNo,
  Tx,
  TxIn,
  TxIx (..),
  TxOut,
  UTxO,
  getTxBody,
  getTxId,
  hashScript,
  scriptPolicyId,
  toPlutusCurrencySymbol,
  txOutValue,
  txOuts',
  utxoFromTx,
  pattern PlutusScript,
  pattern TxIn,
 )
import Hydra.Cardano.Api.Gen (genTxIn)
import Hydra.Cardano.Api.Pretty (renderTx, renderTxWithUTxO)
import Hydra.Chain (PostTxError (..), maximumNumberOfParties)
import Hydra.Chain.Direct.Handlers (incrementTxBalancingMargin, rejectOversizedDeposit, serializedValueSize)
import Hydra.Chain.Direct.State (
  ChainContext (..),
  ChainState (..),
  ClosedState (..),
  HasKnownUTxO (getKnownUTxO),
  HydraContext (..),
  IncrementTxError (..),
  OpenState (..),
  PartialFanoutError (..),
  RecoverTxError (..),
  finalPartialFanout,
  getKnownUTxO,
  increment,
  initialChainState,
  initialize,
  partialFanout,
  recover,
 )
import Hydra.Contract.Dummy (dummyMintingScript)
import Hydra.Contract.HeadTokens qualified as HeadTokens
import Hydra.HeadLogic qualified as HL
import Hydra.Ledger.Cardano.Evaluate (renderEvaluationReport)
import Hydra.Ledger.Cardano.Time (slotNoFromUTCTime)
import Hydra.Tx (ConfirmedSnapshot (..), txInToHeadSeed)
import Hydra.Tx.ContestationPeriod (toNominalDiffTime)
import Hydra.Tx.Deposit (DepositObservation (..), observeDepositTx)
import Hydra.Tx.Observe (
  CloseObservation (..),
  ContestObservation (..),
  DecrementObservation (..),
  FanoutObservation (..),
  HeadObservation (..),
  IncrementObservation (..),
  NotAnInitReason (..),
  PartialFanoutObservation (..),
  observeDecrementTx,
  observeHeadTx,
  observeIncrementTx,
  observeInitTx,
  observePartialFanoutTx,
 )
import Hydra.Tx.Recover (RecoverObservation (..), observeRecoverTx)
import PlutusLedgerApi.V3 qualified as Plutus
import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs)
import Test.Hydra.Chain.Direct.State (
  ChainTransition,
  ctxHeadParameters,
  ctxParticipants,
  findFittingPartialChunk,
  genChainStateWithTx,
  genCloseTx,
  genClosedStateForFanout,
  genClosedStateWithAppliedDecommit,
  genClosedStateWithDuplicateTxOuts,
  genClosedStateWithPendingCommit,
  genClosedStateWithUnconfirmedCommit,
  genContestTx,
  genDecrementTx,
  genDepositTx,
  genDepositTxWith,
  genFanoutTx,
  genFinalPartialFanoutTx,
  genHydraContext,
  genIncrementTx,
  genIncrementTxWith,
  genPartialFanoutTx,
  genPartialFanoutTxWithComplexUTxO,
  genRecoverTx,
  maxGenParties,
  pickChainContext,
  unsafeIncrement,
  unsafePartialFanout,
 )
import Test.Hydra.Chain.Direct.State qualified as Transition
import Test.Hydra.Ledger.Cardano.Fixtures (evaluateTx, evaluateTx', maxCpu, maxMem, maxTxSize, pparamsWithMainnetValueLimit)
import Test.Hydra.Tx.Fixture (defaultPParams, slotLength, systemStart, testNetworkId)
import Test.Hydra.Tx.Gen (genConfirmedSnapshot, genOutputFor, genTxOutAdaOnly, genUTxOAdaOnlyOfSize, genUTxOWithUniquePolicyTokensOfSize, propTransactionEvaluates)
import Test.Hydra.Tx.Mutation (
  Mutation (..),
  applyMutation,
  modifyInlineDatum,
  replaceHeadId,
  replacePolicyIdWith,
 )
import Test.Hydra.Tx.Utils (splitUTxO)
import Test.QuickCheck (
  Property,
  Testable (property),
  checkCoverage,
  choose,
  classify,
  conjoin,
  counterexample,
  forAll,
  forAllBlind,
  forAllShow,
  forAllShrink,
  ioProperty,
  label,
  oneof,
  tabulate,
  (.&&.),
  (===),
  (==>),
 )
import Test.QuickCheck.Monadic (assert, assertWith, monadicIO, monitor)
import Test.Util (utxoNoThunks)
import Prelude qualified

spec :: Spec
spec :: Spec
spec = Spec -> Spec
forall a. SpecWith a -> SpecWith a
parallel (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
  Proxy PubKeyHash -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Plutus.PubKeyHash)

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"observeTx" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    -- TODO: DRY with TxSpec
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"All valid transitions for all possible states can be observed." Property
prop_observeAnyTx

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"splitUTxO" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> (UTxO -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"it splits at least one utxo off" UTxO -> Property
prop_splitUTxO

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"init" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Natural -> ((UTxO -> Tx -> Property) -> Property) -> Spec
propBelowSizeLimit Natural
maxTxSize (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllInit
    ((UTxO -> Tx -> Property) -> Property) -> Spec
propIsValid (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllInit

    -- XXX: This is testing observeInitTx (we will get rid of 'observeInit')
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"only proper head is observed" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$
      PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Property)
-> PropertyM IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
        HydraContext
ctx <- Gen HydraContext -> PropertyM IO HydraContext
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Int -> Gen HydraContext
genHydraContext Int
maximumNumberOfParties)
        ChainContext
cctx <- Gen ChainContext -> PropertyM IO ChainContext
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen ChainContext -> PropertyM IO ChainContext)
-> Gen ChainContext -> PropertyM IO ChainContext
forall a b. (a -> b) -> a -> b
$ HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
        TxIn
seedInput <- Gen TxIn -> PropertyM IO TxIn
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary
        VerificationKey PaymentKey
vk <- Gen (VerificationKey PaymentKey)
-> PropertyM IO (VerificationKey PaymentKey)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary
        TxOut CtxUTxO Era
seedTxOut <- Gen (TxOut CtxUTxO Era) -> PropertyM IO (TxOut CtxUTxO Era)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen (TxOut CtxUTxO Era) -> PropertyM IO (TxOut CtxUTxO Era))
-> Gen (TxOut CtxUTxO Era) -> PropertyM IO (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey -> Gen (TxOut CtxUTxO Era)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genTxOutAdaOnly VerificationKey PaymentKey
vk

        let tx :: Tx
tx = ChainContext
-> PParams LedgerEra -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
cctx PParams LedgerEra
defaultPParams TxIn
seedInput (HydraContext -> [OnChainId]
ctxParticipants HydraContext
ctx) (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx)
        (Mutation
mutation, String
cex, NotAnInitReason
expected) <- Gen (Mutation, String, NotAnInitReason)
-> PropertyM IO (Mutation, String, NotAnInitReason)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen (Mutation, String, NotAnInitReason)
 -> PropertyM IO (Mutation, String, NotAnInitReason))
-> Gen (Mutation, String, NotAnInitReason)
-> PropertyM IO (Mutation, String, NotAnInitReason)
forall a b. (a -> b) -> a -> b
$ TxIn -> Tx -> Gen (Mutation, String, NotAnInitReason)
genInitTxMutation TxIn
seedInput Tx
tx
        let utxo :: UTxO
utxo = TxIn -> TxOut CtxUTxO Era -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
seedInput TxOut CtxUTxO Era
seedTxOut
        let (Tx
tx', UTxO
utxo') = Mutation -> (Tx, UTxO) -> (Tx, UTxO)
applyMutation Mutation
mutation (Tx
tx, UTxO
utxo)

            originalIsObserved :: Property
originalIsObserved = Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Either NotAnInitReason InitObservation -> Bool
forall a b. Either a b -> Bool
isRight (Tx -> Either NotAnInitReason InitObservation
observeInitTx Tx
tx)

            -- We expected mutated transaction to still be valid, but not observed.
            mutatedIsValid :: Property
mutatedIsValid = Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
              case Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx' UTxO
utxo' of
                Left EvaluationError
_ -> Bool
False
                Right EvaluationReport
ok
                  | (Either ScriptExecutionError ExecutionUnits -> Bool)
-> EvaluationReport -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isRight EvaluationReport
ok -> Bool
True
                  | Bool
otherwise -> Bool
False

            mutatedIsNotObserved :: Property
mutatedIsNotObserved =
              Tx -> Either NotAnInitReason InitObservation
observeInitTx Tx
tx' Either NotAnInitReason InitObservation
-> Either NotAnInitReason InitObservation -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== NotAnInitReason -> Either NotAnInitReason InitObservation
forall a b. a -> Either a b
Left NotAnInitReason
expected

        Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> PropertyM IO Property)
-> Property -> PropertyM IO Property
forall a b. (a -> b) -> a -> b
$
          [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
            [ Property
originalIsObserved
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Tx -> String
renderTx Tx
tx)
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Original transaction is not observed."
            , Property
mutatedIsValid
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Tx -> String
renderTx Tx
tx')
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Mutated transaction is not valid."
            , Property
mutatedIsNotObserved
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Tx -> String
renderTx Tx
tx')
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Should not observe mutated transaction"
            ]
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
cex
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label (NotAnInitReason -> String
forall b a. (Show a, IsString b) => a -> b
show NotAnInitReason
expected)

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"deposit" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Natural -> ((UTxO -> Tx -> Property) -> Property) -> Spec
propBelowSizeLimit Natural
maxTxSize (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllDeposit
    ((UTxO -> Tx -> Property) -> Property) -> Spec
propIsValid (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllDeposit

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"observes deposit" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllDeposit ((UTxO -> Tx -> Property) -> Property)
-> (UTxO -> Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \UTxO
utxo Tx
tx ->
        case NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
testNetworkId Tx
tx of
          Just DepositObservation{} -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
          Maybe DepositObservation
Nothing ->
            Bool
False Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"observeDepositTx ignored transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
utxo Tx
tx)

    -- The observed deposit UTxO is a 'UTxO' ingress point (decoded from the plutus
    -- datum, not through the forcing JSON/CBOR instances) and flows into 'localUTxO'
    -- and snapshots, where 'forceNewEntries' trusts carried-over entries - so it must
    -- come out of observation fully evaluated. Guards the explicit 'forceUTxO' at the
    -- observation (without it the property holds only incidentally, through the
    -- round-trip guard's re-serialization).
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"observed deposit UTxO is fully evaluated" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllDeposit ((UTxO -> Tx -> Property) -> Property)
-> (UTxO -> Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \UTxO
utxo Tx
tx ->
        case NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
testNetworkId Tx
tx of
          Just DepositObservation{UTxO
deposited :: UTxO
$sel:deposited:DepositObservation :: DepositObservation -> UTxO
deposited} ->
            IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$
              UTxO -> IO (Maybe ThunkInfo)
utxoNoThunks UTxO
deposited IO (Maybe ThunkInfo)
-> (Maybe ThunkInfo -> IO Property) -> IO Property
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe ThunkInfo
Nothing -> Property -> IO Property
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
                Just ThunkInfo
ti -> Property -> IO Property
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ Bool
False Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Thunk in observed deposit UTxO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ThunkInfo -> String
forall b a. (Show a, IsString b) => a -> b
show ThunkInfo
ti)
          Maybe DepositObservation
Nothing ->
            Bool
False Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"observeDepositTx ignored transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
utxo Tx
tx)

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"recover" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Natural -> ((UTxO -> Tx -> Property) -> Property) -> Spec
propBelowSizeLimit Natural
maxTxSize (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllRecover
    ((UTxO -> Tx -> Property) -> Property) -> Spec
propIsValid (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllRecover

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"observes recover" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllRecover ((UTxO -> Tx -> Property) -> Property)
-> (UTxO -> Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \UTxO
utxo Tx
tx ->
        case NetworkId -> UTxO -> Tx -> Maybe RecoverObservation
observeRecoverTx NetworkId
testNetworkId UTxO
utxo Tx
tx of
          Just RecoverObservation{} -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
          Maybe RecoverObservation
Nothing ->
            Bool
False Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"observeRecoverTx ignored transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
utxo Tx
tx)

    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"recover requires the deposit to be its transaction's first output" Property
prop_recoverRequiresFirstDepositOutput

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"increment" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Natural -> ((UTxO -> Tx -> Property) -> Property) -> Spec
propBelowSizeLimit Natural
maxTxSize (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllIncrement
    ((UTxO -> Tx -> Property) -> Property) -> Spec
propIsValid (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllIncrement
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"increment observation observes correct utxo" Property
prop_incrementObservesCorrectUTxO
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"increment requires the deposit to be its transaction's first output" Property
prop_incrementRequiresFirstDepositOutput

    -- Ties 'rejectOversizedDeposit' (which sizes a dry-run increment with a
    -- fabricated snapshot and dummy signatures) to reality: whenever the check
    -- accepts a deposit, the real increment transaction — built with real
    -- per-party signatures and a real accumulator — must stay within layer 1
    -- limits. This is the regression test for drift between the dry-run
    -- fabrication (and its balancing margin) and actual increment transactions.
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"deposits accepted by rejectOversizedDeposit yield increment txs within layer 1 limits" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (HydraContext, OpenState, Tx, UTxO, Tx)
-> ((HydraContext, OpenState, Tx, UTxO, Tx) -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (HydraContext, OpenState, UTxO, Tx)
-> Gen (HydraContext, OpenState, Tx, UTxO, Tx)
genIncrementTxWith (Gen UTxO -> Int -> Gen (HydraContext, OpenState, UTxO, Tx)
genDepositTxWith Gen UTxO
genMixedDeposit Int
maximumNumberOfParties)) (((HydraContext, OpenState, Tx, UTxO, Tx) -> Property) -> Property)
-> ((HydraContext, OpenState, Tx, UTxO, Tx) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(HydraContext
ctx, st :: OpenState
st@OpenState{HeadId
headId :: HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId}, Tx
txDeposit, UTxO
_spendableUTxO, Tx
txIncrement) ->
          Gen ChainContext -> (ChainContext -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx) ((ChainContext -> Property) -> Property)
-> (ChainContext -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainContext
cctx ->
            case PParams LedgerEra
-> ChainContext
-> UTxO
-> HeadId
-> ConfirmedSnapshot Tx
-> Tx
-> SlotNo
-> Either (PostTxError Tx) ()
rejectOversizedDeposit PParams LedgerEra
pparamsWithMainnetValueLimit ChainContext
cctx (OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st) HeadId
headId InitialSnapshot{HeadId
headId :: HeadId
$sel:headId:InitialSnapshot :: HeadId
headId} Tx
txDeposit SlotNo
100 of
              Left DepositTooLarge{} -> String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"rejected" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
              Left PostTxError Tx
e -> String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"unexpected error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PostTxError Tx -> String
forall b a. (Show a, IsString b) => a -> b
show PostTxError Tx
e) (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)
              Right () ->
                String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"accepted" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                  let txSize :: Natural
txSize = Int64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Natural) -> Int64 -> Natural
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length (Tx -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize Tx
txIncrement)
                      -- 5000 bytes is the maxValSize of mainnet, matching
                      -- 'pparamsWithMainnetValueLimit'.
                      valueFits :: Value -> Bool
valueFits Value
v = PParams LedgerEra -> Value -> Natural
serializedValueSize PParams LedgerEra
pparamsWithMainnetValueLimit Value
v Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
5000
                   in (Bool -> Property
forall prop. Testable prop => prop -> Property
property (Natural
txSize Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
incrementTxBalancingMargin Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxTxSize) Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Tx size too large: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall b a. (Show a, IsString b) => a -> b
show Natural
txSize))
                        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (Bool -> Property
forall prop. Testable prop => prop -> Property
property ((TxOut CtxTx -> Bool) -> [TxOut CtxTx] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Value -> Bool
valueFits (Value -> Bool) -> (TxOut CtxTx -> Value) -> TxOut CtxTx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx -> Value
forall ctx. TxOut ctx -> Value
txOutValue) (Tx -> [TxOut CtxTx]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
txIncrement)) Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Output value size beyond mainnet maxValSize")

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"decrement" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Natural -> ((UTxO -> Tx -> Property) -> Property) -> Spec
propBelowSizeLimit Natural
maxTxSize (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllDecrement
    ((UTxO -> Tx -> Property) -> Property) -> Spec
propIsValid (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllDecrement

  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"observes distributed outputs" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
    (UTxO -> UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> UTxO -> Tx -> property) -> Property
forAllDecrement' ((UTxO -> UTxO -> Tx -> Property) -> Property)
-> (UTxO -> UTxO -> Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \UTxO
toDistribute UTxO
utxo Tx
tx ->
      case UTxO -> Tx -> Maybe DecrementObservation
observeDecrementTx UTxO
utxo Tx
tx of
        Just DecrementObservation{UTxO
distributedUTxO :: UTxO
$sel:distributedUTxO:DecrementObservation :: DecrementObservation -> UTxO
distributedUTxO} ->
          UTxO -> [TxOut CtxUTxO Era]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxO
distributedUTxO [TxOut CtxUTxO Era] -> [TxOut CtxUTxO Era] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== UTxO -> [TxOut CtxUTxO Era]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxO
toDistribute
        Maybe DecrementObservation
Nothing ->
          Bool
False Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"observeDecrementTx ignored transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
utxo Tx
tx)

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"close" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Natural -> ((UTxO -> Tx -> Property) -> Property) -> Spec
propBelowSizeLimit Natural
maxTxSize (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllClose
    ((UTxO -> Tx -> Property) -> Property) -> Spec
propIsValid (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllClose

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"contest" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Natural -> ((UTxO -> Tx -> Property) -> Property) -> Spec
propBelowSizeLimit Natural
maxTxSize (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllContest
    ((UTxO -> Tx -> Property) -> Property) -> Spec
propIsValid (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllContest

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"fanout" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Natural -> ((UTxO -> Tx -> Property) -> Property) -> Spec
propBelowSizeLimit Natural
maxTxSize (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllFanout
    ((UTxO -> Tx -> Property) -> Property) -> Spec
propIsValid (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllFanout

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"partialFanout" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Natural -> ((UTxO -> Tx -> Property) -> Property) -> Spec
propBelowSizeLimit Natural
maxTxSize (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllPartialFanout
    ((UTxO -> Tx -> Property) -> Property) -> Spec
propIsValid (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllPartialFanout
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"validates within 90% of maxTxExecutionUnits for complex UTxO" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, Tx)
-> ((ChainContext, ClosedState, UTxO, Tx) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, Tx)
genPartialFanoutTxWithComplexUTxO Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, Tx) -> Property) -> Property)
-> ((ChainContext, ClosedState, UTxO, Tx) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
ctx, ClosedState
_, UTxO
spendableUTxO, Tx
tx) ->
        let utxo :: UTxO
utxo = UTxO
spendableUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
ctx
            safeUnits :: ExecutionUnits
safeUnits =
              ExecutionUnits
                { executionMemory :: Natural
executionMemory = Natural
maxMem Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
9 Natural -> Natural -> Natural
forall a. Integral a => a -> a -> a
`div` Natural
10
                , executionSteps :: Natural
executionSteps = Natural
maxCpu Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
9 Natural -> Natural -> Natural
forall a. Integral a => a -> a -> a
`div` Natural
10
                }
         in case ExecutionUnits
-> Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx' ExecutionUnits
safeUnits Tx
tx UTxO
utxo of
              Right EvaluationReport
report ->
                (Either ScriptExecutionError ExecutionUnits -> Bool)
-> [Either ScriptExecutionError ExecutionUnits] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isRight (EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems EvaluationReport
report)
                  Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Redeemer report:\n  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString (EvaluationReport -> Text
renderEvaluationReport EvaluationReport
report))
              Left EvaluationError
err ->
                Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
                  Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Evaluation failed within 90% budget: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EvaluationError -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationError
err)
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"returns StaleChainState when UTxO does not match on-chain accumulator" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO)
genClosedStateForFanout Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
 -> Property)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(ChainContext
ctx, ClosedState{TxIn
seedTxIn :: TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlotNo, UTxO
_u0) ->
          ChainContext
-> UTxO
-> TxIn
-> Int
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
partialFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn Int
1 UTxO
forall a. Monoid a => a
mempty UTxO
forall a. Monoid a => a
mempty SlotNo
deadlineSlotNo
            Either PartialFanoutError Tx
-> Either PartialFanoutError Tx -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PartialFanoutError -> Either PartialFanoutError Tx
forall a b. a -> Either a b
Left PartialFanoutError
StaleChainState
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"decommit paid out before close: batch tx can be built" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Expectation)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
genClosedStateWithAppliedDecommit Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
  -> Expectation)
 -> Property)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Expectation)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(ChainContext
ctx, ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlotNo, UTxO
u0, UTxO
decommitUTxO) ->
          ChainContext
-> UTxO
-> TxIn
-> Int
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
partialFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn Int
1 (UTxO
u0 UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
decommitUTxO) UTxO
u0 SlotNo
deadlineSlotNo
            Either PartialFanoutError Tx
-> (Either PartialFanoutError Tx -> Bool) -> Expectation
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` Either PartialFanoutError Tx -> Bool
forall a b. Either a b -> Bool
isRight
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"decommit paid out before close: batch tx evaluates on-chain" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
genClosedStateWithAppliedDecommit Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
  -> Property)
 -> Property)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(ChainContext
ctx, ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlotNo, UTxO
u0, UTxO
decommitUTxO) ->
          let evalUTxO :: UTxO
evalUTxO = UTxO
spendableUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
ctx
           in case ChainContext
-> UTxO
-> TxIn
-> Int
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
partialFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn Int
1 (UTxO
u0 UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
decommitUTxO) UTxO
u0 SlotNo
deadlineSlotNo of
                Left PartialFanoutError
err -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"partialFanout build failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PartialFanoutError -> String
forall b a. (Show a, IsString b) => a -> b
show PartialFanoutError
err) Bool
False
                Right Tx
tx -> (Tx, UTxO) -> Property
propTransactionEvaluates (Tx
tx, UTxO
evalUTxO)
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"pending deposit not confirmed on-chain: batch tx can be built" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Expectation)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
genClosedStateWithUnconfirmedCommit Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
  -> Expectation)
 -> Property)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Expectation)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(ChainContext
ctx, ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlotNo, UTxO
u0, UTxO
commitUTxO) ->
          ChainContext
-> UTxO
-> TxIn
-> Int
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
partialFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn Int
1 (UTxO
u0 UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
commitUTxO) UTxO
u0 SlotNo
deadlineSlotNo
            Either PartialFanoutError Tx
-> (Either PartialFanoutError Tx -> Bool) -> Expectation
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` Either PartialFanoutError Tx -> Bool
forall a b. Either a b -> Bool
isRight

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"finalPartialFanout" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Natural -> ((UTxO -> Tx -> Property) -> Property) -> Spec
propBelowSizeLimit Natural
maxTxSize (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllFinalPartialFanout
    ((UTxO -> Tx -> Property) -> Property) -> Spec
propIsValid (UTxO -> Tx -> Property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllFinalPartialFanout
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"returns StaleChainState when UTxO does not match on-chain accumulator" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO)
genClosedStateForFanout Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
 -> Property)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(ChainContext
ctx, ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlotNo, UTxO
u0) ->
          let fanoutProgressUTxO :: UTxO
fanoutProgressUTxO = Tx -> UTxO
utxoFromTx (Tx -> UTxO) -> Tx -> UTxO
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
ChainContext -> UTxO -> TxIn -> Int -> UTxO -> SlotNo -> Tx
ChainContext -> UTxO -> TxIn -> Int -> UTxO -> SlotNo -> Tx
unsafePartialFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn Int
1 UTxO
u0 SlotNo
deadlineSlotNo
           in case ChainContext
-> UTxO
-> TxIn
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
finalPartialFanout ChainContext
ctx UTxO
fanoutProgressUTxO TxIn
seedTxIn UTxO
forall a. Monoid a => a
mempty UTxO
forall a. Monoid a => a
mempty SlotNo
deadlineSlotNo of
                Left PartialFanoutError
StaleChainState -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
                Either PartialFanoutError Tx
other -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"expected Left StaleChainState, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (PartialFanoutError -> String)
-> (Tx -> String) -> Either PartialFanoutError Tx -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PartialFanoutError -> String
forall b a. (Show a, IsString b) => a -> b
show (String -> Tx -> String
forall a b. a -> b -> a
const String
"Right <Tx>") Either PartialFanoutError Tx
other) Bool
False
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"deposit confirmed on-chain before close: final batch distributes it" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Expectation)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
genClosedStateWithPendingCommit Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
  -> Expectation)
 -> Property)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Expectation)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(ChainContext
ctx, ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlotNo, UTxO
u0, UTxO
commitUTxO) ->
          let fullUTxO :: UTxO
fullUTxO = UTxO
u0 UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
commitUTxO
              evalUTxO :: UTxO
evalUTxO = UTxO
spendableUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
ctx
              (Int
_, Tx
partialTx) = UTxO -> ChainContext -> UTxO -> TxIn -> UTxO -> SlotNo -> (Int, Tx)
findFittingPartialChunk UTxO
evalUTxO ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
fullUTxO SlotNo
deadlineSlotNo
              fanoutProgressUTxO :: UTxO
fanoutProgressUTxO = Tx -> UTxO
utxoFromTx Tx
partialTx
           in ChainContext
-> UTxO
-> TxIn
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
finalPartialFanout ChainContext
ctx UTxO
fanoutProgressUTxO TxIn
seedTxIn UTxO
commitUTxO UTxO
forall a. Monoid a => a
mempty SlotNo
deadlineSlotNo
                Either PartialFanoutError Tx
-> (Either PartialFanoutError Tx -> Bool) -> Expectation
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` Either PartialFanoutError Tx -> Bool
forall a b. Either a b -> Bool
isRight
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"decommit paid out before close: final batch succeeds after initial batch" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
genClosedStateWithAppliedDecommit Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
  -> Property)
 -> Property)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(ChainContext
ctx, ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlotNo, UTxO
u0, UTxO
decommitUTxO) ->
          case ChainContext
-> UTxO
-> TxIn
-> Int
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
partialFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn Int
1 (UTxO
u0 UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
decommitUTxO) UTxO
u0 SlotNo
deadlineSlotNo of
            Left PartialFanoutError
err -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"partialFanout failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PartialFanoutError -> String
forall b a. (Show a, IsString b) => a -> b
show PartialFanoutError
err) Bool
False
            Right Tx
partialTx ->
              let fanoutProgressUTxO :: UTxO
fanoutProgressUTxO = Tx -> UTxO
utxoFromTx Tx
partialTx
                  remaining :: UTxO
remaining = [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList (Int -> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Int -> [a] -> [a]
drop Int
1 (UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
u0))
               in case ChainContext
-> UTxO
-> TxIn
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
finalPartialFanout ChainContext
ctx UTxO
fanoutProgressUTxO TxIn
seedTxIn UTxO
remaining UTxO
decommitUTxO SlotNo
deadlineSlotNo of
                    Left PartialFanoutError
err -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"finalPartialFanout failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PartialFanoutError -> String
forall b a. (Show a, IsString b) => a -> b
show PartialFanoutError
err) Bool
False
                    Right Tx
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"pending deposit not confirmed on-chain: final batch succeeds after initial batch" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
genClosedStateWithUnconfirmedCommit Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
  -> Property)
 -> Property)
-> ((ChainContext, ClosedState, UTxO, SlotNo, UTxO, UTxO)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(ChainContext
ctx, ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlotNo, UTxO
u0, UTxO
commitUTxO) ->
          case ChainContext
-> UTxO
-> TxIn
-> Int
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
partialFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn Int
1 (UTxO
u0 UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
commitUTxO) UTxO
u0 SlotNo
deadlineSlotNo of
            Left PartialFanoutError
err -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"partialFanout failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PartialFanoutError -> String
forall b a. (Show a, IsString b) => a -> b
show PartialFanoutError
err) Bool
False
            Right Tx
partialTx ->
              let fanoutProgressUTxO :: UTxO
fanoutProgressUTxO = Tx -> UTxO
utxoFromTx Tx
partialTx
                  remaining :: UTxO
remaining = [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList (Int -> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Int -> [a] -> [a]
drop Int
1 (UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
u0))
               in case ChainContext
-> UTxO
-> TxIn
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
finalPartialFanout ChainContext
ctx UTxO
fanoutProgressUTxO TxIn
seedTxIn UTxO
remaining UTxO
commitUTxO SlotNo
deadlineSlotNo of
                    Left PartialFanoutError
err -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"finalPartialFanout failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PartialFanoutError -> String
forall b a. (Show a, IsString b) => a -> b
show PartialFanoutError
err) Bool
False
                    Right Tx
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"succeeds when snapshot UTxO has duplicate TxOut values" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen
  (HydraContext, ChainContext, ClosedState, UTxO, SlotNo, UTxO, Int,
   ConfirmedSnapshot Tx)
-> ((HydraContext, ChainContext, ClosedState, UTxO, SlotNo, UTxO,
     Int, ConfirmedSnapshot Tx)
    -> Expectation)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int
-> Gen
     (HydraContext, ChainContext, ClosedState, UTxO, SlotNo, UTxO, Int,
      ConfirmedSnapshot Tx)
genClosedStateWithDuplicateTxOuts Int
maximumNumberOfParties) (((HydraContext, ChainContext, ClosedState, UTxO, SlotNo, UTxO,
   Int, ConfirmedSnapshot Tx)
  -> Expectation)
 -> Property)
-> ((HydraContext, ChainContext, ClosedState, UTxO, SlotNo, UTxO,
     Int, ConfirmedSnapshot Tx)
    -> Expectation)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(HydraContext
_hctx, ChainContext
ctx, ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}, UTxO
spendableUTxO, SlotNo
deadlineSlotNo, UTxO
u0WithDups, Int
chunkSize, ConfirmedSnapshot Tx
_confirmed) ->
          let partialTx :: Tx
partialTx = HasCallStack =>
ChainContext -> UTxO -> TxIn -> Int -> UTxO -> SlotNo -> Tx
ChainContext -> UTxO -> TxIn -> Int -> UTxO -> SlotNo -> Tx
unsafePartialFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn Int
chunkSize UTxO
u0WithDups SlotNo
deadlineSlotNo
              fanoutProgressUTxO :: UTxO
fanoutProgressUTxO = Tx -> UTxO
utxoFromTx Tx
partialTx
              remaining :: UTxO
remaining = [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList (Int -> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Int -> [a] -> [a]
drop Int
chunkSize (UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
u0WithDups))
           in ChainContext
-> UTxO
-> TxIn
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
finalPartialFanout ChainContext
ctx UTxO
fanoutProgressUTxO TxIn
seedTxIn UTxO
remaining UTxO
forall a. Monoid a => a
mempty SlotNo
deadlineSlotNo
                Either PartialFanoutError Tx
-> (Either PartialFanoutError Tx -> Bool) -> Expectation
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` Either PartialFanoutError Tx -> Bool
forall a b. Either a b -> Bool
isRight
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"HeadLogic computes non-empty remaining UTxO when snapshot contains duplicate TxOut values" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen
  (HydraContext, ChainContext, ClosedState, UTxO, SlotNo, UTxO, Int,
   ConfirmedSnapshot Tx)
-> ((HydraContext, ChainContext, ClosedState, UTxO, SlotNo, UTxO,
     Int, ConfirmedSnapshot Tx)
    -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int
-> Gen
     (HydraContext, ChainContext, ClosedState, UTxO, SlotNo, UTxO, Int,
      ConfirmedSnapshot Tx)
genClosedStateWithDuplicateTxOuts Int
maximumNumberOfParties) (((HydraContext, ChainContext, ClosedState, UTxO, SlotNo, UTxO,
   Int, ConfirmedSnapshot Tx)
  -> Property)
 -> Property)
-> ((HydraContext, ChainContext, ClosedState, UTxO, SlotNo, UTxO,
     Int, ConfirmedSnapshot Tx)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
        \(HydraContext
hctx, ChainContext
cctx, ClosedState
stClosed, UTxO
spendableUTxO, SlotNo
deadlineSlotNo, UTxO
u0WithDups, Int
chunkSize, ConfirmedSnapshot Tx
confirmed) ->
          let partialTx :: Tx
partialTx = HasCallStack =>
ChainContext -> UTxO -> TxIn -> Int -> UTxO -> SlotNo -> Tx
ChainContext -> UTxO -> TxIn -> Int -> UTxO -> SlotNo -> Tx
unsafePartialFanout ChainContext
cctx UTxO
spendableUTxO ClosedState
stClosed.seedTxIn Int
chunkSize UTxO
u0WithDups SlotNo
deadlineSlotNo
              evalUTxO :: UTxO
evalUTxO = UTxO
spendableUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
cctx
           in case UTxO -> Tx -> Maybe PartialFanoutObservation
observePartialFanoutTx UTxO
evalUTxO Tx
partialTx of
                Maybe PartialFanoutObservation
Nothing -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"observePartialFanoutTx returned Nothing" Bool
False
                Just PartialFanoutObservation{UTxO
distributedOutputs :: UTxO
$sel:distributedOutputs:PartialFanoutObservation :: PartialFanoutObservation -> UTxO
distributedOutputs} ->
                  let hlClosedState :: ClosedState Tx
hlClosedState =
                        HL.ClosedState
                          { $sel:parameters:ClosedState :: HeadParameters
parameters = HydraContext -> HeadParameters
ctxHeadParameters HydraContext
hctx
                          , $sel:confirmedSnapshot:ClosedState :: ConfirmedSnapshot Tx
confirmedSnapshot = ConfirmedSnapshot Tx
confirmed
                          , $sel:contestationDeadline:ClosedState :: UTCTime
contestationDeadline = ClosedState
stClosed.contestationDeadline
                          , $sel:readyToFanoutSent:ClosedState :: Bool
readyToFanoutSent = Bool
False
                          , $sel:chainState:ClosedState :: ChainStateType Tx
chainState = ChainStateType Tx
initialChainState
                          , $sel:headId:ClosedState :: HeadId
headId = ClosedState
stClosed.headId
                          , $sel:headSeed:ClosedState :: HeadSeed
headSeed = TxIn -> HeadSeed
txInToHeadSeed ClosedState
stClosed.seedTxIn
                          , $sel:version:ClosedState :: SnapshotVersion
version = SnapshotVersion
0
                          }
                      outcome :: Outcome Tx
outcome = ClosedState Tx -> ChainStateType Tx -> UTxOType Tx -> Outcome Tx
forall tx.
IsTx tx =>
ClosedState tx -> ChainStateType tx -> UTxOType tx -> Outcome tx
HL.onClosedChainPartialFanoutTx ClosedState Tx
hlClosedState ChainStateType Tx
initialChainState UTxOType Tx
UTxO
distributedOutputs
                      expectedRemaining :: UTxO
expectedRemaining = [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList ([(TxIn, TxOut CtxUTxO Era)] -> UTxO)
-> (UTxO -> [(TxIn, TxOut CtxUTxO Era)]) -> UTxO -> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Int -> [a] -> [a]
drop Int
chunkSize ([(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)])
-> (UTxO -> [(TxIn, TxOut CtxUTxO Era)])
-> UTxO
-> [(TxIn, TxOut CtxUTxO Era)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList (UTxO -> UTxO) -> UTxO -> UTxO
forall a b. (a -> b) -> a -> b
$ UTxO
u0WithDups
                      -- A node observing a partial fanout it didn't initiate is a
                      -- passive observer: it records the remaining set (by content)
                      -- but does not post the next fanout.
                      remainingUTxOs :: [UTxO]
remainingUTxOs =
                        [ UTxOType Tx
UTxO
remainingOutputs
                        | HL.HeadPartialFannedOut{UTxOType Tx
remainingOutputs :: UTxOType Tx
$sel:remainingOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
remainingOutputs} <-
                            case Outcome Tx
outcome of
                              HL.Continue{[StateChanged Tx]
stateChanges :: [StateChanged Tx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges} -> [StateChanged Tx]
stateChanges
                              HL.Wait{[StateChanged Tx]
$sel:stateChanges:Continue :: forall tx. Outcome tx -> [StateChanged tx]
stateChanges :: [StateChanged Tx]
stateChanges} -> [StateChanged Tx]
stateChanges
                              Outcome Tx
_ -> []
                        ]
                   in String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
                        (String
"Expected HeadPartialFannedOut{remainingOutputs = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> String
forall b a. (Show a, IsString b) => a -> b
show UTxO
expectedRemaining String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"}")
                        ([UTxO]
remainingUTxOs [UTxO] -> [UTxO] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [UTxO
expectedRemaining])

genInitTxMutation :: TxIn -> Tx -> Gen (Mutation, String, NotAnInitReason)
genInitTxMutation :: TxIn -> Tx -> Gen (Mutation, String, NotAnInitReason)
genInitTxMutation TxIn
seedInput Tx
tx =
  Gen (Mutation, String, NotAnInitReason)
genChangeMintingPolicy
 where
  genChangeMintingPolicy :: Gen (Mutation, String, NotAnInitReason)
genChangeMintingPolicy =
    (Mutation, String, NotAnInitReason)
-> Gen (Mutation, String, NotAnInitReason)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( [Mutation] -> Mutation
Changes ([Mutation] -> Mutation) -> [Mutation] -> Mutation
forall a b. (a -> b) -> a -> b
$
          PlutusScript -> Mutation
ChangeMintingPolicy PlutusScript
alwaysSucceedsV3
            Mutation -> [Mutation] -> [Mutation]
forall a. a -> [a] -> [a]
: ((TxOut CtxTx, Word) -> Mutation)
-> [(TxOut CtxTx, Word)] -> [Mutation]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TxOut CtxTx, Word) -> Mutation
changeMintingPolicy ([TxOut CtxTx] -> [Word] -> [(TxOut CtxTx, Word)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxOut CtxTx]
changedOutputsValue [Word
0 ..])
      , String
"new minting policy: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ScriptHash -> String
forall b a. (Show a, IsString b) => a -> b
show (Script PlutusScriptV3 -> ScriptHash
forall lang. Script lang -> ScriptHash
hashScript (Script PlutusScriptV3 -> ScriptHash)
-> Script PlutusScriptV3 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ PlutusScript -> Script PlutusScriptV3
PlutusScript PlutusScript
alwaysSucceedsV3)
      , NotAnInitReason
NotAHeadPolicy
      )

  -- We do replace the minting policy of all tokens and datum of a head output to
  -- simulate a faked init transaction.
  alwaysSucceedsV3 :: PlutusScript
alwaysSucceedsV3 = PlutusScript
dummyMintingScript
  originalPolicyId :: PolicyId
originalPolicyId = TxIn -> PolicyId
HeadTokens.headPolicyId TxIn
seedInput
  fakePolicyId :: PolicyId
fakePolicyId = Script PlutusScriptV3 -> PolicyId
forall lang. Script lang -> PolicyId
scriptPolicyId (Script PlutusScriptV3 -> PolicyId)
-> Script PlutusScriptV3 -> PolicyId
forall a b. (a -> b) -> a -> b
$ PlutusScript -> Script PlutusScriptV3
PlutusScript PlutusScript
alwaysSucceedsV3
  changeMintingPolicy :: (TxOut CtxTx, Word) -> Mutation
changeMintingPolicy (TxOut CtxTx
out, Word
idx)
    | Word
idx Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0 = Word -> TxOut CtxTx -> Mutation
ChangeOutput Word
idx (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 -> State -> State)
-> CurrencySymbol -> State -> State
forall a b. (a -> b) -> a -> b
$ PolicyId -> CurrencySymbol
toPlutusCurrencySymbol PolicyId
fakePolicyId) TxOut CtxTx
out
    | Bool
otherwise = Word -> TxOut CtxTx -> Mutation
ChangeOutput Word
idx TxOut CtxTx
out
  changedOutputsValue :: [TxOut CtxTx]
changedOutputsValue = PolicyId -> PolicyId -> TxOut CtxTx -> TxOut CtxTx
forall a. PolicyId -> PolicyId -> TxOut a -> TxOut a
replacePolicyIdWith PolicyId
originalPolicyId PolicyId
fakePolicyId (TxOut CtxTx -> TxOut CtxTx) -> [TxOut CtxTx] -> [TxOut CtxTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx -> [TxOut CtxTx]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx

-- * Properties

-- | Given any Head protocol state and the transaction corresponding a protocol
-- transition we should be able to observe this transition correctly even in
-- presence of other valid Hydra Head protocol states in the used lookup utxo.
prop_observeAnyTx :: Property
prop_observeAnyTx :: Property
prop_observeAnyTx =
  Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ do
    Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> String)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genChainStateWithTx ((String
"Transition: " <>) (String -> String)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> String)
-> (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainContext, ChainState, UTxO, Tx, ChainTransition) -> String
forall a b c d. (a, b, c, d, ChainTransition) -> String
showTransition) (((ChainContext, ChainState, UTxO, Tx, ChainTransition)
  -> Property)
 -> Property)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
ctx, ChainState
st, UTxO
additionalUTxO, Tx
tx, ChainTransition
transition) ->
      Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> String)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genChainStateWithTx ((String
"Some other transition: " <>) (String -> String)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> String)
-> (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainContext, ChainState, UTxO, Tx, ChainTransition) -> String
forall a b c d. (a, b, c, d, ChainTransition) -> String
showTransition) (((ChainContext, ChainState, UTxO, Tx, ChainTransition)
  -> Property)
 -> Property)
-> ((ChainContext, ChainState, UTxO, Tx, ChainTransition)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
_, ChainState
otherSt, UTxO
additionalUTxO', Tx
_, ChainTransition
_) -> do
        [ChainTransition] -> Property -> Property
forall a prop.
(Show a, Enum a, Bounded a, Typeable a, Testable prop) =>
[a] -> prop -> Property
genericCoverTable [ChainTransition
transition] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ do
          let expectedHeadId :: Maybe HeadId
expectedHeadId = ChainState -> Maybe HeadId
chainStateHeadId ChainState
st
              utxo :: UTxO
utxo = ChainState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainState
st UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainState
otherSt UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
additionalUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
additionalUTxO'
          case NetworkId -> UTxO -> Tx -> HeadObservation
observeHeadTx (ChainContext -> NetworkId
networkId ChainContext
ctx) UTxO
utxo Tx
tx of
            HeadObservation
NoHeadTx ->
              Bool
False Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"observeHeadTx ignored transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
utxo Tx
tx)
            -- NOTE: we don't have the generated headId easily accessible in the initial state
            Init{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Init
            Deposit DepositObservation{HeadId
headId :: HeadId
$sel:headId:DepositObservation :: DepositObservation -> HeadId
headId} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Deposit Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId Maybe HeadId -> Maybe HeadId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe HeadId
expectedHeadId
            Recover RecoverObservation{HeadId
headId :: HeadId
$sel:headId:RecoverObservation :: RecoverObservation -> HeadId
headId} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Recover Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId Maybe HeadId -> Maybe HeadId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe HeadId
expectedHeadId
            Increment IncrementObservation{HeadId
headId :: HeadId
$sel:headId:IncrementObservation :: IncrementObservation -> HeadId
headId} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Increment Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId Maybe HeadId -> Maybe HeadId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe HeadId
expectedHeadId
            Decrement DecrementObservation{HeadId
headId :: HeadId
$sel:headId:DecrementObservation :: DecrementObservation -> HeadId
headId} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Decrement Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId Maybe HeadId -> Maybe HeadId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe HeadId
expectedHeadId
            Close CloseObservation{HeadId
headId :: HeadId
$sel:headId:CloseObservation :: CloseObservation -> HeadId
headId} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Close Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId Maybe HeadId -> Maybe HeadId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe HeadId
expectedHeadId
            Contest ContestObservation{HeadId
headId :: HeadId
$sel:headId:ContestObservation :: ContestObservation -> HeadId
headId} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Contest Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId Maybe HeadId -> Maybe HeadId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe HeadId
expectedHeadId
            Fanout FanoutObservation{HeadId
headId :: HeadId
$sel:headId:FanoutObservation :: FanoutObservation -> HeadId
headId} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Fanout Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId Maybe HeadId -> Maybe HeadId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe HeadId
expectedHeadId
            FinalPartialFanout FanoutObservation{HeadId
$sel:headId:FanoutObservation :: FanoutObservation -> HeadId
headId :: HeadId
headId} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.FinalPartialFanout Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId Maybe HeadId -> Maybe HeadId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe HeadId
expectedHeadId
            PartialFanout PartialFanoutObservation{HeadId
headId :: HeadId
$sel:headId:PartialFanoutObservation :: PartialFanoutObservation -> HeadId
headId} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.PartialFanout Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId Maybe HeadId -> Maybe HeadId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe HeadId
expectedHeadId
 where
  showTransition :: (a, b, c, d, ChainTransition) -> String
  showTransition :: forall a b c d. (a, b, c, d, ChainTransition) -> String
showTransition (a
_, b
_, c
_, d
_, ChainTransition
t) = ChainTransition -> String
forall b a. (Show a, IsString b) => a -> b
show ChainTransition
t

  chainStateHeadId :: ChainState -> Maybe HeadId
chainStateHeadId = \case
    Idle{} -> Maybe HeadId
forall a. Maybe a
Nothing
    Open OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
    Closed ClosedState{HeadId
headId :: HeadId
$sel:headId:ClosedState :: ClosedState -> HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId

-- | Given a UTxO with more than one entry, we can split it into two non-empty UTxO.
prop_splitUTxO :: UTxO -> Property
prop_splitUTxO :: UTxO -> Property
prop_splitUTxO UTxO
utxo =
  (UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
utxo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
    let (UTxO
inHead, UTxO
toDecommit) = UTxO -> (UTxO, UTxO)
splitUTxO UTxO
utxo
     in [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
          [ Bool -> Bool
not (UTxO -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxO
inHead) Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"inHead is empty"
          , Bool -> Bool
not (UTxO -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxO
toDecommit) Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"toDecommit is empty"
          , UTxO
inHead UTxO -> UTxO -> Bool
forall a. Eq a => a -> a -> Bool
/= UTxO
toDecommit Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"inHead == toDecommit"
          ]

prop_incrementObservesCorrectUTxO :: Property
prop_incrementObservesCorrectUTxO :: Property
prop_incrementObservesCorrectUTxO = PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  (HydraContext
ctx, st :: OpenState
st@OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId, TxIn
seedTxIn :: TxIn
$sel:seedTxIn:OpenState :: OpenState -> TxIn
seedTxIn}, UTxO
_, Tx
txDeposit) <- Gen (HydraContext, OpenState, UTxO, Tx)
-> PropertyM IO (HydraContext, OpenState, UTxO, Tx)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen (HydraContext, OpenState, UTxO, Tx)
 -> PropertyM IO (HydraContext, OpenState, UTxO, Tx))
-> Gen (HydraContext, OpenState, UTxO, Tx)
-> PropertyM IO (HydraContext, OpenState, UTxO, Tx)
forall a b. (a -> b) -> a -> b
$ Int -> Gen (HydraContext, OpenState, UTxO, Tx)
genDepositTx Int
maxGenParties
  (HydraContext
_, OpenState
_, UTxO
_, Tx
txDeposit2) <- Gen (HydraContext, OpenState, UTxO, Tx)
-> PropertyM IO (HydraContext, OpenState, UTxO, Tx)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen (HydraContext, OpenState, UTxO, Tx)
 -> PropertyM IO (HydraContext, OpenState, UTxO, Tx))
-> Gen (HydraContext, OpenState, UTxO, Tx)
-> PropertyM IO (HydraContext, OpenState, UTxO, Tx)
forall a b. (a -> b) -> a -> b
$ Int -> Gen (HydraContext, OpenState, UTxO, Tx)
genDepositTx Int
maxGenParties
  let networkId :: NetworkId
networkId = HydraContext -> NetworkId
ctxNetworkId HydraContext
ctx
  case NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
networkId Tx
txDeposit of
    Maybe DepositObservation
Nothing -> Bool -> String -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> String -> PropertyM m ()
assertWith Bool
False String
"Deposit not observed"
    Just DepositObservation{$sel:depositTxId:DepositObservation :: DepositObservation -> TxId
depositTxId = TxId
depositedTxId, UTCTime
deadline :: UTCTime
$sel:deadline:DepositObservation :: DepositObservation -> UTCTime
deadline} -> do
      ChainContext
cctx <- Gen ChainContext -> PropertyM IO ChainContext
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen ChainContext -> PropertyM IO ChainContext)
-> Gen ChainContext -> PropertyM IO ChainContext
forall a b. (a -> b) -> a -> b
$ HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
      let slotNo :: SlotNo
slotNo = SystemStart -> SlotLength -> UTCTime -> SlotNo
slotNoFromUTCTime SystemStart
systemStart SlotLength
slotLength UTCTime
deadline
      let version :: SnapshotVersion
version = SnapshotVersion
0
      let openUTxO :: UTxO
openUTxO = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st
      -- NOTE: Use second deposit utxo deliberately here to test that the
      -- increment observation picks the correct one.
      -- We rely here on a fact that eventually this property will generate
      -- UTxO which would be wrongly picked up by the increment observation.
      let utxo :: UTxO
utxo = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> Tx -> UTxO
utxoFromTx Tx
txDeposit UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> Tx -> UTxO
utxoFromTx Tx
txDeposit2
      ConfirmedSnapshot Tx
snapshot <- Gen (ConfirmedSnapshot Tx) -> PropertyM IO (ConfirmedSnapshot Tx)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen (ConfirmedSnapshot Tx) -> PropertyM IO (ConfirmedSnapshot Tx))
-> Gen (ConfirmedSnapshot Tx)
-> PropertyM IO (ConfirmedSnapshot Tx)
forall a b. (a -> b) -> a -> b
$ HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType Tx
-> Maybe (UTxOType Tx)
-> Maybe (TxIdType Tx)
-> Maybe (UTxOType Tx)
-> [Secret (SigningKey HydraKey)]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType tx
-> Maybe (UTxOType tx)
-> Maybe (TxIdType tx)
-> Maybe (UTxOType tx)
-> [Secret (SigningKey HydraKey)]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId SnapshotVersion
version SnapshotNumber
1 UTxOType Tx
UTxO
openUTxO (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
utxo) (TxId -> Maybe TxId
forall a. a -> Maybe a
Just TxId
depositedTxId) Maybe (UTxOType Tx)
Maybe UTxO
forall a. Maybe a
Nothing (HydraContext -> [Secret (SigningKey HydraKey)]
ctxHydraSigningKeys HydraContext
ctx)
      let txIncrement :: Tx
txIncrement =
            HasCallStack =>
ChainContext
-> UTxO
-> (HeadSeed, HeadId)
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> Tx
ChainContext
-> UTxO
-> (HeadSeed, HeadId)
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> Tx
unsafeIncrement
              ChainContext
cctx
              UTxO
utxo
              (TxIn -> HeadSeed
txInToHeadSeed TxIn
seedTxIn, HeadId
headId)
              (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx)
              ConfirmedSnapshot Tx
snapshot
              SlotNo
slotNo
      case NetworkId -> UTxO -> Tx -> Maybe IncrementObservation
observeIncrementTx NetworkId
networkId UTxO
utxo Tx
txIncrement of
        Maybe IncrementObservation
Nothing -> Bool -> String -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> String -> PropertyM m ()
assertWith Bool
False String
"Increment not observed"
        Just IncrementObservation{TxId
depositTxId :: TxId
$sel:depositTxId:IncrementObservation :: IncrementObservation -> TxId
depositTxId} -> do
          let txDepositId :: TxId
txDepositId = TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
txDeposit)
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String -> Property -> Property) -> String -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String
"Expected TxId:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxId -> String
forall b a. (Show a, IsString b) => a -> b
show TxId
depositTxId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Actual TxId:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxId -> String
forall b a. (Show a, IsString b) => a -> b
show TxId
txDepositId)
          Bool -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> PropertyM m ()
assert (TxId
depositTxId TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxId
txDepositId)

-- | 'Hydra.Contract.Head.checkIncrement' requires the claimed deposit to be its
-- transaction's first output, so 'increment' resolves exactly that output rather
-- than any output of the deposit transaction. Matching by transaction id alone
-- would build a transaction that cannot validate.
prop_incrementRequiresFirstDepositOutput :: Property
prop_incrementRequiresFirstDepositOutput :: Property
prop_incrementRequiresFirstDepositOutput = PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  (HydraContext
ctx, st :: OpenState
st@OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId, TxIn
$sel:seedTxIn:OpenState :: OpenState -> TxIn
seedTxIn :: TxIn
seedTxIn}, UTxO
_, Tx
txDeposit) <- Gen (HydraContext, OpenState, UTxO, Tx)
-> PropertyM IO (HydraContext, OpenState, UTxO, Tx)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen (HydraContext, OpenState, UTxO, Tx)
 -> PropertyM IO (HydraContext, OpenState, UTxO, Tx))
-> Gen (HydraContext, OpenState, UTxO, Tx)
-> PropertyM IO (HydraContext, OpenState, UTxO, Tx)
forall a b. (a -> b) -> a -> b
$ Int -> Gen (HydraContext, OpenState, UTxO, Tx)
genDepositTx Int
maxGenParties
  let networkId :: NetworkId
networkId = HydraContext -> NetworkId
ctxNetworkId HydraContext
ctx
  case NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
networkId Tx
txDeposit of
    Maybe DepositObservation
Nothing -> Bool -> String -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> String -> PropertyM m ()
assertWith Bool
False String
"Deposit not observed"
    Just DepositObservation{TxId
$sel:depositTxId:DepositObservation :: DepositObservation -> TxId
depositTxId :: TxId
depositTxId, UTxO
$sel:deposited:DepositObservation :: DepositObservation -> UTxO
deposited :: UTxO
deposited, UTCTime
$sel:deadline:DepositObservation :: DepositObservation -> UTCTime
deadline :: UTCTime
deadline} -> do
      ChainContext
cctx <- Gen ChainContext -> PropertyM IO ChainContext
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen ChainContext -> PropertyM IO ChainContext)
-> Gen ChainContext -> PropertyM IO ChainContext
forall a b. (a -> b) -> a -> b
$ HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
      let openUTxO :: UTxO
openUTxO = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st
          slotNo :: SlotNo
slotNo = SystemStart -> SlotLength -> UTCTime -> SlotNo
slotNoFromUTCTime SystemStart
systemStart SlotLength
slotLength UTCTime
deadline
      case (TxIn -> TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxIn -> TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.findWithKey (\TxIn
txin TxOut CtxUTxO Era
_ -> TxIn
txin TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxId -> TxIx -> TxIn
TxIn TxId
depositTxId (Word -> TxIx
TxIx Word
0)) (Tx -> UTxO
utxoFromTx Tx
txDeposit) of
        Maybe (TxIn, TxOut CtxUTxO Era)
Nothing -> Bool -> String -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> String -> PropertyM m ()
assertWith Bool
False String
"Deposit is not the first output of its transaction"
        Just (TxIn
_, TxOut CtxUTxO Era
depositOut) -> do
          -- Same deposit output, same transaction id, moved off index 0.
          let utxo :: UTxO
utxo = UTxO
openUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> TxIn -> TxOut CtxUTxO Era -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton (TxId -> TxIx -> TxIn
TxIn TxId
depositTxId (Word -> TxIx
TxIx Word
1)) TxOut CtxUTxO Era
depositOut
          ConfirmedSnapshot Tx
snapshot <-
            Gen (ConfirmedSnapshot Tx) -> PropertyM IO (ConfirmedSnapshot Tx)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen (ConfirmedSnapshot Tx) -> PropertyM IO (ConfirmedSnapshot Tx))
-> Gen (ConfirmedSnapshot Tx)
-> PropertyM IO (ConfirmedSnapshot Tx)
forall a b. (a -> b) -> a -> b
$
              HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType Tx
-> Maybe (UTxOType Tx)
-> Maybe (TxIdType Tx)
-> Maybe (UTxOType Tx)
-> [Secret (SigningKey HydraKey)]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType tx
-> Maybe (UTxOType tx)
-> Maybe (TxIdType tx)
-> Maybe (UTxOType tx)
-> [Secret (SigningKey HydraKey)]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId SnapshotVersion
0 SnapshotNumber
1 UTxOType Tx
UTxO
openUTxO (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
deposited) (TxId -> Maybe TxId
forall a. a -> Maybe a
Just TxId
depositTxId) Maybe (UTxOType Tx)
Maybe UTxO
forall a. Maybe a
Nothing (HydraContext -> [Secret (SigningKey HydraKey)]
ctxHydraSigningKeys HydraContext
ctx)
          case ChainContext
-> UTxO
-> (HeadSeed, HeadId)
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> Either IncrementTxError Tx
increment ChainContext
cctx UTxO
utxo (TxIn -> HeadSeed
txInToHeadSeed TxIn
seedTxIn, HeadId
headId) (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) ConfirmedSnapshot Tx
snapshot SlotNo
slotNo of
            Left CannotFindDepositOutputInIncrement{} -> () -> PropertyM IO ()
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Left IncrementTxError
err -> Bool -> String -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> String -> PropertyM m ()
assertWith Bool
False (String -> PropertyM IO ()) -> String -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected CannotFindDepositOutputInIncrement, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> IncrementTxError -> String
forall b a. (Show a, IsString b) => a -> b
show IncrementTxError
err
            Right Tx
_ -> Bool -> String -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> String -> PropertyM m ()
assertWith Bool
False String
"Expected increment to fail, but it built a transaction"

-- | 'Hydra.Tx.Recover.recoverTx' spends @TxIn depositTxId (TxIx 0)@, so 'recover'
-- resolves exactly that output. Matching by transaction id alone would read one
-- output's datum and then build a transaction spending a different one.
prop_recoverRequiresFirstDepositOutput :: Property
prop_recoverRequiresFirstDepositOutput :: Property
prop_recoverRequiresFirstDepositOutput = PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  (HydraContext
ctx, OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId}, UTxO
_, Tx
txDeposit) <- Gen (HydraContext, OpenState, UTxO, Tx)
-> PropertyM IO (HydraContext, OpenState, UTxO, Tx)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen (HydraContext, OpenState, UTxO, Tx)
 -> PropertyM IO (HydraContext, OpenState, UTxO, Tx))
-> Gen (HydraContext, OpenState, UTxO, Tx)
-> PropertyM IO (HydraContext, OpenState, UTxO, Tx)
forall a b. (a -> b) -> a -> b
$ Int -> Gen (HydraContext, OpenState, UTxO, Tx)
genDepositTx Int
maxGenParties
  let networkId :: NetworkId
networkId = HydraContext -> NetworkId
ctxNetworkId HydraContext
ctx
  case NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
networkId Tx
txDeposit of
    Maybe DepositObservation
Nothing -> Bool -> String -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> String -> PropertyM m ()
assertWith Bool
False String
"Deposit not observed"
    Just DepositObservation{TxId
$sel:depositTxId:DepositObservation :: DepositObservation -> TxId
depositTxId :: TxId
depositTxId, UTCTime
$sel:deadline:DepositObservation :: DepositObservation -> UTCTime
deadline :: UTCTime
deadline} -> do
      ChainContext
cctx <- Gen ChainContext -> PropertyM IO ChainContext
forall (m :: * -> *) a. Monad m => Gen a -> PropertyM m a
pickBlind (Gen ChainContext -> PropertyM IO ChainContext)
-> Gen ChainContext -> PropertyM IO ChainContext
forall a b. (a -> b) -> a -> b
$ HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
      let slotNo :: SlotNo
slotNo = SystemStart -> SlotLength -> UTCTime -> SlotNo
slotNoFromUTCTime SystemStart
systemStart SlotLength
slotLength UTCTime
deadline
      case (TxIn -> TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxIn -> TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.findWithKey (\TxIn
txin TxOut CtxUTxO Era
_ -> TxIn
txin TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxId -> TxIx -> TxIn
TxIn TxId
depositTxId (Word -> TxIx
TxIx Word
0)) (Tx -> UTxO
utxoFromTx Tx
txDeposit) of
        Maybe (TxIn, TxOut CtxUTxO Era)
Nothing -> Bool -> String -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> String -> PropertyM m ()
assertWith Bool
False String
"Deposit is not the first output of its transaction"
        Just (TxIn
_, TxOut CtxUTxO Era
depositOut) -> do
          -- Same deposit output, same transaction id, moved off index 0.
          let utxo :: UTxO
utxo = TxIn -> TxOut CtxUTxO Era -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton (TxId -> TxIx -> TxIn
TxIn TxId
depositTxId (Word -> TxIx
TxIx Word
1)) TxOut CtxUTxO Era
depositOut
          case ChainContext
-> HeadId -> TxId -> UTxO -> SlotNo -> Either RecoverTxError Tx
recover ChainContext
cctx HeadId
headId TxId
depositTxId UTxO
utxo SlotNo
slotNo of
            Left CannotFindDepositOutputToRecover{} -> () -> PropertyM IO ()
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Left RecoverTxError
err -> Bool -> String -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> String -> PropertyM m ()
assertWith Bool
False (String -> PropertyM IO ()) -> String -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ String
"Expected CannotFindDepositOutputToRecover, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> RecoverTxError -> String
forall b a. (Show a, IsString b) => a -> b
show RecoverTxError
err
            Right Tx
_ -> Bool -> String -> PropertyM IO ()
forall (m :: * -> *). Monad m => Bool -> String -> PropertyM m ()
assertWith Bool
False String
"Expected recover to fail, but it built a transaction"

--
-- Generic Properties
--

propBelowSizeLimit ::
  Natural ->
  ((UTxO -> Tx -> Property) -> Property) ->
  SpecWith ()
propBelowSizeLimit :: Natural -> ((UTxO -> Tx -> Property) -> Property) -> Spec
propBelowSizeLimit Natural
txSizeLimit (UTxO -> Tx -> Property) -> Property
forAllTx =
  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (String
"transaction size is below " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall i. (Show i, Integral i) => i -> String
showKB Natural
txSizeLimit) (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
    (UTxO -> Tx -> Property) -> Property
forAllTx ((UTxO -> Tx -> Property) -> Property)
-> (UTxO -> Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \UTxO
_ Tx
tx ->
      let cbor :: ByteString
cbor = Tx -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize Tx
tx
          len :: Int64
len = ByteString -> Int64
LBS.length ByteString
cbor
       in Int64
len Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Natural -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
txSizeLimit
            Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
label (Int64 -> String
forall i. (Show i, Integral i) => i -> String
showKB Int64
len)
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Tx -> String
renderTx Tx
tx)
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Actual size: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall b a. (Show a, IsString b) => a -> b
show Int64
len)
 where
  showKB :: (Show i, Integral i) => i -> String
  showKB :: forall i. (Show i, Integral i) => i -> String
showKB i
nb = i -> String
forall b a. (Show a, IsString b) => a -> b
show (i
nb i -> i -> i
forall a. Integral a => a -> a -> a
`div` i
1024) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"kB"

propIsValid ::
  ((UTxO -> Tx -> Property) -> Property) ->
  SpecWith ()
propIsValid :: ((UTxO -> Tx -> Property) -> Property) -> Spec
propIsValid (UTxO -> Tx -> Property) -> Property
forAllTx =
  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"validates within maxTxExecutionUnits" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
    (UTxO -> Tx -> Property) -> Property
forAllTx ((UTxO -> Tx -> Property) -> Property)
-> (UTxO -> Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
      \UTxO
utxo Tx
tx -> (Tx, UTxO) -> Property
propTransactionEvaluates (Tx
tx, UTxO
utxo)

-- * Generators

-- TODO: These forAllXX functions are hard to use and understand. Maybe simple
-- 'Gen' or functions in 'PropertyM' are better combinable?

forAllInit ::
  Testable property =>
  (UTxO -> Tx -> property) ->
  Property
forAllInit :: forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllInit UTxO -> Tx -> property
action =
  Gen HydraContext -> (HydraContext -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen HydraContext
genHydraContext Int
maximumNumberOfParties) ((HydraContext -> Property) -> Property)
-> (HydraContext -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \HydraContext
ctx ->
    Gen ChainContext -> (ChainContext -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx) ((ChainContext -> Property) -> Property)
-> (ChainContext -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainContext
cctx -> do
      Gen (TxIn, TxOut CtxUTxO Era)
-> ((TxIn, TxOut CtxUTxO Era) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll ((,) (TxIn -> TxOut CtxUTxO Era -> (TxIn, TxOut CtxUTxO Era))
-> Gen TxIn -> Gen (TxOut CtxUTxO Era -> (TxIn, TxOut CtxUTxO Era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
genTxIn Gen (TxOut CtxUTxO Era -> (TxIn, TxOut CtxUTxO Era))
-> Gen (TxOut CtxUTxO Era) -> Gen (TxIn, TxOut CtxUTxO Era)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VerificationKey PaymentKey -> Gen (TxOut CtxUTxO Era)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutputFor (ChainContext -> VerificationKey PaymentKey
ownVerificationKey ChainContext
cctx)) (((TxIn, TxOut CtxUTxO Era) -> Property) -> Property)
-> ((TxIn, TxOut CtxUTxO Era) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(TxIn
seedIn, TxOut CtxUTxO Era
seedOut) -> do
        let tx :: Tx
tx = ChainContext
-> PParams LedgerEra -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
cctx PParams LedgerEra
defaultPParams TxIn
seedIn (HydraContext -> [OnChainId]
ctxParticipants HydraContext
ctx) (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx)
            utxo :: UTxO
utxo = TxIn -> TxOut CtxUTxO Era -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
seedIn TxOut CtxUTxO Era
seedOut UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
cctx
         in UTxO -> Tx -> property
action UTxO
utxo Tx
tx
              property -> (property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Bool -> String -> property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify
                ([VerificationKey PaymentKey] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys HydraContext
ctx))
                String
"1 party"
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Bool -> String -> Property -> Property
forall prop. Testable prop => Bool -> String -> prop -> Property
classify
                (Bool -> Bool
not ([VerificationKey PaymentKey] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys HydraContext
ctx)))
                String
"2+ parties"

forAllDeposit ::
  Testable property =>
  (UTxO -> Tx -> property) ->
  Property
forAllDeposit :: forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllDeposit UTxO -> Tx -> property
action = do
  Gen (HydraContext, OpenState, UTxO, Tx)
-> ((HydraContext, OpenState, UTxO, Tx)
    -> [(HydraContext, OpenState, UTxO, Tx)])
-> ((HydraContext, OpenState, UTxO, Tx) -> property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink (Int -> Gen (HydraContext, OpenState, UTxO, Tx)
genDepositTx Int
maximumNumberOfParties) (HydraContext, OpenState, UTxO, Tx)
-> [(HydraContext, OpenState, UTxO, Tx)]
forall a. Arbitrary a => a -> [a]
shrink (((HydraContext, OpenState, UTxO, Tx) -> property) -> Property)
-> ((HydraContext, OpenState, UTxO, Tx) -> property) -> Property
forall a b. (a -> b) -> a -> b
$ \(HydraContext
_ctx, OpenState
st, UTxO
utxoToDeposit, Tx
tx) ->
    let utxo :: UTxO
utxo = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
utxoToDeposit
     in UTxO -> Tx -> property
action UTxO
utxo Tx
tx

forAllRecover ::
  Testable property =>
  (UTxO -> Tx -> property) ->
  Property
forAllRecover :: forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllRecover UTxO -> Tx -> property
action = do
  Gen (UTxO, Tx)
-> ((UTxO, Tx) -> [(UTxO, Tx)])
-> ((UTxO, Tx) -> property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen (UTxO, Tx)
genRecoverTx (UTxO, Tx) -> [(UTxO, Tx)]
forall a. Arbitrary a => a -> [a]
shrink (((UTxO, Tx) -> property) -> Property)
-> ((UTxO, Tx) -> property) -> Property
forall a b. (a -> b) -> a -> b
$ (UTxO -> Tx -> property) -> (UTxO, Tx) -> property
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry UTxO -> Tx -> property
action

-- | Deposits ranging from trivially fitting (a few ada-only outputs) to
-- clearly oversized (>100 distinct-policy tokens whose merged value exceeds
-- mainnet's 5000 byte maxValSize), so 'rejectOversizedDeposit' exercises both
-- verdicts.
genMixedDeposit :: Gen UTxO
genMixedDeposit :: Gen UTxO
genMixedDeposit =
  [Gen UTxO] -> Gen UTxO
forall a. HasCallStack => [Gen a] -> Gen a
oneof
    [ Int -> Gen UTxO
genUTxOAdaOnlyOfSize (Int -> Gen UTxO) -> Gen Int -> Gen UTxO
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
10)
    , Int -> Gen UTxO
genUTxOWithUniquePolicyTokensOfSize (Int -> Gen UTxO) -> Gen Int -> Gen UTxO
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
140)
    ]

forAllIncrement ::
  Testable property =>
  (UTxO -> Tx -> property) ->
  Property
forAllIncrement :: forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllIncrement UTxO -> Tx -> property
action = do
  (UTxO -> Tx -> property) -> Property
forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllIncrement' ((UTxO -> Tx -> property) -> Property)
-> (UTxO -> Tx -> property) -> Property
forall a b. (a -> b) -> a -> b
$ \UTxO
utxo Tx
tx ->
    UTxO -> Tx -> property
action UTxO
utxo Tx
tx

forAllIncrement' ::
  Testable property =>
  (UTxO -> Tx -> property) ->
  Property
forAllIncrement' :: forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllIncrement' UTxO -> Tx -> property
action = do
  Gen (HydraContext, OpenState, UTxO, Tx)
-> ((HydraContext, OpenState, UTxO, Tx)
    -> [(HydraContext, OpenState, UTxO, Tx)])
-> ((HydraContext, OpenState, UTxO, Tx) -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink (Int -> Gen (HydraContext, OpenState, UTxO, Tx)
genIncrementTx Int
maximumNumberOfParties) (HydraContext, OpenState, UTxO, Tx)
-> [(HydraContext, OpenState, UTxO, Tx)]
forall a. Arbitrary a => a -> [a]
shrink (((HydraContext, OpenState, UTxO, Tx) -> Property) -> Property)
-> ((HydraContext, OpenState, UTxO, Tx) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(HydraContext
ctx, OpenState
st, UTxO
incrementUTxO, Tx
tx) ->
    Gen ChainContext -> (ChainContext -> property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx) ((ChainContext -> property) -> Property)
-> (ChainContext -> property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainContext
cctx ->
      let utxo :: UTxO
utxo = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
cctx UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
incrementUTxO
       in UTxO -> Tx -> property
action UTxO
utxo Tx
tx

forAllDecrement ::
  Testable property =>
  (UTxO -> Tx -> property) ->
  Property
forAllDecrement :: forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllDecrement UTxO -> Tx -> property
action = do
  (UTxO -> UTxO -> Tx -> property) -> Property
forall property.
Testable property =>
(UTxO -> UTxO -> Tx -> property) -> Property
forAllDecrement' ((UTxO -> UTxO -> Tx -> property) -> Property)
-> (UTxO -> UTxO -> Tx -> property) -> Property
forall a b. (a -> b) -> a -> b
$ \UTxO
_ UTxO
utxo Tx
tx ->
    UTxO -> Tx -> property
action UTxO
utxo Tx
tx

forAllDecrement' ::
  Testable property =>
  (UTxO -> UTxO -> Tx -> property) ->
  Property
forAllDecrement' :: forall property.
Testable property =>
(UTxO -> UTxO -> Tx -> property) -> Property
forAllDecrement' UTxO -> UTxO -> Tx -> property
action = do
  Gen (ChainContext, UTxO, OpenState, UTxO, Tx)
-> ((ChainContext, UTxO, OpenState, UTxO, Tx)
    -> [(ChainContext, UTxO, OpenState, UTxO, Tx)])
-> ((ChainContext, UTxO, OpenState, UTxO, Tx) -> property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink (Int -> Gen (ChainContext, UTxO, OpenState, UTxO, Tx)
genDecrementTx Int
maximumNumberOfParties) (ChainContext, UTxO, OpenState, UTxO, Tx)
-> [(ChainContext, UTxO, OpenState, UTxO, Tx)]
forall a. Arbitrary a => a -> [a]
shrink (((ChainContext, UTxO, OpenState, UTxO, Tx) -> property)
 -> Property)
-> ((ChainContext, UTxO, OpenState, UTxO, Tx) -> property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
ctx, UTxO
distributed, OpenState
st, UTxO
utxo', Tx
tx) ->
    let utxo :: UTxO
utxo = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
ctx UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
utxo'
     in UTxO -> UTxO -> Tx -> property
action UTxO
distributed UTxO
utxo Tx
tx

forAllClose ::
  Testable property =>
  (UTxO -> Tx -> property) ->
  Property
forAllClose :: forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllClose UTxO -> Tx -> property
action = do
  -- FIXME: we should not hardcode number of parties but generate it within bounds
  Gen (ChainContext, OpenState, UTxO, Tx, ConfirmedSnapshot Tx)
-> ((ChainContext, OpenState, UTxO, Tx, ConfirmedSnapshot Tx)
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int
-> Gen (ChainContext, OpenState, UTxO, Tx, ConfirmedSnapshot Tx)
genCloseTx Int
maximumNumberOfParties) (((ChainContext, OpenState, UTxO, Tx, ConfirmedSnapshot Tx)
  -> Property)
 -> Property)
-> ((ChainContext, OpenState, UTxO, Tx, ConfirmedSnapshot Tx)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
ctx, OpenState
_, UTxO
utxo', Tx
tx, ConfirmedSnapshot Tx
sn) ->
    let utxo :: UTxO
utxo = UTxO
utxo' UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
ctx
     in UTxO -> Tx -> property
action UTxO
utxo Tx
tx
          property -> (property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> property -> Property
forall prop. Testable prop => String -> prop -> Property
label ([String] -> String
forall a. HasCallStack => [a] -> a
Prelude.head ([String] -> String)
-> (ConfirmedSnapshot Tx -> [String])
-> ConfirmedSnapshot Tx
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
Prelude.words (String -> [String])
-> (ConfirmedSnapshot Tx -> String)
-> ConfirmedSnapshot Tx
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfirmedSnapshot Tx -> String
forall b a. (Show a, IsString b) => a -> b
show (ConfirmedSnapshot Tx -> String) -> ConfirmedSnapshot Tx -> String
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot Tx
sn)

forAllContest ::
  Testable property =>
  (UTxO -> Tx -> property) ->
  Property
forAllContest :: forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllContest UTxO -> Tx -> property
action =
  -- XXX: This is always generating a fresh closed state with no previous contests
  Gen (HydraContext, PointInTime, ClosedState, UTxO, Tx)
-> ((HydraContext, PointInTime, ClosedState, UTxO, Tx) -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (HydraContext, PointInTime, ClosedState, UTxO, Tx)
genContestTx (((HydraContext, PointInTime, ClosedState, UTxO, Tx) -> Property)
 -> Property)
-> ((HydraContext, PointInTime, ClosedState, UTxO, Tx) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(hctx :: HydraContext
hctx@HydraContext{ContestationPeriod
ctxContestationPeriod :: ContestationPeriod
$sel:ctxContestationPeriod:HydraContext :: HydraContext -> ContestationPeriod
ctxContestationPeriod}, PointInTime
closePointInTime, ClosedState
stClosed, UTxO
_, Tx
tx) ->
    -- XXX: Pick an arbitrary context to contest. We will stumble over this when
    -- we make contests only possible once per party.
    Gen ChainContext -> (ChainContext -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (HydraContext -> Gen ChainContext
pickChainContext HydraContext
hctx) ((ChainContext -> Property) -> Property)
-> (ChainContext -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainContext
ctx ->
      let utxo :: UTxO
utxo = ClosedState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ClosedState
stClosed UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
ctx
       in UTxO -> Tx -> property
action UTxO
utxo Tx
tx
            property -> (property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Contestation deadline: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTCTime -> String
forall b a. (Show a, IsString b) => a -> b
show ClosedState
stClosed.contestationDeadline)
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Contestation period: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ContestationPeriod -> String
forall b a. (Show a, IsString b) => a -> b
show ContestationPeriod
ctxContestationPeriod)
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Close point: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PointInTime -> String
forall b a. (Show a, IsString b) => a -> b
show PointInTime
closePointInTime)
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"Contestation period" (ContestationPeriod -> [String]
tabulateContestationPeriod ContestationPeriod
ctxContestationPeriod)
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"Close point (slot)" (SlotNo -> [String]
tabulateNum (SlotNo -> [String]) -> SlotNo -> [String]
forall a b. (a -> b) -> a -> b
$ PointInTime -> SlotNo
forall a b. (a, b) -> a
fst PointInTime
closePointInTime)
 where
  tabulateNum :: SlotNo -> [String]
  tabulateNum :: SlotNo -> [String]
tabulateNum SlotNo
x
    | SlotNo
x SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
0 = [String
"> 0"]
    | SlotNo
x SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
0 = [String
"< 0"]
    | Bool
otherwise = [String
"== 0"]

  tabulateContestationPeriod :: ContestationPeriod -> [String]
tabulateContestationPeriod (ContestationPeriod -> NominalDiffTime
toNominalDiffTime -> NominalDiffTime
cp)
    | NominalDiffTime
cp NominalDiffTime -> NominalDiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== NominalDiffTime
confirmedHorizon = [String
"k blocks on mainnet"]
    | NominalDiffTime
cp NominalDiffTime -> NominalDiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== NominalDiffTime
oneDay = [String
"one day"]
    | NominalDiffTime
cp NominalDiffTime -> NominalDiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== NominalDiffTime
oneWeek = [String
"one week"]
    | NominalDiffTime
cp NominalDiffTime -> NominalDiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== NominalDiffTime
oneMonth = [String
"one month"]
    | NominalDiffTime
cp NominalDiffTime -> NominalDiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== NominalDiffTime
oneYear = [String
"one year"]
    | NominalDiffTime
cp NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
confirmedHorizon = [String
"< k blocks"]
    | Bool
otherwise = [String
"> k blocks"]

  confirmedHorizon :: NominalDiffTime
confirmedHorizon = NominalDiffTime
2160 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
20 -- k blocks on mainnet
  oneDay :: NominalDiffTime
oneDay = NominalDiffTime
3600 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
24
  oneWeek :: NominalDiffTime
oneWeek = NominalDiffTime
oneDay NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
7
  oneMonth :: NominalDiffTime
oneMonth = NominalDiffTime
oneDay NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
30
  oneYear :: NominalDiffTime
oneYear = NominalDiffTime
oneDay NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
365

forAllFanout ::
  Testable property =>
  (UTxO -> Tx -> property) ->
  Property
forAllFanout :: forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllFanout UTxO -> Tx -> property
action =
  -- TODO: The utxo to fanout should be more arbitrary to have better test coverage
  Gen (ChainContext, ClosedState, UTxO, Tx)
-> ((ChainContext, ClosedState, UTxO, Tx) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, Tx)
genFanoutTx Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, Tx) -> Property) -> Property)
-> ((ChainContext, ClosedState, UTxO, Tx) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
ctx, ClosedState
_stClosed, UTxO
spendableUTxO, Tx
tx) ->
    let utxo :: UTxO
utxo = UTxO
spendableUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
ctx
     in UTxO -> Tx -> property
action UTxO
utxo Tx
tx
          property -> (property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> property -> Property
forall prop. Testable prop => String -> prop -> Property
label (String
"Fanout size: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
prettyLength ([TxOut CtxTx] -> Int
forall ctx. [TxOut ctx] -> Int
countAssets ([TxOut CtxTx] -> Int) -> [TxOut CtxTx] -> Int
forall a b. (a -> b) -> a -> b
$ Tx -> [TxOut CtxTx]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx))
 where
  maxSupported :: Int
  maxSupported :: Int
maxSupported = Int
44

  countAssets :: [TxOut ctx] -> Int
  countAssets :: forall ctx. [TxOut ctx] -> Int
countAssets = Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int) -> ([TxOut ctx] -> Sum Int) -> [TxOut ctx] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut ctx -> Sum Int) -> [TxOut ctx] -> Sum Int
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> (TxOut ctx -> Int) -> TxOut ctx -> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AssetId, Quantity)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(AssetId, Quantity)] -> Int)
-> (TxOut ctx -> [(AssetId, Quantity)]) -> TxOut ctx -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
Value -> [Item Value]
forall l. IsList l => l -> [Item l]
IsList.toList (Value -> [(AssetId, Quantity)])
-> (TxOut ctx -> Value) -> TxOut ctx -> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut ctx -> Value
forall ctx. TxOut ctx -> Value
txOutValue)

  prettyLength :: Int -> String
  prettyLength :: Int -> String
prettyLength Int
len
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxSupported = String
"> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
maxSupported String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ???"
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
40 = String
"40-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
maxSupported
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10 = String
"10-40"
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 = String
"1-10"
    | Bool
otherwise = String
"0"

forAllPartialFanout ::
  Testable property =>
  (UTxO -> Tx -> property) ->
  Property

-- | Use spendableUTxO (not 'getKnownUTxO stClosed'): the generator adds the
-- full UTxO value to the head output so 'partialFanoutTx' can subtract
-- distributed values without going negative. The evaluation UTxO must match.
forAllPartialFanout :: forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllPartialFanout UTxO -> Tx -> property
action =
  Gen (ChainContext, ClosedState, UTxO, Tx)
-> ((ChainContext, ClosedState, UTxO, Tx) -> property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, Tx)
genPartialFanoutTx Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, Tx) -> property) -> Property)
-> ((ChainContext, ClosedState, UTxO, Tx) -> property) -> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
ctx, ClosedState
_, UTxO
spendableUTxO, Tx
tx) ->
    let utxo :: UTxO
utxo = UTxO
spendableUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
ctx
     in UTxO -> Tx -> property
action UTxO
utxo Tx
tx

-- | The spendable UTxO for the final partial fanout is the FanoutProgress head
-- output produced by the preceding partial fanout step, so we use the 3rd
-- element from the generator rather than 'getKnownUTxO stClosed'.
forAllFinalPartialFanout ::
  Testable property =>
  (UTxO -> Tx -> property) ->
  Property
forAllFinalPartialFanout :: forall property.
Testable property =>
(UTxO -> Tx -> property) -> Property
forAllFinalPartialFanout UTxO -> Tx -> property
action =
  Gen (ChainContext, ClosedState, UTxO, Tx)
-> ((ChainContext, ClosedState, UTxO, Tx) -> property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (ChainContext, ClosedState, UTxO, Tx)
genFinalPartialFanoutTx Int
maximumNumberOfParties) (((ChainContext, ClosedState, UTxO, Tx) -> property) -> Property)
-> ((ChainContext, ClosedState, UTxO, Tx) -> property) -> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
ctx, ClosedState
_, UTxO
fanoutProgressUTxO, Tx
tx) ->
    let utxo :: UTxO
utxo = UTxO
fanoutProgressUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
ctx
     in UTxO -> Tx -> property
action UTxO
utxo Tx
tx