X-Git-Url: http://gitweb.michael.orlitzky.com/?p=list-remote-forwards.git;a=blobdiff_plain;f=src%2FDNS.hs;h=8d94de51e9c7772d33adcb6cf5ec3e40c9479105;hp=00db178331f00a6ab29d5c332dcf60d00e8a32db;hb=f75845314598408bce3a1b972f2ba274d93d0e8d;hpb=e3ef76e60ddd54e5fad787c5883533d2410b3e2a

diff --git a/src/DNS.hs b/src/DNS.hs
index 00db178..8d94de5 100644
--- a/src/DNS.hs
+++ b/src/DNS.hs
@@ -1,28 +1,47 @@
 module DNS (
-  dns_properties,
-  dns_tests,
-  lookup_mxs,
-  normalize )
+  MxSetMap,
+  mx_set_map,
+  normalize_string_domain )
 where
 
-import qualified Data.ByteString.Char8 as BS (
-  append,
-  last,
-  map,
-  null,
-  pack )
-import Data.Char ( toLower )
+import qualified Data.ByteString.Char8 as BS ( pack, unpack )
+import Data.List ( nub )
+import Data.Map ( Map )
+import qualified Data.Map as Map ( fromList )
+import Data.Set ( Set )
+import qualified Data.Set as Set ( fromList )
 import Network.DNS (
   Domain,
   defaultResolvConf,
   lookupMX,
   makeResolvSeed,
+  normalize,
   withResolver )
-import Test.Tasty ( TestTree, testGroup )
-import Test.Tasty.HUnit ( (@?=), testCase )
-import Test.Tasty.QuickCheck ( testProperty )
 
--- Slow since we create the resolver every time.
+-- | A map from domain names (represented as 'String's) to sets of
+--   mail exchanger names (also represented as 'String's).
+--
+type MxSetMap = Map String MxSet
+
+-- | A set of mail exchanger names, represented as 'String's.
+type MxSet = Set String
+
+
+-- | Normalize a domain name string by converting to a 'Domain',
+--   calling 'normalize', and then converting back.
+--
+--   ==== __Examples__
+--
+--   >>> normalize_string_domain "ExAMplE.com"
+--   "example.com."
+--
+normalize_string_domain :: String -> String
+normalize_string_domain = BS.unpack . normalize . BS.pack
+
+
+-- | Retrieve all MX records for the given domain. This is somewhat
+--   inefficient, since we create the resolver every time.
+--
 lookup_mxs :: Domain -> IO [Domain]
 lookup_mxs domain = do
   default_rs <- makeResolvSeed defaultResolvConf
@@ -33,75 +52,45 @@ lookup_mxs domain = do
                Right pairs -> map fst pairs
 
 
--- | Perform both normalize_case and normalize_root.
-normalize :: Domain -> Domain
-normalize = normalize_case . normalize_root
-
--- | Normalize the given name by appending a trailing dot (the DNS
---   root) if necessary.
+-- | Takes a list of domain names represented as 'String's and
+--   constructs a map from domain names to sets of mail exchangers
+--   (for those domain names) also represented as 'String's.
 --
-normalize_root :: Domain -> Domain
-normalize_root d
-  | BS.null d = BS.pack "."
-  | BS.last d == '.' = d
-  | otherwise = d `BS.append` trailing_dot
-    where
-      trailing_dot = BS.pack "."
-
-
--- | Normalize the given name by lowercasing it.
+--   During construction, we have to switch to the DNS internal
+--   representation of a 'Domain' which uses ByteStrings, but before
+--   we return the map to the client, we want everything to be in
+--   terms of standard 'String's for comparison purposes.
 --
-normalize_case :: Domain -> Domain
-normalize_case = BS.map toLower
-
--- * Tests
-
-test_normalize_case :: TestTree
-test_normalize_case =
-  testCase desc $ actual @?= expected
-  where
-    desc = "normalize_case lowercases DNS names"
-    expected = BS.pack "example.com"
-    actual = normalize_case $ BS.pack "ExAmPlE.COM"
-
-prop_normalize_case_idempotent :: TestTree
-prop_normalize_case_idempotent =
-  testProperty desc $ prop
-  where
-    desc = "normalize_case is idempotent"
-
-    prop :: String -> Bool
-    prop s = (normalize_case . normalize_case) bs  == normalize_case bs
-      where
-        bs = BS.pack s
+--   The list of domains is normalized and de-duped before lookups are
+--   performed to avoid doing lookups twice for identical domains.
+--
+mx_set_map :: [String] -> IO MxSetMap
+mx_set_map domains = do
+  -- Construct a list of pairs.
+  pairs <- mapM make_pair unique_domains
 
-test_normalize_root_adds_dot :: TestTree
-test_normalize_root_adds_dot =
-  testCase desc $ actual @?= expected
-  where
-    desc = "normalize_root adds a trailing dot"
-    expected = BS.pack "example.com."
-    actual = normalize_root $ BS.pack "example.com"
+  -- And make a map from the pairs.
+  return $ Map.fromList pairs
 
-prop_normalize_root_idempotent :: TestTree
-prop_normalize_root_idempotent =
-  testProperty desc prop
   where
-    desc = "normalize_root is idempotent"
-
-    prop :: String -> Bool
-    prop s = (normalize_root . normalize_root) bs  == normalize_root bs
-      where
-        bs = BS.pack s
-
-dns_tests :: TestTree
-dns_tests =
-  testGroup "DNS Tests" [
-    test_normalize_case,
-    test_normalize_root_adds_dot ]
-
-dns_properties :: TestTree
-dns_properties =
-  testGroup "DNS Properties" [
-    prop_normalize_case_idempotent,
-    prop_normalize_root_idempotent ]
+    -- Convert, normalize, and de-dupe the @domains@.
+    unique_domains :: [Domain]
+    unique_domains = nub $ map (normalize . BS.pack) domains
+
+    -- | Convert a string domain name into a pair containing the
+    --   domain name in the first component and a set of its mail
+    --   exchangers (as strings) in the second component.
+    --
+    make_pair :: Domain -> IO (String, Set String)
+    make_pair domain = do
+      -- Lookup the @domain@'s MX records.
+      mx_list <- lookup_mxs domain
+
+      -- Now convert the MX records *back* to strings.
+      let string_mx_list = map BS.unpack mx_list
+
+      -- Convert the list into a set
+      let string_mx_set = Set.fromList string_mx_list
+
+      -- Finally, construct the pair and return it.
+      return (BS.unpack domain, string_mx_set)