Fix CollectCom to ensure it collects all value

We seemingly have dropped this technique accidentially. Instead of
checking the head output value against all the collected value, we would
check the other inputs & outputs balance. This is more efficient as we
usually have a more constant number of inputs and outputs to pay for
fees / get change in return.

hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs

@@ -175,6 +175,8 @@ healthyCommitOutput party committed =
 data CollectComMutation
   = -- | Ensures collectCom does not allow any output address but νHead.
     NotContinueContract
+  | -- | Needs to prevent that not all value is collected into the head output.
+    ExtractSomeValue
   | MutateOpenUTxOHash
   | -- | Ensures collectCom cannot collect from an initial UTxO.
     MutateCommitToInitial
@@ -197,6 +199,21 @@ genCollectComMutation (tx, _utxo) =
     [ SomeMutation (Just $ toErrorCode NotPayingToHead) NotContinueContract <$> do
         mutatedAddress <- genAddressInEra testNetworkId
         pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut)
+    , SomeMutation (Just $ toErrorCode NotAllValueCollected) ExtractSomeValue <$> do
+        -- Remove one lovelace from headOutput, i.e. to "collect dust"
+        -- TODO: select a random asset and amount
+        let removedValue = lovelaceToValue 1
+        -- Add another output which would extract the 'removedValue'. The ledger
+        -- would check for this, and this is needed because the way we implement
+        -- collectCom checks.
+        extractionTxOut <- do
+          someAddress <- genAddressInEra testNetworkId
+          pure $ TxOut someAddress removedValue TxOutDatumNone ReferenceScriptNone
+        pure $
+          Changes
+            [ ChangeOutput 0 $ modifyTxOutValue (\v -> v <> negateValue removedValue) headTxOut
+            , AddOutput extractionTxOut
+            ]
     , SomeMutation (Just $ toErrorCode IncorrectUtxoHash) MutateOpenUTxOHash . ChangeOutput 0 <$> mutateUTxOHash
     , SomeMutation (Just $ toErrorCode MissingCommits) MutateNumberOfParties <$> do
         moreParties <- (: healthyOnChainParties) <$> arbitrary
@@ -206,6 +223,9 @@ genCollectComMutation (tx, _utxo) =
             , ChangeOutput 0 $ mutatedPartiesHeadTxOut moreParties headTxOut
             ]
     , SomeMutation (Just $ toErrorCode STNotSpent) MutateHeadId <$> do
+        -- XXX: This mutation is unrealistic. It would only change the headId in
+        -- the value, but not in the datum. This is not allowed by the protocol
+        -- prior to this transaction.
         illedHeadResolvedInput <-
           mkHeadOutput
             <$> pure testNetworkId

hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs

@@ -265,8 +265,10 @@ data Mutation
     -- both the 'DatumHash' in the UTxO context and the map of 'DatumHash' to
     -- 'Datum' in the transaction's witnesses.
     ChangeInputHeadDatum Head.State
-  | -- | Adds given output to the transaction's outputs.
+  | -- | Adds given output as first transaction output.
     PrependOutput (TxOut CtxTx)
+  | -- | Adds given output as last transaction output.
+    AddOutput (TxOut CtxTx)
   | -- | Removes given output from the transaction's outputs.
     RemoveOutput Word
   | -- | Drops the given input from the transaction's inputs
@@ -349,6 +351,10 @@ applyMutation mutation (tx@(Tx body wits), utxo) = case mutation of
     ( alterTxOuts (txOut :) tx
     , utxo
     )
+  AddOutput txOut ->
+    ( alterTxOuts (<> [txOut]) tx
+    , utxo
+    )
   RemoveOutput ix ->
     ( alterTxOuts (removeAt ix) tx
     , utxo

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

@@ -158,13 +158,14 @@ checkCollectCom ::
   (ContestationPeriod, [Party], CurrencySymbol) ->
   Bool
 checkCollectCom ctx@ScriptContext{scriptContextTxInfo = txInfo} (contestationPeriod, parties, headId) =
-  mustNotMintOrBurn txInfo
-    && mustCollectUtxoHash
+  mustCollectUtxoHash
     && mustNotChangeParameters
+    && mustCollectAllValue
+    -- XXX: Is this really needed? If yes, why not check on the output?
+    && traceIfFalse $(errorCode STNotSpent) (hasST headId val)
     && everyoneHasCommitted
     && mustBeSignedByParticipant ctx headId
-    -- FIXME: does not check all value collected
-    && traceIfFalse $(errorCode STNotSpent) (hasST headId val)
+    && mustNotMintOrBurn txInfo
  where
   mustCollectUtxoHash =
     traceIfFalse $(errorCode IncorrectUtxoHash) $
@@ -176,6 +177,14 @@ checkCollectCom ctx@ScriptContext{scriptContextTxInfo = txInfo} (contestationPer
         && contestationPeriod' == contestationPeriod
         && headId' == headId
 
+  mustCollectAllValue =
+    traceIfFalse $(errorCode NotAllValueCollected) $
+      -- NOTE: Instead of checking the head output val' against all collected
+      -- value, we do ensure the output value is all non collected value - fees.
+      -- This makes the script not scale badly with number of participants as it
+      -- would commonly only be a small number of inputs/outputs to pay fees.
+      otherValueOut == notCollectedValueIn - txInfoFee txInfo
+
   (parties', utxoHash, contestationPeriod', headId') =
     -- XXX: fromBuiltinData is super big (and also expensive?)
     case fromBuiltinData @DatumType $ getDatum (headOutputDatum ctx) of
@@ -191,30 +200,37 @@ checkCollectCom ctx@ScriptContext{scriptContextTxInfo = txInfo} (contestationPer
 
   headAddress = getHeadAddress ctx
 
-  val =
-    maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx
-
   everyoneHasCommitted =
     traceIfFalse $(errorCode MissingCommits) $
       nTotalCommits == length parties
 
-  (collectedCommits, nTotalCommits) =
+  val = maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx
+
+  otherValueOut =
+    case txInfoOutputs txInfo of
+      -- NOTE: First output must be head output
+      (_ : rest) -> foldMap txOutValue rest
+      _ -> mempty
+
+  -- NOTE: We do keep track of the value we do not want to collect as this is
+  -- typically less, ideally only a single other input with only ADA in it.
+  (collectedCommits, nTotalCommits, notCollectedValueIn) =
     foldr
       extractAndCountCommits
-      ([], 0)
+      ([], 0, mempty)
       (txInfoInputs txInfo)
 
-  extractAndCountCommits TxInInfo{txInInfoResolved} (commits, nCommits)
+  extractAndCountCommits TxInInfo{txInInfoResolved} (commits, nCommits, notCollected)
     | isHeadOutput txInInfoResolved =
-      (commits, nCommits)
+      (commits, nCommits, notCollected)
     | hasPT headId txInInfoResolved =
       case commitDatum txInfo txInInfoResolved of
         Just commit@Commit{} ->
-          (commit : commits, succ nCommits)
+          (commit : commits, succ nCommits, notCollected)
         Nothing ->
-          (commits, succ nCommits)
+          (commits, succ nCommits, notCollected)
     | otherwise =
-      (commits, nCommits)
+      (commits, nCommits, notCollected <> txOutValue txInInfoResolved)
 
   isHeadOutput txOut = txOutAddress txOut == headAddress
 {-# INLINEABLE checkCollectCom #-}
@@ -261,8 +277,6 @@ checkClose ctx parties initialUtxoHash sig cperiod headPolicyId =
     && checkSnapshot
     && mustBeSignedByParticipant ctx headPolicyId
     && mustInitializeContesters
-    -- XXX: missing to trace for this error code
-    && hasST headPolicyId val
     && mustPreserveValue
     && mustNotChangeParameters
  where
@@ -370,11 +384,6 @@ checkContest ctx contestationDeadline contestationPeriod parties closedSnapshotN
     && checkSignedParticipantContestOnlyOnce
     && mustBeWithinContestationPeriod
     && mustUpdateContesters
-    -- XXX: This check is redundant and can be removed,
-    -- because is enough to check that the value is preserved.
-    -- Remember we are comming from a valid Closed state,
-    -- having already checked that the ST is present.
-    && hasST headId val
     && mustPushDeadline
     && mustNotChangeParameters
     && mustPreserveValue

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

@@ -44,6 +44,7 @@ data HeadError
   | SignatureVerificationFailed
   | PartySignatureVerificationFailed
   | NotPayingToHead
+  | NotAllValueCollected
   deriving (Show)
 
 instance ToErrorCode HeadError where
@@ -87,3 +88,4 @@ instance ToErrorCode HeadError where
     SignatureVerificationFailed -> "H35"
     PartySignatureVerificationFailed -> "H36"
     NotPayingToHead -> "H37"
+    NotAllValueCollected -> "H38"