Fanout mutations

We splitted the fanout errors into two types: FannedOutUtxoHashNotEqualToClosedUtxoHash and FannedOutUtxoHashNotEqualToClosedUtxoHashToDecommit
cardano-scaling · Jul 3, 2024 · 290d1b1 · 290d1b1
1 parent 8739358
commit 290d1b1
Show file tree

Hide file tree

Showing 3 changed files with 45 additions and 17 deletions.
diff --git 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
@@ -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
@@ -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"