Introduce incrementUTxo field in the ReqSn and stub out onOpenChainDe…

…positTx

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

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 ()))

hydra-node/src/Hydra/HeadLogic.hs

@@ -357,7 +357,7 @@ onOpenNetworkReqTx env ledger st ttl tx =
           -- spec. Do we really need to store that we have
           -- requested a snapshot? If yes, should update spec.
           <> newState SnapshotRequestDecided{snapshotNumber = nextSn}
-          <> cause (NetworkEffect $ ReqSn version nextSn (txId <$> localTxs') decommitTx)
+          <> cause (NetworkEffect $ ReqSn version nextSn (txId <$> localTxs') decommitTx Nothing)
       else outcome
   Environment{party} = env
 
@@ -406,8 +406,9 @@ onOpenNetworkReqSn ::
   [TxIdType tx] ->
   -- | Optional decommit transaction of removing funds from the head.
   Maybe tx ->
+  Maybe (UTxOType tx) ->
   Outcome tx
-onOpenNetworkReqSn env ledger st otherParty sv sn requestedTxIds mDecommitTx =
+onOpenNetworkReqSn env ledger st otherParty sv sn requestedTxIds mDecommitTx mIncrementUTxO =
   -- Spec: require s = ŝ + 1 ∧ leader(s) = j
   requireReqSn $
     -- Spec: wait ŝ = ̅S.s
@@ -652,7 +653,7 @@ onOpenNetworkAckSn Environment{party} openState otherParty snapshotSignature sn
       then
         outcome
           <> newState SnapshotRequestDecided{snapshotNumber = nextSn}
-          <> cause (NetworkEffect $ ReqSn version nextSn (txId <$> localTxs) decommitTx)
+          <> cause (NetworkEffect $ ReqSn version nextSn (txId <$> localTxs) decommitTx Nothing)
       else outcome
 
   maybePostDecrementTx snapshot@Snapshot{utxoToDecommit} signatures outcome =
@@ -815,7 +816,7 @@ onOpenNetworkReqDec env ledger ttl openState decommitTx =
 
   maybeRequestSnapshot =
     if not snapshotInFlight && isLeader parameters party nextSn
-      then cause (NetworkEffect (ReqSn version nextSn (txId <$> localTxs) (Just decommitTx)))
+      then cause (NetworkEffect (ReqSn version nextSn (txId <$> localTxs) (Just decommitTx) Nothing))
       else noop
 
   Environment{party} = env
@@ -850,10 +851,34 @@ onOpenNetworkReqDec env ledger ttl openState decommitTx =
 
 onOpenChainDepositTx ::
   IsTx tx =>
+  Environment ->
   OpenState tx ->
   UTxOType tx ->
   Outcome tx
-onOpenChainDepositTx openState utxo = undefined
+onOpenChainDepositTx env st utxo =
+  if not snapshotInFlight && isLeader parameters party nextSn
+    then -- TODO: shall we include deposit tx in the ReqSn?
+      cause (NetworkEffect $ ReqSn version nextSn (txId <$> localTxs) Nothing (Just utxo))
+    else noop
+ where
+  -- TODO: implement me!
+  waitOnResolvedDecrement cont = undefined
+
+  nextSn = confirmedSn + 1
+
+  Environment{party} = env
+
+  CoordinatedHeadState{localTxs, localUTxO, confirmedSnapshot, seenSnapshot, decommitTx, version} = coordinatedHeadState
+
+  Snapshot{number = confirmedSn} = getSnapshot confirmedSnapshot
+
+  OpenState{coordinatedHeadState, headId, currentSlot, parameters} = st
+
+  snapshotInFlight = case seenSnapshot of
+    NoSeenSnapshot -> False
+    LastSeenSnapshot{} -> False
+    RequestedSnapshot{} -> True
+    SeenSnapshot{} -> True
 
 -- | Observe a decrement transaction. If the outputs match the ones of the
 -- pending decommit tx, then we consider the decommit finalized, and remove the
@@ -1112,8 +1137,8 @@ update env ledger st ev = case (st, ev) of
     onOpenClientNewTx tx
   (Open openState, NetworkInput ttl (ReceivedMessage{msg = ReqTx tx})) ->
     onOpenNetworkReqTx env ledger openState ttl tx
-  (Open openState, NetworkInput _ (ReceivedMessage{sender, msg = ReqSn sv sn txIds decommitTx})) ->
-    onOpenNetworkReqSn env ledger openState sender sv sn txIds decommitTx
+  (Open openState, NetworkInput _ (ReceivedMessage{sender, msg = ReqSn sv sn txIds decommitTx incrementUTxO})) ->
+    onOpenNetworkReqSn env ledger openState sender sv sn txIds decommitTx incrementUTxO
   (Open openState, NetworkInput _ (ReceivedMessage{sender, msg = AckSn snapshotSignature sn})) ->
     onOpenNetworkAckSn env openState sender snapshotSignature sn
   ( Open openState@OpenState{headId = ourHeadId}
@@ -1136,7 +1161,7 @@ update env ledger st ev = case (st, ev) of
   (Open openState, NetworkInput ttl (ReceivedMessage{msg = ReqDec{transaction}})) ->
     onOpenNetworkReqDec env ledger ttl openState transaction
   (Open openState@OpenState{headId = ourHeadId}, ChainInput Observation{observedTx = OnDepositTx{headId, utxo}})
-    | ourHeadId == headId -> onOpenChainDepositTx openState utxo
+    | ourHeadId == headId -> onOpenChainDepositTx env openState utxo
   (Open openState@OpenState{headId = ourHeadId}, ChainInput Observation{observedTx = OnDecrementTx{headId, newVersion, distributedOutputs}})
     -- TODO: What happens if observed decrement tx get's rolled back?
     | ourHeadId == headId ->

hydra-node/src/Hydra/Network/Message.hs

@@ -78,6 +78,7 @@ data Message tx
       , snapshotNumber :: SnapshotNumber
       , transactionIds :: [TxIdType tx]
       , decommitTx :: Maybe tx
+      , incrementUTxO :: Maybe (UTxOType tx)
       }
   | AckSn
       { signed :: Signature (Snapshot tx)
@@ -97,15 +98,15 @@ instance ArbitraryIsTx tx => Arbitrary (Message tx) where
 instance (ToCBOR tx, ToCBOR (UTxOType tx), ToCBOR (TxIdType tx)) => ToCBOR (Message tx) where
   toCBOR = \case
     ReqTx tx -> toCBOR ("ReqTx" :: Text) <> toCBOR tx
-    ReqSn sv sn txs decommitTx -> toCBOR ("ReqSn" :: Text) <> toCBOR sv <> toCBOR sn <> toCBOR txs <> toCBOR decommitTx
+    ReqSn sv sn txs decommitTx incrementUTxO -> toCBOR ("ReqSn" :: Text) <> toCBOR sv <> toCBOR sn <> toCBOR txs <> toCBOR decommitTx <> toCBOR incrementUTxO
     AckSn sig sn -> toCBOR ("AckSn" :: Text) <> toCBOR sig <> toCBOR sn
     ReqDec utxo -> toCBOR ("ReqDec" :: Text) <> toCBOR utxo
 
 instance (FromCBOR tx, FromCBOR (UTxOType tx), FromCBOR (TxIdType tx)) => FromCBOR (Message tx) where
   fromCBOR =
     fromCBOR >>= \case
       ("ReqTx" :: Text) -> ReqTx <$> fromCBOR
-      "ReqSn" -> ReqSn <$> fromCBOR <*> fromCBOR <*> fromCBOR <*> fromCBOR
+      "ReqSn" -> ReqSn <$> fromCBOR <*> fromCBOR <*> fromCBOR <*> fromCBOR <*> fromCBOR
       "AckSn" -> AckSn <$> fromCBOR <*> fromCBOR
       "ReqDec" -> ReqDec <$> fromCBOR
       msg -> fail $ show msg <> " is not a proper CBOR-encoded Message"

hydra-node/test/Hydra/HeadLogicSnapshotSpec.hs

@@ -85,7 +85,7 @@ spec = do
             outcome = update (envFor aliceSk) simpleLedger (inOpenState' [alice, bob] coordinatedHeadState) $ receiveMessage $ ReqTx tx
 
         outcome
-          `hasEffect` NetworkEffect (ReqSn 0 1 [txId tx] Nothing)
+          `hasEffect` NetworkEffect (ReqSn 0 1 [txId tx] Nothing Nothing)
 
       it "does NOT send ReqSn when we are NOT the leader even if no snapshot in flight" $ do
         let tx = aValidTx 1
@@ -124,7 +124,7 @@ spec = do
 
       it "sends ReqSn  when leader and there are seen transactions" $ do
         headState <- runHeadLogic bobEnv simpleLedger (inOpenState threeParties) $ do
-          step (receiveMessage $ ReqSn 0 1 [] Nothing)
+          step (receiveMessage $ ReqSn 0 1 [] Nothing Nothing)
           step (receiveMessageFrom carol $ ReqTx $ aValidTx 1)
           step (ackFrom carolSk carol)
           step (ackFrom aliceSk alice)
@@ -135,7 +135,7 @@ spec = do
 
       it "does NOT send ReqSn when we are the leader but there are NO seen transactions" $ do
         headState <- runHeadLogic bobEnv simpleLedger (inOpenState threeParties) $ do
-          step (receiveMessage $ ReqSn 0 1 [] Nothing)
+          step (receiveMessage $ ReqSn 0 1 [] Nothing Nothing)
           step (ackFrom carolSk carol)
           step (ackFrom aliceSk alice)
           getState
@@ -148,7 +148,7 @@ spec = do
           notLeaderEnv = envFor carolSk
 
         let initiateSigningASnapshot actor =
-              step (receiveMessageFrom actor $ ReqSn 0 1 [] Nothing)
+              step (receiveMessageFrom actor $ ReqSn 0 1 [] Nothing Nothing)
             newTxBeforeSnapshotAcknowledged =
               step (receiveMessageFrom carol $ ReqTx $ aValidTx 1)
 
@@ -164,7 +164,7 @@ spec = do
 
       it "updates seenSnapshot state when sending ReqSn" $ do
         headState <- runHeadLogic bobEnv simpleLedger (inOpenState threeParties) $ do
-          step (receiveMessage $ ReqSn 0 1 [] Nothing)
+          step (receiveMessage $ ReqSn 0 1 [] Nothing Nothing)
           step (receiveMessageFrom carol $ ReqTx $ aValidTx 1)
           step (ackFrom carolSk carol)
           step (ackFrom aliceSk alice)
@@ -212,7 +212,7 @@ prop_singleMemberHeadAlwaysSnapshotOnReqTx sn = monadicST $ do
     Snapshot{number = confirmedSn} = getSnapshot sn
     nextSn = confirmedSn + 1
   pure $
-    outcome `hasEffect` NetworkEffect (ReqSn version nextSn [txId tx] Nothing)
+    outcome `hasEffect` NetworkEffect (ReqSn version nextSn [txId tx] Nothing Nothing)
       & counterexample (show outcome)
 
 prop_thereIsAlwaysALeader :: Property

hydra-node/test/Hydra/HeadLogicSpec.hs

@@ -120,7 +120,7 @@ spec =
           `assertWait` WaitOnNotApplicableTx (ValidationError "cannot apply transaction")
 
       it "confirms snapshot given it receives AckSn from all parties" $ do
-        let reqSn = receiveMessage $ ReqSn 0 1 [] Nothing
+        let reqSn = receiveMessage $ ReqSn 0 1 [] Nothing Nothing
             snapshot1 = Snapshot testHeadId 0 1 [] mempty Nothing
             ackFrom sk vk = receiveMessageFrom vk $ AckSn (sign sk snapshot1) 1
         snapshotInProgress <- runHeadLogic bobEnv ledger (inOpenState threeParties) $ do
@@ -151,7 +151,7 @@ spec =
             step $ receiveMessage $ ReqTx tx1
             step $ receiveMessage $ ReqTx tx2
             step $ receiveMessage $ ReqTx tx3
-            step $ receiveMessage $ ReqSn 0 1 [1] Nothing
+            step $ receiveMessage $ ReqSn 0 1 [1] Nothing Nothing
             getState
 
           case s of
@@ -261,7 +261,7 @@ spec =
 
           let s1 = update aliceEnv ledger s0 reqDecEvent
 
-          let reqSn = ReqSn{snapshotVersion = 0, snapshotNumber = 1, transactionIds = [], decommitTx = Just decommitTx'}
+          let reqSn = ReqSn{snapshotVersion = 0, snapshotNumber = 1, transactionIds = [], decommitTx = Just decommitTx', incrementUTxO = Nothing}
           s1 `hasEffect` NetworkEffect reqSn
 
       describe "Tracks Transaction Ids" $ do
@@ -280,7 +280,7 @@ spec =
         it "removes transactions in allTxs given it receives a ReqSn" $ do
           let s0 = inOpenState threeParties
               t1 = SimpleTx 1 mempty (utxoRef 1)
-              reqSn = receiveMessage $ ReqSn 0 1 [1] Nothing
+              reqSn = receiveMessage $ ReqSn 0 1 [1] Nothing Nothing
 
           s1 <- runHeadLogic bobEnv ledger s0 $ do
             step $ receiveMessage $ ReqTx t1
@@ -294,7 +294,7 @@ spec =
         it "removes transactions from allTxs when included in a acked snapshot even when emitting a ReqSn" $ do
           let t1 = SimpleTx 1 mempty (utxoRef 1)
               pendingTransaction = SimpleTx 2 mempty (utxoRef 2)
-              reqSn = receiveMessage $ ReqSn 0 1 [1] Nothing
+              reqSn = receiveMessage $ ReqSn 0 1 [1] Nothing Nothing
               snapshot1 = testSnapshot 1 0 [1] (utxoRefs [1])
               ackFrom sk vk = receiveMessageFrom vk $ AckSn (sign sk snapshot1) 1
 
@@ -314,7 +314,7 @@ spec =
             _ -> False
 
       it "rejects last AckSn if one signature was from a different snapshot" $ do
-        let reqSn = receiveMessage $ ReqSn 0 1 [] Nothing
+        let reqSn = receiveMessage $ ReqSn 0 1 [] Nothing Nothing
             snapshot = testSnapshot 1 0 [] mempty
             snapshot' = testSnapshot 2 0 [] mempty
             ackFrom sk vk = receiveMessageFrom vk $ AckSn (sign sk snapshot) 1
@@ -331,7 +331,7 @@ spec =
             _ -> False
 
       it "rejects last AckSn if one signature was from a different key" $ do
-        let reqSn = receiveMessage $ ReqSn 0 1 [] Nothing
+        let reqSn = receiveMessage $ ReqSn 0 1 [] Nothing Nothing
             snapshot = testSnapshot 1 0 [] mempty
             ackFrom sk vk = receiveMessageFrom vk $ AckSn (sign sk snapshot) 1
         waitingForLastAck <-
@@ -347,7 +347,7 @@ spec =
             _ -> False
 
       it "rejects last AckSn if one signature was from a completely different message" $ do
-        let reqSn = receiveMessage $ ReqSn 0 1 [] Nothing
+        let reqSn = receiveMessage $ ReqSn 0 1 [] Nothing Nothing
             snapshot1 = testSnapshot 1 0 [] mempty
             ackFrom sk vk = receiveMessageFrom vk $ AckSn (sign sk snapshot1) 1
             invalidAckFrom sk vk =
@@ -366,7 +366,7 @@ spec =
             _ -> False
 
       it "rejects last AckSn if already received signature from this party" $ do
-        let reqSn = receiveMessage $ ReqSn 0 1 [] Nothing
+        let reqSn = receiveMessage $ ReqSn 0 1 [] Nothing Nothing
             snapshot1 = testSnapshot 1 0 [] mempty
             ackFrom sk vk = receiveMessageFrom vk $ AckSn (sign sk snapshot1) 1
         waitingForAck <-
@@ -383,7 +383,7 @@ spec =
       it "rejects snapshot request with transaction not applicable to previous snapshot" $ do
         let reqTx42 = receiveMessage $ ReqTx (SimpleTx 42 mempty (utxoRef 1))
             reqTx1 = receiveMessage $ ReqTx (SimpleTx 1 (utxoRef 1) (utxoRef 2))
-            input = receiveMessage $ ReqSn 0 1 [1] Nothing
+            input = receiveMessage $ ReqSn 0 1 [1] Nothing Nothing
             s0 = inOpenState threeParties
 
         s2 <- runHeadLogic bobEnv ledger s0 $ do
@@ -396,7 +396,7 @@ spec =
 
       it "waits if we receive a snapshot with unseen transactions" $ do
         let s0 = inOpenState threeParties
-            reqSn = receiveMessage $ ReqSn 0 1 [1] Nothing
+            reqSn = receiveMessage $ ReqSn 0 1 [1] Nothing Nothing
         update bobEnv ledger s0 reqSn
           `assertWait` WaitOnTxs [1]
 
@@ -411,13 +411,13 @@ spec =
       -- snapshot collection.
 
       it "rejects if we receive a too far future snapshot" $ do
-        let input = receiveMessageFrom bob $ ReqSn 0 2 [] Nothing
+        let input = receiveMessageFrom bob $ ReqSn 0 2 [] Nothing Nothing
             st = inOpenState threeParties
         update bobEnv ledger st input `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 0)
 
       it "waits if we receive a future snapshot while collecting signatures" $ do
-        let reqSn1 = receiveMessage $ ReqSn 0 1 [] Nothing
-            reqSn2 = receiveMessageFrom bob $ ReqSn 0 2 [] Nothing
+        let reqSn1 = receiveMessage $ ReqSn 0 1 [] Nothing Nothing
+            reqSn2 = receiveMessageFrom bob $ ReqSn 0 2 [] Nothing Nothing
         st <-
           runHeadLogic bobEnv ledger (inOpenState threeParties) $ do
             step reqSn1
@@ -429,22 +429,22 @@ spec =
       it "acks signed snapshot from the constant leader" $ do
         let leader = alice
             snapshot = testSnapshot 1 0 [] mempty
-            input = receiveMessageFrom leader $ ReqSn 0 (number snapshot) [] Nothing
+            input = receiveMessageFrom leader $ ReqSn 0 (number snapshot) [] Nothing Nothing
             sig = sign bobSk snapshot
             st = inOpenState threeParties
             ack = AckSn sig (number snapshot)
         update bobEnv ledger st input `hasEffect` NetworkEffect ack
 
       it "does not ack snapshots from non-leaders" $ do
-        let input = receiveMessageFrom notTheLeader $ ReqSn 0 1 [] Nothing
+        let input = receiveMessageFrom notTheLeader $ ReqSn 0 1 [] Nothing Nothing
             notTheLeader = bob
             st = inOpenState threeParties
         update bobEnv ledger st input `shouldSatisfy` \case
           Error (RequireFailed ReqSnNotLeader{requestedSn = 1, leader}) -> leader == notTheLeader
           _ -> False
 
       it "rejects too-old snapshots" $ do
-        let input = receiveMessageFrom theLeader $ ReqSn 0 2 [] Nothing
+        let input = receiveMessageFrom theLeader $ ReqSn 0 2 [] Nothing Nothing
             theLeader = alice
             snapshot = testSnapshot 2 0 [] mempty
             st =
@@ -453,7 +453,7 @@ spec =
         update bobEnv ledger st input `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 0)
 
       it "rejects too-old snapshots when collecting signatures" $ do
-        let input = receiveMessageFrom theLeader $ ReqSn 0 2 [] Nothing
+        let input = receiveMessageFrom theLeader $ ReqSn 0 2 [] Nothing Nothing
             theLeader = alice
             snapshot = testSnapshot 2 0 [] mempty
             st =
@@ -465,15 +465,15 @@ spec =
         update bobEnv ledger st input `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 3)
 
       it "rejects too-new snapshots from the leader" $ do
-        let input = receiveMessageFrom theLeader $ ReqSn 0 3 [] Nothing
+        let input = receiveMessageFrom theLeader $ ReqSn 0 3 [] Nothing Nothing
             theLeader = carol
             st = inOpenState threeParties
         update bobEnv ledger st input `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 3 0)
 
       it "rejects invalid snapshots version" $ do
         let validSnNumber = 0
             invalidSnVersion = 1
-            input = receiveMessageFrom theLeader $ ReqSn invalidSnVersion validSnNumber [] Nothing
+            input = receiveMessageFrom theLeader $ ReqSn invalidSnVersion validSnNumber [] Nothing Nothing
             theLeader = carol
             expectedSnVersion = 0
             st = inOpenState threeParties
@@ -483,9 +483,9 @@ spec =
         let theLeader = alice
             nextSN = 1
             firstReqTx = receiveMessage $ ReqTx (aValidTx 42)
-            firstReqSn = receiveMessageFrom theLeader $ ReqSn 0 nextSN [42] Nothing
+            firstReqSn = receiveMessageFrom theLeader $ ReqSn 0 nextSN [42] Nothing Nothing
             secondReqTx = receiveMessage $ ReqTx (aValidTx 51)
-            secondReqSn = receiveMessageFrom theLeader $ ReqSn 0 nextSN [51] Nothing
+            secondReqSn = receiveMessageFrom theLeader $ ReqSn 0 nextSN [51] Nothing Nothing
 
         s3 <- runHeadLogic bobEnv ledger (inOpenState threeParties) $ do
           step firstReqTx
@@ -518,8 +518,8 @@ spec =
                   , seenSnapshot = LastSeenSnapshot 1
                   , localUTxO = activeUTxO
                   }
-            reqSn0 = receiveMessageFrom alice $ ReqSn 0 1 [] (Just decommitTx1)
-            reqSn1 = receiveMessageFrom bob $ ReqSn 0 2 [] (Just decommitTx2)
+            reqSn0 = receiveMessageFrom alice $ ReqSn 0 1 [] (Just decommitTx1) Nothing
+            reqSn1 = receiveMessageFrom bob $ ReqSn 0 2 [] (Just decommitTx2) Nothing
 
         outcome <- runHeadLogic bobEnv ledger s0 $ do
           step reqSn0
@@ -707,7 +707,7 @@ spec =
         st <-
           run $
             runHeadLogic bobEnv ledger st0 $ do
-              step (receiveMessage $ ReqSn 0 1 [] Nothing)
+              step (receiveMessage $ ReqSn 0 1 [] Nothing Nothing)
               getState
 
         assert $ case st of