2 files changed, 33 insertions, 6 deletions

diff --git a/Presence/DNSCache.hs b/Presence/DNSCache.hs
index 4a936d57..82e0cb56 100644
--- a/Presence/DNSCache.hs
+++ b/Presence/DNSCache.hs
@@ -10,6 +10,7 @@
 -- this.
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE RankNTypes    #-}
+{-# LANGUAGE CPP           #-}
 module DNSCache
     ( DNSCache
     , reverseResolve
@@ -20,7 +21,12 @@ module DNSCache
     , withPort
     ) where
 
-import Control.Concurrent
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
 import Control.Concurrent.STM
 import Data.Text       ( Text )
 import Network.Socket  ( SockAddr(..), AddrInfoFlag(..), defaultHints, getAddrInfo, AddrInfo(..) )
@@ -37,6 +43,8 @@ import Data.Function
 import Data.List
 import Data.Ord
 import Data.Maybe
+import System.IO
+import System.IO.Error
 
 import SockAddr      ()
 import ControlMaybe  ( handleIO_ )
@@ -95,6 +103,12 @@ make6mapped4 :: SockAddr -> SockAddr
 make6mapped4 addr@(SockAddrInet6 {}) = addr
 make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
 
+tryForkOS :: IO () -> IO ThreadId
+tryForkOS action = catchIOError (forkOS action) $ \e -> do
+    hPutStrLn stderr $ "DNSCache: Link with -threaded to avoid excessively long time-out."
+    forkIO action
+
+
 -- Attempt to resolve the given domain name.  Returns an empty list if the
 -- resolve operation takes longer than the timeout, but the 'DNSCache' will be
 -- updated when the resolve completes.
@@ -107,7 +121,9 @@ rawForwardResolve ::
 rawForwardResolve dns fail timeout addrtext = do
     r <- atomically newEmptyTMVar
     mvar <- atomically newEmptyTMVar
-    rt <- forkOS $ resolver r mvar
+    rt <- tryForkOS $ do
+        myThreadId >>= flip labelThread ("resolve."++show addrtext)
+        resolver r mvar
     -- TODO: System.Timeout.timeout might be more appropriate than this
     -- hack involving throwTo (ErrorCall "Interrupteddelay").
     tt <- forkIO $ timer (fail addrtext) timeout r rt
@@ -137,7 +153,7 @@ strip_brackets s =
 
 reportTimeout :: forall a. Show a => a -> IO ()
 reportTimeout addrtext = do
-      putStrLn $ "timeout resolving: "++show addrtext
+      hPutStrLn stderr $ "timeout resolving: "++show addrtext
       -- killThread rt
 
 timer :: forall t a. IO () -> Int -> TMVar [a] -> t -> IO ()
diff --git a/src/Control/Concurrent/Lifted/Instrument.hs b/src/Control/Concurrent/Lifted/Instrument.hs
index 7e4a7356..41814d98 100644
--- a/src/Control/Concurrent/Lifted/Instrument.hs
+++ b/src/Control/Concurrent/Lifted/Instrument.hs
@@ -2,6 +2,7 @@
 module Control.Concurrent.Lifted.Instrument
     ( module Control.Concurrent.Lifted
     , forkIO
+    , forkOS
     , fork
     , labelThread
     , threadsInformation
@@ -9,7 +10,7 @@ module Control.Concurrent.Lifted.Instrument
     ) where
 
 import qualified Control.Concurrent.Lifted as Raw
-import Control.Concurrent.Lifted hiding (fork)
+import Control.Concurrent.Lifted hiding (fork,forkOS)
 import Control.Exception (fromException)
 import Control.Monad.Trans.Control
 import System.IO.Unsafe
@@ -46,9 +47,19 @@ forkIO :: IO () -> IO ThreadId
 forkIO = fork
 {-# INLINE forkIO #-}
 
+forkOS :: (MonadBaseControl IO m, MonadIO m) => m () -> m ThreadId
+forkOS = instrumented Raw.forkOS
+{-# INLINE forkOS #-}
+
 fork :: (MonadBaseControl IO m, MonadIO m) => m () -> m ThreadId
-fork action = do
-    t <- Raw.fork $ do
+fork = instrumented Raw.fork
+{-# INLINE fork #-}
+
+instrumented :: ( MonadBaseControl IO m
+                , MonadIO m) =>
+                (m () -> m ThreadId) -> m () -> m ThreadId
+instrumented rawFork action = do
+    t <- rawFork $ do
         tid <- myThreadId
         tm <- liftBase getCurrentTime
         bracket_ (modifyThreads $! Map.insert tid (PerThread "" tm))