Split decommit utxo in the snapshot

This produces errors with negative values in the output. Also triggers H24 FannedOutUtxoHashNotEqualToClosedUtxoHash.
input-output-hk · Apr 25, 2024 · 308d99f · 308d99f
1 parent d109b65
commit 308d99f
Show file tree

Hide file tree

Showing 3 changed files with 37 additions and 26 deletions.
diff --git a/hydra-node/src/Hydra/Chain/Direct/State.hs b/hydra-node/src/Hydra/Chain/Direct/State.hs
@@ -487,11 +487,11 @@ decrement ctx headId headParameters spendableUTxO snapshot signatures = do
   pid <- headIdToPolicyId headId ?> InvalidHeadIdInDecrement{headId}
   let utxoOfThisHead' = utxoOfThisHead pid spendableUTxO
   headUTxO <- UTxO.find (isScriptTxOut headScript) utxoOfThisHead' ?> CannotFindHeadOutputInDecrement
-  -- case utxoToDecommit of
-  --   Nothing ->
-  --     Left SnapshotMissingDecrementUTxO
-  --   Just _decrementUTxO ->
-  Right $ decrementTx scriptRegistry ownVerificationKey headId headParameters headUTxO snapshot signatures
+  case utxoToDecommit of
+    Nothing ->
+      Left SnapshotMissingDecrementUTxO
+    Just _decrementUTxO ->
+      Right $ decrementTx scriptRegistry ownVerificationKey headId headParameters headUTxO snapshot signatures
  where
   headScript = fromPlutusScript @PlutusScriptV2 Head.validatorScript
 

diff --git a/hydra-node/src/Hydra/Chain/Direct/Tx.hs b/hydra-node/src/Hydra/Chain/Direct/Tx.hs
@@ -560,17 +560,17 @@ closeTx scriptRegistry vk closing startSlotNo (endSlotNo, utcTime) openThreadOut
     modifyTxOutDatum (const headDatumAfter) headOutputBefore
 
   headDatumAfter =
-      mkTxOutDatumInline
-        Head.Closed
-          { snapshotNumber
-          , utxoHash = toBuiltin utxoHashBytes
-          , utxoToDecommitHash = toBuiltin decommitUTxOHashBytes
-          , parties = openParties
-          , contestationDeadline
-          , contestationPeriod = openContestationPeriod
-          , headId = headIdToCurrencySymbol headId
-          , contesters = []
-          }
+    mkTxOutDatumInline
+      Head.Closed
+        { snapshotNumber
+        , utxoHash = toBuiltin utxoHashBytes
+        , utxoToDecommitHash = toBuiltin decommitUTxOHashBytes
+        , parties = openParties
+        , contestationDeadline
+        , contestationPeriod = openContestationPeriod
+        , headId = headIdToCurrencySymbol headId
+        , contesters = []
+        }
 
   snapshotNumber = toInteger $ case closing of
     CloseWithInitialSnapshot{} -> 0

diff --git a/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs b/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs
@@ -215,6 +215,7 @@ instance StateModel Model where
       headState == Open
         && snapshot > latestSnapshot
         && isAugmented snapshot
+        && not (null (snapshotUTxO snapshot))
     Close{snapshot} ->
       snapshot /= Augmented 0 -- TODO: don't generate this one
         && headState == Open
@@ -416,13 +417,22 @@ signedSnapshot ms =
       , number = snapshotNumber ms
       , confirmed = []
       , utxo = allUTxO
-      , utxoToDecommit = Nothing -- FIXME
+      , utxoToDecommit = decommitUTxO
       }
 
-  allUTxO = snapshotUTxO ms
+  (decommitUTxO, allUTxO)
+    | null (snapshotUTxO ms) = (Nothing, mempty)
+    | otherwise = splitDecrementUTxO (snapshotUTxO ms) `generateWith` 42
 
   signatures = aggregate [sign sk snapshot | sk <- [Fixture.aliceSk, Fixture.bobSk, Fixture.carolSk]]
 
+  splitDecrementUTxO :: UTxO -> Gen (Maybe UTxO, UTxO)
+  splitDecrementUTxO utxo = do
+    let pairs = UTxO.pairs utxo
+    let toDecommit = elements pairs `generateWith` 42
+    let toKeep = filter (/= toDecommit) pairs
+    pure (Just $ UTxO.fromPairs [toDecommit], UTxO.fromPairs toKeep)
+
 -- | A confirmed snapshot (either initial or later confirmed), based on
 -- 'signedSnapshot'.
 confirmedSnapshot :: ModelSnapshot -> ConfirmedSnapshot Tx
@@ -464,14 +474,15 @@ openHeadUTxO =
 newDecrementTx :: HasCallStack => Actor -> (Snapshot Tx, MultiSignature (Snapshot Tx)) -> AppM Tx
 newDecrementTx actor (snapshot, signatures) = do
   spendableUTxO <- get
-  either (failure . show) pure $
-    decrement
-      (actorChainContext actor)
-      (mkHeadId Fixture.testPolicyId)
-      Fixture.testHeadParameters
-      spendableUTxO
-      snapshot
-      signatures
+  traceShow snapshot $
+    either (failure . show) pure $
+      decrement
+        (actorChainContext actor)
+        (mkHeadId Fixture.testPolicyId)
+        Fixture.testHeadParameters
+        spendableUTxO
+        snapshot
+        signatures
 
 -- | Creates a transaction that closes 'openHeadUTxO' with given the snapshot.
 -- NOTE: This uses fixtures for headId, parties (alice, bob, carol),