2 files changed, 57 insertions, 1 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 2f903d5f..fed2976f 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -34,6 +34,7 @@ import Data.Conduit as C
 import Data.Function
 import Data.Hashable
 import Data.List
+import Data.Word
 import qualified Data.IntMap.Strict as IntMap
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -394,6 +395,7 @@ data Session = Session
     , toxkeys           :: TVar Tox.AnnouncedKeys
     , userkeys          :: TVar [(SecretKey,PublicKey)]
     , roster            :: Tox.ContactInfo
+    , sessions          :: TVar [PerSession]
     , connectionManager :: Maybe ConnectionManager
     , onionRouter       :: OnionRouter
     , announcer         :: Announcer
@@ -470,6 +472,7 @@ clientSession s@Session{..} sock cnum h = do
             , ["ls"]
             , ["k"]
             , ["roster"]
+            , ["sessions"]
             , ["onion"]
             , ["g"]
             , ["p"]
@@ -666,6 +669,33 @@ clientSession s@Session{..} sock cnum h = do
                 hPutClientChunk h $ unlines [ dns, "", "Friend Requests" ]
                 hPutClient h $ showReport frs
 
+        ("sessions", s) | "" <- strp s
+            -> cmd0 $ do
+                sessions' <- atomically $ readTVar sessions :: IO [PerSession]
+                let sessionsReport = mapM showPerSession sessions'
+                    headers = ["Key", "NextMsg", "Handled","Unhandled"]
+                    showPerSession (PerSession
+                                        { perSessionMsgs = msgQ
+                                        , perSessionPublicKey = pubKey
+                                        , perSessionAddr = sockAddr
+                                        , perSessionNumVar = msgNumVar
+                                        }) = do
+                        num <- atomically (readTVar msgNumVar)
+                        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 countHandled        -- "Handled"
+                               , show countUnhandled      -- "Unhandled"
+                               ]
+                if null sessions'
+                 then hPutClient h "No sessions."
+                 else do
+                    rows <- sessionsReport
+                    hPutClient h (showColumns (headers:rows))
+
         ("onion", s) -> cmd0 $ join $ atomically $ do
             rm <- readTVar $ routeMap onionRouter
             ts <- readTVar $ trampolineNodes onionRouter
@@ -1218,6 +1248,7 @@ announceToxJabberPeer echan laddr saddr pingflag tsrc tsnk
 data PerSession = PerSession { perSessionMsgs :: PacketQueue (Bool{-Handled?-},Tox.CryptoMessage)
                              , perSessionPublicKey :: PublicKey
                              , perSessionAddr :: SockAddr
+                             , perSessionNumVar :: TVar Word32
                              }
 
 main :: IO ()
@@ -1328,7 +1359,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
     crypto <- Tox.newCrypto
     netCryptoSessionsState <- Tox.newSessionsState crypto Tox.defaultUnRecHook Tox.defaultCryptoDataHooks
     sessions <- atomically (newTVar []) :: IO (TVar [PerSession])
-    (mbtox,quitTox,toxdhts,toxips,taddrs) <- case porttox opts of
+    (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- case porttox opts of
         "" -> return (Nothing,return (), Map.empty, return [],[])
         toxport -> do
             addrTox <- getBindAddress toxport (ip6tox opts)
@@ -1538,6 +1569,17 @@ main = runResourceT $ liftBaseWith $ \resT -> do
 
     forM_ (take 1 taddrs) $ \addrTox -> do
         atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> 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)))
+            msgNumVar <- atomically (newTVar 0)
+            let perSession = PerSession { perSessionMsgs = msgQ
+                                        , perSessionPublicKey = pubKey
+                                        , perSessionAddr = sockAddr
+                                        , perSessionNumVar = msgNumVar
+                                        }
+            atomically $ modifyTVar' sessions (perSession:)
             tmchan <- atomically newTMChan
             let Just pingMachine = Tox.ncPingMachine netcrypto
                 pingflag         = readTVar (pingFlag pingMachine)
@@ -1555,6 +1597,10 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                     Tox.forgetCrypto crypto netCryptoSessionsState netcrypto
                     return Nothing
                 handleIncoming mTyp session cm = do
+                    atomically $ do
+                        num <- readTVar msgNumVar
+                        enqueue msgQ num (False,cm)
+                        modifyTVar' msgNumVar (+1)
                     atomically $ writeTMChan tmchan cm -- (Tox.bufferData cd)
                     return Nothing
             atomically $ writeTVar (Tox.ncUnrecognizedHook netcrypto) handleIncoming
@@ -1585,6 +1631,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                 , toxkeys           = keysdb
                 , userkeys          = toxids
                 , roster            = rstr
+                , sessions          = sessions
                 , connectionManager = ConnectionManager <$> mconns
                 , onionRouter       = orouter
                 , externalAddresses = liftM2 (++) btips toxips
diff --git a/src/Data/PacketQueue.hs b/src/Data/PacketQueue.hs
index b7737656..a4c99cab 100644
--- a/src/Data/PacketQueue.hs
+++ b/src/Data/PacketQueue.hs
@@ -11,6 +11,7 @@ module Data.PacketQueue
     , enqueue
     , observeOutOfBand
     , PacketOutQueue
+    , packetQueueViewList
     , newOutGoing
     , readyOutGoing
     , tryAppendQueueOutgoing
@@ -25,6 +26,7 @@ import Control.Concurrent.STM.TArray
 import Control.Monad
 import Data.Word
 import Data.Array.MArray
+import Data.Maybe
 
 data PacketQueue a = PacketQueue
     { pktq    :: TArray Word32 (Maybe a)
@@ -33,6 +35,13 @@ data PacketQueue a = PacketQueue
     , buffend :: TVar Word32 -- on incoming, highest packet number handled + 1
     }
 
+packetQueueViewList :: PacketQueue a -> STM [(Word32,a)]
+packetQueueViewList p = do
+    let f (n,Nothing) = Nothing
+        f (n,Just x)  = Just (n,x)
+    catMaybes . map f <$> getAssocs (pktq p)
+
+
 -- | Create a new PacketQueue.
 new :: Word32 -- ^ Capacity of queue.
     -> Word32 -- ^ Initial sequence number.