Track dropped crypto packets, sessions command...

(cherry-pick of b8ef29e3d43)

1 files changed, 13 insertions, 4 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index fed2976f..57ee8deb 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -673,20 +673,23 @@ clientSession s@Session{..} sock cnum h = do
             -> cmd0 $ do
                 sessions' <- atomically $ readTVar sessions :: IO [PerSession]
                 let sessionsReport = mapM showPerSession sessions'
-                    headers = ["Key", "NextMsg", "Handled","Unhandled"]
+                    headers = ["Key", "NextMsg", "Dropped","Handled","Unhandled"]
                     showPerSession (PerSession
                                         { perSessionMsgs = msgQ
                                         , perSessionPublicKey = pubKey
                                         , perSessionAddr = sockAddr
                                         , perSessionNumVar = msgNumVar
+                                        , perSessionDropCount = dropCntVar
                                         }) = do
                         num <- atomically (readTVar msgNumVar)
+                        dropped <- atomically (readTVar dropCntVar)
                         as <- atomically (packetQueueViewList msgQ)
                         let (h,u) = partition (fst . snd) as
                             countHandled   = length h
                             countUnhandled = length u
                         return [ show (Tox.key2id pubKey) -- "Key"
                                , show num                 -- "NextMsg"
+                               , show dropped             -- "Dropped"
                                , show countHandled        -- "Handled"
                                , show countUnhandled      -- "Unhandled"
                                ]
@@ -1248,7 +1251,8 @@ announceToxJabberPeer echan laddr saddr pingflag tsrc tsnk
 data PerSession = PerSession { perSessionMsgs :: PacketQueue (Bool{-Handled?-},Tox.CryptoMessage)
                              , perSessionPublicKey :: PublicKey
                              , perSessionAddr :: SockAddr
-                             , perSessionNumVar :: TVar Word32
+                             , perSessionNumVar    :: TVar Word32
+                             , perSessionDropCount :: TVar Word32
                              }
 
 main :: IO ()
@@ -1572,12 +1576,14 @@ main = runResourceT $ liftBaseWith $ \resT -> do
             -- allsessionsMap <- atomically $ readTVar (netCryptoSessions netCryptoSessionsState)
             let sockAddr = Tox.ncSockAddr netcrypto
                 pubKey   = Tox.ncTheirPublicKey netcrypto
-            msgQ <- atomically (Data.PacketQueue.new 10 0 :: STM (PacketQueue (Bool,Tox.CryptoMessage)))
+            msgQ <- atomically (Data.PacketQueue.newOverwrite 10 0 :: STM (PacketQueue (Bool,Tox.CryptoMessage)))
             msgNumVar <- atomically (newTVar 0)
+            dropCntVar <- atomically (newTVar 0)
             let perSession = PerSession { perSessionMsgs = msgQ
                                         , perSessionPublicKey = pubKey
                                         , perSessionAddr = sockAddr
                                         , perSessionNumVar = msgNumVar
+                                        , perSessionDropCount = dropCntVar
                                         }
             atomically $ modifyTVar' sessions (perSession:)
             tmchan <- atomically newTMChan
@@ -1599,8 +1605,11 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                 handleIncoming mTyp session cm = do
                     atomically $ do
                         num <- readTVar msgNumVar
-                        enqueue msgQ num (False,cm)
+                        (wraps,offset) <- enqueue msgQ num (False,cm)
+                        capacity <- getCapacity msgQ
+                        let dropped = wraps * capacity + offset
                         modifyTVar' msgNumVar (+1)
+                        writeTVar dropCntVar dropped
                     atomically $ writeTMChan tmchan cm -- (Tox.bufferData cd)
                     return Nothing
             atomically $ writeTVar (Tox.ncUnrecognizedHook netcrypto) handleIncoming