Incremental Commits off-chain changes

Signed-off-by: Sasha Bogicevic <[email protected]>

docs/docs/dev/protocol.md

@@ -2,42 +2,97 @@
 
 Additional implementation-specific documentation for the Hydra Head protocol and extensions like incremental decommits.
 
+### Incremental Commits
+
+#### Deposit flow
+
+```mermaid
+sequenceDiagram
+    Alice->>+Node A: POST /commit (UTxO, UTCTime)
+    Node A-->>-Alice: depositTx
+
+    Alice ->> Alice: sign depositTx
+    Alice ->> Alice: submit depositTx
+
+    Chain ->>+ Node A: OnDepositTx utxo
+    Chain ->>+ Node B: OnDepositTx utxo
+
+    Node A -->> Alice: DepositDetected
+
+    Node A -->> Alice: CommitRequested
+
+    par Alice isLeader
+        Node A->>Node A: ReqSn utxo
+    and
+        Node A->>Node B: ReqSn utxo
+    end
+
+    Node A->>Node A: sig = sign snapshot incl. inputs(commitTx)
+
+    par broadcast
+        Node A->>Node A: AckSn sig
+    and
+        Node A->>Node B: AckSn sig
+    end
+    Node B->>Node A: AckSn sig
+    Node A -->> Alice: SnapshotConfirmed
+
+    Node A -->> Alice: CommitApproved
+
+    Node A ->> Chain: IncrementTx snapshot sig
+    Chain ->> Node A: OnIncrementTx
+    Node A -->> Alice: CommitFinalized
+```
+
+#### Recover flow
+
+```mermaid
+sequenceDiagram
+    Alice->>+Node A: DELETE /commit/tx-in (UTxO, UTCTime, SlotNo)
+    Node A-->>-Alice: recoverTx
+
+    Alice ->> Alice: sign recoverTx
+    Alice ->> Alice: submit recoverTx
+```
+
 ### Incremental Decommits
 
 ```mermaid
 sequenceDiagram
-    Alice->>HeadLogic: Decommit (decTx)
-    HeadLogic->>HeadLogic: canApply decTx
+    Alice->>+Node A: POST /decommit (decTx)
+    Node A-->>-Alice: OK
+
+    Node A->>Node A: canApply decTx
 
     par broadcast
-        HeadLogic->>HeadLogic: ReqDec decTx
+        Node A->>Node A: ReqDec decTx
     and
-        HeadLogic->>Node B: ReqDec decTx
+        Node A->>Node B: ReqDec decTx
     end
 
-    HeadLogic -->> Alice: DecommitRequested
+    Node A -->> Alice: DecommitRequested
 
     par Alice isLeader
-        HeadLogic->>HeadLogic: ReqSn decTx
+        Node A->>Node A: ReqSn decTx
     and
-        HeadLogic->>Node B: ReqSn decTx
+        Node A->>Node B: ReqSn decTx
     end
 
-    HeadLogic->>HeadLogic: canApply decTx, decUTxO =  outputs(decTx)
-    HeadLogic->>HeadLogic: sig = sign snapshot incl. decUTxO
+    Node A->>Node A: canApply decTx, decUTxO =  outputs(decTx)
+    Node A->>Node A: sig = sign snapshot incl. decUTxO
 
     par broadcast
-        HeadLogic->>HeadLogic: AckSn sig
+        Node A->>Node A: AckSn sig
     and
-        HeadLogic->>Node B: AckSn sig
+        Node A->>Node B: AckSn sig
     end
 
-    Node B->>HeadLogic: AckSn sig
+    Node B->>Node A: AckSn sig
 
-    HeadLogic -->> Alice: SnapshotConfirmed
-    HeadLogic -->> Alice: DecommitApproved
+    Node A -->> Alice: SnapshotConfirmed
+    Node A -->> Alice: DecommitApproved
 
-    HeadLogic ->> Chain: DecrementTx snapshot sig
-    Chain ->> HeadLogic: OnDecrementTx
-    HeadLogic -->> Alice: DecommitFinalized
+    Node A ->> Chain: DecrementTx snapshot sig
+    Chain ->> Node A: OnDecrementTx
+    Node A -->> Alice: DecommitFinalized
 ```

hydra-chain-observer/hydra-chain-observer.cabal

@@ -93,6 +93,7 @@ test-suite tests
   type:               exitcode-stdio-1.0
   build-depends:
     , hspec
+    , hydra-cardano-api
     , hydra-chain-observer
     , hydra-node
     , hydra-prelude

hydra-chain-observer/src/Hydra/ChainObserver.hs

@@ -91,6 +91,8 @@ data ChainObserverLog
   | HeadInitTx {headId :: HeadId}
   | HeadCommitTx {headId :: HeadId}
   | HeadCollectComTx {headId :: HeadId}
+  | HeadDepositTx {headId :: HeadId}
+  | HeadIncrementTx {headId :: HeadId}
   | HeadDecrementTx {headId :: HeadId}
   | HeadCloseTx {headId :: HeadId}
   | HeadFanoutTx {headId :: HeadId}
@@ -203,6 +205,8 @@ chainSyncClient tracer networkId startingPoint observerHandler =
     OnInitTx{headId} -> HeadInitTx{headId}
     OnCommitTx{headId} -> HeadCommitTx{headId}
     OnCollectComTx{headId} -> HeadCollectComTx{headId}
+    OnIncrementTx{headId} -> HeadIncrementTx{headId}
+    OnDepositTx{headId} -> HeadDepositTx{headId}
     OnDecrementTx{headId} -> HeadDecrementTx{headId}
     OnCloseTx{headId} -> HeadCloseTx{headId}
     OnFanoutTx{headId} -> HeadFanoutTx{headId}

hydra-chain-observer/test/Hydra/ChainObserverSpec.hs

@@ -3,6 +3,7 @@ module Hydra.ChainObserverSpec where
 import Hydra.Prelude
 import Test.Hydra.Prelude
 
+import Hydra.Cardano.Api (utxoFromTx)
 import Hydra.Chain.Direct.State (HasKnownUTxO (getKnownUTxO), genChainStateWithTx)
 import Hydra.Chain.Direct.State qualified as Transition
 import Hydra.Chain.Direct.Tx (HeadObservation (..))
@@ -20,11 +21,12 @@ spec =
         forAllBlind genChainStateWithTx $ \(_ctx, st, tx, transition) ->
           genericCoverTable [transition] $
             counterexample (show transition) $
-              let utxo = getKnownUTxO st
+              let utxo = getKnownUTxO st <> utxoFromTx tx
                in case snd $ observeTx testNetworkId utxo tx of
                     Just (Init{}) -> transition === Transition.Init
                     Just (Commit{}) -> transition === Transition.Commit
                     Just (CollectCom{}) -> transition === Transition.Collect
+                    Just (Deposit{}) -> transition === Transition.Deposit
                     Just (Decrement{}) -> transition === Transition.Decrement
                     Just (Abort{}) -> transition === Transition.Abort
                     Just (Close{}) -> transition === Transition.Close
@@ -33,9 +35,12 @@ spec =
                     _ -> property False
 
     prop "Updates UTxO state given transaction part of Head lifecycle" $
-      forAllBlind genChainStateWithTx $ \(_ctx, st, tx, _transition) ->
+      forAllBlind genChainStateWithTx $ \(_ctx, st, tx, transition) ->
         let utxo = getKnownUTxO st
-         in fst (observeTx testNetworkId utxo tx) =/= utxo
+         in -- NOTE: deposit doesn't affect the Head UTxO state
+            if transition == Transition.Deposit
+              then property True
+              else fst (observeTx testNetworkId utxo tx) =/= utxo
 
     prop "Does not updates UTxO state given transactions outside of Head lifecycle" $
       forAll genSequenceOfSimplePaymentTransactions $ \(utxo, txs) ->

hydra-cluster/src/Hydra/Cluster/Scenarios.hs

@@ -83,6 +83,7 @@ import HydraNode (
   withHydraCluster,
   withHydraNode,
  )
+import Network.HTTP.Conduit (parseUrlThrow)
 import Network.HTTP.Conduit qualified as L
 import Network.HTTP.Req (
   HttpException (VanillaHttpException),
@@ -97,6 +98,7 @@ import Network.HTTP.Req (
   runReq,
   (/:),
  )
+import Network.HTTP.Simple (getResponseBody, httpJSON, setRequestBodyJSON)
 import System.Directory (removeDirectoryRecursive)
 import System.FilePath ((</>))
 import Test.Hydra.Tx.Gen (genKeyPair)
@@ -314,7 +316,6 @@ singlePartyOpenAHead tracer workDir node hydraScriptsTxId callback =
       -- Initialize & open head
       send n1 $ input "Init" []
       headId <- waitMatch (10 * blockTime) n1 $ headIsInitializingWith (Set.fromList [alice])
-      -- Commit nothing for now
       requestCommitTx n1 utxoToCommit <&> signTx walletSk >>= submitTx node
       waitFor hydraTracer (10 * blockTime) [n1] $
         output "HeadIsOpen" ["utxo" .= toJSON utxoToCommit, "headId" .= headId]
@@ -594,6 +595,54 @@ initWithWrongKeys workDir tracer node@RunningNode{nodeSocket} hydraScriptsTxId =
 
       participants `shouldMatchList` expectedParticipants
 
+-- | Open a a single participant head and incrementally commit to it.
+canCommit :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> TxId -> IO ()
+canCommit tracer workDir node hydraScriptsTxId =
+  (`finally` returnFundsToFaucet tracer node Alice) $ do
+    refuelIfNeeded tracer node Alice 30_000_000
+    let contestationPeriod = UnsafeContestationPeriod 1
+    aliceChainConfig <-
+      chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] contestationPeriod
+        <&> setNetworkId networkId
+    withHydraNode hydraTracer aliceChainConfig workDir 1 aliceSk [] [1] $ \n1 -> do
+      send n1 $ input "Init" []
+      headId <- waitMatch 10 n1 $ headIsInitializingWith (Set.fromList [alice])
+
+      -- Commit nothing
+      requestCommitTx n1 mempty >>= submitTx node
+      waitFor hydraTracer (10 * blockTime) [n1] $
+        output "HeadIsOpen" ["utxo" .= object mempty, "headId" .= headId]
+
+      -- Get some L1 funds
+      (walletVk, walletSk) <- generate genKeyPair
+      commitUTxO <- seedFromFaucet node walletVk 5_000_000 (contramap FromFaucet tracer)
+      let depositRequest = object ["utxo" .= commitUTxO]
+      resp <-
+        parseUrlThrow ("POST " <> hydraNodeBaseUrl n1 <> "/commit")
+          <&> setRequestBodyJSON depositRequest
+            >>= httpJSON
+
+      let incrementTx = getResponseBody resp :: Tx
+      let tx = signTx walletSk incrementTx
+
+      submitTx node tx
+      -- NOTE: we want to find the deposit script output here but cluster
+      -- doesn't depend on hydra-plutus so that we can use `findTxOutByScript`
+      -- on a deposit script. How can we be sure that deposit output is always the first one?
+      let expectedDepositUTxO = UTxO.singleton $ List.head $ UTxO.pairs (utxoFromTx tx)
+
+      waitFor hydraTracer 10 [n1] $
+        output "CommitApproved" ["headId" .= headId, "utxoToCommit" .= expectedDepositUTxO]
+
+      waitFor hydraTracer 10 [n1] $
+        output "CommitFinalized" ["headId" .= headId]
+ where
+  RunningNode{networkId, nodeSocket, blockTime} = node
+
+  hydraTracer = contramap FromHydraNode tracer
+
+  hydraNodeBaseUrl HydraClient{hydraNodeId} = "http://127.0.0.1:" <> show (4000 + hydraNodeId)
+
 -- | Open a a single participant head with some UTxO and incrementally decommit it.
 canDecommit :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> TxId -> IO ()
 canDecommit tracer workDir node hydraScriptsTxId =

hydra-cluster/test/Test/DirectChainSpec.hs

@@ -326,6 +326,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do
                     , number = 1
                     , utxo = inHead
                     , confirmed = []
+                    , utxoToCommit = Nothing
                     , utxoToDecommit = Just toDecommit
                     , version = v
                     }
@@ -459,6 +460,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do
                     , number = 1
                     , utxo = inHead
                     , confirmed = []
+                    , utxoToCommit = Nothing
                     , utxoToDecommit = Just toDecommit
                     , version = 0
                     }
@@ -482,6 +484,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do
                     , number = 2
                     , utxo = inHead
                     , confirmed = []
+                    , utxoToCommit = Nothing
                     , utxoToDecommit = Just toDecommit
                     , version = 1
                     }

hydra-cluster/test/Test/EndToEndSpec.hs

@@ -57,6 +57,7 @@ import Hydra.Cluster.Fixture (
 import Hydra.Cluster.Scenarios (
   EndToEndLog (..),
   canCloseWithLongContestationPeriod,
+  canCommit,
   canDecommit,
   canSubmitTransactionThroughAPI,
   headIsInitializingWith,
@@ -193,6 +194,11 @@ spec = around (showLogsOnFailure "EndToEndSpec") $ do
           withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \node ->
             publishHydraScriptsAs node Faucet
               >>= canDecommit tracer tmpDir node
+      it "can incrementally commit" $ \tracer -> do
+        withClusterTempDir $ \tmpDir -> do
+          withCardanoNodeDevnet (contramap FromCardanoNode tracer) tmpDir $ \node ->
+            publishHydraScriptsAs node Faucet
+              >>= canCommit tracer tmpDir node
 
     describe "three hydra nodes scenario" $ do
       it "does not error when all nodes open the head concurrently" $ \tracer ->

hydra-explorer/src/Hydra/Explorer/ExplorerState.hs

@@ -226,6 +226,50 @@ aggregateCollectComObservation headId point blockNo currentHeads =
       , blockNo = blockNo
       }
 
+aggregateDepositObservation :: HeadId -> ChainPoint -> BlockNo -> [HeadState] -> [HeadState]
+aggregateDepositObservation headId point blockNo currentHeads =
+  case findHeadState headId currentHeads of
+    Just headState ->
+      let newHeadState = headState{status = Open}
+       in replaceHeadState newHeadState currentHeads
+    Nothing -> currentHeads <> [newUnknownHeadState]
+ where
+  newUnknownHeadState =
+    HeadState
+      { headId
+      , seedTxIn = Unknown
+      , status = Open
+      , contestationPeriod = Unknown
+      , members = Unknown
+      , contestations = Seen 0
+      , snapshotNumber = Seen 0
+      , contestationDeadline = Unknown
+      , point = point
+      , blockNo = blockNo
+      }
+
+aggregateIncrementObservation :: HeadId -> ChainPoint -> BlockNo -> [HeadState] -> [HeadState]
+aggregateIncrementObservation headId point blockNo currentHeads =
+  case findHeadState headId currentHeads of
+    Just headState ->
+      let newHeadState = headState{status = Open}
+       in replaceHeadState newHeadState currentHeads
+    Nothing -> currentHeads <> [newUnknownHeadState]
+ where
+  newUnknownHeadState =
+    HeadState
+      { headId
+      , seedTxIn = Unknown
+      , status = Open
+      , contestationPeriod = Unknown
+      , members = Unknown
+      , contestations = Seen 0
+      , snapshotNumber = Seen 0
+      , contestationDeadline = Unknown
+      , point = point
+      , blockNo = blockNo
+      }
+
 aggregateDecrementObservation :: HeadId -> ChainPoint -> BlockNo -> [HeadState] -> [HeadState]
 aggregateDecrementObservation headId point blockNo currentHeads =
   case findHeadState headId currentHeads of
@@ -364,6 +408,16 @@ aggregateHeadObservations observations explorerState =
           { heads = aggregateCollectComObservation headId point blockNo heads
           , tick = TickState point blockNo
           }
+      HeadObservation{point, blockNo, onChainTx = OnDepositTx{headId}} ->
+        ExplorerState
+          { heads = aggregateDepositObservation headId point blockNo heads
+          , tick = TickState point blockNo
+          }
+      HeadObservation{point, blockNo, onChainTx = OnIncrementTx{headId}} ->
+        ExplorerState
+          { heads = aggregateIncrementObservation headId point blockNo heads
+          , tick = TickState point blockNo
+          }
       HeadObservation{point, blockNo, onChainTx = OnDecrementTx{headId}} ->
         ExplorerState
           { heads = aggregateDecrementObservation headId point blockNo heads

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

@@ -186,7 +186,7 @@ computeContestCost = do
     utxo <- arbitrary
     (closedSnapshotNumber, _, _, stClosed@ClosedState{headId}) <- genStClosed ctx utxo mempty
     cctx <- pickChainContext ctx
-    snapshot <- genConfirmedSnapshot headId 0 (succ closedSnapshotNumber) utxo mempty (ctxHydraSigningKeys ctx)
+    snapshot <- genConfirmedSnapshot headId 0 (succ closedSnapshotNumber) utxo Nothing mempty (ctxHydraSigningKeys ctx)
     pointInTime <- genPointInTimeBefore (getContestationDeadline stClosed)
     let cp = ctxContestationPeriod ctx
     let contestUtxo = getKnownUTxO stClosed <> getKnownUTxO cctx
@@ -242,7 +242,7 @@ computeFanOutCost = do
     utxo <- genUTxOAdaOnlyOfSize numOutputs
     ctx <- genHydraContextFor numParties
     (_committed, stOpen@OpenState{headId, seedTxIn}) <- genStOpen ctx
-    snapshot <- genConfirmedSnapshot headId 0 1 utxo mempty [] -- We do not validate the signatures
+    snapshot <- genConfirmedSnapshot headId 0 1 utxo Nothing mempty [] -- We do not validate the signatures
     cctx <- pickChainContext ctx
     let cp = ctxContestationPeriod ctx
     (startSlot, closePoint) <- genValidityBoundsFromContestationPeriod cp

hydra-node/exe/hydra-net/Main.hs

@@ -225,7 +225,7 @@ injectReqSn peer snapshotNumber hydraKeyFile fakeHydraKeyFile = do
 
   client tracer sk party = Idle $ do
     let snapshotVersion = 0
-    let msg = Data "2" (ReqSn @Tx snapshotVersion snapshotNumber [] Nothing)
+    let msg = Data "2" (ReqSn @Tx snapshotVersion snapshotNumber [] Nothing Nothing)
     let signed = Signed msg (sign sk msg) party
     traceWith tracer $ Injecting signed
     pure $ SendMsg signed (pure $ SendDone (pure ()))