DNSCache now uses InterruptibleDelay where appropriate.

1 files changed, 13 insertions, 20 deletions

diff --git a/Presence/DNSCache.hs b/Presence/DNSCache.hs
index 82e0cb56..aaf1a7be 100644
--- a/Presence/DNSCache.hs
+++ b/Presence/DNSCache.hs
@@ -33,7 +33,7 @@ import Network.Socket  ( SockAddr(..), AddrInfoFlag(..), defaultHints, getAddrIn
 import Data.Time.Clock ( UTCTime, getCurrentTime, diffUTCTime )
 import System.IO.Error ( isDoesNotExistError )
 import System.Endian   ( fromBE32, toBE32 )
-import Control.Exception ( handle, ErrorCall(..) )
+import Control.Exception ( handle )
 import Data.Map        ( Map )
 import qualified Data.Map    as Map
 import qualified Network.BSD as BSD
@@ -49,6 +49,7 @@ import System.IO.Error
 import SockAddr      ()
 import ControlMaybe  ( handleIO_ )
 import GetHostByAddr ( getHostByAddr )
+import InterruptibleDelay
 
 type TimeStamp = UTCTime
 
@@ -118,16 +119,15 @@ tryForkOS action = catchIOError (forkOS action) $ \e -> do
 -- persist for reasons I don't understand as of this writing. (See 'updateCache')
 rawForwardResolve ::
     DNSCache -> (Text -> IO ()) -> Int -> Text -> IO [SockAddr]
-rawForwardResolve dns fail timeout addrtext = do
+rawForwardResolve dns onFail timeout addrtext = do
     r <- atomically newEmptyTMVar
-    mvar <- atomically newEmptyTMVar
+    mvar <- interruptibleDelay
     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
-    atomically $ putTMVar mvar tt
+    startDelay mvar timeout
+    did <- atomically $ tryPutTMVar r []
+    when did (onFail addrtext)
     atomically $ readTMVar r
  where
     resolver r mvar = do
@@ -138,8 +138,7 @@ rawForwardResolve dns fail timeout addrtext = do
                     (Just "5269")
       did <- atomically $ tryPutTMVar r xs
       when did $ do
-      tt <- atomically $ readTMVar mvar
-      throwTo tt (ErrorCall "Interrupted delay")
+      interruptDelay mvar
       utc <- getCurrentTime
       atomically $ dnsObserve dns True utc $ map (addrtext,) xs
       return ()
@@ -156,13 +155,6 @@ reportTimeout addrtext = do
       hPutStrLn stderr $ "timeout resolving: "++show addrtext
       -- killThread rt
 
-timer :: forall t a. IO () -> Int -> TMVar [a] -> t -> IO ()
-timer fail timeout r rt = do
-      handle (\(ErrorCall _)-> return ()) $ do
-      threadDelay timeout
-      did <- atomically $ tryPutTMVar r []
-      when did fail
-
 unmap6mapped4 :: SockAddr -> SockAddr
 unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) =
     SockAddrInet port (toBE32 a)
@@ -170,12 +162,13 @@ unmap6mapped4 addr = addr
 
 rawReverseResolve ::
     DNSCache -> (SockAddr -> IO ()) -> Int -> SockAddr -> IO [Text]
-rawReverseResolve dns fail timeout addr = do
+rawReverseResolve dns onFail timeout addr = do
     r <- atomically newEmptyTMVar
-    mvar <- atomically newEmptyTMVar
+    mvar <- interruptibleDelay
     rt <- forkOS $ resolver r mvar
-    tt <- forkIO $ timer (fail addr) timeout r rt
-    atomically $ putTMVar mvar tt
+    startDelay mvar timeout
+    did <- atomically $ tryPutTMVar r []
+    when did (onFail addr)
     atomically $ readTMVar r
  where
     resolver r mvar =