From c403b77556d5379d22e95cc706a57a2478e44194 Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Tue, 4 Jul 2023 21:39:35 +0400 Subject: [PATCH] wip --- hbs2-peer/app/PeerInfo.hs | 12 --- hbs2-peer/app/PeerMain.hs | 51 ------------ hbs2-peer/app/ProxyMessaging.hs | 137 ++++++++++++++++---------------- 3 files changed, 69 insertions(+), 131 deletions(-) diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index bb6278fd..cf2ed433 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -244,15 +244,3 @@ peerPingLoop cfg penv = do -- trace $ "SEND PING TO" <+> pretty p sendPing @e p -- trace $ "SENT PING TO" <+> pretty p - pause dt - sendPingCrypted @e p - (pubKeyFromKeypair @(Encryption e) (view envAsymmetricKeyPair penv)) - -- trace $ "SENT PING CRYPTED TO" <+> pretty p - - where - dt = case (requestPeriodLim @e @(PeerHandshake e)) of - NoLimit -> 0 - ReqLimPerProto t -> t + 0.1 - ReqLimPerMessage t -> t + 0.1 - - diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 9ba7defd..62345501 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -836,58 +836,7 @@ runPeer opts = U.handle (\e -> myException e -- Nothing -> unencrypted ping -- Just pubkey -> encryptengd - let - requestPlain :: forall m msg . - ( MonadIO m - -- , HasProtocol L4Proto msg - , msg ~ PeerHandshake L4Proto - , HasOwnPeer L4Proto m - -- , Messaging MessagingTCP L4Proto (AnyMessage ByteString L4Proto) - -- , Messaging MessagingUDP L4Proto (AnyMessage ByteString L4Proto) - , HasTimeLimits L4Proto (PeerHandshake L4Proto) m - ) => Peer e -> msg -> m () - requestPlain peer_e msg = do - let protoN = protoId @e @msg (Proxy @msg) - me <- ownPeer @e - - allowed <- tryLockForPeriod peer_e msg - - when (not allowed) do - trace $ "REQUEST: not allowed to send" <+> viaShow msg - - -- when allowed do - -- sendTo proxy (To peer_e) (From me) (AnyMessage @(Encoded e) @e protoN (encode msg)) - - -- 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 - -- 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)) sendPing pip - pause $ case (requestPeriodLim @e @(PeerHandshake e)) of - NoLimit -> 0 - ReqLimPerProto t -> t + 0.1 - ReqLimPerMessage t -> t + 0.1 - -- 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 87af9b7f..0d13b56f 100644 --- a/hbs2-peer/app/ProxyMessaging.hs +++ b/hbs2-peer/app/ProxyMessaging.hs @@ -94,89 +94,90 @@ runProxyMessaging env = liftIO do liftIO $ mapM_ waitCatch [u,t] -instance Messaging PlainProxyMessaging L4Proto LBS.ByteString where +instance Messaging ProxyMessaging L4Proto LBS.ByteString where sendTo = sendToPlainProxyMessaging - receive (PlainProxyMessaging bus) = receive bus + receive = receiveFromProxyMessaging sendToPlainProxyMessaging :: (MonadIO m) - => PlainProxyMessaging + => ProxyMessaging -> To L4Proto -> From L4Proto -> LBS.ByteString - -- -> AnyMessage LBS.ByteString L4Proto -> m () -sendToPlainProxyMessaging (PlainProxyMessaging bus) t@(To whom) proto msg = do +sendToPlainProxyMessaging bus t@(To whom) proto msg = do let udp = view proxyUDP bus case view sockType whom of UDP -> sendTo udp t proto msg TCP -> maybe1 (view proxyTCP bus) none $ \tcp -> do sendTo tcp t proto msg -instance Messaging ProxyMessaging L4Proto LBS.ByteString where - sendTo = sendToProxyMessaging - receive = receiveFromProxyMessaging +-- 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 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) +-- 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 - - ) +-- )