diff options
Diffstat (limited to 'dht')
-rw-r--r-- | dht/OnionRouter.hs | 8 | ||||
-rw-r--r-- | dht/Presence/Presence.hs | 3 | ||||
-rw-r--r-- | dht/Presence/XMPPServer.hs | 11 | ||||
-rw-r--r-- | dht/dht-client.cabal | 3 | ||||
-rw-r--r-- | dht/src/Control/Concurrent/ThreadUtil.hs | 24 |
5 files changed, 35 insertions, 14 deletions
diff --git a/dht/OnionRouter.hs b/dht/OnionRouter.hs index 57c8ba35..cb74f6db 100644 --- a/dht/OnionRouter.hs +++ b/dht/OnionRouter.hs | |||
@@ -3,7 +3,7 @@ | |||
3 | {-# LANGUAGE RankNTypes #-} | 3 | {-# LANGUAGE RankNTypes #-} |
4 | module OnionRouter where | 4 | module OnionRouter where |
5 | 5 | ||
6 | import Control.Concurrent.Lifted.Instrument | 6 | import Control.Concurrent.ThreadUtil |
7 | import Crypto.Tox | 7 | import Crypto.Tox |
8 | import Network.Address | 8 | import Network.Address |
9 | import Network.Kademlia | 9 | import Network.Kademlia |
@@ -471,9 +471,9 @@ handleEvent getnodes or e@(BuildRoute (RouteId rid)) = do | |||
471 | n -> (>>= (listToMaybe . drop (fromIntegral s) . (\(ns,_,_)->cycle' ns))) | 471 | n -> (>>= (listToMaybe . drop (fromIntegral s) . (\(ns,_,_)->cycle' ns))) |
472 | <$> TCP.getUDPNodes (tcpKademliaClient or) q (TCP.udpNodeInfo $ ts !! n) | 472 | <$> TCP.getUDPNodes (tcpKademliaClient or) q (TCP.udpNodeInfo $ ts !! n) |
473 | sendqs = do | 473 | sendqs = do |
474 | forkIO $ sendq asel aq 0 >>= atomically . writeTVar av . Just | 474 | forkLabeled "sendq.asel" $ sendq asel aq 0 >>= atomically . writeTVar av . Just |
475 | forkIO $ sendq bsel bq 1 >>= atomically . writeTVar bv . Just | 475 | forkLabeled "sendq.bsel" $ sendq bsel bq 1 >>= atomically . writeTVar bv . Just |
476 | forkIO $ sendq csel cq 2 >>= atomically . writeTVar cv . Just | 476 | forkLabeled "sendq.csel" $ sendq csel cq 2 >>= atomically . writeTVar cv . Just |
477 | -- This timeout should be unnecessary... But I'm paranoid. | 477 | -- This timeout should be unnecessary... But I'm paranoid. |
478 | -- Note: 10 seconds should be sufficient for typical get-nodes queries. | 478 | -- Note: 10 seconds should be sufficient for typical get-nodes queries. |
479 | tm <- timeout 30000000 $ atomically $ do -- Wait for all 3 results. | 479 | tm <- timeout 30000000 $ atomically $ do -- Wait for all 3 results. |
diff --git a/dht/Presence/Presence.hs b/dht/Presence/Presence.hs index 8cdd1cdc..a09a517d 100644 --- a/dht/Presence/Presence.hs +++ b/dht/Presence/Presence.hs | |||
@@ -290,7 +290,8 @@ chooseResourceName state k (Remote addr) clientsNameForMe desired = do | |||
290 | buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client) | 290 | buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client) |
291 | forM_ buds $ \bud -> do | 291 | forM_ buds $ \bud -> do |
292 | let (_,h,_) = splitJID bud | 292 | let (_,h,_) = splitJID bud |
293 | forkIO $ void $ resolvePeer (manager state $ clientProfile client) h | 293 | forkLabeled "XMPP.buddies.resolvePeer" $ do |
294 | void $ resolvePeer (manager state $ clientProfile client) h | ||
294 | 295 | ||
295 | atomically $ do | 296 | atomically $ do |
296 | modifyTVar' (clients state) $ Map.insert k client | 297 | modifyTVar' (clients state) $ Map.insert k client |
diff --git a/dht/Presence/XMPPServer.hs b/dht/Presence/XMPPServer.hs index e98b9a2e..de2dd5d3 100644 --- a/dht/Presence/XMPPServer.hs +++ b/dht/Presence/XMPPServer.hs | |||
@@ -65,12 +65,7 @@ import Control.Monad.Trans (lift) | |||
65 | import Control.Monad.IO.Class (MonadIO, liftIO) | 65 | import Control.Monad.IO.Class (MonadIO, liftIO) |
66 | import Control.Monad.Fix (fix) | 66 | import Control.Monad.Fix (fix) |
67 | import Control.Monad | 67 | import Control.Monad |
68 | #ifdef THREAD_DEBUG | 68 | import Control.Concurrent.ThreadUtil (forkIO,myThreadId,forkLabeled,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar) |
69 | import Control.Concurrent.Lifted.Instrument (forkIO,myThreadId,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar) | ||
70 | #else | ||
71 | import Control.Concurrent.Lifted (forkIO,myThreadId,ThreadId) | ||
72 | import GHC.Conc (labelThread) | ||
73 | #endif | ||
74 | import Control.Concurrent.STM | 69 | import Control.Concurrent.STM |
75 | import Data.List hiding ((\\)) | 70 | import Data.List hiding ((\\)) |
76 | -- import Control.Concurrent.STM.TChan | 71 | -- import Control.Concurrent.STM.TChan |
@@ -344,7 +339,7 @@ conduitToChan c = do | |||
344 | chan <- atomically newLockedChan | 339 | chan <- atomically newLockedChan |
345 | clsrs <- atomically $ newTVar (Just []) | 340 | clsrs <- atomically $ newTVar (Just []) |
346 | quitvar <- atomically $ newEmptyTMVar | 341 | quitvar <- atomically $ newEmptyTMVar |
347 | forkIO $ do | 342 | forkLabeled "XMPP.conduitToChan" $ do |
348 | runConduit $ c .| copyToChannel id chan clsrs .| awaitForever (const $ return ()) | 343 | runConduit $ c .| copyToChannel id chan clsrs .| awaitForever (const $ return ()) |
349 | atomically $ writeTVar clsrs Nothing | 344 | atomically $ writeTVar clsrs Nothing |
350 | return (chan,clsrs,quitvar) | 345 | return (chan,clsrs,quitvar) |
@@ -462,7 +457,7 @@ sendReply donevar stype reply replychan = do | |||
462 | , stanzaOrigin = LocalPeer | 457 | , stanzaOrigin = LocalPeer |
463 | } | 458 | } |
464 | ioWriteChan replychan replyStanza | 459 | ioWriteChan replychan replyStanza |
465 | void . liftIO . forkIO $ do | 460 | void . liftIO . forkLabeled "XMPPServer.sendReply" $ do |
466 | mapM_ (liftIO . atomically . writeLChan (stanzaChan replyStanza)) reply | 461 | mapM_ (liftIO . atomically . writeLChan (stanzaChan replyStanza)) reply |
467 | liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing | 462 | liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing |
468 | -- liftIO $ wlog "finished reply stanza" | 463 | -- liftIO $ wlog "finished reply stanza" |
diff --git a/dht/dht-client.cabal b/dht/dht-client.cabal index 168dd079..31f78bcf 100644 --- a/dht/dht-client.cabal +++ b/dht/dht-client.cabal | |||
@@ -71,7 +71,8 @@ library | |||
71 | , RecordWildCards | 71 | , RecordWildCards |
72 | , NondecreasingIndentation | 72 | , NondecreasingIndentation |
73 | hs-source-dirs: src, ., Presence | 73 | hs-source-dirs: src, ., Presence |
74 | exposed-modules: Network.SocketLike | 74 | exposed-modules: Control.Concurrent.ThreadUtil |
75 | Network.SocketLike | ||
75 | Data.Digest.CRC32C | 76 | Data.Digest.CRC32C |
76 | Data.Bits.ByteString | 77 | Data.Bits.ByteString |
77 | Data.TableMethods | 78 | Data.TableMethods |
diff --git a/dht/src/Control/Concurrent/ThreadUtil.hs b/dht/src/Control/Concurrent/ThreadUtil.hs new file mode 100644 index 00000000..2888e899 --- /dev/null +++ b/dht/src/Control/Concurrent/ThreadUtil.hs | |||
@@ -0,0 +1,24 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | module Control.Concurrent.ThreadUtil | ||
3 | ( | ||
4 | #ifdef THREAD_DEBUG | ||
5 | module Control.Concurrent.Lifted.Instrument | ||
6 | #else | ||
7 | module Control.Control.Lifted | ||
8 | , module GHC.Conc | ||
9 | #endif | ||
10 | ) where | ||
11 | |||
12 | #ifdef THREAD_DEBUG | ||
13 | import Control.Concurrent.Lifted.Instrument | ||
14 | #else | ||
15 | import Control.Concurrent.Lifted | ||
16 | import GHC.Conc (labelThread) | ||
17 | |||
18 | forkLabeled :: String -> IO () -> IO ThreadId | ||
19 | forkLabeled lbl action = do | ||
20 | t <- forkIO action | ||
21 | labelThread t lbl | ||
22 | return t | ||
23 | {-# INLINE forkLabeled #-} | ||
24 | #endif | ||