From 4371090def28793aa2fdf33fb7432a959ba214fa Mon Sep 17 00:00:00 2001
From: Kazu Yamamoto <kazu@iij.ad.jp>
Date: Wed, 24 Mar 2010 12:03:28 +0900
Subject: implementing lookupXviaMX

---
 Network/DNS/Lookup.hs   | 57 ++++++++++++++++++++++++++++++++++++++++++++++---
 Network/DNS/Resolver.hs |  5 +++++
 2 files changed, 59 insertions(+), 3 deletions(-)

(limited to 'Network/DNS')

diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs
index c458149..ad0da4d 100644
--- a/Network/DNS/Lookup.hs
+++ b/Network/DNS/Lookup.hs
@@ -1,10 +1,24 @@
-module Network.DNS.Lookup where
+{-|
+  Upper level DNS lookup functions.
+-}
+
+module Network.DNS.Lookup (
+    lookupA, lookupAAAA
+  , lookupMX, lookupAviaMX, lookupAAAAviaMX
+  , lookupTXT
+  ) where
 
 import Control.Applicative
 import Data.IP
+import Data.Maybe
 import Network.DNS.Types
 import Network.DNS.Resolver as DNS
 
+----------------------------------------------------------------
+
+{-|
+  Resolving 'IPv4' by 'A'.
+-}
 lookupA :: Resolver -> Domain -> IO (Maybe [IPv4])
 lookupA rlv dom = toV4 <$> DNS.lookup rlv dom A
   where
@@ -12,6 +26,9 @@ lookupA rlv dom = toV4 <$> DNS.lookup rlv dom A
     unTag (RD_A x) = x
     unTag _ = error "lookupA"
 
+{-|
+  Resolving 'IPv6' by 'AAAA'.
+-}
 lookupAAAA :: Resolver -> Domain -> IO (Maybe [IPv6])
 lookupAAAA rlv dom = toV6 <$> DNS.lookup rlv dom AAAA
   where
@@ -19,12 +36,46 @@ lookupAAAA rlv dom = toV6 <$> DNS.lookup rlv dom AAAA
     unTag (RD_AAAA x) = x
     unTag _ = error "lookupAAAA"
 
+----------------------------------------------------------------
+
+{-|
+  Resolving 'Domain' and its preference by 'MX'.
+-}
+lookupMX :: Resolver -> Domain -> IO (Maybe [(Domain,Int)])
+lookupMX rlv dom = toMX <$> DNS.lookup rlv dom MX
+  where
+    toMX = maybe Nothing (Just . map unTag)
+    unTag (RD_MX pr dm) = (dm,pr)
+    unTag _ = error "lookupMX"
+
+{-|
+  Resolving 'IPv4' by 'A' via 'MX'.
+-}
 lookupAviaMX :: Resolver -> Domain -> IO (Maybe [IPv4])
-lookupAviaMX = undefined
+lookupAviaMX rlv dom = lookupXviaMX rlv dom (lookupA rlv)
 
+{-|
+  Resolving 'IPv6' by 'AAAA' via 'MX'.
+-}
 lookupAAAAviaMX :: Resolver -> Domain -> IO (Maybe [IPv6])
-lookupAAAAviaMX = undefined
+lookupAAAAviaMX rlv dom = lookupXviaMX rlv dom (lookupAAAA rlv)
+
+lookupXviaMX :: Resolver -> Domain -> (Domain -> IO (Maybe [a])) -> IO (Maybe [a])
+lookupXviaMX rlv dom func = do
+    mdps <- lookupMX rlv dom
+    maybe (return Nothing) lookup' mdps
+  where
+    lookup' dps = do
+        as <- catMaybes <$> mapM func (map fst dps)
+        case as of
+          []  -> return Nothing
+          ass -> return $ Just (concat ass)
+
+----------------------------------------------------------------
 
+{-|
+  Resolving 'String' by 'TXT'.
+-}
 lookupTXT :: Resolver -> Domain -> IO (Maybe [String])
 lookupTXT rlv dom = toTXT <$> DNS.lookup rlv dom TXT
   where
diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs
index e959bcb..54a6411 100644
--- a/Network/DNS/Resolver.hs
+++ b/Network/DNS/Resolver.hs
@@ -78,6 +78,11 @@ makeAddrInfo addr = do
 
 ----------------------------------------------------------------
 
+{-|
+  Giving a thread-safe 'Resolver' to the function of the second
+  argument. 'withResolver' should be passed to 'forkIO'.
+-}
+
 withResolver :: ResolvSeed -> (Resolver -> IO ()) -> IO ()
 withResolver seed func = do
   let ai = addrInfo seed
-- 
cgit v1.2.3