summaryrefslogtreecommitdiff
path: root/dht
diff options
context:
space:
mode:
Diffstat (limited to 'dht')
-rw-r--r--dht/OnionRouter.hs8
-rw-r--r--dht/Presence/Presence.hs3
-rw-r--r--dht/Presence/XMPPServer.hs11
-rw-r--r--dht/dht-client.cabal3
-rw-r--r--dht/src/Control/Concurrent/ThreadUtil.hs24
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 #-}
4module OnionRouter where 4module OnionRouter where
5 5
6import Control.Concurrent.Lifted.Instrument 6import Control.Concurrent.ThreadUtil
7import Crypto.Tox 7import Crypto.Tox
8import Network.Address 8import Network.Address
9import Network.Kademlia 9import 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)
65import Control.Monad.IO.Class (MonadIO, liftIO) 65import Control.Monad.IO.Class (MonadIO, liftIO)
66import Control.Monad.Fix (fix) 66import Control.Monad.Fix (fix)
67import Control.Monad 67import Control.Monad
68#ifdef THREAD_DEBUG 68import Control.Concurrent.ThreadUtil (forkIO,myThreadId,forkLabeled,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar)
69import Control.Concurrent.Lifted.Instrument (forkIO,myThreadId,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar)
70#else
71import Control.Concurrent.Lifted (forkIO,myThreadId,ThreadId)
72import GHC.Conc (labelThread)
73#endif
74import Control.Concurrent.STM 69import Control.Concurrent.STM
75import Data.List hiding ((\\)) 70import 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 #-}
2module 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
13import Control.Concurrent.Lifted.Instrument
14#else
15import Control.Concurrent.Lifted
16import GHC.Conc (labelThread)
17
18forkLabeled :: String -> IO () -> IO ThreadId
19forkLabeled lbl action = do
20 t <- forkIO action
21 labelThread t lbl
22 return t
23{-# INLINE forkLabeled #-}
24#endif