From 75232557f3c6b4547e8e8ba7a92a5b3e970a039b Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 4 Jul 2023 22:47:26 +0400 Subject: [PATCH] Extracted EncryptionHandshake from PeerHandshake --- hbs2-core/hbs2-core.cabal | 1 + .../lib/HBS2/Net/Proto/EncryptionHandshake.hs | 122 ++++++++++++++++ hbs2-core/lib/HBS2/Net/Proto/Peer.hs | 134 ++---------------- hbs2-peer/app/PeerMain.hs | 41 ++---- hbs2-peer/app/PeerTypes.hs | 2 +- 5 files changed, 147 insertions(+), 153 deletions(-) create mode 100644 hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 5c88b796..5d71be67 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs new file mode 100644 index 00000000..309bfa9e --- /dev/null +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs index c1658c98..1328900a 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs +++ b/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 - - -- Мы отправляли ключ шифрования, но собеседник отказался - -- от шифрованной сессии - -- when (isJust mpubkey) do + maybe1 se' (pure ()) $ \(PeerPingData nonce t0) -> 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 pde (KnownPeerKey pip) id + update d (KnownPeerKey pip) id - emit AnyKnownPeerEventKey (KnownPeerEvent pip pde) - emit (ConcretePeerKey pip) (ConcretePeerData pip pde) - - ---- 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 + emit AnyKnownPeerEventKey (KnownPeerEvent pip d) + emit (ConcretePeerKey pip) (ConcretePeerData pip d) 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) - 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)) + ConcretePeerData (Peer e) (PeerData 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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 62345501..f060e00c 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/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 - banned <- maybe (pure False) (peerBanned pip . view peerData) mpde - let known = isJust mpde && not banned + mpd :: Maybe (PeerData e) <- find (KnownPeerKey pip) id + banned <- maybe (pure False) (peerBanned pip) mpd + 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 - 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 + subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p pd) -> do let thatNonce = view peerOwnNonce pd now <- liftIO getTimeCoarse - defPeerInfo <- newPeerInfo - fetch True defPeerInfo (PeerInfoKey p) id >>= \pinfo -> do + -- defPeerInfo <- newPeerInfo + -- 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)) () diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index 4bd57255..2d85344b 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/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