Decrement on-chain: Check value in the Head is preserved

Add this check in the specfication too.
input-output-hk · Apr 17, 2024 · 71c4bea · 71c4bea
1 parent 48388dc
commit 71c4bea
Show file tree

Hide file tree

Showing 9 changed files with 56 additions and 38 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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