From f59f8c0acd3a098d7a93b71fcf10d84cc576b7ab Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 7 Sep 2018 12:03:18 -0400 Subject: Fixed handling of lossy outgoing in Network.Lossless. --- src/Network/Lossless.hs | 38 ++++++++++++++++++++++++-------------- src/Network/Tox/Session.hs | 29 +++++++++++++++++++++-------- 2 files changed, 45 insertions(+), 22 deletions(-) diff --git a/src/Network/Lossless.hs b/src/Network/Lossless.hs index bdbeb3a2..f48dc8fd 100644 --- a/src/Network/Lossless.hs +++ b/src/Network/Lossless.hs @@ -27,7 +27,7 @@ data SequenceInfo = SequenceInfo lossless :: Show addr => (x -> addr -> IO (PacketInboundEvent (x',addr'))) - -> (SequenceInfo -> x' -> addr' -> IO y) + -> (SequenceInfo -> x' -> addr' -> IO (Bool,y)) -> addr -> TransportA String addr x y -> IO ( Transport String addr' x' @@ -39,44 +39,54 @@ lossless isLossless encode saddr udp = do oob <- atomically newTChan -- Out-of-band channel, these packets (or -- errors) bypass the packet buffer to be -- received immediately. - rloop <- forkIO $ fix $ \loop -> do + rloop <- forkIO $ do -- This thread enqueues inbound packets or writes them to the oob -- channel. myThreadId >>= flip labelThread ("lossless."++show saddr) + fix $ \loop -> do awaitMessage udp $ \m -> do - forM_ m $ \raw -> do - m' <- mapM (uncurry isLossless) raw + m' <- mapM (mapM $ uncurry isLossless) m case m' of - Left e -> do - atomically $ writeTChan oob (Left e) + Nothing -> do + atomically $ writeTChan oob Nothing + -- Quit thread here. + Just (Left e) -> do + atomically $ writeTChan oob (Just $ Left e) loop - Right event -> do + Just (Right event) -> do atomically $ do -- x' <- isLossless xaddr x PB.grokInboundPacket pb event case event of - PacketReceivedLossy {} -> writeTChan oob (Right $ peReceivedPayload event) + PacketReceivedLossy {} -> writeTChan oob (Just $ Right $ peReceivedPayload event) _ -> do report <- pbReport "enqueued" pb - writeTChan oob (Left report) + writeTChan oob (Just $ Left report) loop let tr = Transport { awaitMessage = \kont -> do join $ atomically $ orElse (do x <- readTChan oob - return $ kont $! Just x) + return $ kont $! x) (do x <- PB.awaitReadyPacket pb report <- pbReport "dequeued" pb return $ do - dput XNetCrypto report + atomically $ writeTChan oob (Just $ Left report) kont $! Just (Right x)) , sendMessage = \a' x' -> do seqno <- atomically $ do seqno <- PB.nextToSendSequenceNumber pb ack <- PB.expectingSequenceNumber pb return $ SequenceInfo seqno ack - x <- encode seqno x' a' - (isfull,nn) <- atomically $ PB.grokOutboundPacket pb (PacketSent (sequenceNumber seqno) x) + (islossy,x) <- encode seqno x' a' + (isfull,nn) <- + if islossy + then do + dput XNetCrypto $ shows saddr $ " <-- Lossy packet " ++ show seqno + return (False,(0,0)) -- avoid updating seqno on lossy packets. + else do + dput XNetCrypto $ shows saddr $ " <-- Lossless packet " ++ show seqno + atomically $ PB.grokOutboundPacket pb (PacketSent (sequenceNumber seqno) x) when isfull $ do dput XNetCrypto $ shows saddr $ " <-- Outbound queue is full! Retrying... " ++ show (nn,seqno) atomically $ do @@ -84,7 +94,7 @@ lossless isLossless encode saddr udp = do when isfull retry sendMessage udp saddr x , closeTransport = do - killThread rloop + atomically $ writeTChan oob Nothing -- quit rloop thread closeTransport udp } resend ns = do diff --git a/src/Network/Tox/Session.hs b/src/Network/Tox/Session.hs index 88221b11..7b84ba80 100644 --- a/src/Network/Tox/Session.hs +++ b/src/Network/Tox/Session.hs @@ -15,7 +15,7 @@ import Network.Lossless import Network.QueryResponse import Network.SessionTransports import Network.Tox.Crypto.Transport -import Network.Tox.DHT.Transport (Cookie) +import Network.Tox.DHT.Transport (Cookie,key2id) import Network.Tox.Handshake type SessionKey = SecretKey @@ -69,7 +69,7 @@ plainHandshakeH sp saddr skey handshake = do dput XNetCrypto $ prelude ++ "handshake: " ++ show (otherCookie hd, baseNonce hd) sent <- spGetSentHandshake sp skey saddr (handshakeCookie handshake) (otherCookie hd) -- TODO: this is always returning sent = Nothing - dput XNetCrypto $ prelude ++ "plainHandshakeH: cached outgoing: " ++ show (fmap (baseNonce . snd) sent) + dput XNetCrypto $ " <-- (cached) handshake baseNonce" ++ show (fmap (baseNonce . snd) sent) forM_ sent $ \(hd_skey,hd_sent) -> do sk <- SessionKeys (spCrypto sp) hd_skey @@ -81,7 +81,9 @@ plainHandshakeH sp saddr skey handshake = do forM_ m $ \(sid, t) -> do (t2,resend,getMissing) <- lossless (\cp a -> return $ fmap (,a) $ checkLossless $ runIdentity $ pktData cp) - (\seqno p _ -> encryptPacket sk $ bookKeeping seqno p) + (\seqno p _ -> do + y <- encryptPacket sk $ bookKeeping seqno p + return (lossyness (msgID p) == Lossy, y)) () t let _ = t :: TransportA String () (CryptoPacket Identity) (CryptoPacket Encrypted) @@ -101,16 +103,22 @@ plainHandshakeH sp saddr skey handshake = do decryptPacket :: SessionKeys -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ())) decryptPacket sk saddr (CryptoPacket n16 ciphered) = do - (n,δ) <- atomically $ do + (n24,δ) <- atomically $ do n <- readTVar (skNonceIncoming sk) let δ = n16 - nonce24ToWord16 n return ( n `addtoNonce24` fromIntegral δ, δ ) - secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n + secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24 case decodePlain =<< decrypt secret ciphered of Left e -> return Nothing Right x -> do when ( δ > 43690 ) - $ atomically $ writeTVar (skNonceIncoming sk) (n `addtoNonce24` 21845) + $ atomically $ writeTVar (skNonceIncoming sk) (n24 `addtoNonce24` 21845) + + do let them = key2id $ skThem sk + CryptoData ack seqno _ = x + cm = decodeRawCryptoMsg x + dput XNetCrypto $ unwords [take 8 (show them),"-->",show (msgID cm),show (n24,ack,seqno)] + return $ Just ( CryptoPacket n16 (pure x), () ) encryptPacket :: SessionKeys -> CryptoData -> IO (CryptoPacket Encrypted) @@ -121,12 +129,17 @@ encryptPacket sk plain = do return n24 secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24 let ciphered = encrypt secret $ encodePlain $ plain + + do let them = key2id $ skThem sk + CryptoData ack seqno cm = plain + dput XNetCrypto $ unwords [take 8 (show them),"<--",show (msgID cm),show (n24,ack,seqno)] + return $ CryptoPacket (nonce24ToWord16 n24) ciphered data SessionKeys = SessionKeys { skCrypto :: TransportCrypto - , skMe :: SecretKey - , skThem :: PublicKey + , skMe :: SecretKey -- My session key + , skThem :: PublicKey -- Their session key , skNonceIncoming :: TVar Nonce24 -- +21845 when a threshold is reached. , skNonceOutgoing :: TVar Nonce24 -- +1 on every packet } -- cgit v1.2.3