From 1449a9ddb6107eba856aada2b32817f4b05d264f Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Tue, 3 Oct 2017 17:14:08 -0400
Subject: Documented DNSCache module.

---
 Presence/DNSCache.hs | 40 +++++++++++++++++++++++++++++++++++-----
 1 file changed, 35 insertions(+), 5 deletions(-)

(limited to 'Presence')

diff --git a/Presence/DNSCache.hs b/Presence/DNSCache.hs
index e3ccc386..4a936d57 100644
--- a/Presence/DNSCache.hs
+++ b/Presence/DNSCache.hs
@@ -1,3 +1,13 @@
+-- | Both 'getAddrInfo' and 'getHostByAddr' have hard-coded timeouts for
+-- waiting upon network queries that can be a little too long for some use
+-- cases. This module wraps both of them so that they block for at most one
+-- second.  It caches late-arriving results so that they can be returned by
+-- repeated timed-out queries.
+--
+-- In order to achieve the shorter timeout, it is likely that the you will need
+-- to build with GHC's -threaded option.  Otherwise, if the wrapped FFI calls
+-- to resolve the address will block Haskell threads.  Note: I didn't verify
+-- this.
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE RankNTypes    #-}
 module DNSCache
@@ -23,6 +33,7 @@ import qualified Data.Map    as Map
 import qualified Network.BSD as BSD
 import qualified Data.Text   as Text
 import Control.Monad
+import Data.Function
 import Data.List
 import Data.Ord
 import Data.Maybe
@@ -46,9 +57,6 @@ newDNSCache = do
         rcache <- newTVarIO Map.empty
         return DNSCache { fcache=fcache, rcache=rcache }
 
-equivBy :: forall a t. Eq a => (t -> a) -> t -> t -> Bool
-equivBy f a b = f a == f b
-
 updateCache :: Eq x =>
     Bool -> TimeStamp -> [x] -> Maybe [(TimeStamp,x)] -> Maybe [(TimeStamp,x)]
 updateCache withScrub utc xs mys = do
@@ -68,12 +76,12 @@ dnsObserve dns withScrub utc obs = do
     r <- readTVar $ rcache dns
     let obs' = map (\(n,a)->(n,a `withPort` 0)) obs
         gs = do
-            g <- groupBy (equivBy fst) $ sortBy (comparing fst) obs'
+            g <- groupBy ((==) `on` fst) $ sortBy (comparing fst) obs'
             (n,_) <- take 1 g
             return (n,map snd g)
         f' = foldl' updatef f gs
         hs = do
-            h <- groupBy (equivBy snd) $ sortBy (comparing snd) obs'
+            h <- groupBy ((==) `on` snd) $ sortBy (comparing snd) obs'
             (_,a) <- take 1 h
             return (a,map fst h)
         r' = foldl' updater r hs
@@ -87,12 +95,21 @@ make6mapped4 :: SockAddr -> SockAddr
 make6mapped4 addr@(SockAddrInet6 {}) = addr
 make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
 
+-- 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.
+--
+-- When the resolve operation does complete, any entries less than a minute old
+-- will be overwritten with the new results.  Older entries are allowed to
+-- 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
     r <- atomically newEmptyTMVar
     mvar <- atomically newEmptyTMVar
     rt <- forkOS $ 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
     atomically $ readTMVar r
@@ -155,6 +172,8 @@ rawReverseResolve dns fail timeout addr = do
             atomically $ dnsObserve dns False utc $ map (,addr) xs
         atomically $ putTMVar r  xs
 
+-- Returns expired (older than a minute) cached reverse-dns results
+-- and removes them from the cache.
 expiredReverse :: DNSCache -> SockAddr -> IO [Text]
 expiredReverse dns addr = do
     utc <- getCurrentTime
@@ -163,6 +182,8 @@ expiredReverse dns addr = do
         r <- readTVar $ rcache dns
         let ns = maybe [] id $ Map.lookup addr r
             minute = 60 -- seconds
+            -- XXX: Is this right?  flip diffUTCTime utc returns the age of the 
+            -- cache entry?
             (es0,ns') = partition ( (>=minute) . flip diffUTCTime utc . fst ) ns
             es = map snd es0
         modifyTVar' (rcache dns) $ Map.insert addr ns'
@@ -190,6 +211,9 @@ cachedReverse dns addr = do
         -}
         return $ map snd ns
 
+-- Returns any dns query results for the given name that were observed less
+-- than a minute ago and updates the forward-cache to remove any results older
+-- than that.
 cachedForward :: DNSCache -> Text -> IO [SockAddr]
 cachedForward dns n = do
     utc <- getCurrentTime
@@ -201,6 +225,10 @@ cachedForward dns n = do
         modifyTVar' (fcache dns) $ Map.insert n as'
         return $ map snd as'
 
+-- Reverse-resolves an address to a domain name.  Returns both the result of a
+-- new query and any freshly cached results.  Cache entries older than a minute
+-- will not be returned, but will be refreshed in spawned threads so that they
+-- may be available for the next call.
 reverseResolve :: DNSCache -> SockAddr -> IO [Text]
 reverseResolve dns addr = do
     expired <- expiredReverse dns addr
@@ -211,6 +239,8 @@ reverseResolve dns addr = do
     cs <- cachedReverse dns addr
     return $ xs ++ filter (not . flip elem xs) cs
 
+-- Resolves a name, if there's no result within one second, then any cached
+-- results that are less than a minute old are returned.
 forwardResolve :: DNSCache -> Text -> IO [SockAddr]
 forwardResolve dns n = do
     as <- rawForwardResolve dns (const $ return ()) 1000000 n
-- 
cgit v1.2.3