Improved 'c' command.

5 files changed, 54 insertions, 15 deletions

diff --git a/dht/Presence/XMPPServer.hs b/dht/Presence/XMPPServer.hs
index 3bafd33c..2f2a1b4b 100644
--- a/dht/Presence/XMPPServer.hs
+++ b/dht/Presence/XMPPServer.hs
@@ -1775,9 +1775,9 @@ xmppServer allocate bind_addr = do
                               { pingInterval = 15000 + fuzz
                               , timeout      = 2000
                               , duplex       = False }
-        tcp <- tcpManager (\(PeerAddress addr) -> (addr, peer_params, 10000)) sv
+        tcp <- tcpManager (\(PeerAddress addr) -> (addr, peer_params, 10000)) sv -- TODO: unused
         return XMPPServer { _xmpp_sv          = sv
-                          , _xmpp_man         = tcp
+                          , _xmpp_man         = tcp -- TODO: unused
                           , _xmpp_peer_params = peer_params
                           , _xmpp_peer_bind   = peer_bind
                           }
diff --git a/dht/ToxManager.hs b/dht/ToxManager.hs
index c4440409..34cdcb6f 100644
--- a/dht/ToxManager.hs
+++ b/dht/ToxManager.hs
@@ -147,7 +147,7 @@ toxman ssvar announcer toxbkts tox presence = ToxManager
             return ()
 
     , deactivateAccount      = \k pubname -> do
-       dput XMan $ "toxman DECTIVATE (todo) 1 " ++ show pubname
+       dput XMan $ "toxman DEACTIVATE " ++ show pubname
        let ContactInfo{ accounts } = Tox.toxContactInfo tox
            mpubid = stripSuffix ".tox" pubname >>= readMaybe . T.unpack
        bStopped <- fmap (fromMaybe Nothing) $ atomically $ do
@@ -225,7 +225,7 @@ toxman ssvar announcer toxbkts tox presence = ToxManager
         m <- forM (keyAsUnique paddr >>= (`Map.lookup` ss)) $ \c -> do
             fmap (uncurry ToxContact . (key2id *** key2id)) <$> compatibleKeys c
         return $ maybeToList (join m)
-     }
+     } :: Connection.Manager ToxProgress ToxContact
     , resolveToxPeer = \me them -> do
         let m = do meid <- readMaybe $ T.unpack me
                    themid <- readMaybe $ T.unpack them
diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs
index c01d50cd..99ff746c 100644
--- a/dht/examples/dhtd.hs
+++ b/dht/examples/dhtd.hs
@@ -35,6 +35,7 @@ import Data.Bits (xor)
 import Data.Char
 import Data.Conduit as C
 import qualified Data.Conduit.List as C
+import Data.Data
 import Data.Dependent.Sum
 import Data.Function
 import Data.Functor.Identity
@@ -298,7 +299,7 @@ reportSearchResults meth h DHTSearch{searchShowTok,searchState,searchResults} =
         ns'           = map showN ns
     reportResult meth id (const Nothing) id h (Right (ns',rs, Just ()))
 
-data ConnectionManager = forall status k. ConnectionManager { typedManager :: Connection.Manager status k }
+data ConnectionManager = forall status k. Data k => ConnectionManager { typedManager :: Connection.Manager status k }
 
 data Session = Session
     { netname           :: String
@@ -314,6 +315,7 @@ data Session = Session
     , announcer         :: Announcer
     , signalQuit        :: IO ()
     , mbTox             :: Maybe (Tox.Tox JabberClients)
+    , sessionsVar       :: TVar (Map.Map Uniq24 AggregateSession)
     }
 
 exceptionsToClient :: ClientHandle -> IO () -> IO ()
@@ -360,6 +362,15 @@ waitOn bg nid ni = do
     bg nid ni $ putMVar mvar
     takeMVar mvar
 
+getSessions :: TVar (Map.Map Uniq24 AggregateSession) -> Uniq24 -> STM [Tox.Session]
+getSessions ssvar u24 = do
+    agmap <- readTVar ssvar
+    case Map.lookup u24 agmap of
+        Nothing -> return []
+        Just agg -> do
+            smap <- readTVar $ contactSession agg
+            return $ map singleSession $ IntMap.elems smap
+
 clientSession :: Session -> t1 -> t -> ClientHandle -> IO ()
 clientSession s@Session{..} sock cnum h = do
     line <- dropWhile isSpace <$> hGetClientLine h
@@ -1090,7 +1101,12 @@ clientSession s@Session{..} sock cnum h = do
                                ]
                 rs = map mkrow cs
             return $ do
-            hPutClient h $ "connections\n" ++ showColumns rs
+                us <- mapM (mapM aggSessionKey . getToxContacts . fst) cs
+                sessionss <- atomically $ mapM (mapM (getSessions sessionsVar)) us
+                let ls = do
+                        (sessions,row) <- zip sessionss (lines $ showColumns rs)
+                        row : map (mappend "    " . show . sTheirAddr) (concat sessions)
+                hPutClient h $ unlines $ ("connections ("++show(length rs)++")") : ls
 
         ("help", s) | Just DHT{..} <- Map.lookup netname dhts
                     -> cmd0 $ do
@@ -1325,6 +1341,14 @@ onNewToxSession sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do
 
     return ()
 
+getToxContacts :: Data d => d -> [Tox.ToxContact]
+getToxContacts a = case cast a of
+    Just t -> [t]
+    Nothing -> concat $ gmapQ getToxContacts a
+
+aggSessionKey :: Tox.ToxContact -> IO Uniq24
+aggSessionKey (Tox.ToxContact me them) = xor24 <$> hash24 (Tox.id2key me) <*> hash24 (Tox.id2key them)
+
 selectManager :: Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text
 selectManager mtman tcp profile = case stripSuffix ".tox" profile of
     Just k | Just tman <- mtman
@@ -1366,7 +1390,12 @@ selectManager mtman tcp profile = case stripSuffix ".tox" profile of
                     , connections = let valid (Tox.ToxContact local them) = do
                                             guard $ T.pack (show local) == k
                                             return $ T.pack (show them ++ ".tox")
-                                    in fmap (mapMaybe valid) $ connections tox
+                                    in fmap (mapMaybe valid) $ do -- fmap (map (T.pack . show)) $
+                                            cs <- connections tox
+                                            let ncs = length cs
+                                                nms = length $ mapMaybe valid cs
+                                            tput XMan $ "Manager{Tox} (all,valid)=" ++ show (ncs,nms)
+                                            return cs
                     , stringToKey = \s -> Just $ T.pack (s ++ ".tox")
                     , showProgress = \(ToxStatus stat) -> showProgress tox stat
                     }
@@ -1381,7 +1410,10 @@ selectManager mtman tcp profile = case stripSuffix ".tox" profile of
                     , showKey = showKey tcp
                     , setPolicy = setPolicy tcp
                     , status =  \k -> fmap XMPPStatus <$> status tcp k
-                    , connections = connections tcp
+                    , connections = do
+                        cs <- connections tcp
+                        tput XMan $ "Manager{TCP} cons=" ++ show (length cs)
+                        return cs
                     , stringToKey = stringToKey tcp
                     , showProgress = \(XMPPStatus stat) -> showProgress tcp stat
                     }
@@ -1668,9 +1700,14 @@ initJabber opts ssvar announcer mbtox toxdhts toxchat = case portxmpp opts of
             xmpp_thread <- forkXmpp sv (presenceHooks state chats (verbosity opts) (Just cport) (Just sport))
             let conns :: ConnectionManager -- Manager (Either Pending TCPStatus) (Either T.Text T.Text)
                 conns = fromMaybe (ConnectionManager tcp) $ do
-                    sel <- tman
-                    Just $ ConnectionManager $ addManagers (selectManager (Just sel) tcp "auto.tox") tcp
-            return (Just sv, Just conns, Just state, killThread xmpp_thread >> quitChatService)
+                    sel <- fmap ($ error "PresenseState") tman
+                    let _ = sel :: ToxManager ClientAddress
+                        mantox = toxConnections sel :: Connection.Manager Tox.ToxProgress Tox.ToxContact
+                    Just $ ConnectionManager mantox -- addManagers (toxConnections sel) tcp
+            return ( Just sv
+                   , Just conns
+                   , Just state
+                   , killThread xmpp_thread >> quitChatService)
 
 main :: IO ()
 main = do
@@ -1784,7 +1821,7 @@ main = do
 
     keysdb <- Tox.newKeysDatabase
 
-    ssvar <- atomically $ newTVar Map.empty
+    ssvar <- atomically $ newTVar Map.empty :: IO ( TVar (Map.Map Uniq24 AggregateSession) )
     rec (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate) <- do
 
         (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- initTox opts ssvar keysdb msv invc
@@ -1826,6 +1863,7 @@ main = do
                 , externalAddresses = liftM2 (++) btips toxips
                 , announcer         = announcer
                 , mbTox             = mbtox
+                , sessionsVar       = ssvar
                 }
         srv <- streamServer (withSession session) [SockAddrUnix "dht.sock"]
         return ( do atomically $ readTVar signalQuit >>= check
diff --git a/dht/src/Network/Tox/AggregateSession.hs b/dht/src/Network/Tox/AggregateSession.hs
index 999c7399..faf512d0 100644
--- a/dht/src/Network/Tox/AggregateSession.hs
+++ b/dht/src/Network/Tox/AggregateSession.hs
@@ -6,7 +6,8 @@
 {-# LANGUAGE LambdaCase      #-}
 {-# LANGUAGE PatternSynonyms #-}
 module Network.Tox.AggregateSession
-    ( AggregateSession
+    ( AggregateSession(contactSession)
+    , SingleCon(singleSession)
     , newAggregateSession
     , aggregateStatus
     , checkCompatible
diff --git a/dht/src/Network/Tox/NodeId.hs b/dht/src/Network/Tox/NodeId.hs
index 8567e77d..a3ddd617 100644
--- a/dht/src/Network/Tox/NodeId.hs
+++ b/dht/src/Network/Tox/NodeId.hs
@@ -626,12 +626,12 @@ solveBase64NoSpamID b64digits pub = do
 -- even though they are long-term keys rather than the public keys of Tox DHT
 -- nodes.
 data ToxContact = ToxContact NodeId{-me-} NodeId{-them-}
- deriving (Eq,Ord)
+ deriving (Eq,Ord,Data)
 
 instance Show ToxContact where show = show . showToxContact_
 
 showToxContact_ :: ToxContact -> String
-showToxContact_ (ToxContact me them) = show me ++ ":" ++ show them
+showToxContact_ (ToxContact me them) = "(" ++ take 8 (show me) ++ ")" ++ show them
 
 -- | This type indicates the progress of a tox encrypted friend link
 -- connection.  Two scenarios are illustrated below.  The parenthesis show the