Allow multiple commits

This changes the Redeemer and Datum types of commitTx to be [TxOutRef]
instead of Maybe TxOutRef and generalize the checks on- and off-chain to
work on a list of committed UTxO instead of an optional, single one.

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

@@ -307,17 +307,11 @@ commit ctx st utxo = do
   case ownInitial of
     Nothing ->
       Left (CannotFindOwnInitial{knownUTxO = getKnownUTxO st})
-    Just initial ->
-      case UTxO.pairs utxo of
-        [aUTxO] -> do
-          rejectByronAddress aUTxO
-          rejectReferenceScripts aUTxO
-          rejectMoreThanMainnetLimit networkId (snd aUTxO)
-          Right $ commitTx networkId scriptRegistry headId ownParty (Just aUTxO) initial
-        [] -> do
-          Right $ commitTx networkId scriptRegistry headId ownParty Nothing initial
-        _ ->
-          Left (MoreThanOneUTxOCommitted @Tx)
+    Just initial -> do
+      rejectByronAddress utxo
+      rejectReferenceScripts utxo
+      rejectMoreThanMainnetLimit networkId utxo
+      Right $ commitTx networkId scriptRegistry headId ownParty utxo initial
  where
   ChainContext{networkId, ownParty, ownVerificationKey, scriptRegistry} = ctx
 
@@ -343,28 +337,33 @@ commit ctx st utxo = do
       [(AssetName bs, 1)] -> bs == serialiseToRawBytes vkh
       _ -> False
 
-  rejectByronAddress :: (TxIn, TxOut CtxUTxO) -> Either (PostTxError Tx) ()
-  rejectByronAddress = \case
-    (_, TxOut (ByronAddressInEra addr) _ _ _) ->
-      Left (UnsupportedLegacyOutput addr)
-    (_, TxOut ShelleyAddressInEra{} _ _ _) ->
-      Right ()
-
-  rejectReferenceScripts :: (TxIn, TxOut CtxUTxO) -> Either (PostTxError Tx) ()
-  rejectReferenceScripts (_, out) =
-    case txOutReferenceScript out of
-      ReferenceScriptNone -> Right ()
-      ReferenceScript{} -> Left CannotCommitReferenceScript
+  rejectByronAddress :: UTxO -> Either (PostTxError Tx) ()
+  rejectByronAddress u = do
+    forM_ u $ \case
+      (TxOut (ByronAddressInEra addr) _ _ _) ->
+        Left (UnsupportedLegacyOutput addr)
+      (TxOut ShelleyAddressInEra{} _ _ _) ->
+        Right ()
+
+  rejectReferenceScripts :: UTxO -> Either (PostTxError Tx) ()
+  rejectReferenceScripts u =
+    when (any hasReferenceScript u) $
+      Left CannotCommitReferenceScript
+   where
+    hasReferenceScript out =
+      case txOutReferenceScript out of
+        ReferenceScript{} -> True
+        ReferenceScriptNone -> False
 
   -- Rejects outputs with more than 'maxMainnetLovelace' lovelace on mainnet
   -- NOTE: Remove this limit once we have more experiments on mainnet.
-  rejectMoreThanMainnetLimit :: NetworkId -> TxOut CtxUTxO -> Either (PostTxError Tx) ()
-  rejectMoreThanMainnetLimit network output =
+  rejectMoreThanMainnetLimit :: NetworkId -> UTxO -> Either (PostTxError Tx) ()
+  rejectMoreThanMainnetLimit network u = do
     when (network == Mainnet && lovelaceAmt > maxMainnetLovelace) $
       Left $
         CommittedTooMuchADAForMainnet lovelaceAmt maxMainnetLovelace
    where
-    lovelaceAmt = selectLovelace (txOutValue output)
+    lovelaceAmt = foldMap (selectLovelace . txOutValue) u
 
 -- | Construct a collect transaction based on the 'InitialState'. This will
 -- reimburse all the already committed outputs.

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

@@ -170,9 +170,8 @@ commitTx ::
   ScriptRegistry ->
   HeadId ->
   Party ->
-  -- | A single UTxO to commit to the Head
-  -- We currently limit committing one UTxO to the head because of size limitations.
-  Maybe (TxIn, TxOut CtxUTxO) ->
+  -- | The UTxO to commit to the Head
+  UTxO ->
   -- | The initial output (sent to each party) which should contain the PT and is
   -- locked by initial script
   (TxIn, TxOut CtxUTxO, Hash PaymentKey) ->
@@ -182,7 +181,7 @@ commitTx networkId scriptRegistry headId party utxo (initialInput, out, vkh) =
     emptyTxBody
       & addInputs [(initialInput, initialWitness)]
       & addReferenceInputs [initialScriptRef]
-      & addVkInputs (maybeToList mCommittedInput)
+      & addVkInputs committedTxIns
       & addExtraRequiredSigners [vkh]
       & addOutputs [commitOutput]
  where
@@ -198,29 +197,26 @@ commitTx networkId scriptRegistry headId party utxo (initialInput, out, vkh) =
     mkScriptDatum $ Initial.datum (headIdToCurrencySymbol headId)
   initialRedeemer =
     toScriptData . Initial.redeemer $
-      Initial.ViaCommit (toPlutusTxOutRef <$> mCommittedInput)
-  mCommittedInput =
-    fst <$> utxo
+      Initial.ViaCommit (toPlutusTxOutRef <$> committedTxIns)
+  committedTxIns =
+    Set.toList $ UTxO.inputSet utxo
   commitOutput =
     TxOut commitAddress commitValue commitDatum ReferenceScriptNone
   commitScript =
     fromPlutusScript Commit.validatorScript
   commitAddress =
     mkScriptAddress @PlutusScriptV2 networkId commitScript
   commitValue =
-    txOutValue out <> maybe mempty (txOutValue . snd) utxo
+    txOutValue out <> foldMap txOutValue utxo
   commitDatum =
     mkTxOutDatum $ mkCommitDatum party utxo (headIdToCurrencySymbol headId)
 
-mkCommitDatum :: Party -> Maybe (TxIn, TxOut CtxUTxO) -> CurrencySymbol -> Plutus.Datum
+mkCommitDatum :: Party -> UTxO -> CurrencySymbol -> Plutus.Datum
 mkCommitDatum party utxo headId =
-  Commit.datum (partyToChain party, serializedUTxO, headId)
+  Commit.datum (partyToChain party, commits, headId)
  where
-  serializedUTxO = case utxo of
-    Nothing ->
-      Nothing
-    Just (i, o) ->
-      Commit.serializeCommit (i, o)
+  commits =
+    mapMaybe Commit.serializeCommit $ UTxO.pairs utxo
 
 -- | Create a transaction collecting all "committed" utxo and opening a Head,
 -- i.e. driving the Head script state.
@@ -274,14 +270,13 @@ collectComTx networkId scriptRegistry vk initialThreadOutput commits headId =
         , headId = headIdToCurrencySymbol headId
         }
 
-  extractCommit d =
+  extractCommits d =
     case fromScriptData d of
       Nothing -> error "SNAFU"
-      Just ((_, Just o, _) :: Commit.DatumType) -> Just o
-      _ -> Nothing
+      Just ((_, cs, _) :: Commit.DatumType) -> cs
 
   utxoHash =
-    Head.hashPreSerializedCommits $ mapMaybe (extractCommit . snd . snd) $ Map.toList commits
+    Head.hashPreSerializedCommits $ foldMap (extractCommits . snd . snd) $ Map.toList commits
 
   mkCommit (commitInput, (_commitOutput, commitDatum)) =
     ( commitInput
@@ -774,22 +769,21 @@ observeCommitTx ::
   Maybe CommitObservation
 observeCommitTx networkId initials tx = do
   initialTxIn <- findInitialTxIn
-  mCommittedTxIn <- decodeInitialRedeemer initialTxIn
+  committedTxIns <- decodeInitialRedeemer initialTxIn
 
   (commitIn, commitOut) <- findTxOutByAddress commitAddress tx
   dat <- txOutScriptData commitOut
-  (onChainParty, onChainCommit, _headId) :: Commit.DatumType <- fromScriptData dat
+  (onChainParty, onChainCommits, _headId) :: Commit.DatumType <- fromScriptData dat
   party <- partyFromChain onChainParty
 
-  committed <-
+  committed <- do
     -- TODO: We could simplify this by just using the datum. However, we would
     -- need to ensure the commit is belonging to a head / is rightful. By just
     -- looking for some known initials we achieve this (a bit complicated) now.
-    case (mCommittedTxIn, onChainCommit >>= Commit.deserializeCommit (networkIdToNetwork networkId)) of
-      (Nothing, Nothing) -> Just mempty
-      (Just i, Just (_i, o)) -> Just $ UTxO.singleton (i, o)
-      (Nothing, Just{}) -> error "found commit with no redeemer out ref but with serialized output."
-      (Just{}, Nothing) -> error "found commit with redeemer out ref but with no serialized output."
+    committedUTxO <- traverse (Commit.deserializeCommit (networkIdToNetwork networkId)) onChainCommits
+    when (map fst committedUTxO /= committedTxIns) $
+      error "TODO: commit redeemer not matching the serialized commits in commit datum"
+    pure . UTxO.fromPairs $ committedUTxO
 
   pure
     CommitObservation
@@ -807,8 +801,8 @@ observeCommitTx networkId initials tx = do
     findRedeemerSpending tx >=> \case
       Initial.ViaAbort ->
         Nothing
-      Initial.ViaCommit{committedRef} ->
-        Just (fromPlutusTxOutRef <$> committedRef)
+      Initial.ViaCommit{committedRefs} ->
+        Just (fromPlutusTxOutRef <$> committedRefs)
 
   commitAddress = mkScriptAddress @PlutusScriptV2 networkId commitScript
 

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

@@ -76,7 +76,7 @@ deserializeCommit network Commit{input, preSerializedOutput} =
 -- TODO: Party is not used on-chain but is needed off-chain while it's still
 -- based on mock crypto. When we move to real crypto we could simply use
 -- the PT's token name to identify the committing party
-type DatumType = (Party, Maybe Commit, CurrencySymbol)
+type DatumType = (Party, [Commit], CurrencySymbol)
 type RedeemerType = CommitRedeemer
 
 -- | The v_commit validator verifies that:

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

@@ -114,31 +114,20 @@ checkAbort ctx@ScriptContext{scriptContextTxInfo = txInfo} headCurrencySymbol pa
     -- correspond to the number of commit inputs to make sure everything is
     -- reimbursed because we assume the outputs are correctly sorted with
     -- reimbursed commits coming first
-    hashTxOuts $ take (length commited) (txInfoOutputs txInfo)
+    hashTxOuts $ take (length committed) (txInfoOutputs txInfo)
 
   hashOfCommittedUTxO =
-    hashPreSerializedCommits commited
+    hashPreSerializedCommits committed
 
-  commited = committedUTxO [] (txInfoInputs txInfo)
+  committed = committedUTxO [] (txInfoInputs txInfo)
 
   committedUTxO commits = \case
-    [] ->
-      commits
+    [] -> commits
     TxInInfo{txInInfoResolved = txOut} : rest
       | hasPT headCurrencySymbol txOut ->
-          case commitDatum txInfo txOut of
-            Just commit ->
-              committedUTxO
-                (commit : commits)
-                rest
-            Nothing ->
-              committedUTxO
-                commits
-                rest
+          committedUTxO (commitDatum txInfo txOut <> commits) rest
       | otherwise ->
-          committedUTxO
-            commits
-            rest
+          committedUTxO commits rest
 
 -- | On-Chain verification for 'CollectCom' transition. It verifies that:
 --
@@ -222,26 +211,22 @@ checkCollectCom ctx@ScriptContext{scriptContextTxInfo = txInfo} (contestationPer
     | isHeadOutput txInInfoResolved =
         (commits, nCommits, notCollected)
     | hasPT headId txInInfoResolved =
-        case commitDatum txInfo txInInfoResolved of
-          Just commit@Commit{} ->
-            (commit : commits, succ nCommits, notCollected)
-          Nothing ->
-            (commits, succ nCommits, notCollected)
+        (commitDatum txInfo txInInfoResolved <> commits, succ nCommits, notCollected)
     | otherwise =
         (commits, nCommits, notCollected <> txOutValue txInInfoResolved)
 
   isHeadOutput txOut = txOutAddress txOut == headAddress
 {-# INLINEABLE checkCollectCom #-}
 
 -- | Try to find the commit datum in the input and
--- if it is there return the commited utxo
-commitDatum :: TxInfo -> TxOut -> Maybe Commit
+-- if it is there return the committed utxo
+commitDatum :: TxInfo -> TxOut -> [Commit]
 commitDatum txInfo input = do
   let datum = findTxOutDatum txInfo input
   case fromBuiltinData @Commit.DatumType $ getDatum datum of
-    Just (_party, commit, _headId) ->
-      commit
-    Nothing -> Nothing
+    Just (_party, commits, _headId) ->
+      commits
+    Nothing -> []
 {-# INLINEABLE commitDatum #-}
 
 -- | The close validator must verify that:

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

@@ -34,7 +34,7 @@ import PlutusLedgerApi.V2 (
   ScriptHash,
   ToData (toBuiltinData),
   TokenName (unTokenName),
-  TxInInfo (txInInfoResolved),
+  TxInInfo (..),
   TxOut (txOutValue),
   TxOutRef,
   Value (getValue),
@@ -47,7 +47,7 @@ import qualified PlutusTx.Builtins as Builtins
 data InitialRedeemer
   = ViaAbort
   | ViaCommit
-      { committedRef :: Maybe TxOutRef
+      { committedRefs :: [TxOutRef]
       -- ^ Points to the committed Utxo.
       }
 
@@ -80,18 +80,18 @@ validator commitValidator headId red context =
       traceIfFalse
         $(errorCode STNotBurned)
         (mustBurnST (txInfoMint $ scriptContextTxInfo context) headId)
-    ViaCommit{committedRef} ->
-      checkCommit commitValidator headId committedRef context
+    ViaCommit{committedRefs} ->
+      checkCommit commitValidator headId committedRefs context
 
 checkCommit ::
   -- | Hash of the commit validator
   ScriptHash ->
   -- | Head id
   CurrencySymbol ->
-  Maybe TxOutRef ->
+  [TxOutRef] ->
   ScriptContext ->
   Bool
-checkCommit commitValidator headId committedRef context =
+checkCommit commitValidator headId committedRefs context =
   checkCommittedValue
     && checkLockedCommit
     && checkHeadId
@@ -103,17 +103,20 @@ checkCommit commitValidator headId committedRef context =
       lockedValue == initialValue + committedValue
 
   checkLockedCommit =
-    case (committedTxOut, lockedCommit) of
-      (Nothing, Nothing) ->
+    traceIfFalse $(errorCode MismatchCommittedTxOutInDatum) $
+      go (committedUTxO, lockedCommits)
+   where
+    go = \case
+      ([], []) ->
         True
-      (Nothing, Just{}) ->
+      ([], (_ : _)) ->
         traceError $(errorCode NothingCommittedButTxOutInOutputDatum)
-      (Just{}, Nothing) ->
+      ((_ : _), []) ->
         traceError $(errorCode CommittedTxOutButNothingInOutputDatum)
-      (Just (ref, txOut), Just Commit{input, preSerializedOutput}) ->
-        traceIfFalse $(errorCode MismatchCommittedTxOutInDatum) $
-          Builtins.serialiseData (toBuiltinData txOut) == preSerializedOutput
-            && ref == input
+      (TxInInfo{txInInfoOutRef, txInInfoResolved} : restCommitted, Commit{input, preSerializedOutput} : restCommits) ->
+        Builtins.serialiseData (toBuiltinData txInInfoResolved) == preSerializedOutput
+          && txInInfoOutRef == input
+          && go (restCommitted, restCommits)
 
   checkHeadId =
     traceIfFalse $(errorCode WrongHeadIdInCommitDatum) $
@@ -140,15 +143,17 @@ checkCommit commitValidator headId committedRef context =
     maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput context
 
   committedValue =
-    maybe mempty (txOutValue . snd) committedTxOut
+    foldMap (txOutValue . txInInfoResolved) committedUTxO
 
-  committedTxOut = do
-    ref <- committedRef
-    (ref,) . txInInfoResolved <$> findTxInByTxOutRef ref txInfo
+  committedUTxO = do
+    flip fmap committedRefs $ \ref ->
+      case findTxInByTxOutRef ref txInfo of
+        Nothing -> traceError "outref not found"
+        Just txInInfo -> txInInfo
 
   lockedValue = valueLockedBy txInfo commitValidator
 
-  (lockedCommit, headId') =
+  (lockedCommits, headId') =
     case scriptOutputsAt commitValidator txInfo of
       [(dat, _)] ->
         case dat of
@@ -160,8 +165,8 @@ checkCommit commitValidator headId committedRef context =
               Just da ->
                 case fromBuiltinData @Commit.DatumType $ getDatum da of
                   Nothing -> traceError $(errorCode ExpectedCommitDatumTypeGotSomethingElse)
-                  Just (_party, mCommit, hid) ->
-                    (mCommit, hid)
+                  Just (_party, commits, hid) ->
+                    (commits, hid)
       _ -> traceError $(errorCode ExpectedSingleCommitOutput)
 
   ScriptContext{scriptContextTxInfo = txInfo} = context