diff --git a/hydra-node/src/Hydra/Chain.hs b/hydra-node/src/Hydra/Chain.hs index 980e0cdcb26..893c8f64ec7 100644 --- a/hydra-node/src/Hydra/Chain.hs +++ b/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. diff --git a/hydra-node/src/Hydra/Chain/Direct/Handlers.hs b/hydra-node/src/Hydra/Chain/Direct/Handlers.hs index 9ac25e56f77..d90ad0e57e6 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Handlers.hs +++ b/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 diff --git a/hydra-node/src/Hydra/Chain/Direct/State.hs b/hydra-node/src/Hydra/Chain/Direct/State.hs index 5f2243dc0b9..e47da1c5b9f 100644 --- a/hydra-node/src/Hydra/Chain/Direct/State.hs +++ b/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 => diff --git a/hydra-node/src/Hydra/Chain/Direct/Tx.hs b/hydra-node/src/Hydra/Chain/Direct/Tx.hs index 0dd152040b9..e124d46ebb8 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Tx.hs +++ b/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,6 +684,8 @@ 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. @@ -691,12 +693,12 @@ fanoutTx :: -- | 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,7 +712,11 @@ 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) @@ -718,6 +724,11 @@ fanoutTx scriptRegistry utxo (headInput, headOutput) deadlineSlotNo headTokenScr orderedTxOutsToFanout = toTxContext <$> toList utxo + orderedTxOutsToDecommit = + case utxoToDecommit of + Nothing -> [] + Just decommitUTxO -> toTxContext <$> toList decommitUTxO + data AbortTxError = OverlappingInputs | CannotFindHeadOutputToAbort diff --git a/hydra-node/src/Hydra/HeadLogic.hs b/hydra-node/src/Hydra/HeadLogic.hs index 5ab2dd81c50..5e36be93757 100644 --- a/hydra-node/src/Hydra/HeadLogic.hs +++ b/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 diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/FanOut.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/FanOut.hs index 09f794e35d6..4494264509e 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/FanOut.hs +++ b/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 diff --git a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs b/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs index c4f0f4511e3..9e55ee45ad3 100644 --- a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs +++ b/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 = diff --git a/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs b/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs index f527c1974aa..578203f13e3 100644 --- a/hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs +++ b/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 diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index c956c58e3c4..593f8944f37 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/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 = diff --git a/hydra-plutus/src/Hydra/Contract/HeadState.hs b/hydra-plutus/src/Hydra/Contract/HeadState.hs index 684a48007e5..e1db81ba1c8 100644 --- a/hydra-plutus/src/Hydra/Contract/HeadState.hs +++ b/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