Add decommit utxo to confirmed snapshot in StateSpec

Model the decommit utxo as a separate utxo in the confirmed snapshot.
input-output-hk · May 7, 2024 · 4360af9 · 4360af9
1 parent 33f4aaa
commit 4360af9
Show file tree

Hide file tree

Showing 3 changed files with 15 additions and 11 deletions.
diff --git a/hydra-node/bench/tx-cost/TxCost.hs b/hydra-node/bench/tx-cost/TxCost.hs
@@ -172,7 +172,7 @@ computeContestCost = do
     utxo <- arbitrary
     (closedSnapshotNumber, _, stClosed@ClosedState{headId}) <- genStClosed ctx utxo
     cctx <- pickChainContext ctx
-    snapshot <- genConfirmedSnapshot headId (succ closedSnapshotNumber) utxo (ctxHydraSigningKeys ctx)
+    snapshot <- genConfirmedSnapshot headId (succ closedSnapshotNumber) utxo Nothing (ctxHydraSigningKeys ctx)
     pointInTime <- genPointInTimeBefore (getContestationDeadline stClosed)
     let cp = ctxContestationPeriod ctx
     let contestUtxo = getKnownUTxO stClosed <> getKnownUTxO cctx
@@ -228,7 +228,7 @@ computeFanOutCost = do
     utxo <- genUTxOAdaOnlyOfSize numOutputs
     ctx <- genHydraContextFor numParties
     (_committed, stOpen@OpenState{headId, seedTxIn}) <- genStOpen ctx
-    snapshot <- genConfirmedSnapshot headId 1 utxo [] -- We do not validate the signatures
+    snapshot <- genConfirmedSnapshot headId 1 utxo Nothing [] -- We do not validate the signatures
     cctx <- pickChainContext ctx
     let cp = ctxContestationPeriod ctx
     (startSlot, closePoint) <- genValidityBoundsFromContestationPeriod cp

diff --git a/hydra-node/src/Hydra/Chain/Direct/State.hs b/hydra-node/src/Hydra/Chain/Direct/State.hs
@@ -1040,15 +1040,17 @@ genDecrementTx numParties = do
 
 splitUTxO :: UTxO -> Gen (UTxO, UTxO)
 splitUTxO utxo = do
-  ix <- choose (0, length utxo)
+  -- NOTE: here we skip the head output which is always at the first position.
+  ix <- choose (1, length utxo)
   let (p1, p2) = splitAt ix (UTxO.pairs utxo)
   pure (UTxO.fromPairs p1, UTxO.fromPairs p2)
 
 genCloseTx :: Int -> Gen (ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
 genCloseTx numParties = do
   ctx <- genHydraContextFor numParties
   (u0, stOpen@OpenState{headId}) <- genStOpen ctx
-  snapshot <- genConfirmedSnapshot headId 0 u0 (ctxHydraSigningKeys ctx)
+  (confirmedUtxo, utxoToDecommit) <- splitUTxO u0
+  snapshot <- genConfirmedSnapshot headId 1 confirmedUtxo (Just utxoToDecommit) (ctxHydraSigningKeys ctx)
   cctx <- pickChainContext ctx
   let cp = ctxContestationPeriod ctx
   (startSlot, pointInTime) <- genValidityBoundsFromContestationPeriod cp
@@ -1059,7 +1061,8 @@ genContestTx :: Gen (HydraContext, PointInTime, ClosedState, Tx)
 genContestTx = do
   ctx <- genHydraContextFor maximumNumberOfParties
   (u0, stOpen@OpenState{headId}) <- genStOpen ctx
-  confirmed <- genConfirmedSnapshot headId 0 u0 []
+  (confirmedUtXO, utxoToDecommit) <- splitUTxO u0
+  confirmed <- genConfirmedSnapshot headId 1 confirmedUtXO (Just utxoToDecommit) []
   cctx <- pickChainContext ctx
   let cp = ctxContestationPeriod ctx
   (startSlot, closePointInTime) <- genValidityBoundsFromContestationPeriod cp
@@ -1068,7 +1071,8 @@ genContestTx = do
   let stClosed = snd $ fromJust $ observeClose stOpen txClose
   let utxo = getKnownUTxO stClosed
   someUtxo <- arbitrary
-  contestSnapshot <- genConfirmedSnapshot headId (succ $ number $ getSnapshot confirmed) someUtxo (ctxHydraSigningKeys ctx)
+  (confirmedUTxO', utxoToDecommit') <- splitUTxO someUtxo
+  contestSnapshot <- genConfirmedSnapshot headId (succ $ number $ getSnapshot confirmed) confirmedUTxO' (Just utxoToDecommit') (ctxHydraSigningKeys ctx)
   contestPointInTime <- genPointInTimeBefore (getContestationDeadline stClosed)
   pure (ctx, closePointInTime, stClosed, unsafeContest cctx utxo headId cp contestSnapshot contestPointInTime)
 

diff --git a/hydra-node/src/Hydra/Snapshot.hs b/hydra-node/src/Hydra/Snapshot.hs
@@ -149,7 +149,8 @@ instance IsTx tx => Arbitrary (ConfirmedSnapshot tx) where
     ks <- arbitrary
     utxo <- arbitrary
     headId <- arbitrary
-    genConfirmedSnapshot headId 0 utxo ks
+    -- NOTE: arbitrary instance does not assume any decommits
+    genConfirmedSnapshot headId 0 utxo Nothing ks
 
   shrink = \case
     InitialSnapshot hid sn -> [InitialSnapshot hid sn' | sn' <- shrink sn]
@@ -164,9 +165,10 @@ genConfirmedSnapshot ::
   -- this lower bound.
   SnapshotNumber ->
   UTxOType tx ->
+  Maybe (UTxOType tx) ->
   [SigningKey HydraKey] ->
   Gen (ConfirmedSnapshot tx)
-genConfirmedSnapshot headId minSn utxo sks
+genConfirmedSnapshot headId minSn utxo utxoToDecommit sks
   | minSn > 0 = confirmedSnapshot
   | otherwise =
       frequency
@@ -181,9 +183,7 @@ genConfirmedSnapshot headId minSn utxo sks
     -- FIXME: This is another nail in the coffin to our current modeling of
     -- snapshots
     number <- arbitrary `suchThat` (> minSn)
-    -- TODO: check whether we are fine with this not producing any decommitting utxo ever
-    -- TODO: use splitUTxO generator
-    let snapshot = Snapshot{headId, number, utxo, confirmed = [], utxoToDecommit = mempty}
+    let snapshot = Snapshot{headId, number, utxo, confirmed = [], utxoToDecommit}
     let signatures = aggregate $ fmap (`sign` snapshot) sks
     pure $ ConfirmedSnapshot{snapshot, signatures}