Refactor contest with IncrementalAction and fix the contestcurrent

mutation
cardano-scaling · Dec 18, 2024 · ccf49b6 · ccf49b6
1 parent eed7b5c
commit ccf49b6
Show file tree

Hide file tree

Showing 3 changed files with 42 additions and 69 deletions.
diff --git a/hydra-tx/src/Hydra/Tx/Contest.hs b/hydra-tx/src/Hydra/Tx/Contest.hs
@@ -24,6 +24,7 @@ import Hydra.Tx.IsTx (hashUTxO)
 import Hydra.Tx.ScriptRegistry (ScriptRegistry, headReference)
 import Hydra.Tx.Snapshot (Snapshot (..), SnapshotVersion)
 
+import Hydra.Tx.Fanout (IncrementalAction (..), setIncrementalAction)
 import Hydra.Tx.Utils (mkHydraHeadV1TxName)
 import PlutusLedgerApi.V3 (toBuiltin)
 import PlutusLedgerApi.V3 qualified as Plutus
@@ -137,40 +138,29 @@ contestTx scriptRegistry vk headId contestationPeriod openVersion snapshot sig (
 
 setContestRedeemer :: Snapshot Tx -> SnapshotVersion -> MultiSignature (Snapshot Tx) -> Head.ContestRedeemer
 setContestRedeemer Snapshot{version, utxoToCommit, utxoToDecommit} openVersion sig =
-  if version == openVersion
-    then
-      if
-        | isJust utxoToDecommit ->
+  let incrementalAction = setIncrementalAction utxoToCommit utxoToDecommit
+   in if version == openVersion
+        then case incrementalAction of
+          Just (ToCommit utxo') ->
+            Head.ContestUnusedInc
+              { signature = toPlutusSignatures sig
+              , alreadyCommittedUTxOHash = toBuiltin $ hashUTxO utxo'
+              }
+          Just (ToDecommit _) ->
             Head.ContestUnusedDec
               { signature = toPlutusSignatures sig
               }
-        | isJust utxoToCommit ->
-            Head.ContestUnusedInc
+          Just NoThing -> Head.ContestCurrent{signature = toPlutusSignatures sig}
+          Nothing -> Head.ContestCurrent{signature = toPlutusSignatures sig}
+        else case incrementalAction of
+          Just (ToCommit _) ->
+            Head.ContestUsedInc
               { signature = toPlutusSignatures sig
-              , alreadyCommittedUTxOHash = toBuiltin . hashUTxO $ fromMaybe mempty utxoToCommit
               }
-        | isNothing utxoToCommit
-        , isNothing utxoToDecommit ->
-            Head.ContestCurrent
+          Just (ToDecommit utxo') ->
+            Head.ContestUsedDec
               { signature = toPlutusSignatures sig
+              , alreadyDecommittedUTxOHash = toBuiltin $ hashUTxO utxo'
               }
-        | otherwise -> error "contestTx: unexpected to have both utxo to commit and decommit in the same snapshot."
-    else case (isJust utxoToCommit, isJust utxoToDecommit) of
-      (True, False) ->
-        Head.ContestUsedInc
-          { signature = toPlutusSignatures sig
-          }
-      (False, True) ->
-        Head.ContestUsedDec
-          { signature = toPlutusSignatures sig
-          , alreadyDecommittedUTxOHash = toBuiltin . hashUTxO $ fromMaybe mempty utxoToDecommit
-          }
-      (False, False) ->
-        -- NOTE: here the assumption is: if your snapshot doesn't
-        -- contain anything to de/commit then it must mean that we
-        -- either already have seen it happen (which would even out the
-        -- two versions) or this is a _normal_ snapshot so the version
-        -- is not _bumped_ further anyway and it needs to be the same
-        -- between snapshot and the open state version.
-        error $ "contestTx: both commit and decommit utxo empty but version not the same! snapshot version: " <> show version <> " open version: " <> show openVersion
-      (True, True) -> error "contestTx: unexpected to have both utxo to commit and decommit in the same snapshot."
+          Just NoThing -> Head.ContestCurrent{signature = toPlutusSignatures sig}
+          Nothing -> Head.ContestCurrent{signature = toPlutusSignatures sig}
diff --git a/hydra-tx/test/Hydra/Tx/Contract/Contest/ContestCurrent.hs b/hydra-tx/test/Hydra/Tx/Contract/Contest/ContestCurrent.hs
@@ -151,7 +151,7 @@ genContestMutation (tx, _utxo) =
     [ SomeMutation (pure $ toErrorCode NotPayingToHead) NotContinueContract <$> do
         mutatedAddress <- genAddressInEra testNetworkId
         pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut)
-    , SomeMutation (pure $ toErrorCode SignatureVerificationFailed) MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do
+    , SomeMutation (pure $ toErrorCode FailedContestCurrent) MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do
         mutatedSignature <- arbitrary :: Gen (MultiSignature (Snapshot Tx))
         pure $
           Head.Contest
@@ -182,6 +182,27 @@ genContestMutation (tx, _utxo) =
     , SomeMutation (pure $ toErrorCode SignerIsNotAParticipant) MutateRequiredSigner <$> do
         newSigner <- verificationKeyHash <$> genVerificationKey `suchThat` (/= healthyContesterVerificationKey)
         pure $ ChangeRequiredSigners [newSigner]
+    , -- REVIEW: This is a bit confusing and not giving much value. Maybe we can remove this.
+      -- This also seems to be covered by MutateRequiredSigner
+      SomeMutation (pure $ toErrorCode FailedContestCurrent) ContestFromDifferentHead <$> do
+        otherHeadId <- headPolicyId <$> arbitrary `suchThat` (/= healthyClosedHeadTxIn)
+        pure $
+          Changes
+            [ ChangeOutput 0 (replacePolicyIdWith testPolicyId otherHeadId headTxOut)
+            , ChangeInput
+                healthyClosedHeadTxIn
+                (replacePolicyIdWith testPolicyId otherHeadId healthyClosedHeadTxOut)
+                ( Just $
+                    toScriptData
+                      ( Head.Contest
+                          Head.ContestCurrent
+                            { signature =
+                                toPlutusSignatures $
+                                  healthySignature healthyContestSnapshotNumber
+                            }
+                      )
+                )
+            ]
     , SomeMutation (pure $ toErrorCode NoSigners) MutateNoRequiredSigner <$> do
         pure $ ChangeRequiredSigners []
     , SomeMutation (pure $ toErrorCode TooManySigners) MutateMultipleRequiredSigner <$> do
@@ -208,27 +229,6 @@ genContestMutation (tx, _utxo) =
         lb <- arbitrary
         ub <- TxValidityUpperBound <$> arbitrary `suchThat` slotOverContestationDeadline
         pure (lb, ub)
-    , -- REVIEW: This is a bit confusing and not giving much value. Maybe we can remove this.
-      -- This also seems to be covered by MutateRequiredSigner
-      SomeMutation (pure $ toErrorCode SignerIsNotAParticipant) ContestFromDifferentHead <$> do
-        otherHeadId <- headPolicyId <$> arbitrary `suchThat` (/= healthyClosedHeadTxIn)
-        pure $
-          Changes
-            [ ChangeOutput 0 (replacePolicyIdWith testPolicyId otherHeadId headTxOut)
-            , ChangeInput
-                healthyClosedHeadTxIn
-                (replacePolicyIdWith testPolicyId otherHeadId healthyClosedHeadTxOut)
-                ( Just $
-                    toScriptData
-                      ( Head.Contest
-                          Head.ContestCurrent
-                            { signature =
-                                toPlutusSignatures $
-                                  healthySignature healthyContestSnapshotNumber
-                            }
-                      )
-                )
-            ]
     , SomeMutation (pure $ toErrorCode MintingOrBurningIsForbidden) MutateTokenMintingOrBurning
         <$> (changeMintedTokens tx =<< genMintedOrBurnedValue)
     , SomeMutation (pure $ toErrorCode SignerAlreadyContested) MutateInputContesters . ChangeInputHeadDatum <$> do

diff --git a/hydra-tx/testlib/Test/Hydra/Tx/Mutation.hs b/hydra-tx/testlib/Test/Hydra/Tx/Mutation.hs
@@ -857,23 +857,6 @@ replaceUTxOHash utxoHash = \case
         }
   otherState -> otherState
 
-replaceAlphaUTxOHash :: Head.Hash -> Head.State -> Head.State
-replaceAlphaUTxOHash alphaUTxOHash' = \case
-  Head.Closed Head.ClosedDatum{parties, utxoHash, omegaUTxOHash, snapshotNumber, contestationDeadline, headId, contesters, contestationPeriod, version} ->
-    Head.Closed
-      Head.ClosedDatum
-        { Head.parties = parties
-        , Head.snapshotNumber = snapshotNumber
-        , Head.utxoHash
-        , Head.alphaUTxOHash = alphaUTxOHash'
-        , Head.omegaUTxOHash = omegaUTxOHash
-        , Head.contestationDeadline = contestationDeadline
-        , Head.contestationPeriod = contestationPeriod
-        , Head.headId = headId
-        , Head.contesters = contesters
-        , Head.version = version
-        }
-  otherState -> otherState
 replaceOmegaUTxOHash :: Head.Hash -> Head.State -> Head.State
 replaceOmegaUTxOHash omegaUTxOHash' = \case
   Head.Closed Head.ClosedDatum{parties, utxoHash, alphaUTxOHash, snapshotNumber, contestationDeadline, headId, contesters, contestationPeriod, version} ->