Reference vHead in fanout transactions

This reduces this transaction size substantially and makes it bound by
memory budget now.

hydra-node/exe/tx-cost/TxCost.hs

@@ -193,7 +193,7 @@ computeFanOutCost = do
   pure $ interesting <> limit
  where
   compute numElems = do
-    (utxo, tx) <- generate $ genFanoutTx maximumNumberOfParties numElems
+    (tx, utxo) <- generate $ genFanoutTx maximumNumberOfParties numElems
     case checkSizeAndEvaluate tx utxo of
       Just (txSize, memUnit, cpuUnit, minFee) ->
         pure $ Just (NumUTxO numElems, txSize, memUnit, cpuUnit, minFee)
@@ -212,7 +212,7 @@ computeFanOutCost = do
     let closeTx = close cctx stOpen snapshot startSlot closePoint
     let stClosed = snd . fromJust $ observeClose stOpen closeTx
     let deadlineSlotNo = slotNoFromUTCTime (getContestationDeadline stClosed)
-    pure (getKnownUTxO stClosed, fanout stClosed utxo deadlineSlotNo)
+    pure (fanout cctx stClosed utxo deadlineSlotNo, getKnownUTxO stClosed <> getKnownUTxO cctx)
 
 newtype NumParties = NumParties Int
   deriving newtype (Eq, Show, Ord, Num, Real, Enum, Integral)

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

@@ -273,7 +273,7 @@ prepareTxToPost timeHandle wallet ctx cst@ChainStateAt{chainState} tx =
       pure (contest ctx st confirmedSnapshot upperBound)
     (FanoutTx{utxo, contestationDeadline}, Closed st) -> do
       deadlineSlot <- throwLeft $ slotFromUTCTime contestationDeadline
-      pure (fanout st utxo deadlineSlot)
+      pure (fanout ctx st utxo deadlineSlot)
     (_, _) -> throwIO $ InvalidStateToPost{txTried = tx, chainState = cst}
  where
   -- XXX: Might want a dedicated exception type here

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

@@ -450,14 +450,17 @@ contest ctx st confirmedSnapshot pointInTime = do
 -- | Construct a fanout transaction based on the 'ClosedState' and off-chain
 -- agreed 'UTxO' set to fan out.
 fanout ::
+  ChainContext ->
   ClosedState ->
   UTxO ->
   -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
   SlotNo ->
   Tx
-fanout st utxo deadlineSlotNo = do
-  fanoutTx utxo (i, o, dat) deadlineSlotNo closedHeadTokenScript
+fanout ctx st utxo deadlineSlotNo = do
+  fanoutTx scriptRegistry utxo (i, o, dat) deadlineSlotNo closedHeadTokenScript
  where
+  ChainContext{scriptRegistry} = ctx
+
   ClosedState{closedThreadOutput, closedHeadTokenScript} = st
 
   ClosedThreadOutput{closedThreadUTxO = (i, o, dat)} = closedThreadOutput
@@ -882,8 +885,9 @@ genFanoutTx numParties numOutputs = do
   ctx <- genHydraContext numParties
   utxo <- genUTxOAdaOnlyOfSize numOutputs
   (_, toFanout, stClosed) <- genStClosed ctx utxo
+  cctx <- pickChainContext ctx
   let deadlineSlotNo = slotNoFromUTCTime (getContestationDeadline stClosed)
-  pure (ctx, stClosed, fanout stClosed toFanout deadlineSlotNo)
+  pure (ctx, stClosed, fanout cctx stClosed toFanout deadlineSlotNo)
 
 getContestationDeadline :: ClosedState -> UTCTime
 getContestationDeadline

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

@@ -432,6 +432,8 @@ contestTx vk Snapshot{number, utxo} sig (slotNo, _) ClosedThreadOutput{closedThr
 -- accordingly. The head validator allows fanout only > deadline, so we need
 -- to set the lower bound to be deadline + 1 slot.
 fanoutTx ::
+  -- | Published Hydra scripts to reference.
+  ScriptRegistry ->
   -- | Snapshotted UTxO to fanout on layer 1
   UTxO ->
   -- | Everything needed to spend the Head state-machine output.
@@ -441,17 +443,21 @@ fanoutTx ::
   -- | Minting Policy script, made from initial seed
   PlutusScript ->
   Tx
-fanoutTx utxo (headInput, headOutput, ScriptDatumForTxIn -> headDatumBefore) deadlineSlotNo headTokenScript =
+fanoutTx scriptRegistry utxo (headInput, headOutput, ScriptDatumForTxIn -> headDatumBefore) deadlineSlotNo headTokenScript =
   unsafeBuildTransaction $
     emptyTxBody
       & addInputs [(headInput, headWitness)]
+      & addReferenceInputs [headScriptRef]
       & addOutputs orderedTxOutsToFanout
       & burnTokens headTokenScript Burn headTokens
       & setValidityLowerBound (deadlineSlotNo + 1)
  where
   headWitness =
-    BuildTxWith $ ScriptWitness scriptWitnessCtx $ mkScriptWitness headScript headDatumBefore headRedeemer
-
+    BuildTxWith $
+      ScriptWitness scriptWitnessCtx $
+        mkScriptReference headScriptRef headScript headDatumBefore headRedeemer
+  headScriptRef =
+    fst (headReference scriptRegistry)
   headScript =
     fromPlutusScript @PlutusScriptV2 Head.validatorScript
   headRedeemer =

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

@@ -11,6 +11,7 @@ import Hydra.Prelude hiding (label)
 import Cardano.Api.UTxO as UTxO
 import Hydra.Chain.Direct.Contract.Mutation (Mutation (..), SomeMutation (..))
 import Hydra.Chain.Direct.Fixture (testNetworkId, testPolicyId, testSeedInput)
+import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO)
 import Hydra.Chain.Direct.Tx (fanoutTx, mkHeadOutput)
 import qualified Hydra.Contract.HeadState as Head
 import Hydra.Contract.HeadTokens (mkHeadTokenScript)
@@ -33,13 +34,20 @@ healthyFanoutTx :: (Tx, UTxO)
 healthyFanoutTx =
   (tx, lookupUTxO)
  where
+  lookupUTxO =
+    UTxO.singleton (headInput, headOutput)
+      <> registryUTxO scriptRegistry
+
   tx =
     fanoutTx
+      scriptRegistry
       healthyFanoutUTxO
       (headInput, headOutput, headDatum)
       healthySlotNo
       headTokenScript
 
+  scriptRegistry = genScriptRegistry `generateWith` 42
+
   headInput = generateWith arbitrary 42
 
   headTokenScript = mkHeadTokenScript testSeedInput
@@ -60,8 +68,6 @@ healthyFanoutTx =
 
   headDatum = fromPlutusData $ toData healthyFanoutDatum
 
-  lookupUTxO = UTxO.singleton (headInput, headOutput)
-
 healthyFanoutUTxO :: UTxO
 healthyFanoutUTxO =
   -- FIXME: fanoutTx would result in 0 outputs and MutateChangeOutputValue below fail