From 9eed3a6d3f54e6bc945b806fafd9b719cdb94245 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 12 Jul 2023 22:34:21 +0400 Subject: [PATCH] wip --- .../lib/HBS2/Net/Proto/EncryptionHandshake.hs | 165 ++++++++++++------ hbs2-peer/app/Brains.hs | 24 +++ hbs2-peer/app/EncryptionKeys.hs | 20 ++- hbs2-peer/app/PeerMain.hs | 18 +- hbs2-peer/app/ProxyMessaging.hs | 7 + 5 files changed, 160 insertions(+), 74 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs index bd9d1d91..dc373cb3 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/EncryptionHandshake.hs @@ -10,6 +10,7 @@ import HBS2.Data.Types import HBS2.Events import HBS2.Net.Auth.Credentials import HBS2.Net.Proto +import HBS2.Net.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated import HBS2.System.Logger.Simple @@ -30,63 +31,115 @@ newtype EENonce = EENonce { unEENonce :: BS.ByteString } deriving newtype (Eq, Serialise, Hashable) deriving (Pretty, Show) via AsBase58 BS.ByteString +instance + ( Show (PubKey 'Encrypt (Encryption e)) + , Show (PubKey 'Sign (Encryption e)) + , Show (Nonce ()) + ) + => Pretty (PeerData e) where + pretty = viaShow + data EncryptionHandshake e = - BeginEncryptionExchange EENonce (PubKey 'Encrypt (Encryption e)) + BeginEncryptionExchange EENonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) | AckEncryptionExchange EENonce (Signature (Encryption e)) (PubKey 'Encrypt (Encryption e)) + | ResetEncryptionKeys 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 () +sendResetEncryptionKeys :: forall e s m . + ( MonadIO m + , Request e (EncryptionHandshake e) m + , e ~ L4Proto + , s ~ Encryption e + ) + => Peer e + -> m () -sendEncryptionPubKey pip pubkey = do - nonce <- newNonce @(EncryptionHandshake e) - tt <- liftIO $ getTimeCoarse - request pip (BeginEncryptionExchange @e nonce pubkey) +sendResetEncryptionKeys peer = do + request peer (ResetEncryptionKeys @e) + +sendBeginEncryptionExchange :: forall e s m . + ( MonadIO m + , Request e (EncryptionHandshake e) m + , Sessions e (EncryptionHandshake e) m + , HasNonces (EncryptionHandshake e) m + -- , HasCredentials s m + , Asymm s + , Signatures s + , Serialise (PubKey 'Encrypt s) + , Nonce (EncryptionHandshake e) ~ EENonce + , Pretty (Peer e) + , HasProtocol e (EncryptionHandshake e) + , e ~ L4Proto + , s ~ Encryption e + ) + => PeerEnv e + -> PeerCredentials s + -> Peer e + -> PubKey 'Encrypt (Encryption e) + -> m () + +sendBeginEncryptionExchange penv creds peer pubkey = do + nonce0 <- newNonce @(EncryptionHandshake e) + let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv + let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce0 <> (cs . serialise) ourpubkey) + request peer (BeginEncryptionExchange @e nonce0 sign pubkey) data EncryptionHandshakeAdapter e m s = EncryptionHandshakeAdapter - { encHandshake_considerPeerAsymmKey :: PeerAddr e -> Encrypt.PublicKey -> m () + { encHandshake_considerPeerAsymmKey :: PeerAddr e -> Maybe (PeerData e) -> Maybe Encrypt.PublicKey -> m () } -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 - , PubKey Encrypt s ~ Encrypt.PublicKey - ) - => EncryptionHandshakeAdapter e m s - -> PeerEnv e - -> EncryptionHandshake e - -> m () +encryptionHandshakeProto :: forall e s m . + ( MonadIO m + , Response e (EncryptionHandshake e) m + , Request e (EncryptionHandshake e) m + , Sessions e (KnownPeer 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 + , Sessions e (EncryptionHandshake e) m + , Serialise (PubKey 'Encrypt (Encryption e)) + , s ~ Encryption e + , e ~ L4Proto + , PubKey Encrypt s ~ Encrypt.PublicKey + , Show (PubKey 'Sign s) + , Show (Nonce ()) + ) + => EncryptionHandshakeAdapter e m s + -> PeerEnv e + -> EncryptionHandshake e + -> m () encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case - BeginEncryptionExchange nonce theirpubkey -> do - pip <- thatPeer proto - trace $ "GOT BeginEncryptionExchange from" <+> pretty pip + ResetEncryptionKeys -> do + peer <- thatPeer proto + paddr <- toPeerAddr peer + mpeerData <- find (KnownPeerKey peer) id + -- TODO: check theirsign + trace $ "EHSP ResetEncryptionKeys from" <+> viaShow (peer, paddr, mpeerData) + encHandshake_considerPeerAsymmKey paddr mpeerData Nothing - paddr <- toPeerAddr pip - encHandshake_considerPeerAsymmKey paddr theirpubkey + creds <- getCredentials @s + let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv + sendBeginEncryptionExchange @e penv creds peer ourpubkey + + BeginEncryptionExchange nonce0 theirsign theirpubkey -> do + peer <- thatPeer proto + paddr <- toPeerAddr peer + mpeerData <- find (KnownPeerKey peer) id + -- TODO: check theirsign + + trace $ "EHSP BeginEncryptionExchange from" <+> viaShow (peer, paddr, mpeerData) + + encHandshake_considerPeerAsymmKey paddr mpeerData (Just theirpubkey) -- взять свои ключи creds <- getCredentials @s @@ -94,28 +147,24 @@ encryptionHandshakeProto EncryptionHandshakeAdapter{..} penv = \case let ourpubkey = pubKeyFromKeypair @s $ view envAsymmetricKeyPair penv -- подписать нонс - let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce <> (cs . serialise) ourpubkey) + let sign = makeSign @s (view peerSignSk creds) (unEENonce nonce0 <> (cs . serialise) ourpubkey) -- отправить обратно вместе с публичным ключом - response (AckEncryptionExchange @e nonce sign ourpubkey) + response (AckEncryptionExchange @e nonce0 sign ourpubkey) - -- Нужно ли запомнить его theirpubkey или достаточно того, что будет - -- получено в обратном AckEncryptionExchange? - -- Нужно! - emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey) + emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey) - -- se <- find (KnownPeerKey pip) id <&> isJust - -- unless se $ do - -- sendEncryptionPubKey pip ourpubkey + AckEncryptionExchange nonce0 theirsign theirpubkey -> do + peer <- thatPeer proto + paddr <- toPeerAddr peer + mpeerData <- find (KnownPeerKey peer) id + -- TODO: check theirsign - AckEncryptionExchange nonce0 sign theirpubkey -> do - pip <- thatPeer proto - -- trace $ "AckEncryptionExchange" <+> pretty pip + trace $ "EHSP AckEncryptionExchange from" <+> viaShow (peer, paddr, mpeerData) - paddr <- toPeerAddr pip - encHandshake_considerPeerAsymmKey paddr theirpubkey + encHandshake_considerPeerAsymmKey paddr mpeerData (Just theirpubkey) - emit PeerAsymmInfoKey (PeerAsymmPubKey pip theirpubkey) + emit PeerAsymmInfoKey (PeerAsymmPubKey peer theirpubkey) where proto = Proxy @(EncryptionHandshake e) diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index fd312d62..87045fcd 100644 --- a/hbs2-peer/app/Brains.hs +++ b/hbs2-peer/app/Brains.hs @@ -603,6 +603,8 @@ transactional brains action = do err $ "BRAINS: " <+> viaShow e execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|] +--- + insertPeerAsymmKey :: forall e m . ( e ~ L4Proto , MonadIO m @@ -643,6 +645,26 @@ insertPeerSymmKey br peer hSymmKey = do |] (show $ pretty peer, show hSymmKey) +deletePeerAsymmKey :: forall e m . (e ~ L4Proto, MonadIO m) + => BasicBrains e -> PeerAddr e -> m () + +deletePeerAsymmKey br peer = + void $ liftIO $ execute (view brainsDb br) [qc| + DELETE FROM peer_symmkey + WHERE peer = ? + |] (Only (show $ pretty peer)) + +deletePeerSymmKey :: forall e m . (e ~ L4Proto, MonadIO m) + => BasicBrains e -> PeerAddr e -> m () + +deletePeerSymmKey br peer = + void $ liftIO $ execute (view brainsDb br) [qc| + DELETE FROM peer_symmkey + WHERE peer = ? + |] (Only (show $ pretty peer)) + +--- + -- FIXME: eventually-close-db newBasicBrains :: forall e m . (Hashable (Peer e), MonadIO m) => PeerConfig @@ -735,6 +757,7 @@ newBasicBrains cfg = liftIO do create table if not exists peer_asymmkey ( peer text not null , asymmkey text not null + , ts DATE DEFAULT (datetime('now','localtime')) , primary key (peer) ) |] @@ -743,6 +766,7 @@ newBasicBrains cfg = liftIO do create table if not exists peer_symmkey ( peer text not null , symmkey text not null + , ts DATE DEFAULT (datetime('now','localtime')) , primary key (peer) ) |] diff --git a/hbs2-peer/app/EncryptionKeys.hs b/hbs2-peer/app/EncryptionKeys.hs index 32820c79..18e069bb 100644 --- a/hbs2-peer/app/EncryptionKeys.hs +++ b/hbs2-peer/app/EncryptionKeys.hs @@ -52,15 +52,17 @@ encryptionHandshakeWorker :: forall e m s . -- , Sessions e (PeerInfo e) m -- , Sessions e (KnownPeer e) m -- , Pretty (Peer e) + -- , HasCredentials s m ) - => PeerConfig - -> PeerEnv e - -> EncryptionHandshakeAdapter e m s - -> m () + => PeerConfig + -> PeerEnv e + -> PeerCredentials s + -> EncryptionHandshakeAdapter e m s + -> m () -encryptionHandshakeWorker pconf penv EncryptionHandshakeAdapter{..} = do +encryptionHandshakeWorker pconf penv creds EncryptionHandshakeAdapter{..} = do - -- e <- ask + -- e :: PeerEnv e <- ask let ourpubkey = pubKeyFromKeypair @s $ _envAsymmetricKeyPair penv pl <- getPeerLocator @e @@ -68,7 +70,7 @@ encryptionHandshakeWorker pconf penv EncryptionHandshakeAdapter{..} = do forever do liftIO $ pause @'Seconds 10 - pips <- knownPeers @e pl + peers <- knownPeers @e pl - forM_ pips \p -> do - sendEncryptionPubKey @e p ourpubkey + forM_ peers \peer -> do + sendBeginEncryptionExchange @e penv creds peer ourpubkey diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 51e4cf43..16ff1bcb 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -650,12 +650,16 @@ runPeer opts = U.handle (\e -> myException e ( MonadIO m ) => EncryptionHandshakeAdapter L4Proto m s encryptionHshakeAdapter = EncryptionHandshakeAdapter - { encHandshake_considerPeerAsymmKey = \addr pk -> do - insertPeerAsymmKey brains addr pk - insertPeerSymmKey brains addr $ - genCommonSecret @s - (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) - pk + { encHandshake_considerPeerAsymmKey = \addr mpeerData -> \case + Nothing -> do + deletePeerAsymmKey brains addr + deletePeerSymmKey brains addr + Just pk -> do + insertPeerAsymmKey brains addr pk + insertPeerSymmKey brains addr $ + genCommonSecret @s + (privKeyFromKeypair @s (view envAsymmetricKeyPair penv)) + pk } env <- ask @@ -807,7 +811,7 @@ runPeer opts = U.handle (\e -> myException e peerThread "blockDownloadLoop" (blockDownloadLoop denv) peerThread "encryptionHandshakeWorker" - (EncryptionKeys.encryptionHandshakeWorker @e conf penv encryptionHshakeAdapter) + (EncryptionKeys.encryptionHandshakeWorker @e conf penv pc encryptionHshakeAdapter) let tcpProbeWait :: Timeout 'Seconds tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf) diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index cea156e1..88c15441 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -151,6 +151,13 @@ receiveFromProxyMessaging bus _ = liftIO do encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) msg + -- TODO: + -- Если мы не смогли, по любой причине, расшифровать сообщение, + -- то нужно стереть у себя ключ + -- Если мы не смогли, по любой причине, расшифровать сообщение, + -- но уверены что оно зашифровано, то нужно отправить + -- sendResetEncryptionKeys + where dfm :: Peer L4Proto -> Maybe Encrypt.CombinedKey -> LBS.ByteString -> IO (Maybe LBS.ByteString) dfm = \whom mk msg -> case mk of