No party inside the message

This ensure that one can not forge a message from another party
and signed it with it's own key. There is no party in a message
so the party is always the signer of the Authenticated message.

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

@@ -5,6 +5,7 @@ module Main where
 import Hydra.Prelude
 
 import Hydra.API.Server (Server (Server, sendOutput), withAPIServer)
+import Hydra.API.ServerOutput (ServerOutput (PeerConnected, PeerDisconnected))
 import Hydra.Cardano.Api (serialiseToRawBytesHex)
 import Hydra.Chain (HeadParameters (..))
 import Hydra.Chain.CardanoClient (QueryPoint (..), queryGenesisParameters)
@@ -33,6 +34,7 @@ import Hydra.Logging (Verbosity (..), traceWith, withTracer)
 import Hydra.Logging.Messages (HydraLog (..))
 import Hydra.Logging.Monitoring (withMonitoring)
 import Hydra.Network (Host (..))
+import Hydra.Network.Authenticate (Authenticated (Authenticated), withAuthentication)
 import Hydra.Network.Heartbeat (withHeartbeat)
 import Hydra.Network.Message (Connectivity (..))
 import Hydra.Network.Ouroboros (withOuroborosNetwork)
@@ -55,8 +57,6 @@ import Hydra.Options (
   validateRunOptions,
  )
 import Hydra.Persistence (Persistence (load), createPersistence, createPersistenceIncremental)
-import Hydra.API.ServerOutput (ServerOutput(PeerConnected, PeerDisconnected))
-import Hydra.Network.Authenticate (withAuthentication, Authenticated (Authenticated))
 
 newtype ParamMismatchError = ParamMismatchError String deriving (Eq, Show)
 
@@ -104,7 +104,7 @@ main = do
         wallet <- mkTinyWallet (contramap DirectChain tracer) chainConfig
         withDirectChain (contramap DirectChain tracer) chainConfig ctx wallet (getChainState hs) (putEvent . OnChainEvent) $ \chain -> do
           let RunOptions{host, port, peers, nodeId} = opts
-              putNetworkEvent (Authenticated msg _) = putEvent $ NetworkEvent defaultTTL msg
+              putNetworkEvent (Authenticated msg otherParty) = putEvent $ NetworkEvent defaultTTL otherParty msg
               RunOptions{apiHost, apiPort} = opts
           apiPersistence <- createPersistenceIncremental $ persistenceDir <> "/server-output"
           withAPIServer apiHost apiPort party apiPersistence (contramap APIServer tracer) chain (putEvent . ClientEvent) $ \server -> do

hydra-node/src/Hydra/HeadLogic.hs

@@ -69,7 +69,7 @@ data Event tx
     --
     --  * `ttl` is a simple counter that's decreased every time the event is
     --    reenqueued due to a wait. It's default value is `defaultTTL`
-    NetworkEvent {ttl :: TTL, message :: Message tx}
+    NetworkEvent {ttl :: TTL, party :: Party, message :: Message tx}
   | -- | Event received from the chain via a "Hydra.Chain".
     OnChainEvent {chainEvent :: ChainEvent tx}
   | -- | Event to re-ingest errors from 'postTx' for further processing.
@@ -688,7 +688,7 @@ onOpenNetworkReqSn env ledger st otherParty sn requestedTxs =
                       }
                 }
           )
-          `Combined` Effects [NetworkEffect $ AckSn party snapshotSignature sn]
+          `Combined` Effects [NetworkEffect $ AckSn snapshotSignature sn]
  where
   requireReqSn continue =
     if
@@ -736,7 +736,7 @@ onOpenNetworkReqSn env ledger st otherParty sn requestedTxs =
 
   OpenState{parameters, coordinatedHeadState, currentSlot} = st
 
-  Environment{party, signingKey} = env
+  Environment{signingKey} = env
 
 -- | Process a snapshot acknowledgement ('AckSn') from a party.
 --
@@ -995,12 +995,12 @@ update env ledger st ev = case (st, ev) of
     onOpenClientClose openState
   (Open{}, ClientEvent (NewTx tx)) ->
     onOpenClientNewTx tx
-  (Open openState, NetworkEvent ttl (ReqTx tx)) ->
+  (Open openState, NetworkEvent ttl _ (ReqTx tx)) ->
     onOpenNetworkReqTx env ledger openState ttl tx
-  (Open openState, NetworkEvent _ (ReqSn otherParty sn txs)) ->
+  (Open openState, NetworkEvent _ otherParty (ReqSn sn txs)) ->
     -- XXX: ttl == 0 not handled for ReqSn
     onOpenNetworkReqSn env ledger openState otherParty sn txs
-  (Open openState, NetworkEvent _ (AckSn otherParty snapshotSignature sn)) ->
+  (Open openState, NetworkEvent _ otherParty (AckSn snapshotSignature sn)) ->
     -- XXX: ttl == 0 not handled for AckSn
     onOpenNetworkAckSn env openState otherParty snapshotSignature sn
   ( Open openState@OpenState{headId = ourHeadId}
@@ -1089,7 +1089,7 @@ newSn Environment{party} parameters CoordinatedHeadState{confirmedSnapshot, seen
 -- | Emit a snapshot if we are the next snapshot leader. 'Outcome' modifying
 -- signature so it can be chained with other 'update' functions.
 emitSnapshot :: Environment -> Outcome tx -> Outcome tx
-emitSnapshot env@Environment{party} outcome =
+emitSnapshot env outcome =
   case outcome of
     NewState (Open OpenState{parameters, coordinatedHeadState, chainState, headId, currentSlot}) ->
       case newSn env parameters coordinatedHeadState of
@@ -1112,7 +1112,7 @@ emitSnapshot env@Environment{party} outcome =
                   , currentSlot
                   }
             )
-            `Combined` Effects [NetworkEffect (ReqSn party sn txs)]
+            `Combined` Effects [NetworkEffect (ReqSn sn txs)]
         _ -> outcome
     Combined l r -> Combined (emitSnapshot env l) (emitSnapshot env r)
     _ -> outcome

hydra-node/src/Hydra/Logging/Monitoring.hs

@@ -89,7 +89,7 @@ monitor ::
   HydraLog tx net ->
   m ()
 monitor transactionsMap metricsMap = \case
-  (Node BeginEvent{event = NetworkEvent _ (ReqTx tx)}) -> do
+  (Node BeginEvent{event = NetworkEvent _ _ (ReqTx tx)}) -> do
     t <- getMonotonicTime
     -- NOTE: If a requested transaction never gets confirmed, it might stick
     -- forever in the transactions map which could lead to unbounded growth and

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

@@ -9,7 +9,6 @@ import Cardano.Crypto.Util (SignableRepresentation, getSignableRepresentation)
 import Hydra.Crypto (Signature)
 import Hydra.Ledger (IsTx, UTxOType)
 import Hydra.Network (NodeId)
-import Hydra.Party (Party)
 import Hydra.Snapshot (Snapshot, SnapshotNumber)
 
 data Connectivity
@@ -18,12 +17,18 @@ data Connectivity
   deriving stock (Generic, Eq, Show)
   deriving anyclass (ToJSON, FromJSON)
 
--- NOTE(SN): Every message comes from a 'Party', we might want to move it out of
--- here into the 'NetworkEvent'
 data Message tx
   = ReqTx {transaction :: tx}
-  | ReqSn {party :: Party, snapshotNumber :: SnapshotNumber, transactions :: [tx]}
-  | AckSn {party :: Party, signed :: Signature (Snapshot tx), snapshotNumber :: SnapshotNumber}
+  | ReqSn {snapshotNumber :: SnapshotNumber, transactions :: [tx]}
+  | -- NOTE: We remove the party from the ackSn but, it would make sense to put it
+    -- back as the signed snapshot is tied to the party and we should not
+    -- consider which party sent this message to validate this snapshot signature.
+    -- but currently we do not validate the snapshot signature itself, which is
+    -- a problem.
+    -- When we fix that, when we check the snapshot signature, that would be a
+    -- good idea to introduce the party in AckSn again or, maybe better, only
+    -- the verification key of the party.
+    AckSn {signed :: Signature (Snapshot tx), snapshotNumber :: SnapshotNumber}
   deriving stock (Generic, Eq, Show)
   deriving anyclass (ToJSON, FromJSON)
 
@@ -33,15 +38,15 @@ instance IsTx tx => Arbitrary (Message tx) where
 instance (ToCBOR tx, ToCBOR (UTxOType tx)) => ToCBOR (Message tx) where
   toCBOR = \case
     ReqTx tx -> toCBOR ("ReqTx" :: Text) <> toCBOR tx
-    ReqSn party sn txs -> toCBOR ("ReqSn" :: Text) <> toCBOR party <> toCBOR sn <> toCBOR txs
-    AckSn party sig sn -> toCBOR ("AckSn" :: Text) <> toCBOR party <> toCBOR sig <> toCBOR sn
+    ReqSn sn txs -> toCBOR ("ReqSn" :: Text) <> toCBOR sn <> toCBOR txs
+    AckSn sig sn -> toCBOR ("AckSn" :: Text) <> toCBOR sig <> toCBOR sn
 
 instance (FromCBOR tx, FromCBOR (UTxOType tx)) => FromCBOR (Message tx) where
   fromCBOR =
     fromCBOR >>= \case
       ("ReqTx" :: Text) -> ReqTx <$> fromCBOR
-      "ReqSn" -> ReqSn <$> fromCBOR <*> fromCBOR <*> fromCBOR
-      "AckSn" -> AckSn <$> fromCBOR <*> fromCBOR <*> fromCBOR
+      "ReqSn" -> ReqSn <$> fromCBOR <*> fromCBOR
+      "AckSn" -> AckSn <$> fromCBOR <*> fromCBOR
       msg -> fail $ show msg <> " is not a proper CBOR-encoded Message"
 
 instance IsTx tx => SignableRepresentation (Message tx) where

hydra-node/src/Hydra/Node.hs

@@ -125,8 +125,8 @@ stepHydraNode tracer node = do
   decreaseTTL =
     \case
       -- XXX: this is smelly, handle wait re-enqueing differently
-      Queued{eventId, queuedEvent = NetworkEvent ttl msg}
-        | ttl > 0 -> Queued{eventId, queuedEvent = NetworkEvent (ttl - 1) msg}
+      Queued{eventId, queuedEvent = NetworkEvent ttl aParty msg}
+        | ttl > 0 -> Queued{eventId, queuedEvent = NetworkEvent (ttl - 1) aParty msg}
       e -> e
 
   Environment{party} = env
@@ -176,7 +176,7 @@ processEffect HydraNode{hn, oc = Chain{postTx}, server, eq, env = Environment{pa
   traceWith tracer $ BeginEffect party eventId effectId e
   case e of
     ClientEffect i -> sendOutput server i
-    NetworkEffect msg -> broadcast hn msg >> putEvent eq (NetworkEvent defaultTTL msg)
+    NetworkEffect msg -> broadcast hn msg >> putEvent eq (NetworkEvent defaultTTL party msg)
     OnChainEffect{postChainTx} ->
       postTx postChainTx
         `catch` \(postTxError :: PostTxError tx) ->

hydra-node/test/Hydra/BehaviorSpec.hs

@@ -666,7 +666,7 @@ createMockNetwork node nodes =
     let otherNodes = filter (\n -> getNodeId n /= getNodeId node) allNodes
     mapM_ (`handleMessage` msg) otherNodes
 
-  handleMessage HydraNode{eq} = putEvent eq . NetworkEvent defaultTTL
+  handleMessage HydraNode{eq, env = Environment{party}} = putEvent eq . NetworkEvent defaultTTL party
 
   getNodeId = getField @"party" . env
 

hydra-node/test/Hydra/HeadLogicSpec.hs

@@ -81,24 +81,24 @@ spec =
         let inputs = utxoRef 1
             tx = SimpleTx 2 inputs mempty
             ttl = 0
-            reqTx = NetworkEvent ttl $ ReqTx tx
+            reqTx = NetworkEvent ttl alice $ ReqTx tx
             s0 = inOpenState threeParties ledger
 
         update bobEnv ledger s0 reqTx `hasEffectSatisfying` \case
           ClientEffect TxInvalid{transaction} -> transaction == tx
           _ -> False
 
       it "waits if a requested tx is not (yet) applicable" $ do
-        let reqTx = NetworkEvent defaultTTL $ ReqTx $ SimpleTx 2 inputs mempty
+        let reqTx = NetworkEvent defaultTTL alice $ ReqTx $ SimpleTx 2 inputs mempty
             inputs = utxoRef 1
             s0 = inOpenState threeParties ledger
 
         update bobEnv ledger s0 reqTx `shouldBe` Wait (WaitOnNotApplicableTx (ValidationError "cannot apply transaction"))
 
       it "confirms snapshot given it receives AckSn from all parties" $ do
-        let reqSn = NetworkEvent defaultTTL $ ReqSn alice 1 []
+        let reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 []
             snapshot1 = Snapshot 1 mempty []
-            ackFrom sk vk = NetworkEvent defaultTTL $ AckSn vk (sign sk snapshot1) 1
+            ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot1) 1
         snapshotInProgress <- runEvents bobEnv ledger (inOpenState threeParties ledger) $ do
           step reqSn
           step (ackFrom carolSk carol)
@@ -110,11 +110,11 @@ spec =
         getConfirmedSnapshot snapshotConfirmed `shouldBe` Just snapshot1
 
       it "rejects last AckSn if one signature was from a different snapshot" $ do
-        let reqSn = NetworkEvent defaultTTL $ ReqSn alice 1 []
+        let reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 []
             snapshot = Snapshot 1 mempty []
             snapshot' = Snapshot 2 mempty []
-            ackFrom sk vk = NetworkEvent defaultTTL $ AckSn vk (sign sk snapshot) 1
-            invalidAckFrom sk vk = NetworkEvent defaultTTL $ AckSn vk (sign sk snapshot') 1
+            ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot) 1
+            invalidAckFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot') 1
         waitingForLastAck <-
           runEvents bobEnv ledger (inOpenState threeParties ledger) $ do
             step reqSn
@@ -127,9 +127,9 @@ spec =
             _ -> False
 
       it "rejects last AckSn if one signature was from a different key" $ do
-        let reqSn = NetworkEvent defaultTTL $ ReqSn alice 1 []
+        let reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 []
             snapshot = Snapshot 1 mempty []
-            ackFrom sk vk = NetworkEvent defaultTTL $ AckSn vk (sign sk snapshot) 1
+            ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot) 1
         waitingForLastAck <-
           runEvents bobEnv ledger (inOpenState threeParties ledger) $ do
             step reqSn
@@ -142,12 +142,12 @@ spec =
             _ -> False
 
       it "rejects last AckSn if one signature was from a completely different message" $ do
-        let reqSn = NetworkEvent defaultTTL $ ReqSn alice 1 []
+        let reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 []
             snapshot1 = Snapshot 1 mempty []
-            ackFrom sk vk = NetworkEvent defaultTTL $ AckSn vk (sign sk snapshot1) 1
+            ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot1) 1
             invalidAckFrom sk vk =
-              NetworkEvent defaultTTL $
-                AckSn vk (coerce $ sign sk ("foo" :: ByteString)) 1
+              NetworkEvent defaultTTL vk $
+                AckSn (coerce $ sign sk ("foo" :: ByteString)) 1
         waitingForLastAck <-
           runEvents bobEnv ledger (inOpenState threeParties ledger) $ do
             step reqSn
@@ -160,9 +160,9 @@ spec =
             _ -> False
 
       it "rejects last AckSn if already received signature from this party" $ do
-        let reqSn = NetworkEvent defaultTTL $ ReqSn alice 1 []
+        let reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 []
             snapshot1 = Snapshot 1 mempty []
-            ackFrom sk vk = NetworkEvent defaultTTL $ AckSn vk (sign sk snapshot1) 1
+            ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot1) 1
         waitingForAck <-
           runEvents bobEnv ledger (inOpenState threeParties ledger) $ do
             step reqSn
@@ -174,27 +174,27 @@ spec =
             _ -> False
 
       it "waits if we receive a snapshot with not-yet-seen transactions" $ do
-        let event = NetworkEvent defaultTTL $ ReqSn alice 1 [SimpleTx 1 (utxoRef 1) (utxoRef 2)]
+        let event = NetworkEvent defaultTTL alice $ ReqSn 1 [SimpleTx 1 (utxoRef 1) (utxoRef 2)]
         update bobEnv ledger (inOpenState threeParties ledger) event
           `shouldBe` Wait (WaitOnNotApplicableTx (ValidationError "cannot apply transaction"))
 
       it "waits if we receive an AckSn for an unseen snapshot" $ do
         let snapshot = Snapshot 1 mempty []
-            event = NetworkEvent defaultTTL $ AckSn alice (sign aliceSk snapshot) 1
+            event = NetworkEvent defaultTTL alice $ AckSn (sign aliceSk snapshot) 1
         update bobEnv ledger (inOpenState threeParties ledger) event `shouldBe` Wait WaitOnSeenSnapshot
 
       -- TODO: Write property tests for various future / old snapshot behavior.
       -- That way we could cover variations of snapshot numbers and state of
       -- snapshot collection.
 
       it "rejects if we receive a too far future snapshot" $ do
-        let event = NetworkEvent defaultTTL $ ReqSn bob 2 []
+        let event = NetworkEvent defaultTTL bob $ ReqSn 2 []
             st = inOpenState threeParties ledger
         update bobEnv ledger st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 0)
 
       it "waits if we receive a future snapshot while collecting signatures" $ do
-        let reqSn1 = NetworkEvent defaultTTL $ ReqSn alice 1 []
-            reqSn2 = NetworkEvent defaultTTL $ ReqSn bob 2 []
+        let reqSn1 = NetworkEvent defaultTTL alice $ ReqSn 1 []
+            reqSn2 = NetworkEvent defaultTTL bob $ ReqSn 2 []
         st <-
           runEvents bobEnv ledger (inOpenState threeParties ledger) $
             step reqSn1
@@ -204,22 +204,22 @@ spec =
       it "acks signed snapshot from the constant leader" $ do
         let leader = alice
             snapshot = Snapshot 1 mempty []
-            event = NetworkEvent defaultTTL $ ReqSn leader (number snapshot) []
+            event = NetworkEvent defaultTTL leader $ ReqSn (number snapshot) []
             sig = sign bobSk snapshot
             st = inOpenState threeParties ledger
-            ack = AckSn bob sig (number snapshot)
+            ack = AckSn sig (number snapshot)
         update bobEnv ledger st event `hasEffect` NetworkEffect ack
 
       it "does not ack snapshots from non-leaders" $ do
-        let event = NetworkEvent defaultTTL $ ReqSn notTheLeader 1 []
+        let event = NetworkEvent defaultTTL notTheLeader $ ReqSn 1 []
             notTheLeader = bob
             st = inOpenState threeParties ledger
         update bobEnv ledger st event `shouldSatisfy` \case
           Error (RequireFailed ReqSnNotLeader{requestedSn = 1, leader}) -> leader == notTheLeader
           _ -> False
 
       it "rejects too-old snapshots" $ do
-        let event = NetworkEvent defaultTTL $ ReqSn theLeader 2 []
+        let event = NetworkEvent defaultTTL theLeader $ ReqSn 2 []
             theLeader = alice
             snapshot = Snapshot 2 mempty []
             st =
@@ -233,7 +233,7 @@ spec =
         update bobEnv ledger st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 0)
 
       it "rejects too-old snapshots when collecting signatures" $ do
-        let event = NetworkEvent defaultTTL $ ReqSn theLeader 2 []
+        let event = NetworkEvent defaultTTL theLeader $ ReqSn 2 []
             theLeader = alice
             snapshot = Snapshot 2 mempty []
             st =
@@ -247,16 +247,16 @@ spec =
         update bobEnv ledger st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 3)
 
       it "rejects too-new snapshots from the leader" $ do
-        let event = NetworkEvent defaultTTL $ ReqSn theLeader 3 []
+        let event = NetworkEvent defaultTTL theLeader $ ReqSn 3 []
             theLeader = carol
             st = inOpenState threeParties ledger
         update bobEnv ledger st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 3 0)
 
       it "rejects overlapping snapshot requests from the leader" $ do
         let theLeader = alice
             nextSN = 1
-            firstReqSn = NetworkEvent defaultTTL $ ReqSn theLeader nextSN [aValidTx 42]
-            secondReqSn = NetworkEvent defaultTTL $ ReqSn theLeader nextSN [aValidTx 51]
+            firstReqSn = NetworkEvent defaultTTL theLeader $ ReqSn nextSN [aValidTx 42]
+            secondReqSn = NetworkEvent defaultTTL theLeader $ ReqSn nextSN [aValidTx 51]
         receivedReqSn <-
           assertUpdateState bobEnv ledger firstReqSn
             `evalStateT` inOpenState threeParties ledger
@@ -267,7 +267,7 @@ spec =
 
       it "ignores in-flight ReqTx when closed" $ do
         let s0 = inClosedState threeParties
-            event = NetworkEvent defaultTTL $ ReqTx (aValidTx 42)
+            event = NetworkEvent defaultTTL alice $ ReqTx (aValidTx 42)
         update bobEnv ledger s0 event `shouldBe` Error (InvalidEvent event s0)
 
       it "everyone does collect on last commit after collect com" $ do
@@ -405,7 +405,7 @@ spec =
         st <-
           run $
             runEvents bobEnv ledger st0 $
-              step (NetworkEvent defaultTTL $ ReqSn alice 1 [])
+              step (NetworkEvent defaultTTL alice $ ReqSn 1 [])
 
         assert $ case st of
           Open

hydra-node/test/Hydra/Logging/MonitoringSpec.hs

@@ -30,8 +30,8 @@ spec =
     failAfter 3 $ do
       [p] <- randomUnusedTCPPorts 1
       withMonitoring (Just $ fromIntegral p) nullTracer $ \tracer -> do
-        traceWith tracer (Node $ BeginEvent alice 0 (NetworkEvent defaultTTL (ReqTx (aValidTx 42))))
-        traceWith tracer (Node $ BeginEvent alice 1 (NetworkEvent defaultTTL (ReqTx (aValidTx 43))))
+        traceWith tracer (Node $ BeginEvent alice 0 (NetworkEvent defaultTTL alice (ReqTx (aValidTx 42))))
+        traceWith tracer (Node $ BeginEvent alice 1 (NetworkEvent defaultTTL alice (ReqTx (aValidTx 43))))
         threadDelay 0.1
         traceWith tracer (Node $ BeginEffect alice 0 0 (ClientEffect (SnapshotConfirmed testHeadId (Snapshot 1 (utxoRefs [1]) [43, 42]) mempty)))