From 290d1b17e9224dfcef2bbc8f1f120cc68e01f965 Mon Sep 17 00:00:00 2001
From: Sasha Bogicevic <sasha.bogicevic@iohk.io>
Date: Wed, 3 Jul 2024 15:44:08 +0200
Subject: [PATCH] Fanout mutations

We splitted the fanout errors into two types:
FannedOutUtxoHashNotEqualToClosedUtxoHash and
FannedOutUtxoHashNotEqualToClosedUtxoHashToDecommit
---
 .../Hydra/Chain/Direct/Contract/FanOut.hs     | 52 +++++++++++++------
 hydra-plutus/src/Hydra/Contract/Head.hs       |  8 ++-
 hydra-plutus/src/Hydra/Contract/HeadError.hs  |  2 +
 3 files changed, 45 insertions(+), 17 deletions(-)

diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/FanOut.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/FanOut.hs
index f2f551a088e..23e0578a3d7 100644
--- a/hydra-node/test/Hydra/Chain/Direct/Contract/FanOut.hs
+++ b/hydra-node/test/Hydra/Chain/Direct/Contract/FanOut.hs
@@ -119,37 +119,57 @@ data FanoutMutation
 genFanoutMutation :: (Tx, UTxO) -> Gen SomeMutation
 genFanoutMutation (tx, _utxo) =
   oneof
-    [ SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateAddUnexpectedOutput . PrependOutput <$> do
+    [ -- XXX: Transaction is posted after contestation deadline tmin > tfinal .
+      SomeMutation (pure $ toErrorCode LowerBoundBeforeContestationDeadline) MutateValidityBeforeDeadline . ChangeValidityInterval <$> do
+        lb <- genSlotBefore $ slotNoFromUTCTime systemStart slotLength healthyContestationDeadline
+        pure (TxValidityLowerBound lb, TxValidityNoUpperBound)
+    , -- XXX: All tokens are burnt |{cid 7→ · 7→ −1} ∈ mint| = m′ + 1.
+      SomeMutation (pure $ toErrorCode BurntTokenNumberMismatch) MutateThreadTokenQuantity <$> do
+        (token, _) <- elements burntTokens
+        changeMintedTokens tx (valueFromList [(token, 1)])
+
+    , -- XXX: The first m outputs are distributing funds according to η. That is, the outputs exactly
+      -- correspond to the UTxO canonically combined U
+    SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateAddUnexpectedOutput . PrependOutput <$> do
         arbitrary >>= genOutput
-    , SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateChangeOutputValue <$> do
+    , -- XXX: The following n outputs are distributing funds according to η∆ .
+      -- That is, the outputs exactly # correspond to the UTxO canonically combined U∆
+      SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHashToDecommit) MutateChangeOutputValue <$> do
         let outs = txOuts' tx
         -- NOTE: Assumes the fanout transaction has non-empty outputs, which
         -- might not be always the case when testing unbalanced txs and we need
         -- to ensure it by at least one utxo is in healthyFanoutUTxO
-        (ix, out) <- elements (zip [0 .. length outs - 1] outs)
+
+        let noOfUtxoToOutputs = size $ toMap (fst healthyFanoutSnapshotUTxO)
+        (ix, out) <- elements (zip [noOfUtxoToOutputs .. length outs - 1] outs)
         value' <- genValue `suchThat` (/= txOutValue out)
         pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out)
-    , SomeMutation (pure $ toErrorCode LowerBoundBeforeContestationDeadline) MutateValidityBeforeDeadline . ChangeValidityInterval <$> do
-        lb <- genSlotBefore $ slotNoFromUTCTime systemStart slotLength healthyContestationDeadline
-        pure (TxValidityLowerBound lb, TxValidityNoUpperBound)
-    , SomeMutation (pure $ toErrorCode BurntTokenNumberMismatch) MutateThreadTokenQuantity <$> do
-        (token, _) <- elements burntTokens
-        changeMintedTokens tx (valueFromList [(token, 1)])
-    , SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateAddUnexpectedOutput . PrependOutput <$> do
-        arbitrary >>= genOutput
-    , SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateFanoutRedeemer . ChangeHeadRedeemer <$> do
+    , -- XXX: The following n outputs are distributing funds according to η∆ .
+      -- That is, the outputs exactly # correspond to the UTxO canonically combined U∆
+      SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateChangeOutputValue <$> do
+        let outs = txOuts' tx
+        -- NOTE: Assumes the fanout transaction has non-empty outputs, which
+        -- might not be always the case when testing unbalanced txs and we need
+        -- to ensure it by at least one utxo is in healthyFanoutUTxO
+
+        let noOfUtxoToDecommitOutputs = size $ toMap (snd healthyFanoutSnapshotUTxO)
+        (ix, out) <- elements (zip [0 .. (length outs - noOfUtxoToDecommitOutputs) - 1] outs)
+        value' <- genValue `suchThat` (/= txOutValue out)
+        pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out)
+    , -- XXX: The following n outputs are distributing funds according to η∆ .
+      -- That is, the outputs exactly # correspond to the UTxO canonically combined U∆
+      SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHashToDecommit) MutateFanoutRedeemer . ChangeHeadRedeemer <$> do
         let noOfUtxoToOutputs = fromIntegral . size $ toMap (fst healthyFanoutSnapshotUTxO)
         let noOfUtxoDecommitToOutputs = fromIntegral . size $ toMap (snd healthyFanoutSnapshotUTxO)
         n <- elements [1 .. 3]
         pure (Head.Fanout noOfUtxoToOutputs (noOfUtxoDecommitToOutputs - n))
-    , SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateFanoutRedeemer . ChangeHeadRedeemer <$> do
+    , -- XXX: The first m outputs are distributing funds according to η. That is, the outputs exactly
+      -- correspond to the UTxO canonically combined U
+      SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateFanoutRedeemer . ChangeHeadRedeemer <$> do
         let noOfUtxoToOutputs = fromIntegral . size $ toMap (fst healthyFanoutSnapshotUTxO)
         let noOfUtxoDecommitToOutputs = fromIntegral . size $ toMap (snd healthyFanoutSnapshotUTxO)
         n <- elements [1 .. 3]
         pure (Head.Fanout (noOfUtxoToOutputs - n) noOfUtxoDecommitToOutputs)
-    , SomeMutation (pure $ toErrorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) MutateFanoutRedeemer . ChangeHeadRedeemer <$> do
-        let noOfUtxoToOutputs = fromIntegral . size $ toMap (fst healthyFanoutSnapshotUTxO)
-        pure (Head.Fanout noOfUtxoToOutputs 0)
     ]
  where
   burntTokens =
diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs
index 0a15f082d2a..0dfb5f39b2a 100644
--- a/hydra-plutus/src/Hydra/Contract/Head.hs
+++ b/hydra-plutus/src/Hydra/Contract/Head.hs
@@ -507,13 +507,19 @@ checkFanout ::
 checkFanout utxoHash utxoToDecommitHash contestationDeadline numberOfFanoutOutputs numberOfDecommitOutputs ScriptContext{scriptContextTxInfo = txInfo} currencySymbol parties =
   mustBurnAllHeadTokens minted currencySymbol parties
     && hasSameUTxOHash
+    && hasSameUTxOToDecommitHash
     && afterContestationDeadline
  where
   minted = txInfoMint txInfo
 
   hasSameUTxOHash =
     traceIfFalse $(errorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) $
-      fannedOutUtxoHash == utxoHash && decommitUtxoHash == utxoToDecommitHash
+      fannedOutUtxoHash == utxoHash
+
+  hasSameUTxOToDecommitHash =
+    traceIfFalse $(errorCode FannedOutUtxoHashNotEqualToClosedUtxoHashToDecommit) $
+      decommitUtxoHash == utxoToDecommitHash
+
   fannedOutUtxoHash = hashTxOuts $ take numberOfFanoutOutputs txInfoOutputs
 
   decommitUtxoHash = hashTxOuts $ take numberOfDecommitOutputs $ drop numberOfFanoutOutputs txInfoOutputs
diff --git a/hydra-plutus/src/Hydra/Contract/HeadError.hs b/hydra-plutus/src/Hydra/Contract/HeadError.hs
index 3163ec77bda..c9c034de78a 100644
--- a/hydra-plutus/src/Hydra/Contract/HeadError.hs
+++ b/hydra-plutus/src/Hydra/Contract/HeadError.hs
@@ -45,6 +45,7 @@ data HeadError
   | SnapshotNumberMismatch
   | IncorrectVersion
   | LastKnownVersionIsNotMatching
+  | FannedOutUtxoHashNotEqualToClosedUtxoHashToDecommit
 
 instance ToErrorCode HeadError where
   toErrorCode = \case
@@ -87,3 +88,4 @@ instance ToErrorCode HeadError where
     SnapshotNumberMismatch -> "H37"
     IncorrectVersion -> "H38"
     LastKnownVersionIsNotMatching -> "H39"
+    FannedOutUtxoHashNotEqualToClosedUtxoHashToDecommit -> "H40"