Add utxoToDecommit to FanoutTx

This is needed to determine the proper hash of the outputs in the checkFanout
validator.

Author: v0d1ch

hydra-node/src/Hydra/Chain.hs

@@ -75,7 +75,7 @@ data PostChainTx tx
       }
   | CloseTx {headId :: HeadId, headParameters :: HeadParameters, confirmedSnapshot :: ConfirmedSnapshot tx}
   | ContestTx {headId :: HeadId, headParameters :: HeadParameters, confirmedSnapshot :: ConfirmedSnapshot tx}
-  | FanoutTx {utxo :: UTxOType tx, headSeed :: HeadSeed, contestationDeadline :: UTCTime}
+  | FanoutTx {utxo :: UTxOType tx, utxoToDecommit :: Maybe (UTxOType tx), headSeed :: HeadSeed, contestationDeadline :: UTCTime}
   deriving stock (Generic)
 
 deriving stock instance IsTx tx => Eq (PostChainTx tx)
@@ -93,7 +93,7 @@ instance IsTx tx => Arbitrary (PostChainTx tx) where
       DecrementTx <$> shrink headId <*> shrink headParameters <*> shrink snapshot <*> shrink signatures
     CloseTx{headId, headParameters, confirmedSnapshot} -> CloseTx <$> shrink headId <*> shrink headParameters <*> shrink confirmedSnapshot
     ContestTx{headId, headParameters, confirmedSnapshot} -> ContestTx <$> shrink headId <*> shrink headParameters <*> shrink confirmedSnapshot
-    FanoutTx{utxo, headSeed, contestationDeadline} -> FanoutTx <$> shrink utxo <*> shrink headSeed <*> shrink contestationDeadline
+    FanoutTx{utxo, utxoToDecommit, headSeed, contestationDeadline} -> FanoutTx <$> shrink utxo <*> shrink utxoToDecommit <*> shrink headSeed <*> shrink contestationDeadline
 
 -- | Describes transactions as seen on chain. Holds as minimal information as
 -- possible to simplify observing the chain.

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

@@ -396,13 +396,13 @@ prepareTxToPost timeHandle wallet ctx spendableUTxO tx =
       case contest ctx spendableUTxO headId contestationPeriod confirmedSnapshot upperBound of
         Left _ -> throwIO (FailedToConstructContestTx @Tx)
         Right contestTx -> pure contestTx
-    FanoutTx{utxo, headSeed, contestationDeadline} -> do
+    FanoutTx{utxo, utxoToDecommit, headSeed, contestationDeadline} -> do
       deadlineSlot <- throwLeft $ slotFromUTCTime contestationDeadline
       case headSeedToTxIn headSeed of
         Nothing ->
           throwIO (InvalidSeed{headSeed} :: PostTxError Tx)
         Just seedTxIn ->
-          case fanout ctx spendableUTxO seedTxIn utxo deadlineSlot of
+          case fanout ctx spendableUTxO seedTxIn utxo utxoToDecommit deadlineSlot of
             Left _ -> throwIO (FailedToConstructFanoutTx @Tx)
             Right fanoutTx -> pure fanoutTx
  where

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

@@ -535,7 +535,7 @@ close ctx spendableUTxO headId HeadParameters{parties, contestationPeriod} confi
         { snapshotNumber = number
         , closeUtxoHash = UTxOHash $ hashUTxO @Tx utxo
         , closeUtxoToDecommitHash =
-            UTxOHash $ maybe (hashUTxO @Tx mempty) (hashUTxO @Tx) utxoToDecommit
+            UTxOHash $ hashUTxO @Tx $ fromMaybe mempty utxoToDecommit
         , signatures
         }
 
@@ -598,19 +598,21 @@ fanout ::
   UTxO ->
   -- | Seed TxIn
   TxIn ->
-  -- | Snapshot UTxO to fanout
+  -- | Snapshot UTxO to decommit to fanout
   UTxO ->
+  -- | Snapshot UTxO to fanout
+  Maybe UTxO ->
   -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
   SlotNo ->
   Either FanoutTxError Tx
-fanout ctx spendableUTxO seedTxIn utxo deadlineSlotNo = do
+fanout ctx spendableUTxO seedTxIn utxo utxoToDecommit deadlineSlotNo = do
   headUTxO <-
     UTxO.find (isScriptTxOut headScript) (utxoOfThisHead (headPolicyId seedTxIn) spendableUTxO)
       ?> CannotFindHeadOutputToFanout
 
   closedThreadUTxO <- checkHeadDatum headUTxO
 
-  pure $ fanoutTx scriptRegistry utxo closedThreadUTxO deadlineSlotNo headTokenScript
+  pure $ fanoutTx scriptRegistry utxo utxoToDecommit closedThreadUTxO deadlineSlotNo headTokenScript
  where
   headTokenScript = mkHeadTokenScript seedTxIn
 
@@ -1084,7 +1086,8 @@ genFanoutTx numParties numOutputs = do
   cctx <- pickChainContext ctx
   let deadlineSlotNo = slotNoFromUTCTime systemStart slotLength (getContestationDeadline stClosed)
       spendableUTxO = getKnownUTxO stClosed
-  pure (ctx, stClosed, unsafeFanout cctx spendableUTxO seedTxIn toFanout deadlineSlotNo)
+  -- TODO: generate UTxO to decommit here too
+  pure (ctx, stClosed, unsafeFanout cctx spendableUTxO seedTxIn toFanout Nothing deadlineSlotNo)
 
 getContestationDeadline :: ClosedState -> UTCTime
 getContestationDeadline
@@ -1224,11 +1227,13 @@ unsafeFanout ::
   TxIn ->
   -- | Snapshot UTxO to fanout
   UTxO ->
+  -- | Snapshot decommit UTxO to fanout
+  Maybe UTxO ->
   -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
   SlotNo ->
   Tx
-unsafeFanout ctx spendableUTxO seedTxIn utxo deadlineSlotNo =
-  either (error . show) id $ fanout ctx spendableUTxO seedTxIn utxo deadlineSlotNo
+unsafeFanout ctx spendableUTxO seedTxIn utxo utxoToDecommit deadlineSlotNo =
+  either (error . show) id $ fanout ctx spendableUTxO seedTxIn utxo utxoToDecommit deadlineSlotNo
 
 unsafeObserveInit ::
   HasCallStack =>

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

@@ -667,7 +667,7 @@ contestTx scriptRegistry vk Snapshot{number, utxo, utxoToDecommit} sig (slotNo,
         }
   utxoHash = toBuiltin $ hashUTxO @Tx utxo
 
-  utxoToDecommitHash = toBuiltin $ hashUTxO @Tx (fromMaybe mempty utxoToDecommit)
+  utxoToDecommitHash = toBuiltin $ hashUTxO @Tx $ fromMaybe mempty utxoToDecommit
 
 data FanoutTxError
   = CannotFindHeadOutputToFanout
@@ -684,19 +684,21 @@ fanoutTx ::
   ScriptRegistry ->
   -- | Snapshotted UTxO to fanout on layer 1
   UTxO ->
+  -- | Snapshotted decommit UTxO to fanout on layer 1
+  Maybe UTxO ->
   -- | Everything needed to spend the Head state-machine output.
   (TxIn, TxOut CtxUTxO) ->
   -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
   SlotNo ->
   -- | Minting Policy script, made from initial seed
   PlutusScript ->
   Tx
-fanoutTx scriptRegistry utxo (headInput, headOutput) deadlineSlotNo headTokenScript =
+fanoutTx scriptRegistry utxo utxoToDecommit (headInput, headOutput) deadlineSlotNo headTokenScript =
   unsafeBuildTransaction $
     emptyTxBody
       & addInputs [(headInput, headWitness)]
       & addReferenceInputs [headScriptRef]
-      & addOutputs orderedTxOutsToFanout
+      & addOutputs orderedTxOutsToFanout -- <> orderedTxOutsToDecommit)
       & burnTokens headTokenScript Burn headTokens
       & setValidityLowerBound (deadlineSlotNo + 1)
       & setTxMetadata (TxMetadataInEra $ mkHydraHeadV1TxName "FanoutTx")
@@ -710,14 +712,23 @@ fanoutTx scriptRegistry utxo (headInput, headOutput) deadlineSlotNo headTokenScr
   headScript =
     fromPlutusScript @PlutusScriptV2 Head.validatorScript
   headRedeemer =
-    toScriptData (Head.Fanout $ fromIntegral $ length utxo)
+    toScriptData $
+      Head.Fanout
+        { numberOfFanoutOutputs = fromIntegral $ length utxo
+        , numberOfDecommitOutputs = fromIntegral $ maybe 0 length utxoToDecommit
+        }
 
   headTokens =
     headTokensFromValue headTokenScript (txOutValue headOutput)
 
   orderedTxOutsToFanout =
     toTxContext <$> toList utxo
 
+  orderedTxOutsToDecommit =
+    case utxoToDecommit of
+      Nothing -> []
+      Just decommitUTxO -> toTxContext <$> toList decommitUTxO
+
 data AbortTxError
   = OverlappingInputs
   | CannotFindHeadOutputToAbort

hydra-node/src/Hydra/HeadLogic.hs

@@ -835,9 +835,9 @@ onClosedClientFanout ::
   ClosedState tx ->
   Outcome tx
 onClosedClientFanout closedState =
-  cause OnChainEffect{postChainTx = FanoutTx{utxo, headSeed, contestationDeadline}}
+  cause OnChainEffect{postChainTx = FanoutTx{utxo, utxoToDecommit, headSeed, contestationDeadline}}
  where
-  Snapshot{utxo} = getSnapshot confirmedSnapshot
+  Snapshot{utxo, utxoToDecommit} = getSnapshot confirmedSnapshot
 
   ClosedState{headSeed, confirmedSnapshot, contestationDeadline} = closedState
 

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

@@ -43,6 +43,8 @@ healthyFanoutTx =
     fanoutTx
       scriptRegistry
       healthyFanoutUTxO
+      -- TODO: add something to decommit here
+      Nothing
       (headInput, headOutput)
       healthySlotNo
       headTokenScript

hydra-node/test/Hydra/Chain/Direct/StateSpec.hs

@@ -445,7 +445,7 @@ prop_canCloseFanoutEveryCollect = monadicST $ do
     _ -> fail "not observed close"
   -- Fanout
   let fanoutUTxO = getKnownUTxO stClosed
-  let txFanout = unsafeFanout cctx fanoutUTxO seedTxIn initialUTxO (slotNoFromUTCTime systemStart slotLength deadline)
+  let txFanout = unsafeFanout cctx fanoutUTxO seedTxIn initialUTxO Nothing (slotNoFromUTCTime systemStart slotLength deadline)
 
   -- Properties
   let collectFails =

hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs

@@ -562,12 +562,14 @@ newContestTx actor snapshot = do
 newFanoutTx :: Actor -> ModelSnapshot -> AppM (Either FanoutTxError Tx)
 newFanoutTx actor snapshot = do
   spendableUTxO <- get
+  let (snapshot', _) = signedSnapshot snapshot
   pure $
     fanout
       (actorChainContext actor)
       spendableUTxO
       Fixture.testSeedInput
-      (snapshotUTxO snapshot)
+      (utxo snapshot')
+      (utxoToDecommit snapshot')
       deadline
  where
   CP.UnsafeContestationPeriod contestationPeriod = Fixture.cperiod

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

@@ -79,8 +79,8 @@ headValidator oldState input ctx =
       checkClose ctx parties initialUtxoHash signature contestationPeriod headId snapshotNumber
     (Closed{parties, snapshotNumber = closedSnapshotNumber, contestationDeadline, contestationPeriod, headId, contesters}, Contest{signature}) ->
       checkContest ctx contestationDeadline contestationPeriod parties closedSnapshotNumber signature contesters headId
-    (Closed{parties, utxoHash, contestationDeadline, headId}, Fanout{numberOfFanoutOutputs}) ->
-      checkFanout utxoHash contestationDeadline numberOfFanoutOutputs ctx headId parties
+    (Closed{parties, utxoHash, utxoToDecommitHash, contestationDeadline, headId}, Fanout{numberOfFanoutOutputs, numberOfDecommitOutputs}) ->
+      checkFanout utxoHash utxoToDecommitHash contestationDeadline numberOfFanoutOutputs numberOfDecommitOutputs ctx headId parties
     _ ->
       traceError $(errorCode InvalidHeadStateTransition)
 
@@ -483,14 +483,16 @@ checkContest ctx contestationDeadline contestationPeriod parties closedSnapshotN
 {-# INLINEABLE checkContest #-}
 
 checkFanout ::
+  BuiltinByteString ->
   BuiltinByteString ->
   POSIXTime ->
   Integer ->
+  Integer ->
   ScriptContext ->
   CurrencySymbol ->
   [Party] ->
   Bool
-checkFanout utxoHash contestationDeadline numberOfFanoutOutputs ScriptContext{scriptContextTxInfo = txInfo} currencySymbol parties =
+checkFanout utxoHash utxoToDecommitHash contestationDeadline numberOfFanoutOutputs numberOfDecommitOutputs ScriptContext{scriptContextTxInfo = txInfo} currencySymbol parties =
   mustBurnAllHeadTokens minted currencySymbol parties
     && hasSameUTxOHash
     && afterContestationDeadline
@@ -499,10 +501,11 @@ checkFanout utxoHash contestationDeadline numberOfFanoutOutputs ScriptContext{sc
 
   hasSameUTxOHash =
     traceIfFalse $(errorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) $
-      fannedOutUtxoHash == utxoHash
-
+      fannedOutUtxoHash == utxoHash -- && decommitUtxoHash == utxoToDecommitHash
   fannedOutUtxoHash = hashTxOuts $ take numberOfFanoutOutputs txInfoOutputs
 
+  decommitUtxoHash = hashTxOuts $ take numberOfDecommitOutputs $ drop numberOfFanoutOutputs txInfoOutputs
+
   TxInfo{txInfoOutputs} = txInfo
 
   afterContestationDeadline =

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

@@ -64,7 +64,7 @@ data Input
       { signature :: [Signature]
       }
   | Abort
-  | Fanout {numberOfFanoutOutputs :: Integer}
+  | Fanout {numberOfFanoutOutputs :: Integer, numberOfDecommitOutputs :: Integer}
   deriving stock (Generic, Show)
 
 PlutusTx.unstableMakeIsData ''Input