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
     }