From 5ecbd9359485685fe1355ad1c8110e1be40e0bb3 Mon Sep 17 00:00:00 2001
From: Sergey Ivanov <ivanovs-4@yandex.ru>
Date: Tue, 4 Jul 2023 19:24:35 +0400
Subject: [PATCH] Experiment with clearing symmetric key

---
 hbs2-peer/app/PeerMain.hs       | 37 ++++++++++++++++++---------------
 hbs2-peer/app/ProxyMessaging.hs | 21 ++++++++++++-------
 2 files changed, 34 insertions(+), 24 deletions(-)

diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs
index ebd6efe3..9ba7defd 100644
--- a/hbs2-peer/app/PeerMain.hs
+++ b/hbs2-peer/app/PeerMain.hs
@@ -858,33 +858,36 @@ runPeer opts = U.handle (\e -> myException e
                                       -- when allowed do
                                       --     sendTo proxy (To peer_e) (From me) (AnyMessage @(Encoded e) @e protoN (encode msg))
 
-                                      when allowed do
+                                      -- when allowed do
+                                      do
                                           sendToPlainProxyMessaging (PlainProxyMessaging proxy) (To peer_e) (From me)
                                               -- (AnyMessage @(Encoded e) @e protoN (Proto.encode msg))
                                               (serialise (protoN, (Proto.encode msg)))
 
-                              let
-                                  sendPingCrypted' pip pubkey = do
-                                      nonce <- newNonce @(PeerHandshake e)
-                                      tt <- liftIO $ getTimeCoarse
-                                      let pdd = PeerPingData nonce tt (Just pubkey)
-                                      update pdd (PeerHandshakeKey (nonce,pip)) id
-                                      requestPlain pip (PeerPingCrypted @e nonce pubkey)
+                              -- let
+                              --     sendPingCrypted' pip pubkey = do
+                              --         nonce <- newNonce @(PeerHandshake e)
+                              --         tt <- liftIO $ getTimeCoarse
+                              --         let pdd = PeerPingData nonce tt (Just pubkey)
+                              --         update pdd (PeerHandshakeKey (nonce,pip)) id
+                              --         requestPlain pip (PeerPingCrypted @e nonce pubkey)
 
-                              let
-                                  sendPing' pip = do
-                                      nonce <- newNonce @(PeerHandshake e)
-                                      tt <- liftIO $ getTimeCoarse
-                                      let pdd = PeerPingData nonce tt Nothing
-                                      update pdd (PeerHandshakeKey (nonce,pip)) id
-                                      requestPlain pip (PeerPing @e nonce)
+                              -- let
+                              --     sendPing' pip = do
+                              --         nonce <- newNonce @(PeerHandshake e)
+                              --         tt <- liftIO $ getTimeCoarse
+                              --         let pdd = PeerPingData nonce tt Nothing
+                              --         update pdd (PeerHandshakeKey (nonce,pip)) id
+                              --         requestPlain pip (PeerPing @e nonce)
 
-                              sendPingCrypted' pip (pubKeyFromKeypair @s (view envAsymmetricKeyPair penv))
+                              -- sendPingCrypted' pip (pubKeyFromKeypair @s (view envAsymmetricKeyPair penv))
+                              sendPing pip
                               pause $ case (requestPeriodLim @e @(PeerHandshake e)) of
                                   NoLimit -> 0
                                   ReqLimPerProto   t -> t + 0.1
                                   ReqLimPerMessage t -> t + 0.1
-                              sendPing' pip
+                              -- sendPing' pip
+                              sendPingCrypted pip (pubKeyFromKeypair @s (view envAsymmetricKeyPair penv))
 
                             ANNOUNCE h  -> do
                               debug $ "got announce rpc" <+> pretty h
diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs
index 0863abe0..87af9b7f 100644
--- a/hbs2-peer/app/ProxyMessaging.hs
+++ b/hbs2-peer/app/ProxyMessaging.hs
@@ -39,7 +39,7 @@ import Data.String.Conversions (cs)
 import Data.List qualified as L
 import Data.Map (Map)
 import Data.Map qualified as Map
-import Lens.Micro.Platform
+import Lens.Micro.Platform as Lens
 import Control.Monad
 
 -- TODO: protocol-encryption-goes-here
@@ -146,12 +146,21 @@ receiveFromProxyMessaging bus _ = liftIO do
           Nothing -> do
               trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom
               pure (Just msg)
-          Just k -> runMaybeT $ (<|> pure msg) $ do
+          Just k -> runMaybeT $
+            -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать
+            (<|> (do
+                -- И сотрём ключ из памяти
+                liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys bus) $ Lens.at whom .~ Nothing
+                trace $ "ENCRYPTION RECEIVE: got plain message. clearing key of" <+> pretty whom
+                pure msg
+                )) $
+            do
               trace $ "ENCRYPTION RECEIVE: we have a key to decode from" <+> pretty whom <+> ":" <+> viaShow k
               case ((extractNonce . cs) msg) of
                   Nothing -> do
                       trace $ "ENCRYPTION RECEIVE: can not extract nonce from" <+> pretty whom <+> "message" <+> viaShow msg
-                      pure msg
+                      fail ""
+
                   Just (nonce, msg') ->
                       ((MaybeT . pure) (boxOpenAfterNMLazy k nonce msg')
                           <* (trace $ "ENCRYPTION RECEIVE: message successfully decoded from" <+> pretty whom)
@@ -159,15 +168,13 @@ receiveFromProxyMessaging bus _ = liftIO do
                     <|>
                       (do
                           (trace $ "ENCRYPTION RECEIVE: can not decode message from" <+> pretty whom)
-
-                          -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать
-                          pure msg
+                          fail ""
 
                           -- -- Попытаться десериализовать сообщение как PeerPing или PeerPingCrypted
                           -- case deserialiseOrFail msg of
                           --   Right (_ :: PeerHandshake L4Proto) -> do
                           --       trace $ "ENCRYPTION RECEIVE: plain message decoded as PeerHandshake" <+> pretty whom
-                          --       pure msg
+                          --       fail ""
                           --   Left _ -> do
                           --       trace $ "ENCRYPTION RECEIVE: failed" <+> pretty whom
                           --       mzero