voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Sergey Ivanov 2023-07-04 21:39:35 +04:00
parent 5ecbd93594
commit c403b77556
3 changed files with 69 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
hbs2-peer/app/PeerInfo.hs
View File

@ -244,15 +244,3 @@ peerPingLoop cfg penv = do
-- trace $ "SEND PING TO" <+> pretty p -- trace $ "SEND PING TO" <+> pretty p
sendPing @e p sendPing @e p
-- trace $ "SENT PING TO" <+> pretty 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

51
hbs2-peer/app/PeerMain.hs
View File

@ -836,58 +836,7 @@ runPeer opts = U.handle (\e -> myException e
-- Nothing -> unencrypted ping -- Nothing -> unencrypted ping
-- Just pubkey -> encryptengd -- 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 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 ANNOUNCE h -> do
debug $ "got announce rpc" <+> pretty h debug $ "got announce rpc" <+> pretty h

139
hbs2-peer/app/ProxyMessaging.hs
View File

@ -94,89 +94,90 @@ runProxyMessaging env = liftIO do
liftIO $ mapM_ waitCatch [u,t] liftIO $ mapM_ waitCatch [u,t]
instance Messaging PlainProxyMessaging L4Proto LBS.ByteString where instance Messaging ProxyMessaging L4Proto LBS.ByteString where
sendTo = sendToPlainProxyMessaging sendTo = sendToPlainProxyMessaging
receive (PlainProxyMessaging bus) = receive bus receive = receiveFromProxyMessaging
sendToPlainProxyMessaging :: (MonadIO m) sendToPlainProxyMessaging :: (MonadIO m)
=> PlainProxyMessaging => ProxyMessaging
-> To L4Proto -> To L4Proto
-> From L4Proto -> From L4Proto
-> LBS.ByteString -> LBS.ByteString
-- -> AnyMessage LBS.ByteString L4Proto
-> m () -> m ()
sendToPlainProxyMessaging (PlainProxyMessaging bus) t@(To whom) proto msg = do sendToPlainProxyMessaging bus t@(To whom) proto msg = do
let udp = view proxyUDP bus let udp = view proxyUDP bus
case view sockType whom of case view sockType whom of
UDP -> sendTo udp t proto msg UDP -> sendTo udp t proto msg
TCP -> maybe1 (view proxyTCP bus) none $ \tcp -> do TCP -> maybe1 (view proxyTCP bus) none $ \tcp -> do
sendTo tcp t proto msg sendTo tcp t proto msg
instance Messaging ProxyMessaging L4Proto LBS.ByteString where -- sendToProxyMessaging :: (MonadIO m)
sendTo = sendToProxyMessaging -- => ProxyMessaging
receive = receiveFromProxyMessaging -- -> 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 -- receiveFromProxyMessaging :: MonadIO m
-- sendTo (view proxyUDP bus) t proto msg -- => ProxyMessaging -> To L4Proto -> m [(From L4Proto, LBS.ByteString)]
-- trace $ "PROXY: SEND" <+> pretty whom -- receiveFromProxyMessaging bus _ = liftIO do
encKey <- Map.lookup whom <$> (liftIO . readTVarIO) (view proxyEncryptionKeys bus) -- -- trace "PROXY: RECEIVE"
cf <- case encKey of -- -- receive (view proxyUDP bus) w
Nothing -> do -- let answ = view proxyAnswers bus
trace $ "ENCRYPTION SEND: sending plain message to" <+> pretty whom -- rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ)
pure id -- fmap catMaybes $ forM rs \(w@(From whom), msg) -> do
Just k -> do -- encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus)
trace $ "ENCRYPTION SEND: sending encrypted message to" <+> pretty whom <+> "with key" <+> viaShow k -- fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) msg
boxAfterNMLazy k <$> liftIO Encrypt.newNonce
sendTo (PlainProxyMessaging bus) t proto (cf msg)
receiveFromProxyMessaging :: MonadIO m -- where
=> ProxyMessaging -> To L4Proto -> m [(From L4Proto, LBS.ByteString)] -- dfm :: Peer L4Proto -> Maybe Encrypt.CombinedKey -> LBS.ByteString -> IO (Maybe LBS.ByteString)
receiveFromProxyMessaging bus _ = liftIO do -- dfm = \whom mk msg -> case mk of
-- trace "PROXY: RECEIVE" -- Nothing -> do
-- receive (view proxyUDP bus) w -- trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom
let answ = view proxyAnswers bus -- pure (Just msg)
rs <- atomically $ liftM2 (:) (readTQueue answ) (flushTQueue answ) -- Just k -> runMaybeT $
fmap catMaybes $ forM rs \(w@(From whom), msg) -> do -- -- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать
encKeys <- (liftIO . readTVarIO) (view proxyEncryptionKeys bus) -- (<|> (do
fmap (w, ) <$> dfm whom (Map.lookup whom encKeys) msg -- -- И сотрём ключ из памяти
-- -- liftIO $ atomically $ modifyTVar' (view proxyEncryptionKeys bus) $ Lens.at whom .~ Nothing
where -- trace $ "ENCRYPTION RECEIVE: got plain message. clearing key of" <+> pretty whom
dfm :: Peer L4Proto -> Maybe Encrypt.CombinedKey -> LBS.ByteString -> IO (Maybe LBS.ByteString) -- pure msg
dfm = \whom mk msg -> case mk of -- )) $
Nothing -> do -- do
trace $ "ENCRYPTION RECEIVE: we do not have a key to decode" <+> pretty whom -- trace $ "ENCRYPTION RECEIVE: we have a key to decode from" <+> pretty whom <+> ":" <+> viaShow k
pure (Just msg) -- case ((extractNonce . cs) msg) of
Just k -> runMaybeT $ -- Nothing -> do
-- А будем-ка мы просто передавать сообщение дальше как есть, если не смогли расшифровать -- trace $ "ENCRYPTION RECEIVE: can not extract nonce from" <+> pretty whom <+> "message" <+> viaShow msg
(<|> (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 ""
-- -- Попытаться десериализовать сообщение как PeerPing или PeerPingCrypted
-- case deserialiseOrFail msg of
-- Right (_ :: PeerHandshake L4Proto) -> do
-- trace $ "ENCRYPTION RECEIVE: plain message decoded as PeerHandshake" <+> pretty whom
-- fail "" -- fail ""
-- Left _ -> do
-- trace $ "ENCRYPTION RECEIVE: failed" <+> pretty whom
-- mzero
) -- 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
-- )