Simplify close and contest pattern matches

hydra-node/src/Hydra/Chain/Direct/State.hs

@@ -111,13 +111,13 @@ import Hydra.Tx.ContestationPeriod qualified as ContestationPeriod
 import Hydra.Tx.Crypto (HydraKey)
 import Hydra.Tx.Decrement (decrementTx)
 import Hydra.Tx.Deposit (DepositObservation (..), depositTx, observeDepositTx, observeDepositTxOut)
-import Hydra.Tx.Fanout (fanoutTx, setIncrementalAction)
+import Hydra.Tx.Fanout (fanoutTx)
 import Hydra.Tx.Increment (incrementTx)
 import Hydra.Tx.Init (initTx)
 import Hydra.Tx.OnChainId (OnChainId)
 import Hydra.Tx.Recover (recoverTx)
 import Hydra.Tx.Snapshot (genConfirmedSnapshot)
-import Hydra.Tx.Utils (splitUTxO, verificationKeyToOnChainId)
+import Hydra.Tx.Utils (setIncrementalActionMaybe, splitUTxO, verificationKeyToOnChainId)
 import Test.Hydra.Tx.Fixture (depositDeadline, testNetworkId)
 import Test.Hydra.Tx.Gen (
   genOneUTxOFor,
@@ -573,6 +573,7 @@ decrement ctx spendableUTxO headId headParameters decrementingSnapshot = do
 data CloseTxError
   = InvalidHeadIdInClose {headId :: HeadId}
   | CannotFindHeadOutputToClose
+  | BothCommitAndDecommitInClose
   deriving stock (Show)
 
 data RecoverTxError
@@ -644,8 +645,12 @@ close ctx spendableUTxO headId HeadParameters{parties, contestationPeriod} openV
           , openContestationPeriod = ContestationPeriod.toChain contestationPeriod
           , openParties = partyToChain <$> parties
           }
-  pure $ closeTx scriptRegistry ownVerificationKey headId openVersion confirmedSnapshot startSlotNo pointInTime openThreadOutput
+
+  incrementalAction <- setIncrementalActionMaybe utxoToCommit utxoToDecommit ?> BothCommitAndDecommitInClose
+  pure $ closeTx scriptRegistry ownVerificationKey headId openVersion confirmedSnapshot startSlotNo pointInTime openThreadOutput incrementalAction
  where
+  Snapshot{utxoToCommit, utxoToDecommit} = getSnapshot confirmedSnapshot
+
   headScript = fromPlutusScript @PlutusScriptV3 Head.validatorScript
 
   ChainContext{ownVerificationKey, scriptRegistry} = ctx
@@ -657,6 +662,7 @@ data ContestTxError
   | MissingHeadRedeemerInContest
   | WrongDatumInContest
   | FailedToConvertFromScriptDataInContest
+  | BothCommitAndDecommitInContest
   deriving stock (Show)
 
 -- | Construct a contest transaction based on the 'ClosedState' and a confirmed
@@ -684,8 +690,10 @@ contest ctx spendableUTxO headId contestationPeriod openVersion contestingSnapsh
     UTxO.find (isScriptTxOut headScript) (utxoOfThisHead pid spendableUTxO)
       ?> CannotFindHeadOutputToContest
   closedThreadOutput <- checkHeadDatum headUTxO
-  pure $ contestTx scriptRegistry ownVerificationKey headId contestationPeriod openVersion sn sigs pointInTime closedThreadOutput
+  incrementalAction <- setIncrementalActionMaybe utxoToCommit utxoToDecommit ?> BothCommitAndDecommitInContest
+  pure $ contestTx scriptRegistry ownVerificationKey headId contestationPeriod openVersion sn sigs pointInTime closedThreadOutput incrementalAction
  where
+  Snapshot{utxoToCommit, utxoToDecommit} = sn
   checkHeadDatum headUTxO@(_, headOutput) = do
     headDatum <- txOutScriptData (toTxContext headOutput) ?> MissingHeadDatumInContest
     datum <- fromScriptData headDatum ?> FailedToConvertFromScriptDataInContest
@@ -747,7 +755,7 @@ fanout ctx spendableUTxO seedTxIn utxo utxoToCommit utxoToDecommit deadlineSlotN
     UTxO.find (isScriptTxOut headScript) (utxoOfThisHead (headPolicyId seedTxIn) spendableUTxO)
       ?> CannotFindHeadOutputToFanout
   closedThreadUTxO <- checkHeadDatum headUTxO
-  incrementalAction <- setIncrementalAction utxoToCommit utxoToDecommit ?> BothCommitAndDecommitInFanout
+  incrementalAction <- setIncrementalActionMaybe utxoToCommit utxoToDecommit ?> BothCommitAndDecommitInFanout
   pure $ fanoutTx scriptRegistry utxo incrementalAction closedThreadUTxO deadlineSlotNo headTokenScript
  where
   headTokenScript = mkHeadTokenScript seedTxIn

hydra-plutus/src/Hydra/Contract/Head.hs

@@ -457,11 +457,11 @@ checkClose ctx openBefore redeemer =
               parties
               (headId, version - 1, snapshotNumber', utxoHash', emptyHash, alreadyDecommittedUTxOHash)
               signature
-      CloseUnusedInc{signature, alreadyCommittedUTxOHash} ->
+      CloseUnusedInc{signature} ->
         traceIfFalse $(errorCode FailedCloseUnusedInc) $
           verifySnapshotSignature
             parties
-            (headId, version, snapshotNumber', utxoHash', alreadyCommittedUTxOHash, emptyHash)
+            (headId, version, snapshotNumber', utxoHash', emptyHash, emptyHash)
             signature
       CloseUsedInc{signature, alreadyCommittedUTxOHash} ->
         traceIfFalse $(errorCode FailedCloseUsedInc) $

hydra-plutus/src/Hydra/Contract/HeadState.hs

@@ -102,14 +102,13 @@ data CloseRedeemer
     CloseUnusedInc
       { signature :: [Signature]
       -- ^ Multi-signature of a snapshot ξ
-      , alreadyCommittedUTxOHash :: Hash
-      -- ^ UTxO which was already committed ηα
       }
   | -- | Closing snapshot refers to the previous state version
     CloseUsedInc
       { signature :: [Signature]
-      , alreadyCommittedUTxOHash :: Hash
       -- ^ Multi-signature of a snapshot ξ
+      , alreadyCommittedUTxOHash :: Hash
+      -- ^ UTxO which was already committed ηα
       }
   deriving stock (Show, Generic)
 

hydra-tx/src/Hydra/Tx/Close.hs

@@ -34,8 +34,7 @@ import Hydra.Tx (
  )
 import Hydra.Tx.Contest (PointInTime)
 import Hydra.Tx.Crypto (toPlutusSignatures)
-import Hydra.Tx.Fanout (IncrementalAction (..), setIncrementalAction)
-import Hydra.Tx.Utils (mkHydraHeadV1TxName)
+import Hydra.Tx.Utils (IncrementalAction (..), mkHydraHeadV1TxName)
 import PlutusLedgerApi.V3 (toBuiltin)
 
 -- | Representation of the Head output after a CollectCom transaction.
@@ -66,8 +65,9 @@ closeTx ::
   PointInTime ->
   -- | Everything needed to spend the Head state-machine output.
   OpenThreadOutput ->
+  IncrementalAction ->
   Tx
-closeTx scriptRegistry vk headId openVersion confirmedSnapshot startSlotNo (endSlotNo, utcTime) openThreadOutput =
+closeTx scriptRegistry vk headId openVersion confirmedSnapshot startSlotNo (endSlotNo, utcTime) openThreadOutput incrementalAction =
   unsafeBuildTransaction $
     emptyTxBody
       & addInputs [(headInput, headWitness)]
@@ -100,33 +100,28 @@ closeTx scriptRegistry vk headId openVersion confirmedSnapshot startSlotNo (endS
   closeRedeemer =
     case confirmedSnapshot of
       InitialSnapshot{} -> Head.CloseInitial
-      ConfirmedSnapshot{signatures, snapshot = Snapshot{version, utxoToCommit, utxoToDecommit}} ->
-        let incrementalAction = setIncrementalAction utxoToCommit utxoToDecommit
-         in if version == openVersion
-              then case incrementalAction of
-                Just (ToCommit utxo') ->
-                  Head.CloseUnusedInc
-                    { signature = toPlutusSignatures signatures
-                    , alreadyCommittedUTxOHash = toBuiltin $ hashUTxO utxo'
-                    }
-                Just (ToDecommit _) -> Head.CloseUnusedDec{signature = toPlutusSignatures signatures}
-                Just NoThing -> Head.CloseAny{signature = toPlutusSignatures signatures}
-                Nothing -> Head.CloseAny{signature = toPlutusSignatures signatures}
+      ConfirmedSnapshot{signatures, snapshot = Snapshot{version}} ->
+        case incrementalAction of
+          ToCommit utxo' ->
+            if version == openVersion
+              then
+                Head.CloseUnusedInc
+                  { signature = toPlutusSignatures signatures
+                  }
               else
-                -- NOTE: This will only work for version == openVersion - 1
-                case incrementalAction of
-                  Just (ToCommit utxo') ->
-                    Head.CloseUsedInc
-                      { signature = toPlutusSignatures signatures
-                      , alreadyCommittedUTxOHash = toBuiltin $ hashUTxO utxo'
-                      }
-                  Just (ToDecommit utxo') ->
-                    Head.CloseUsedDec
-                      { signature = toPlutusSignatures signatures
-                      , alreadyDecommittedUTxOHash = toBuiltin $ hashUTxO utxo'
-                      }
-                  Just NoThing -> Head.CloseAny{signature = toPlutusSignatures signatures}
-                  Nothing -> Head.CloseAny{signature = toPlutusSignatures signatures}
+                Head.CloseUsedInc
+                  { signature = toPlutusSignatures signatures
+                  , alreadyCommittedUTxOHash = toBuiltin $ hashUTxO utxo'
+                  }
+          ToDecommit utxo' ->
+            if version == openVersion
+              then Head.CloseUnusedDec{signature = toPlutusSignatures signatures}
+              else
+                Head.CloseUsedDec
+                  { signature = toPlutusSignatures signatures
+                  , alreadyDecommittedUTxOHash = toBuiltin $ hashUTxO utxo'
+                  }
+          NoThing -> Head.CloseAny{signature = toPlutusSignatures signatures}
 
   headOutputAfter =
     modifyTxOutDatum (const headDatumAfter) headOutputBefore
@@ -143,7 +138,7 @@ closeTx scriptRegistry vk headId openVersion confirmedSnapshot startSlotNo (endS
               case closeRedeemer of
                 Head.CloseUsedInc{} ->
                   toBuiltin . hashUTxO @Tx . fromMaybe mempty . utxoToCommit $ getSnapshot confirmedSnapshot
-                Head.CloseUnusedInc{alreadyCommittedUTxOHash} -> alreadyCommittedUTxOHash
+                Head.CloseUnusedInc{} -> toBuiltin $ hashUTxO @Tx mempty
                 _ -> toBuiltin $ hashUTxO @Tx mempty
           , omegaUTxOHash =
               case closeRedeemer of

hydra-tx/src/Hydra/Tx/Contest.hs

@@ -24,8 +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 Hydra.Tx.Utils (IncrementalAction (..), mkHydraHeadV1TxName)
 import PlutusLedgerApi.V3 (toBuiltin)
 import PlutusLedgerApi.V3 qualified as Plutus
 
@@ -61,8 +60,9 @@ contestTx ::
   PointInTime ->
   -- | Everything needed to spend the Head state-machine output.
   ClosedThreadOutput ->
+  IncrementalAction ->
   Tx
-contestTx scriptRegistry vk headId contestationPeriod openVersion snapshot sig (slotNo, _) closedThreadOutput =
+contestTx scriptRegistry vk headId contestationPeriod openVersion snapshot sig (slotNo, _) closedThreadOutput incrementalAction =
   unsafeBuildTransaction $
     emptyTxBody
       & addInputs [(headInput, headWitness)]
@@ -72,7 +72,7 @@ contestTx scriptRegistry vk headId contestationPeriod openVersion snapshot sig (
       & setValidityUpperBound slotNo
       & setTxMetadata (TxMetadataInEra $ mkHydraHeadV1TxName "ContestTx")
  where
-  Snapshot{number, utxo, utxoToCommit, utxoToDecommit} = snapshot
+  Snapshot{number, version, utxo, utxoToCommit, utxoToDecommit} = snapshot
 
   ClosedThreadOutput
     { closedThreadUTxO = (headInput, headOutputBefore)
@@ -92,7 +92,31 @@ contestTx scriptRegistry vk headId contestationPeriod openVersion snapshot sig (
   headScript =
     fromPlutusScript @PlutusScriptV3 Head.validatorScript
 
-  contestRedeemer = setContestRedeemer snapshot openVersion sig
+  contestRedeemer =
+    case incrementalAction of
+      ToCommit utxo' ->
+        if version == openVersion
+          then
+            Head.ContestUnusedInc
+              { signature = toPlutusSignatures sig
+              , alreadyCommittedUTxOHash = toBuiltin $ hashUTxO utxo'
+              }
+          else
+            Head.ContestUsedInc
+              { signature = toPlutusSignatures sig
+              }
+      ToDecommit utxo' ->
+        if version == openVersion
+          then
+            Head.ContestUnusedDec
+              { signature = toPlutusSignatures sig
+              }
+          else
+            Head.ContestUsedDec
+              { signature = toPlutusSignatures sig
+              , alreadyDecommittedUTxOHash = toBuiltin $ hashUTxO utxo'
+              }
+      NoThing -> Head.ContestCurrent{signature = toPlutusSignatures sig}
 
   headRedeemer = toScriptData $ Head.Contest contestRedeemer
 
@@ -135,32 +159,3 @@ contestTx scriptRegistry vk headId contestationPeriod openVersion snapshot sig (
           , contesters = contester : closedContesters
           , version = toInteger openVersion
           }
-
-setContestRedeemer :: Snapshot Tx -> SnapshotVersion -> MultiSignature (Snapshot Tx) -> Head.ContestRedeemer
-setContestRedeemer Snapshot{version, utxoToCommit, utxoToDecommit} openVersion sig =
-  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
-              }
-          Just NoThing -> Head.ContestCurrent{signature = toPlutusSignatures sig}
-          Nothing -> Head.ContestCurrent{signature = toPlutusSignatures sig}
-        else case incrementalAction of
-          Just (ToCommit _) ->
-            Head.ContestUsedInc
-              { signature = toPlutusSignatures sig
-              }
-          Just (ToDecommit utxo') ->
-            Head.ContestUsedDec
-              { signature = toPlutusSignatures sig
-              , alreadyDecommittedUTxOHash = toBuiltin $ hashUTxO utxo'
-              }
-          Just NoThing -> Head.ContestCurrent{signature = toPlutusSignatures sig}
-          Nothing -> Head.ContestCurrent{signature = toPlutusSignatures sig}

hydra-tx/src/Hydra/Tx/Fanout.hs

@@ -16,18 +16,7 @@ import Hydra.Ledger.Cardano.Builder (
   unsafeBuildTransaction,
  )
 import Hydra.Tx.ScriptRegistry (ScriptRegistry (..))
-import Hydra.Tx.Utils (headTokensFromValue, mkHydraHeadV1TxName)
-
-data IncrementalAction = ToCommit UTxO | ToDecommit UTxO | NoThing deriving (Eq, Show)
-
-setIncrementalAction :: Maybe UTxO -> Maybe UTxO -> Maybe IncrementalAction
-setIncrementalAction utxoToCommit utxoToDecommit =
-  case (utxoToCommit, utxoToDecommit) of
-    (Just _, Just _) -> Nothing
-    (Just _, Nothing) ->
-      ToCommit <$> utxoToCommit
-    (Nothing, Just _) -> ToDecommit <$> utxoToDecommit
-    (Nothing, Nothing) -> Just NoThing
+import Hydra.Tx.Utils (IncrementalAction (..), headTokensFromValue, mkHydraHeadV1TxName)
 
 -- | Create the fanout transaction, which distributes the closed state
 -- accordingly. The head validator allows fanout only > deadline, so we need

hydra-tx/src/Hydra/Tx/Utils.hs

@@ -91,3 +91,19 @@ parseDatum :: FromScriptData a => TxOut CtxUTxO -> Maybe a
 parseDatum out = do
   headDatum <- txOutScriptData (toTxContext out)
   fromScriptData headDatum
+
+-- | Type to encapsulate one of the two possible incremental actions or a
+-- regular snapshot. This actually signals that our snapshot modeling is likely
+-- not ideal but for now we want to keep track of both fields (de/commit) since
+-- we might want to support batch de/commits too in the future, but having both fields
+-- be Maybe UTxO intruduces a lot of checks if the value is Nothing or mempty.
+data IncrementalAction = ToCommit UTxO | ToDecommit UTxO | NoThing deriving (Eq, Show)
+
+setIncrementalActionMaybe :: Maybe UTxO -> Maybe UTxO -> Maybe IncrementalAction
+setIncrementalActionMaybe utxoToCommit utxoToDecommit =
+  case (utxoToCommit, utxoToDecommit) of
+    (Just _, Just _) -> Nothing
+    (Just _, Nothing) ->
+      ToCommit <$> utxoToCommit
+    (Nothing, Just _) -> ToDecommit <$> utxoToDecommit
+    (Nothing, Nothing) -> Just NoThing

hydra-tx/test/Hydra/Tx/Contract/FanOut.hs

@@ -17,11 +17,11 @@ import Hydra.Ledger.Cardano.Time (slotNoFromUTCTime, slotNoToUTCTime)
 import Hydra.Plutus.Extras (posixFromUTCTime)
 import Hydra.Plutus.Orphans ()
 import Hydra.Tx (registryUTxO)
-import Hydra.Tx.Fanout (IncrementalAction (..), fanoutTx)
+import Hydra.Tx.Fanout (fanoutTx)
 import Hydra.Tx.Init (mkHeadOutput)
 import Hydra.Tx.IsTx (IsTx (hashUTxO))
 import Hydra.Tx.Party (Party, partyToChain, vkey)
-import Hydra.Tx.Utils (adaOnly, splitUTxO)
+import Hydra.Tx.Utils (IncrementalAction (..), adaOnly, splitUTxO)
 import PlutusTx.Builtins (toBuiltin)
 import Test.Hydra.Tx.Fixture (slotLength, systemStart, testNetworkId, testPolicyId, testSeedInput)
 import Test.Hydra.Tx.Gen (genOutput, genScriptRegistry, genUTxOWithSimplifiedAddresses, genValue)