diff options
author | Joe Crayne <joe@jerkface.net> | 2019-12-19 11:06:13 -0500 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 23:27:24 -0500 |
commit | 7895f56e787823af98197981dbdd6c11f2f25597 (patch) | |
tree | cea9fad3d83de2dd098284cd20918a7846315882 /dht/examples | |
parent | b6676d7c3339e46752cadfc1198886062f5c666d (diff) |
Improved 'c' command.
Diffstat (limited to 'dht/examples')
-rw-r--r-- | dht/examples/dhtd.hs | 54 |
1 files changed, 46 insertions, 8 deletions
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) | |||
35 | import Data.Char | 35 | import Data.Char |
36 | import Data.Conduit as C | 36 | import Data.Conduit as C |
37 | import qualified Data.Conduit.List as C | 37 | import qualified Data.Conduit.List as C |
38 | import Data.Data | ||
38 | import Data.Dependent.Sum | 39 | import Data.Dependent.Sum |
39 | import Data.Function | 40 | import Data.Function |
40 | import Data.Functor.Identity | 41 | import Data.Functor.Identity |
@@ -298,7 +299,7 @@ reportSearchResults meth h DHTSearch{searchShowTok,searchState,searchResults} = | |||
298 | ns' = map showN ns | 299 | ns' = map showN ns |
299 | reportResult meth id (const Nothing) id h (Right (ns',rs, Just ())) | 300 | reportResult meth id (const Nothing) id h (Right (ns',rs, Just ())) |
300 | 301 | ||
301 | data ConnectionManager = forall status k. ConnectionManager { typedManager :: Connection.Manager status k } | 302 | data ConnectionManager = forall status k. Data k => ConnectionManager { typedManager :: Connection.Manager status k } |
302 | 303 | ||
303 | data Session = Session | 304 | data Session = Session |
304 | { netname :: String | 305 | { netname :: String |
@@ -314,6 +315,7 @@ data Session = Session | |||
314 | , announcer :: Announcer | 315 | , announcer :: Announcer |
315 | , signalQuit :: IO () | 316 | , signalQuit :: IO () |
316 | , mbTox :: Maybe (Tox.Tox JabberClients) | 317 | , mbTox :: Maybe (Tox.Tox JabberClients) |
318 | , sessionsVar :: TVar (Map.Map Uniq24 AggregateSession) | ||
317 | } | 319 | } |
318 | 320 | ||
319 | exceptionsToClient :: ClientHandle -> IO () -> IO () | 321 | exceptionsToClient :: ClientHandle -> IO () -> IO () |
@@ -360,6 +362,15 @@ waitOn bg nid ni = do | |||
360 | bg nid ni $ putMVar mvar | 362 | bg nid ni $ putMVar mvar |
361 | takeMVar mvar | 363 | takeMVar mvar |
362 | 364 | ||
365 | getSessions :: TVar (Map.Map Uniq24 AggregateSession) -> Uniq24 -> STM [Tox.Session] | ||
366 | getSessions ssvar u24 = do | ||
367 | agmap <- readTVar ssvar | ||
368 | case Map.lookup u24 agmap of | ||
369 | Nothing -> return [] | ||
370 | Just agg -> do | ||
371 | smap <- readTVar $ contactSession agg | ||
372 | return $ map singleSession $ IntMap.elems smap | ||
373 | |||
363 | clientSession :: Session -> t1 -> t -> ClientHandle -> IO () | 374 | clientSession :: Session -> t1 -> t -> ClientHandle -> IO () |
364 | clientSession s@Session{..} sock cnum h = do | 375 | clientSession s@Session{..} sock cnum h = do |
365 | line <- dropWhile isSpace <$> hGetClientLine h | 376 | line <- dropWhile isSpace <$> hGetClientLine h |
@@ -1090,7 +1101,12 @@ clientSession s@Session{..} sock cnum h = do | |||
1090 | ] | 1101 | ] |
1091 | rs = map mkrow cs | 1102 | rs = map mkrow cs |
1092 | return $ do | 1103 | return $ do |
1093 | hPutClient h $ "connections\n" ++ showColumns rs | 1104 | us <- mapM (mapM aggSessionKey . getToxContacts . fst) cs |
1105 | sessionss <- atomically $ mapM (mapM (getSessions sessionsVar)) us | ||
1106 | let ls = do | ||
1107 | (sessions,row) <- zip sessionss (lines $ showColumns rs) | ||
1108 | row : map (mappend " " . show . sTheirAddr) (concat sessions) | ||
1109 | hPutClient h $ unlines $ ("connections ("++show(length rs)++")") : ls | ||
1094 | 1110 | ||
1095 | ("help", s) | Just DHT{..} <- Map.lookup netname dhts | 1111 | ("help", s) | Just DHT{..} <- Map.lookup netname dhts |
1096 | -> cmd0 $ do | 1112 | -> cmd0 $ do |
@@ -1325,6 +1341,14 @@ onNewToxSession sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do | |||
1325 | 1341 | ||
1326 | return () | 1342 | return () |
1327 | 1343 | ||
1344 | getToxContacts :: Data d => d -> [Tox.ToxContact] | ||
1345 | getToxContacts a = case cast a of | ||
1346 | Just t -> [t] | ||
1347 | Nothing -> concat $ gmapQ getToxContacts a | ||
1348 | |||
1349 | aggSessionKey :: Tox.ToxContact -> IO Uniq24 | ||
1350 | aggSessionKey (Tox.ToxContact me them) = xor24 <$> hash24 (Tox.id2key me) <*> hash24 (Tox.id2key them) | ||
1351 | |||
1328 | selectManager :: Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text | 1352 | selectManager :: Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text |
1329 | selectManager mtman tcp profile = case stripSuffix ".tox" profile of | 1353 | selectManager mtman tcp profile = case stripSuffix ".tox" profile of |
1330 | Just k | Just tman <- mtman | 1354 | Just k | Just tman <- mtman |
@@ -1366,7 +1390,12 @@ selectManager mtman tcp profile = case stripSuffix ".tox" profile of | |||
1366 | , connections = let valid (Tox.ToxContact local them) = do | 1390 | , connections = let valid (Tox.ToxContact local them) = do |
1367 | guard $ T.pack (show local) == k | 1391 | guard $ T.pack (show local) == k |
1368 | return $ T.pack (show them ++ ".tox") | 1392 | return $ T.pack (show them ++ ".tox") |
1369 | in fmap (mapMaybe valid) $ connections tox | 1393 | in fmap (mapMaybe valid) $ do -- fmap (map (T.pack . show)) $ |
1394 | cs <- connections tox | ||
1395 | let ncs = length cs | ||
1396 | nms = length $ mapMaybe valid cs | ||
1397 | tput XMan $ "Manager{Tox} (all,valid)=" ++ show (ncs,nms) | ||
1398 | return cs | ||
1370 | , stringToKey = \s -> Just $ T.pack (s ++ ".tox") | 1399 | , stringToKey = \s -> Just $ T.pack (s ++ ".tox") |
1371 | , showProgress = \(ToxStatus stat) -> showProgress tox stat | 1400 | , showProgress = \(ToxStatus stat) -> showProgress tox stat |
1372 | } | 1401 | } |
@@ -1381,7 +1410,10 @@ selectManager mtman tcp profile = case stripSuffix ".tox" profile of | |||
1381 | , showKey = showKey tcp | 1410 | , showKey = showKey tcp |
1382 | , setPolicy = setPolicy tcp | 1411 | , setPolicy = setPolicy tcp |
1383 | , status = \k -> fmap XMPPStatus <$> status tcp k | 1412 | , status = \k -> fmap XMPPStatus <$> status tcp k |
1384 | , connections = connections tcp | 1413 | , connections = do |
1414 | cs <- connections tcp | ||
1415 | tput XMan $ "Manager{TCP} cons=" ++ show (length cs) | ||
1416 | return cs | ||
1385 | , stringToKey = stringToKey tcp | 1417 | , stringToKey = stringToKey tcp |
1386 | , showProgress = \(XMPPStatus stat) -> showProgress tcp stat | 1418 | , showProgress = \(XMPPStatus stat) -> showProgress tcp stat |
1387 | } | 1419 | } |
@@ -1668,9 +1700,14 @@ initJabber opts ssvar announcer mbtox toxdhts toxchat = case portxmpp opts of | |||
1668 | xmpp_thread <- forkXmpp sv (presenceHooks state chats (verbosity opts) (Just cport) (Just sport)) | 1700 | xmpp_thread <- forkXmpp sv (presenceHooks state chats (verbosity opts) (Just cport) (Just sport)) |
1669 | let conns :: ConnectionManager -- Manager (Either Pending TCPStatus) (Either T.Text T.Text) | 1701 | let conns :: ConnectionManager -- Manager (Either Pending TCPStatus) (Either T.Text T.Text) |
1670 | conns = fromMaybe (ConnectionManager tcp) $ do | 1702 | conns = fromMaybe (ConnectionManager tcp) $ do |
1671 | sel <- tman | 1703 | sel <- fmap ($ error "PresenseState") tman |
1672 | Just $ ConnectionManager $ addManagers (selectManager (Just sel) tcp "auto.tox") tcp | 1704 | let _ = sel :: ToxManager ClientAddress |
1673 | return (Just sv, Just conns, Just state, killThread xmpp_thread >> quitChatService) | 1705 | mantox = toxConnections sel :: Connection.Manager Tox.ToxProgress Tox.ToxContact |
1706 | Just $ ConnectionManager mantox -- addManagers (toxConnections sel) tcp | ||
1707 | return ( Just sv | ||
1708 | , Just conns | ||
1709 | , Just state | ||
1710 | , killThread xmpp_thread >> quitChatService) | ||
1674 | 1711 | ||
1675 | main :: IO () | 1712 | main :: IO () |
1676 | main = do | 1713 | main = do |
@@ -1784,7 +1821,7 @@ main = do | |||
1784 | 1821 | ||
1785 | keysdb <- Tox.newKeysDatabase | 1822 | keysdb <- Tox.newKeysDatabase |
1786 | 1823 | ||
1787 | ssvar <- atomically $ newTVar Map.empty | 1824 | ssvar <- atomically $ newTVar Map.empty :: IO ( TVar (Map.Map Uniq24 AggregateSession) ) |
1788 | rec (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate) <- do | 1825 | rec (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate) <- do |
1789 | 1826 | ||
1790 | (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- initTox opts ssvar keysdb msv invc | 1827 | (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- initTox opts ssvar keysdb msv invc |
@@ -1826,6 +1863,7 @@ main = do | |||
1826 | , externalAddresses = liftM2 (++) btips toxips | 1863 | , externalAddresses = liftM2 (++) btips toxips |
1827 | , announcer = announcer | 1864 | , announcer = announcer |
1828 | , mbTox = mbtox | 1865 | , mbTox = mbtox |
1866 | , sessionsVar = ssvar | ||
1829 | } | 1867 | } |
1830 | srv <- streamServer (withSession session) [SockAddrUnix "dht.sock"] | 1868 | srv <- streamServer (withSession session) [SockAddrUnix "dht.sock"] |
1831 | return ( do atomically $ readTVar signalQuit >>= check | 1869 | return ( do atomically $ readTVar signalQuit >>= check |