diff --git a/hydra-cluster/test/Test/ChainObserverSpec.hs b/hydra-cluster/test/Test/ChainObserverSpec.hs index 7f1550f3d59..a5d1737ec52 100644 --- a/hydra-cluster/test/Test/ChainObserverSpec.hs +++ b/hydra-cluster/test/Test/ChainObserverSpec.hs @@ -61,7 +61,7 @@ spec = do commitTx <- requestCommitTx hydraNode commitUTxO - pure (signTx walletSk commitTx) >>= submitTx cardanoNode + submitTx cardanoNode (signTx walletSk commitTx) waitFor hydraTracer 5 [hydraNode] $ output "HeadIsOpen" ["utxo" .= commitUTxO, "headId" .= headId] diff --git a/hydra-node/json-schemas/logs.yaml b/hydra-node/json-schemas/logs.yaml index f8826a6bb2a..442a6bde834 100644 --- a/hydra-node/json-schemas/logs.yaml +++ b/hydra-node/json-schemas/logs.yaml @@ -1550,7 +1550,10 @@ definitions: seenSnapshot: $ref: "logs.yaml#/definitions/SeenSnapshot" decommitTx: - $ref: "api.yaml#/components/schemas/Transaction" + oneOf: + - type: "null" + - type: object + $ref: "api.yaml#/components/schemas/Transaction" SeenSnapshot: oneOf: @@ -2164,6 +2167,20 @@ definitions: type: array items: $ref: "api.yaml#/components/schemas/TxId" + - title: WaitOnNotApplicableDecommitTx + description: >- + Somebody requested a Decommit but there is another one in flight already. + type: object + additionalProperties: false + required: + - tag + - waitingOnDecommitTx + properties: + tag: + type: string + enum: ["WaitOnNotApplicableDecommitTx"] + waitingOnDecommitTx: + $ref: "api.yaml#/components/schemas/Transaction" IP: type: object diff --git a/hydra-node/src/Hydra/Chain/Direct/Tx.hs b/hydra-node/src/Hydra/Chain/Direct/Tx.hs index 3fee2a3a90e..d63d7586e23 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Tx.hs +++ b/hydra-node/src/Hydra/Chain/Direct/Tx.hs @@ -370,7 +370,7 @@ decrementTx scriptRegistry vk headId headParameters (headInput, headOutput) snap & addInputs [(headInput, headWitness)] & addReferenceInputs [headScriptRef] -- NOTE: at this point 'utxoToDecommit' is populated - & addOutputs (headOutput' : map toTxContext (maybe [] (fmap snd . UTxO.pairs) utxoToDecommit)) + & addOutputs (headOutput' : map toTxContext (maybe [] toList utxoToDecommit)) & addExtraRequiredSigners [verificationKeyHash vk] where headRedeemer = toScriptData $ Head.Decrement (toPlutusSignatures signatures) @@ -481,8 +481,7 @@ closeTx scriptRegistry vk closing startSlotNo (endSlotNo, utcTime) openThreadOut Head.Closed { snapshotNumber , utxoHash = toBuiltin utxoHashBytes - , -- TODO: find a way to introduce this value - utxoToDecommitHash = toBuiltin decommitUTxOHashBytes + , utxoToDecommitHash = toBuiltin decommitUTxOHashBytes , parties = openParties , contestationDeadline , contestationPeriod = openContestationPeriod diff --git a/hydra-node/src/Hydra/HeadLogic.hs b/hydra-node/src/Hydra/HeadLogic.hs index 2e06b11cfa2..0f60098600c 100644 --- a/hydra-node/src/Hydra/HeadLogic.hs +++ b/hydra-node/src/Hydra/HeadLogic.hs @@ -613,27 +613,25 @@ onOpenClientDecommit :: onOpenClientDecommit env headId ledger currentSlot coordinatedHeadState decommitTx = checkNoDecommitInFlight $ checkValidDecommitTx $ - Effects - [ NetworkEffect ReqDec{transaction = decommitTx, decommitRequester = party} - ] + cause (NetworkEffect ReqDec{transaction = decommitTx, decommitRequester = party}) where checkNoDecommitInFlight continue = case mExistingDecommitTx of Just existingDecommitTx -> - Effects - [ ClientEffect + cause + ( ClientEffect ServerOutput.DecommitInvalid { headId , decommitInvalidReason = ServerOutput.DecommitAlreadyInFlight{decommitTx = existingDecommitTx} } - ] + ) Nothing -> continue checkValidDecommitTx cont = case applyTransactions ledger currentSlot confirmedUTxO [decommitTx] of Left (_, err) -> - Effects - [ ClientEffect + cause + ( ClientEffect ServerOutput.DecommitInvalid { headId , decommitInvalidReason = @@ -643,7 +641,7 @@ onOpenClientDecommit env headId ledger currentSlot coordinatedHeadState decommit , validationError = err } } - ] + ) Right _ -> cont confirmedUTxO = (getSnapshot confirmedSnapshot).utxo @@ -684,22 +682,18 @@ onOpenNetworkReqDec :: onOpenNetworkReqDec env ttl openState decommitTx = waitOnApplicableDecommit $ let decommitUTxO = utxoFromTx decommitTx - in StateChanged (DecommitRecorded decommitTx) - <> Effects - [ ClientEffect $ ServerOutput.DecommitRequested headId decommitUTxO - ] + in newState (DecommitRecorded decommitTx) + <> cause (ClientEffect $ ServerOutput.DecommitRequested headId decommitUTxO) <> if isLeader parameters party nextSn - then - Effects - [NetworkEffect (ReqSn nextSn (txId <$> localTxs) (Just decommitTx))] - else Error $ RequireFailed $ ReqSnNotLeader{requestedSn = nextSn, leader = party} + then cause (NetworkEffect (ReqSn nextSn (txId <$> localTxs) (Just decommitTx))) + else noop where waitOnApplicableDecommit cont = case mExistingDecommitTx of Nothing -> cont Just existingDecommitTx | ttl > 0 -> - Wait $ WaitOnNotApplicableDecommitTx decommitTx + wait $ WaitOnNotApplicableDecommitTx decommitTx | otherwise -> Error $ RequireFailed $ DecommitTxInFlight{decommitTx = existingDecommitTx} Environment{party} = env @@ -909,8 +903,7 @@ update env ledger st ev = case (st, ev) of ) -- TODO: What happens if observed decrement tx get's rolled back? | ourHeadId == headId -> - causes - [ClientEffect $ ServerOutput.DecommitFinalized{headId}] + cause (ClientEffect $ ServerOutput.DecommitFinalized{headId}) <> newState DecommitFinalized | otherwise -> Error NotOurHead{ourHeadId, otherHeadId = headId} diff --git a/hydra-node/src/Hydra/HeadLogic/Outcome.hs b/hydra-node/src/Hydra/HeadLogic/Outcome.hs index 6b2d2b80fbb..f574af7f538 100644 --- a/hydra-node/src/Hydra/HeadLogic/Outcome.hs +++ b/hydra-node/src/Hydra/HeadLogic/Outcome.hs @@ -158,7 +158,7 @@ data WaitReason tx | WaitOnSeenSnapshot | WaitOnTxs {waitingForTxIds :: [TxIdType tx]} | WaitOnContestationDeadline - | WaitOnNotApplicableDecommitTx { waitingOnDecommitTx :: tx} + | WaitOnNotApplicableDecommitTx {waitingOnDecommitTx :: tx} deriving stock (Generic) deriving stock instance IsTx tx => Eq (WaitReason tx) diff --git a/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs b/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs index 52e05d6fcc7..a2d9ade94fb 100644 --- a/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs @@ -215,9 +215,8 @@ prop_verifyOffChainSignatures = onChainSig = List.head . toPlutusSignatures $ aggregate [offChainSig] onChainParty = partyToChain $ deriveParty sk snapshotNumber = toInteger number - utxoHash = - (toBuiltin $ hashUTxO @SimpleTx utxo) - utxoToDecommitHash = maybe (toBuiltin $ hashUTxO @SimpleTx mempty) (toBuiltin . hashUTxO @SimpleTx) utxoToDecommit + utxoHash = (toBuiltin $ hashUTxO @SimpleTx utxo) + utxoToDecommitHash = (toBuiltin . hashUTxO @SimpleTx $ fromMaybe mempty utxoToDecommit) in verifyPartySignature (headIdToCurrencySymbol headId) snapshotNumber utxoHash utxoToDecommitHash onChainParty onChainSig & counterexample ("headId: " <> show headId) & counterexample ("signed: " <> show onChainSig) @@ -233,7 +232,6 @@ prop_verifySnapshotSignatures = onChainParties = partyToChain <$> parties signatures = toPlutusSignatures $ aggregate [sign sk snapshot | sk <- sks] snapshotNumber = toInteger number - utxoHash = - toBuiltin (hashUTxO @SimpleTx utxo) - utxoToDecommitHash = maybe (toBuiltin $ hashUTxO @SimpleTx mempty) (toBuiltin . hashUTxO @SimpleTx) utxoToDecommit + utxoHash = toBuiltin (hashUTxO @SimpleTx utxo) + utxoToDecommitHash = (toBuiltin . hashUTxO @SimpleTx $ fromMaybe mempty utxoToDecommit) in verifySnapshotSignature onChainParties (headIdToCurrencySymbol headId) snapshotNumber utxoHash utxoToDecommitHash signatures diff --git a/hydra-node/test/Hydra/HeadLogicSpec.hs b/hydra-node/test/Hydra/HeadLogicSpec.hs index 1b6f75f0b5a..fb5493717a9 100644 --- a/hydra-node/test/Hydra/HeadLogicSpec.hs +++ b/hydra-node/test/Hydra/HeadLogicSpec.hs @@ -46,6 +46,7 @@ import Hydra.HeadLogic ( aggregateState, defaultTTL, update, + cause, ) import Hydra.HeadLogic.State (getHeadParameters) import Hydra.Ledger (ChainSlot (..), IsTx (..), Ledger (..), ValidationError (..)) @@ -152,10 +153,8 @@ spec = let input = NetworkInput defaultTTL alice reqDec st <- pickBlind $ oneof $ pure <$> [inInitialState threeParties, inIdleState, inClosedState threeParties] pure $ - update aliceEnv ledger st input - `hasEffectSatisfying` \case - NetworkEffect reqDec' -> reqDec' == reqDec - _ -> False + update aliceEnv ledger st event + `shouldNotBe` cause (NetworkEffect reqDec) it "wait for second decommit when another one is in flight" $ do let decommitTx1 = SimpleTx 1 mempty (utxoRef 1) @@ -173,7 +172,7 @@ spec = let outcome = update bobEnv ledger s1 reqDecEvent2 outcome `shouldSatisfy` \case - Wait (WaitOnNotApplicableDecommitTx{waitingOnDecommitTx = decommitTx''}) -> + Wait (WaitOnNotApplicableDecommitTx{waitingOnDecommitTx = decommitTx''}) _ -> decommitTx2 == decommitTx'' _ -> False diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index 21e6d6c732b..07120c5a11d 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/hydra-plutus/src/Hydra/Contract/Head.hs @@ -241,10 +241,21 @@ checkDecrement ctx@ScriptContext{scriptContextTxInfo = txInfo} prevParties prevS && checkSnapshot && checkSnapshotSignature && mustBeSignedByParticipant ctx prevHeadId + && mustPreserveValue where + mustPreserveValue = + traceIfFalse $(errorCode HeadValueIsNotPreserved) $ + headInValue === headOutValue + -- NOTE: head output + whatever is decommitted needs to be equal to the head input. + headOutValue = txOutValue $ head $ txInfoOutputs txInfo <> decommitOutputs + + headInValue = maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx + + decommitOutputs = tail (txInfoOutputs txInfo) + -- NOTE: we always assume Head output is the first one so we pick all other -- outputs of a decommit tx to calculate the expected hash. - decommitUtxoHash = hashTxOuts $ tail (txInfoOutputs txInfo) + decommitUtxoHash = hashTxOuts decommitOutputs (nextUtxoHash, nextParties, nextSnapshotNumber, nextCperiod, nextHeadId) = case fromBuiltinData @DatumType $ getDatum (headOutputDatum ctx) of Just diff --git a/spec/onchain.tex b/spec/onchain.tex index 4e0f61c0fc7..bdf55f6fadd 100644 --- a/spec/onchain.tex +++ b/spec/onchain.tex @@ -314,6 +314,7 @@ \subsection{Decrement Transaction}\label{sec:increment-tx} \] \item Transaction is signed by a participant $\exists \{\cid \mapsto \keyHash_{i} \mapsto 1\} \in \valHead' \Rightarrow \keyHash_{i} \in \txKeys$. \todo{Need a constraint on the value in the head?} + \item Value in the head is preserved $\valHead' = \valHead$. \end{menumerate} \begin{figure}[h] \centering