From 9c408bcb0396c97c618410bbdfb30972de8ab4a7 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 4 Jul 2023 21:55:03 +0400 Subject: [PATCH] Disable bus encryption --- hbs2-peer/app/ProxyMessaging.hs | 142 +++++++++++++++++--------------- 1 file changed, 76 insertions(+), 66 deletions(-) diff --git a/hbs2-peer/app/ProxyMessaging.hs b/hbs2-peer/app/ProxyMessaging.hs index 0d13b56f..cea156e1 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -94,9 +94,19 @@ runProxyMessaging env = liftIO do liftIO $ mapM_ waitCatch [u,t] + instance Messaging ProxyMessaging L4Proto LBS.ByteString where + sendTo = sendToPlainProxyMessaging - receive = receiveFromProxyMessaging + + receive bus _ = liftIO do + -- trace "PROXY: RECEIVE" + -- receive (view proxyUDP bus) w + let answ = view proxyAnswers bus + atomically $ do + r <- readTQueue answ + rs <- flushTQueue answ + pure (r:rs) sendToPlainProxyMessaging :: (MonadIO m) => ProxyMessaging @@ -111,73 +121,73 @@ sendToPlainProxyMessaging bus t@(To whom) proto msg = do TCP -> maybe1 (view proxyTCP bus) none $ \tcp -> do sendTo tcp t proto msg --- sendToProxyMessaging :: (MonadIO m) --- => ProxyMessaging --- -> To L4Proto --- -> From L4Proto --- -> LBS.ByteString --- -> m () --- sendToProxyMessaging bus t@(To whom) proto msg = do --- -- sendTo (view proxyUDP bus) t proto msg --- -- trace $ "PROXY: SEND" <+> pretty whom --- encKey <- Map.lookup whom <$> (liftIO . readTVarIO) (view proxyEncryptionKeys bus) --- cf <- case encKey of --- Nothing -> do --- trace $ "ENCRYPTION SEND: sending plain message to" <+> pretty whom --- pure id --- Just k -> do --- trace $ "ENCRYPTION SEND: sending encrypted message to" <+> pretty whom <+> "with key" <+> viaShow k --- boxAfterNMLazy k <$> liftIO Encrypt.newNonce --- sendTo (PlainProxyMessaging bus) t proto (cf msg) +sendToProxyMessaging :: (MonadIO m) + => ProxyMessaging + -> To L4Proto + -> From L4Proto + -> LBS.ByteString + -> m () +sendToProxyMessaging bus t@(To whom) proto msg = do + -- sendTo (view proxyUDP bus) t proto msg + -- trace $ "PROXY: SEND" <+> pretty whom + encKey <- Map.lookup whom <$> (liftIO . readTVarIO) (view proxyEncryptionKeys bus) + cf <- case encKey of + Nothing -> do + trace $ "ENCRYPTION SEND: sending plain message to" <+> pretty whom + pure id + Just k -> do + trace $ "ENCRYPTION SEND: sending encrypted message to" <+> pretty whom <+> "with key" <+> viaShow k + boxAfterNMLazy k <$> liftIO Encrypt.newNonce + sendToPlainProxyMessaging bus t proto (cf msg) --- receiveFromProxyMessaging :: MonadIO m --- => ProxyMessaging -> To L4Proto -> m [(From L4Proto, LBS.ByteString)] --- receiveFromProxyMessaging bus _ = liftIO do --- -- trace "PROXY: RECEIVE" --- -- receive (view proxyUDP bus) w --- let answ = view proxyAnswers bus --- rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ) --- fmap catMaybes $ forM rs \(w@(From whom), msg) -> do --- encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) --- fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) msg +receiveFromProxyMessaging :: MonadIO m + => ProxyMessaging -> To L4Proto -> m [(From L4Proto, LBS.ByteString)] +receiveFromProxyMessaging bus _ = liftIO do + -- trace "PROXY: RECEIVE" + -- receive (view proxyUDP bus) w + let answ = view proxyAnswers bus + rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ) + fmap catMaybes $ forM rs \(w@(From whom), msg) -> do + encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) + fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) msg --- where --- dfm :: Peer L4Proto -> Maybe Encrypt.CombinedKey -> LBS.ByteString -> IO (Maybe LBS.ByteString) --- dfm = \whom mk msg -> case mk of --- Nothing -> do --- trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom --- pure (Just msg) --- 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 --- fail "" + where + dfm :: Peer L4Proto -> Maybe Encrypt.CombinedKey -> LBS.ByteString -> IO (Maybe LBS.ByteString) + dfm = \whom mk msg -> case mk of + Nothing -> do + trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom + pure (Just msg) + 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 + fail "" --- Just (nonce, msg') -> --- ((MaybeT . pure) (boxOpenAfterNMLazy k nonce msg') --- <* (trace $ "ENCRYPTION RECEIVE: message successfully decoded from" <+> pretty whom) --- ) --- <|> --- (do --- (trace $ "ENCRYPTION RECEIVE: can not decode message from" <+> pretty whom) --- fail "" + Just (nonce, msg') -> + ((MaybeT . pure) (boxOpenAfterNMLazy k nonce msg') + <* (trace $ "ENCRYPTION RECEIVE: message successfully decoded from" <+> pretty whom) + ) + <|> + (do + (trace $ "ENCRYPTION RECEIVE: can not decode message from" <+> pretty whom) + fail "" --- -- -- Попытаться десериализовать сообщение как PeerPing или PeerPingCrypted --- -- case deserialiseOrFail msg of --- -- Right (_ :: PeerHandshake L4Proto) -> do --- -- trace $ "ENCRYPTION RECEIVE: plain message decoded as PeerHandshake" <+> pretty whom --- -- fail "" --- -- Left _ -> do --- -- trace $ "ENCRYPTION RECEIVE: failed" <+> pretty whom --- -- mzero + -- -- Попытаться десериализовать сообщение как PeerPing или PeerPingCrypted + -- case deserialiseOrFail msg of + -- Right (_ :: PeerHandshake L4Proto) -> do + -- trace $ "ENCRYPTION RECEIVE: plain message decoded as PeerHandshake" <+> pretty whom + -- fail "" + -- Left _ -> do + -- trace $ "ENCRYPTION RECEIVE: failed" <+> pretty whom + -- mzero --- ) + )