Add commitUTxO to CoordinatedHeadState and more logic on ReqSn

Introduce waitOnApplicableCommit as well
Signed-off-by: Sasha Bogicevic <[email protected]>

hydra-node/src/Hydra/HeadLogic.hs

@@ -415,44 +415,45 @@ onOpenNetworkReqSn env ledger st otherParty sv sn requestedTxIds mDecommitTx mIn
     waitNoSnapshotInFlight $
       -- Spec: wait v = v̂
       waitOnSnapshotVersion $
-        requireApplicableDecommitTx $ \(activeUTxO, mUtxoToDecommit) ->
-          -- Resolve transactions by-id
-          waitResolvableTxs $ \requestedTxs -> do
-            -- Spec: require 𝑈_active ◦ Treq ≠ ⊥
-            --       𝑈 ← 𝑈_active ◦ Treq
-            requireApplyTxs activeUTxO requestedTxs $ \u -> do
-              -- Spec: ŝ ← ̅S.s + 1
-              -- NOTE: confSn == seenSn == sn here
-              let nextSnapshot =
-                    Snapshot
-                      { headId
-                      , version = version
-                      , number = sn
-                      , confirmed = requestedTxIds
-                      , utxo = u
-                      , utxoToCommit = mIncrementUTxO
-                      , utxoToDecommit = mUtxoToDecommit
+        requireApplicableDecommitTx $ \(activeUTxOAfterDecommit, mUtxoToDecommit) ->
+          requireApplicableCommit activeUTxOAfterDecommit $ \(activeUTxO, mUtxoToCommit) ->
+            -- Resolve transactions by-id
+            waitResolvableTxs $ \requestedTxs -> do
+              -- Spec: require 𝑈_active ◦ Treq ≠ ⊥
+              --       𝑈 ← 𝑈_active ◦ Treq
+              requireApplyTxs activeUTxO requestedTxs $ \u -> do
+                -- Spec: ŝ ← ̅S.s + 1
+                -- NOTE: confSn == seenSn == sn here
+                let nextSnapshot =
+                      Snapshot
+                        { headId
+                        , version = version
+                        , number = sn
+                        , confirmed = requestedTxIds
+                        , utxo = u
+                        , utxoToCommit = mUtxoToCommit
+                        , utxoToDecommit = mUtxoToDecommit
+                        }
+                -- Spec: η ← combine(𝑈)
+                --       σᵢ ← MS-Sign(kₕˢⁱᵍ, (cid‖v‖ŝ‖η‖ηω))
+                let snapshotSignature = sign signingKey nextSnapshot
+                -- Spec: multicast (ackSn, ŝ, σᵢ)
+                (cause (NetworkEffect $ AckSn snapshotSignature sn) <>) $ do
+                  -- Spec: ̂Σ ← ∅
+                  --       L̂ ← 𝑈
+                  --       𝑋 ← T
+                  --       T̂ ← ∅
+                  --       for tx ∈ 𝑋 : L̂ ◦ tx ≠ ⊥
+                  --         T̂ ← T̂ ⋃ {tx}
+                  --         L̂ ← L̂ ◦ tx
+                  let (newLocalTxs, newLocalUTxO) = pruneTransactions u
+                  newState
+                    SnapshotRequested
+                      { snapshot = nextSnapshot
+                      , requestedTxIds
+                      , newLocalUTxO
+                      , newLocalTxs
                       }
-              -- Spec: η ← combine(𝑈)
-              --       σᵢ ← MS-Sign(kₕˢⁱᵍ, (cid‖v‖ŝ‖η‖ηω))
-              let snapshotSignature = sign signingKey nextSnapshot
-              -- Spec: multicast (ackSn, ŝ, σᵢ)
-              (cause (NetworkEffect $ AckSn snapshotSignature sn) <>) $ do
-                -- Spec: ̂Σ ← ∅
-                --       L̂ ← 𝑈
-                --       𝑋 ← T
-                --       T̂ ← ∅
-                --       for tx ∈ 𝑋 : L̂ ◦ tx ≠ ⊥
-                --         T̂ ← T̂ ⋃ {tx}
-                --         L̂ ← L̂ ◦ tx
-                let (newLocalTxs, newLocalUTxO) = pruneTransactions u
-                newState
-                  SnapshotRequested
-                    { snapshot = nextSnapshot
-                    , requestedTxIds
-                    , newLocalUTxO
-                    , newLocalTxs
-                    }
  where
   requireReqSn continue
     | sv /= version =
@@ -481,6 +482,19 @@ onOpenNetworkReqSn env ledger st otherParty sv sn requestedTxIds mDecommitTx mIn
       [] -> continue $ mapMaybe (`Map.lookup` allTxs) requestedTxIds
       unseen -> wait $ WaitOnTxs unseen
 
+  requireApplicableCommit activeUTxOAfterDecommit cont =
+    case mIncrementUTxO of
+      Nothing -> cont (activeUTxOAfterDecommit, Nothing)
+      Just utxo ->
+        if sv == confVersion && isJust confUTxOToCommit
+          then
+            if confUTxOToCommit == Just utxo
+              then cont (activeUTxOAfterDecommit, confUTxOToCommit)
+              else Error $ RequireFailed ReqSnCommitNotSettled
+          else do
+            let activeUTxOAfterCommit = activeUTxOAfterDecommit <> utxo
+            cont (activeUTxOAfterCommit, Just utxo)
+
   requireApplicableDecommitTx cont =
     case mDecommitTx of
       Nothing -> cont (confirmedUTxO, Nothing)
@@ -540,6 +554,10 @@ onOpenNetworkReqSn env ledger st otherParty sv sn requestedTxIds mDecommitTx mIn
 
   Snapshot{version = confVersion} = getSnapshot confirmedSnapshot
 
+  confUTxOToCommit = case confirmedSnapshot of
+    InitialSnapshot{} -> Nothing
+    ConfirmedSnapshot{snapshot = Snapshot{utxoToCommit}} -> utxoToCommit
+
   confUTxOToDecommit = case confirmedSnapshot of
     InitialSnapshot{} -> Nothing
     ConfirmedSnapshot{snapshot = Snapshot{utxoToDecommit}} -> utxoToDecommit
@@ -858,10 +876,21 @@ onOpenChainDepositTx ::
   Outcome tx
 onOpenChainDepositTx env st utxo =
   waitOnUnresolvedDecommit $
-    if not snapshotInFlight && isLeader parameters party nextSn
-      then cause (NetworkEffect $ ReqSn version nextSn (txId <$> localTxs) Nothing (Just utxo))
-      else noop
+    waitOnUnresolvedCommit $
+      if not snapshotInFlight && isLeader parameters party nextSn
+        then
+          newState CommitRecorded{commitUTxO = utxo, newLocalUTxO = localUTxO <> utxo}
+            <> cause (NetworkEffect $ ReqSn version nextSn (txId <$> (localTxs <> [txSpendingUTxO utxo])) Nothing (Just utxo))
+        else noop
  where
+  waitOnUnresolvedCommit cont =
+    case commitUTxO of
+      Nothing -> cont
+      Just unresolvedCommitUTxO ->
+        if Just unresolvedCommitUTxO == commitUTxO
+          then cont
+          else wait $ WaitOnUnresolvedCommit{commitUTxO = unresolvedCommitUTxO}
+
   waitOnUnresolvedDecommit cont =
     case decommitTx of
       Nothing -> cont
@@ -871,7 +900,7 @@ onOpenChainDepositTx env st utxo =
 
   Environment{party} = env
 
-  CoordinatedHeadState{localTxs, confirmedSnapshot, seenSnapshot, version, decommitTx} = coordinatedHeadState
+  CoordinatedHeadState{localTxs, confirmedSnapshot, seenSnapshot, version, decommitTx, localUTxO, commitUTxO} = coordinatedHeadState
 
   Snapshot{number = confirmedSn} = getSnapshot confirmedSnapshot
 
@@ -1260,6 +1289,18 @@ aggregate st = \case
        where
         CoordinatedHeadState{localTxs} = coordinatedHeadState
       _otherState -> st
+  CommitRecorded{commitUTxO, newLocalUTxO} -> case st of
+    Open
+      os@OpenState{coordinatedHeadState} ->
+        Open
+          os
+            { coordinatedHeadState =
+                coordinatedHeadState
+                  { localUTxO = newLocalUTxO
+                  , commitUTxO = Just commitUTxO
+                  }
+            }
+    _otherState -> st
   DecommitRecorded{decommitTx, newLocalUTxO} -> case st of
     Open
       os@OpenState{coordinatedHeadState} ->
@@ -1371,6 +1412,7 @@ aggregate st = \case
                   , localTxs = mempty
                   , confirmedSnapshot = InitialSnapshot{headId, initialUTxO}
                   , seenSnapshot = NoSeenSnapshot
+                  , commitUTxO = Nothing
                   , decommitTx = Nothing
                   , version = 0
                   }
@@ -1418,6 +1460,19 @@ aggregate st = \case
                     }
               }
       _otherState -> st
+  CommitFinalized{newVersion} ->
+    case st of
+      Open
+        os@OpenState{coordinatedHeadState} ->
+          Open
+            os
+              { coordinatedHeadState =
+                  coordinatedHeadState
+                    { commitUTxO = Nothing
+                    , version = newVersion
+                    }
+              }
+      _otherState -> st
   DecommitFinalized{newVersion} ->
     case st of
       Open
@@ -1469,6 +1524,7 @@ recoverChainStateHistory initialChainState =
     HeadAborted{chainState} -> pushNewState chainState history
     HeadOpened{chainState} -> pushNewState chainState history
     TransactionAppliedToLocalUTxO{} -> history
+    CommitRecorded{} -> history
     DecommitRecorded{} -> history
     SnapshotRequestDecided{} -> history
     SnapshotRequested{} -> history

hydra-node/src/Hydra/HeadLogic/Error.hs

@@ -40,6 +40,7 @@ data RequirementFailure tx
   | ReqSvNumberInvalid {requestedSv :: SnapshotVersion, lastSeenSv :: SnapshotVersion}
   | ReqSnNotLeader {requestedSn :: SnapshotNumber, leader :: Party}
   | ReqSnDecommitNotSettled
+  | ReqSnCommitNotSettled
   | InvalidMultisignature {multisig :: Text, vkeys :: [VerificationKey HydraKey]}
   | SnapshotAlreadySigned {knownSignatures :: [Party], receivedSignature :: Party}
   | AckSnNumberInvalid {requestedSn :: SnapshotNumber, lastSeenSn :: SnapshotNumber}

hydra-node/src/Hydra/HeadLogic/Outcome.hs

@@ -72,6 +72,7 @@ data StateChanged tx
       { tx :: tx
       , newLocalUTxO :: UTxOType tx
       }
+  | CommitRecorded {commitUTxO :: UTxOType tx, newLocalUTxO :: UTxOType tx}
   | DecommitRecorded {decommitTx :: tx, newLocalUTxO :: UTxOType tx}
   | SnapshotRequestDecided {snapshotNumber :: SnapshotNumber}
   | -- | A snapshot was requested by some party.
@@ -83,6 +84,7 @@ data StateChanged tx
       , newLocalUTxO :: UTxOType tx
       , newLocalTxs :: [tx]
       }
+  | CommitFinalized {newVersion :: SnapshotVersion}
   | DecommitFinalized {newVersion :: SnapshotVersion}
   | PartySignedSnapshot {snapshot :: Snapshot tx, party :: Party, signature :: Signature (Snapshot tx)}
   | SnapshotConfirmed {snapshot :: Snapshot tx, signatures :: MultiSignature (Snapshot tx)}
@@ -177,6 +179,7 @@ data WaitReason tx
   | WaitOnTxs {waitingForTxIds :: [TxIdType tx]}
   | WaitOnContestationDeadline
   | WaitOnNotApplicableDecommitTx {notApplicableReason :: DecommitInvalidReason tx}
+  | WaitOnUnresolvedCommit {commitUTxO :: UTxOType tx}
   | WaitOnUnresolvedDecommit {decommitTx :: tx}
   deriving stock (Generic)
 

hydra-node/src/Hydra/HeadLogic/State.hs

@@ -159,6 +159,8 @@ data CoordinatedHeadState tx = CoordinatedHeadState
   -- ^ The latest confirmed snapshot. Spec: S̅
   , seenSnapshot :: SeenSnapshot tx
   -- ^ Last seen snapshot and signatures accumulator. Spec: Û, ŝ and Σ̂
+  , commitUTxO :: Maybe (UTxOType tx)
+  -- ^ Pending decommit transaction. Spec: txω
   , decommitTx :: Maybe tx
   -- ^ Pending decommit transaction. Spec: txω
   , version :: SnapshotVersion

hydra-node/test/Hydra/HeadLogicSnapshotSpec.hs

@@ -64,6 +64,7 @@ spec = do
             , localTxs = mempty
             , confirmedSnapshot = InitialSnapshot testHeadId u0
             , seenSnapshot = NoSeenSnapshot
+            , commitUTxO = Nothing
             , decommitTx = Nothing
             , version = 0
             }
@@ -205,6 +206,7 @@ prop_singleMemberHeadAlwaysSnapshotOnReqTx sn = monadicST $ do
         , localTxs = []
         , confirmedSnapshot = sn
         , seenSnapshot
+        , commitUTxO = Nothing
         , decommitTx = Nothing
         , version
         }