From f7cdd05932a5eca50c79236f832312d2452f7791 Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Thu, 23 May 2024 10:31:43 +0200 Subject: [PATCH] Rebase: fix compilation --- hydra-node/bench/tx-cost/TxCost.hs | 2 +- .../Hydra/Chain/Direct/Contract/CollectCom.hs | 6 +++--- .../Hydra/Chain/Direct/Contract/Decrement.hs | 16 ++++++++-------- .../test/Hydra/Chain/Direct/TxTraceSpec.hs | 16 +++++++++------- hydra-node/test/Hydra/ModelSpec.hs | 6 +++--- 5 files changed, 24 insertions(+), 22 deletions(-) diff --git a/hydra-node/bench/tx-cost/TxCost.hs b/hydra-node/bench/tx-cost/TxCost.hs index 12cce933d04..f83a986bc39 100644 --- a/hydra-node/bench/tx-cost/TxCost.hs +++ b/hydra-node/bench/tx-cost/TxCost.hs @@ -236,7 +236,7 @@ computeFanOutCost = do stClosed = snd . fromJust $ observeClose stOpen closeTx deadlineSlotNo = slotNoFromUTCTime systemStart slotLength (getContestationDeadline stClosed) utxoToFanout = getKnownUTxO stClosed <> getKnownUTxO cctx - pure (utxo, unsafeFanout cctx utxoToFanout seedTxIn utxo deadlineSlotNo, getKnownUTxO stClosed <> getKnownUTxO cctx) + pure (utxo, unsafeFanout cctx utxoToFanout seedTxIn utxo Nothing deadlineSlotNo, getKnownUTxO stClosed <> getKnownUTxO cctx) newtype NumParties = NumParties Int deriving newtype (Eq, Show, Ord, Num, Real, Enum, Integral) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs index 7fb58727236..704d33a0188 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs @@ -207,10 +207,10 @@ genCollectComMutation (tx, _utxo) = [ SomeMutation (pure $ toErrorCode NotPayingToHead) NotContinueContract <$> do mutatedAddress <- genAddressInEra testNetworkId pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut) - , SomeMutation (Just $ toErrorCode NotAllValueCollected) ExtractSomeValue <$> do + , SomeMutation (pure $ toErrorCode NotAllValueCollected) ExtractSomeValue <$> do extractHeadOutputValue headTxOut testPolicyId - , SomeMutation (Just $ toErrorCode IncorrectUtxoHash) MutateOpenUTxOHash . ChangeOutput 0 <$> mutateUTxOHash - , SomeMutation (Just $ toErrorCode MissingCommits) MutateNumberOfParties <$> do + , SomeMutation (pure $ toErrorCode IncorrectUtxoHash) MutateOpenUTxOHash . ChangeOutput 0 <$> mutateUTxOHash + , SomeMutation (pure $ toErrorCode MissingCommits) MutateNumberOfParties <$> do moreParties <- (: healthyOnChainParties) <$> arbitrary pure $ Changes diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Decrement.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Decrement.hs index bead0310853..b754427ee7b 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Decrement.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Decrement.hs @@ -162,30 +162,30 @@ data DecrementMutation genDecrementMutation :: (Tx, UTxO) -> Gen SomeMutation genDecrementMutation (tx, utxo) = oneof - [ SomeMutation (Just $ toErrorCode ChangedParameters) ChangePartiesInOuput <$> do + [ SomeMutation (pure $ toErrorCode ChangedParameters) ChangePartiesInOuput <$> do mutatedParties <- arbitrary `suchThat` (/= healthyOnChainParties) pure $ ChangeOutput 0 $ modifyInlineDatum (replaceParties mutatedParties) headTxOut - , SomeMutation (Just $ toErrorCode SnapshotNumberMismatch) UseDifferentSnapshotNumber <$> do + , SomeMutation (pure $ toErrorCode SnapshotNumberMismatch) UseDifferentSnapshotNumber <$> do mutatedSnapshotNumber <- arbitrarySizedNatural `suchThat` (< healthySnapshotNumber) pure $ ChangeOutput 0 $ modifyInlineDatum (replaceSnapshotNumberInOpen $ toInteger mutatedSnapshotNumber) headTxOut - , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) ProduceInvalidSignatures . ChangeHeadRedeemer <$> do + , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) ProduceInvalidSignatures . ChangeHeadRedeemer <$> do Head.Decrement . toPlutusSignatures <$> (arbitrary :: Gen (MultiSignature (Snapshot Tx))) <*> pure (fromIntegral $ length utxo - 1) - , SomeMutation (Just $ toErrorCode SignerIsNotAParticipant) AlterRequiredSigner <$> do + , SomeMutation (pure $ toErrorCode SignerIsNotAParticipant) AlterRequiredSigner <$> do newSigner <- verificationKeyHash <$> genVerificationKey `suchThat` (/= somePartyCardanoVerificationKey) pure $ ChangeRequiredSigners [newSigner] - , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) ChangeOutputValue <$> do + , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) ChangeOutputValue <$> do let outs = txOuts' tx -- NOTE: Skip the first output since this is the Head output. (ix, out) <- elements (zip [1 .. length outs - 1] outs) value' <- genValue `suchThat` (/= txOutValue out) pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out) - , SomeMutation (Just $ toErrorCode HeadValueIsNotPreserved) ChangeValueInOutput <$> do + , SomeMutation (pure $ toErrorCode HeadValueIsNotPreserved) ChangeValueInOutput <$> do newValue <- genValue pure $ ChangeOutput 0 (headTxOut{txOutValue = newValue}) - , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) DropDecommitOutput <$> do + , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) DropDecommitOutput <$> do ix <- choose (1, length (txOuts' tx) - 1) pure $ RemoveOutput (fromIntegral ix) - , SomeMutation (Just $ toErrorCode HeadValueIsNotPreserved) ExtractSomeValue <$> do + , SomeMutation (pure $ toErrorCode HeadValueIsNotPreserved) ExtractSomeValue <$> do extractHeadOutputValue headTxOut testPolicyId ] where diff --git a/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs b/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs index 926b00670b3..6927f165f3f 100644 --- a/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs @@ -421,17 +421,19 @@ instance RunModel Model AppM where counterexample' (show modelBefore) counterexample' (show action) case action of - Decrement{} -> expectInvalid result - Close{} -> expectInvalid result - Contest{} -> expectInvalid result + Decrement{} -> either (const $ fail "oops") expectInvalid result + Close{} -> either (const $ fail "oops") expectInvalid result + Contest{} -> either (const $ fail "oops") expectInvalid result Fanout{} -> do case result of - TxResult{validationError = Just _} -> fulfilled - TxResult{validationError = Nothing} -> counterexample' "Expected to fail validation" + Left _ -> fulfilled + Right (TxResult{validationError = Nothing}) -> counterexample' "Expected to fail validation" + Right (TxResult{validationError = Just _}) -> fulfilled case result of - TxResult{tx = Left _} -> fulfilled - TxResult{tx = Right _} -> counterexample' "Expected failure to build transaction" + Left _ -> fulfilled + Right (TxResult{tx = Left _}) -> fulfilled + Right (TxResult{tx = Right _}) -> counterexample' "Expected failure to build transaction" _ -> pure () -- | Perform a transaction by evaluating and observing it. This updates the diff --git a/hydra-node/test/Hydra/ModelSpec.hs b/hydra-node/test/Hydra/ModelSpec.hs index 1db4d9a38af..f18dad59e2d 100644 --- a/hydra-node/test/Hydra/ModelSpec.hs +++ b/hydra-node/test/Hydra/ModelSpec.hs @@ -438,9 +438,9 @@ runRunMonadIOSimGen f = do } runReaderT (runMonad (eval f)) (RunState v) -nonConflictingTx :: WorldState -> Quantification (Party, Payment.Payment) -nonConflictingTx st = - withGenQ (genPayment st) (const True) (const []) +nonConflictingTx :: Payment.CardanoSigningKey -> WorldState -> Quantification (Party, Payment.Payment) +nonConflictingTx to st = + withGenQ (genPayment to st) (const True) (const []) `whereQ` \(party, tx) -> precondition st (Model.NewTx party tx) eventually :: Action WorldState () -> DL WorldState ()