1 files changed, 19 insertions, 3 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 ()