diff options
Diffstat (limited to 'dht/Presence/DNSCache.hs')
-rw-r--r-- | dht/Presence/DNSCache.hs | 16 |
1 files changed, 5 insertions, 11 deletions
diff --git a/dht/Presence/DNSCache.hs b/dht/Presence/DNSCache.hs index e28655c5..14581fee 100644 --- a/dht/Presence/DNSCache.hs +++ b/dht/Presence/DNSCache.hs | |||
@@ -22,12 +22,7 @@ module DNSCache | |||
22 | , withPort | 22 | , withPort |
23 | ) where | 23 | ) where |
24 | 24 | ||
25 | #ifdef THREAD_DEBUG | 25 | import Control.Concurrent.ThreadUtil |
26 | import Control.Concurrent.Lifted.Instrument | ||
27 | #else | ||
28 | import Control.Concurrent.Lifted | ||
29 | import GHC.Conc (labelThread) | ||
30 | #endif | ||
31 | import Control.Arrow | 26 | import Control.Arrow |
32 | import Control.Concurrent.STM | 27 | import Control.Concurrent.STM |
33 | import Data.Text ( Text ) | 28 | import Data.Text ( Text ) |
@@ -108,10 +103,10 @@ make6mapped4 :: SockAddr -> SockAddr | |||
108 | make6mapped4 addr@(SockAddrInet6 {}) = addr | 103 | make6mapped4 addr@(SockAddrInet6 {}) = addr |
109 | make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0 | 104 | make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0 |
110 | 105 | ||
111 | tryForkOS :: IO () -> IO ThreadId | 106 | tryForkOS :: String -> IO () -> IO ThreadId |
112 | tryForkOS action = catchIOError (forkOS action) $ \e -> do | 107 | tryForkOS lbl action = catchIOError (forkOSLabeled lbl action) $ \e -> do |
113 | dput XMisc $ "DNSCache: Link with -threaded to avoid excessively long time-out." | 108 | dput XMisc $ "DNSCache: Link with -threaded to avoid excessively long time-out." |
114 | forkIO action | 109 | forkLabeled lbl action |
115 | 110 | ||
116 | 111 | ||
117 | -- Attempt to resolve the given domain name. Returns an empty list if the | 112 | -- Attempt to resolve the given domain name. Returns an empty list if the |
@@ -126,8 +121,7 @@ rawForwardResolve :: | |||
126 | rawForwardResolve dns onFail timeout addrtext = do | 121 | rawForwardResolve dns onFail timeout addrtext = do |
127 | r <- atomically newEmptyTMVar | 122 | r <- atomically newEmptyTMVar |
128 | mvar <- interruptibleDelay | 123 | mvar <- interruptibleDelay |
129 | rt <- tryForkOS $ do | 124 | rt <- tryForkOS ("resolve."++show addrtext) $ do |
130 | myThreadId >>= flip labelThread ("resolve."++show addrtext) | ||
131 | resolver r mvar | 125 | resolver r mvar |
132 | startDelay mvar timeout | 126 | startDelay mvar timeout |
133 | did <- atomically $ tryPutTMVar r [] | 127 | did <- atomically $ tryPutTMVar r [] |