Extracted EncryptionHandshake from PeerHandshake

hbs2-core/hbs2-core.cabal

@@ -94,6 +94,7 @@ library
                     , HBS2.Net.Proto.BlockChunks
                     , HBS2.Net.Proto.BlockInfo
                     , HBS2.Net.Proto.Definition
+                    , HBS2.Net.Proto.EncryptionHandshake
                     , HBS2.Net.Proto.Peer
                     , HBS2.Net.Proto.PeerAnnounce
                     , HBS2.Net.Proto.PeerExchange

hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs

@@ -0,0 +1,122 @@
+{-# Language TemplateHaskell #-}
+{-# Language UndecidableInstances #-}
+module HBS2.Net.Proto.EncryptionHandshake where
+
+-- import HBS2.Base58
+import HBS2.Actors.Peer
+import HBS2.Data.Types
+import HBS2.Events
+import HBS2.Net.Proto
+import HBS2.Clock
+import HBS2.Net.Proto.Sessions
+import HBS2.Prelude.Plated
+import HBS2.Net.Auth.Credentials
+import HBS2.System.Logger.Simple
+
+import Control.Monad
+import Crypto.Saltine.Core.Box qualified as Encrypt
+import Data.Maybe
+import Codec.Serialise()
+import Data.ByteString qualified as BS
+import Data.Hashable
+import Data.String.Conversions (cs)
+import Lens.Micro.Platform
+import Type.Reflection (someTypeRep)
+
+newtype EENonce = EENonce { unEENonce :: BS.ByteString }
+
+data EncryptionHandshake e =
+    BeginEncryptionExchange EENonce (PubKey 'Encrypt (Encryption e))
+  | AckEncryptionExchange EENonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e))
+  deriving stock (Generic)
+
+sendEncryptionPubKey :: forall e m . ( MonadIO m
+                         , Request e (EncryptionHandshake e) m
+                         , Sessions e (EncryptionHandshake e) m
+                         , HasNonces (EncryptionHandshake e) m
+                         , Nonce (EncryptionHandshake e) ~ EENonce
+                         , Pretty (Peer e)
+                         , HasProtocol e (EncryptionHandshake e)
+                         , e ~ L4Proto
+                         )
+         => Peer e -> PubKey 'Encrypt (Encryption e) -> m ()
+
+sendEncryptionPubKey pip pubkey = do
+  nonce <- newNonce @(EncryptionHandshake e)
+  tt <- liftIO $ getTimeCoarse
+  request pip (BeginEncryptionExchange @e nonce pubkey)
+
+encryptionHandshakeProto :: forall e s m . ( MonadIO m
+                                     , Response e (EncryptionHandshake e) m
+                                     , Request e (EncryptionHandshake e) m
+                                     , Sessions e (EncryptionHandshake e) m
+                                     , HasNonces (EncryptionHandshake e) m
+                                     , HasPeerNonce e m
+                                     , Nonce (EncryptionHandshake e) ~ EENonce
+                                     , Pretty (Peer e)
+                                     , EventEmitter e (EncryptionHandshake e) m
+                                     , EventEmitter e (PeerAsymmInfo e) m
+                                     , HasCredentials s m
+                                     , Asymm s
+                                     , Signatures s
+                                     , Serialise (PubKey 'Encrypt (Encryption e))
+                                     , s ~ Encryption e
+                                     , e ~ L4Proto
+                                     )
+                   => PeerEnv e
+                   -> EncryptionHandshake e
+                   -> m ()
+
+encryptionHandshakeProto penv =
+  \case
+
+    BeginEncryptionExchange nonce theirpubkey -> do
+      pip <- thatPeer proto
+      trace $ "GOT BeginEncryptionExchange from" <+> pretty pip
+
+      -- взять свои ключи
+      creds <- getCredentials @s
+
+      let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
+
+      -- подписать нонс
+      let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce <> (cs . serialise) ourpubkey)
+
+      -- отправить обратно вместе с публичным ключом
+      -- response (AckEncryptionExchange @e nonce sign ourpubkey (PeerData (view peerSignPk creds)))
+
+      -- Нужно ли запомнить его theirpubkey или достаточно того, что будет
+      -- получено в обратном AckEncryptionExchange?
+      -- Нужно!
+      emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
+
+      -- se <- find (KnownPeerKey pip) id <&> isJust
+      -- unless se $ do
+      --   sendEncryptionPubKey pip ourpubkey
+
+    AckEncryptionExchange nonce0 sign theirpubkey -> do
+      pip <- thatPeer proto
+      -- trace $ "AckEncryptionExchange" <+> pretty pip
+
+      emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
+
+  where
+    proto = Proxy @(EncryptionHandshake e)
+
+-----
+
+data PeerAsymmInfo e = PeerAsymmInfo
+
+data instance EventKey e (PeerAsymmInfo e) =
+  PeerAsymmInfoKey
+  deriving stock (Generic)
+
+deriving stock instance (Eq (Peer e)) => Eq (EventKey e (PeerAsymmInfo e))
+instance (Hashable (Peer e)) => Hashable (EventKey e (PeerAsymmInfo e))
+
+data instance Event e (PeerAsymmInfo e) =
+  PeerAsymmPubKey (Peer e) (AsymmPubKey (Encryption e))
+  deriving stock (Typeable)
+
+instance Expires (EventKey e (PeerAsymmInfo e)) where
+  expiresIn _ = Nothing

hbs2-core/lib/HBS2/Net/Proto/Peer.hs

@@ -41,19 +41,9 @@ deriving instance
 
 makeLenses 'PeerData
 
-data PeerDataExt e = PeerDataExt
-  { _peerData :: PeerData e
-  , _peerEncPubKey :: Maybe (PubKey 'Encrypt (Encryption e))
-  }
-  deriving stock (Typeable,Generic)
-
-makeLenses 'PeerDataExt
-
 data PeerHandshake e =
     PeerPing  PingNonce
   | PeerPong  PingNonce (Signature (Encryption e)) (PeerData e)
-  | PeerPingCrypted PingNonce (PubKey 'Encrypt (Encryption e))
-  | PeerPongCrypted PingNonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) (PeerData e)
   deriving stock (Generic)
 
 deriving instance
@@ -74,13 +64,12 @@ data PeerPingData e =
   PeerPingData
   { _peerPingNonce :: PingNonce
   , _peerPingSent  :: TimeSpec
-  , _peerPingEncPubKey :: Maybe (PubKey 'Encrypt (Encryption e))
   }
   deriving stock (Generic,Typeable)
 
 makeLenses 'PeerPingData
 
-type instance SessionData e (KnownPeer e) = PeerDataExt e
+type instance SessionData e (KnownPeer e) = PeerData e
 
 newtype instance SessionKey e (PeerHandshake e) =
   PeerHandshakeKey (PingNonce, Peer e)
@@ -109,28 +98,10 @@ sendPing :: forall e m . ( MonadIO m
 sendPing pip = do
   nonce <- newNonce @(PeerHandshake e)
   tt <- liftIO $ getTimeCoarse
-  let pdd = PeerPingData nonce tt Nothing
+  let pdd = PeerPingData nonce tt
   update pdd (PeerHandshakeKey (nonce,pip)) id
   request pip (PeerPing @e nonce)
 
-sendPingCrypted :: forall e m . ( MonadIO m
-                         , Request e (PeerHandshake e) m
-                         , Sessions e (PeerHandshake e) m
-                         , HasNonces (PeerHandshake e) m
-                         , Nonce (PeerHandshake e) ~ PingNonce
-                         , Pretty (Peer e)
-                         , HasProtocol e (PeerHandshake e)
-                         , e ~ L4Proto
-                         )
-         => Peer e -> PubKey 'Encrypt (Encryption e) -> m ()
-
-sendPingCrypted pip pubkey = do
-  nonce <- newNonce @(PeerHandshake e)
-  tt <- liftIO $ getTimeCoarse
-  let pdd = PeerPingData nonce tt (Just pubkey)
-  update pdd (PeerHandshakeKey (nonce,pip)) id
-  request pip (PeerPingCrypted @e nonce pubkey)
-
 newtype PeerHandshakeAdapter e m =
   PeerHandshakeAdapter
   { onPeerRTT :: (Peer e, Integer) -> m ()
@@ -148,7 +119,6 @@ peerHandShakeProto :: forall e s m . ( MonadIO m
                                      , Pretty (Peer e)
                                      , EventEmitter e (PeerHandshake e) m
                                      , EventEmitter e (ConcretePeer e) m
-                                     , EventEmitter e (PeerAsymmInfo e) m
                                      , HasCredentials s m
                                      , Asymm s
                                      , Signatures s
@@ -188,11 +158,7 @@ peerHandShakeProto adapter penv =
 
       se' <- find @e (PeerHandshakeKey (nonce0,pip)) id
 
-      maybe1 se' (pure ()) $ \(PeerPingData nonce t0 mpubkey) -> do
+      maybe1 se' (pure ()) $ \(PeerPingData nonce t0) -> do
-
-        -- Мы отправляли ключ шифрования, но собеседник отказался
-        -- от шифрованной сессии
-        -- when (isJust mpubkey) do
 
         let pk = view peerSignKey d
 
@@ -209,76 +175,10 @@ peerHandShakeProto adapter penv =
 
           -- FIXME: check if peer is blacklisted
           --        right here
-          let pde = PeerDataExt d Nothing
+          update d (KnownPeerKey pip) id
-          update pde (KnownPeerKey pip) id
 
-          emit AnyKnownPeerEventKey (KnownPeerEvent pip pde)
+          emit AnyKnownPeerEventKey (KnownPeerEvent pip d)
-          emit (ConcretePeerKey pip) (ConcretePeerData pip pde)
+          emit (ConcretePeerKey pip) (ConcretePeerData pip d)
-
-    ---- Crypted
-    PeerPingCrypted nonce theirpubkey -> do
-      pip <- thatPeer proto
-      trace $ "GOT PING CRYPTED from" <+> pretty pip
-
-      -- взять свои ключи
-      creds <- getCredentials @s
-
-      let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv
-
-      -- подписать нонс
-      let sign = makeSign @s (view peerSignSk creds) (nonce <> (cs . serialise) ourpubkey)
-
-      own <- peerNonce @e
-
-      -- отправить обратно вместе с публичным ключом
-      response (PeerPongCrypted @e nonce sign ourpubkey (PeerData (view peerSignPk creds) own))
-
-      -- да и пингануть того самим
-
-      se <- find (KnownPeerKey pip) id <&> isJust
-
-      -- Нужно ли запомнить его theirpubkey или достаточно того, что будет
-      -- получено в обратном PeerPongCrypted?
-      -- Нужно!
-      emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey)
-
-      unless se $ do
-        sendPingCrypted pip ourpubkey
-
-    PeerPongCrypted nonce0 sign theirpubkey pd -> do
-      pip <- thatPeer proto
-      trace $ "GOT PONG CRYPTED from" <+> pretty pip
-
-      se' <- find @e (PeerHandshakeKey (nonce0,pip)) id
-
-      maybe1 se' (pure ()) $ \(PeerPingData nonce t0 mpubkey) -> do
-
-        -- TODO: Мы не отправляли ключ шифрования, а собеседник ответил как будто
-        -- отправляли. Как тут поступать?
-        -- guard (isNothing mpubkey)
-
-        let pk = view peerSignKey pd
-            pde = PeerDataExt pd (Just theirpubkey)
-
-        let signed = verifySign @s pk sign (nonce <> (cs . serialise) theirpubkey)
-
-        when signed $ do
-
-          now <- liftIO getTimeCoarse
-          let rtt = toNanoSecs $ now - t0
-
-          onPeerRTT adapter (pip,rtt)
-
-          expire (PeerHandshakeKey (nonce0,pip))
-
-          -- FIXME: check if peer is blacklisted
-          --        right here
-          update pde (KnownPeerKey pip) id
-
-          emit AnyKnownPeerEventKey (KnownPeerEvent pip pde)
-          emit (ConcretePeerKey pip) (ConcretePeerData pip pde)
-
-    ---- /Crypted
 
   where
     proto = Proxy @(PeerHandshake e)
@@ -293,22 +193,7 @@ deriving stock instance (Eq (Peer e)) => Eq (EventKey e (ConcretePeer e))
 instance (Hashable (Peer e)) => Hashable (EventKey e (ConcretePeer e))
 
 data instance Event e (ConcretePeer e) =
-  ConcretePeerData (Peer e) (PeerDataExt e)
+  ConcretePeerData (Peer e) (PeerData e)
-  deriving stock (Typeable)
-
----
-
-data PeerAsymmInfo e = PeerAsymmInfo
-
-data instance EventKey e (PeerAsymmInfo e) =
-  PeerAsymmInfoKey
-  deriving stock (Generic)
-
-deriving stock instance (Eq (Peer e)) => Eq (EventKey e (PeerAsymmInfo e))
-instance (Hashable (Peer e)) => Hashable (EventKey e (PeerAsymmInfo e))
-
-data instance Event e (PeerAsymmInfo e) =
-  PeerAsymmPubKey (Peer e) (AsymmPubKey (Encryption e))
   deriving stock (Typeable)
 
 ---
@@ -318,7 +203,7 @@ data instance EventKey e (PeerHandshake e) =
   deriving stock (Typeable, Eq,Generic)
 
 data instance Event e (PeerHandshake e) =
-  KnownPeerEvent (Peer e) (PeerDataExt e)
+  KnownPeerEvent (Peer e) (PeerData e)
   deriving stock (Typeable)
 
 instance ( Typeable (KnownPeer e)
@@ -334,9 +219,6 @@ instance EventType ( Event e ( PeerHandshake e) ) where
 instance Expires (EventKey e (PeerHandshake e)) where
   expiresIn _ = Nothing
 
-instance Expires (EventKey e (PeerAsymmInfo e)) where
-  expiresIn _ = Nothing
-
 instance Expires (EventKey e (ConcretePeer e)) where
   expiresIn _ = Just 60
 

hbs2-peer/app/PeerMain.hs

@@ -602,7 +602,7 @@ runPeer opts = U.handle (\e -> myException e
         already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust
         unless already do
           mpde <- find (KnownPeerKey p) id
-          maybe1 mpde none $ \pde@(PeerDataExt {_peerData = pd}) -> do
+          maybe1 mpde none $ \pd -> do
             let pk = view peerSignKey pd
             when (Set.member pk helpFetchKeys) do
               liftIO $ Cache.insert nbcache (p,h) ()
@@ -655,38 +655,27 @@ runPeer opts = U.handle (\e -> myException e
               subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do
                unless (nonce == pnonce) $ do
                  debug $ "Got peer announce!" <+> pretty pip
-                 mpde :: Maybe (PeerDataExt e) <- find (KnownPeerKey pip) id
+                 mpd :: Maybe (PeerData e) <- find (KnownPeerKey pip) id
-                 banned <- maybe (pure False) (peerBanned pip . view peerData) mpde
+                 banned <- maybe (pure False) (peerBanned pip) mpd
-                 let known = isJust mpde && not banned
+                 let known = isJust mpd && not banned
                  sendPing pip
 
               subscribe @e BlockAnnounceInfoKey $ \(BlockAnnounceEvent p bi no) -> do
                  pa <- toPeerAddr p
                  liftIO $ atomically $ writeTQueue rpcQ (CHECK no pa (view biHash bi))
 
-              subscribe @e PeerAsymmInfoKey $ \(PeerAsymmPubKey p peerpubkey) -> do
+              subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p pd) -> do
-                defPeerInfo <- newPeerInfo
-                fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
-                      let updj = genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
-                              $ peerpubkey
-                      liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys proxy) $ Lens.at p .~ Just updj
-                      liftIO $ trace [qc| UPDJust from PeerAsymmInfoKey at {p} {updj} |]
-
-              subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p pde@(PeerDataExt{_peerData = pd})) -> do
 
                 let thatNonce = view peerOwnNonce pd
 
                 now <- liftIO getTimeCoarse
 
-                defPeerInfo <- newPeerInfo
+                -- defPeerInfo <- newPeerInfo
-                fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
+                -- fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do
+
+                find (PeerInfoKey p) id >>= mapM_ \pinfo -> do
                       liftIO $ atomically $ writeTVar (view peerPingFailed pinfo) 0
                       liftIO $ atomically $ writeTVar (view peerLastWatched pinfo) now
-                      let mupd = genCommonSecret @s (privKeyFromKeypair @s (view envAsymmetricKeyPair penv))
-                              <$> view peerEncPubKey pde
-                      forM_ mupd \upd -> do
-                          liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys proxy) $ Lens.at p .~ Just upd
-                          liftIO $ trace [qc| UPDJust from AnyKnownPeerEventKey at {p} {upd} |]
 
                 banned <- peerBanned p pd
 
@@ -716,15 +705,15 @@ runPeer opts = U.handle (\e -> myException e
 
                    | otherwise -> do
 
-                    update pde (KnownPeerKey p) id
+                    update pd (KnownPeerKey p) id
 
-                    pd :: Map BS.ByteString (Peer L4Proto) <- fmap (Map.fromList . catMaybes)
+                    pdkv :: Map BS.ByteString (Peer L4Proto) <- fmap (Map.fromList . catMaybes)
                         $ knownPeers @e pl >>= mapM \pip ->
-                              fmap (, pip) <$> find (KnownPeerKey pip) (view (peerData . peerOwnNonce))
+                              fmap (, pip) <$> find (KnownPeerKey pip) (view peerOwnNonce)
 
                     let proto1 = view sockType p
 
-                    case Map.lookup thatNonce pd of
+                    case Map.lookup thatNonce pdkv of
 
                       -- TODO: prefer-local-peer-with-same-nonce-over-remote-peer
                       --   remove remote peer
@@ -875,7 +864,7 @@ runPeer opts = U.handle (\e -> myException e
                                     sendPing @e pip
                                     -- TODO: enqueue-announce-from-unknown-peer?
 
-                                  Just (pde@(PeerDataExt {_peerData = pd}))  -> do
+                                  Just pd  -> do
 
                                     banned <- peerBanned pip pd
 
@@ -968,7 +957,7 @@ runPeer opts = U.handle (\e -> myException e
         void $ liftIO $ async $ withPeerM penv $ do
           forKnownPeers @e $ \p pde -> do
               pa <- toPeerAddr p
-              let k = view (peerData . peerSignKey) pde
+              let k = view peerSignKey pde
               request who (RPCPeersAnswer @e pa k)
 
   let pexInfoAction :: RPC L4Proto -> ResponseM L4Proto (RpcM (ResourceT IO)) ()

hbs2-peer/app/PeerTypes.hs

@@ -359,7 +359,7 @@ forKnownPeers :: forall e  m . ( MonadIO m
                                , Sessions e (KnownPeer e) m
                                , HasPeer e
                                )
-               =>  ( Peer e -> PeerDataExt e -> m () ) -> m ()
+               =>  ( Peer e -> PeerData e -> m () ) -> m ()
 forKnownPeers m = do
   pl <- getPeerLocator @e
   pips <- knownPeers @e pl