X-Git-Url: http://gitweb.michael.orlitzky.com/?p=list-remote-forwards.git;a=blobdiff_plain;f=src%2FDNS.hs;h=556c68675eecb4e4a6293117143e5358255f28bc;hp=00db178331f00a6ab29d5c332dcf60d00e8a32db;hb=66345cef9e56c6175cb6f25f41fbf628648d15a3;hpb=e3ef76e60ddd54e5fad787c5883533d2410b3e2a diff --git a/src/DNS.hs b/src/DNS.hs index 00db178..556c686 100644 --- a/src/DNS.hs +++ b/src/DNS.hs @@ -1,28 +1,66 @@ module DNS ( - dns_properties, - dns_tests, - lookup_mxs, - normalize ) + MxSetMap, + NormalDomain, + mx_set_map, + normalize_string ) 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 type-safe wrapper around a domain name (represented as a +-- string) that ensures we've created it by calling +-- 'normalize_string'. This prevents us from making +-- comparisons on un-normalized 'Domain's or 'String's. +-- +newtype NormalDomain = + NormalDomain String + deriving ( Eq, Ord, Show ) + + +-- | A set of mail exchanger names, represented as 'String's. The use +-- of 'NormalDomain' prevents us from constructing a set of names +-- that aren't normalized first. +-- +type MxSet = Set NormalDomain + + +-- | A map from domain names (represented as 'String's) to sets of +-- mail exchanger names (also represented as 'String's). The use of +-- 'NormalDomain' in the key prevents us from using keys that aren't +-- normalized; this is important because we'll be using them for +-- lookups and want e.g. \"foo.com\" and \"FOO.com\" to look up the +-- same MX records. +-- +type MxSetMap = Map NormalDomain MxSet + + +-- | Normalize a domain name string by converting to a 'Domain', +-- calling 'normalize', and then converting back. +-- +-- ==== __Examples__ +-- +-- >>> normalize_string "ExAMplE.com" +-- NormalDomain "example.com." +-- +normalize_string :: String -> NormalDomain +normalize_string = NormalDomain . 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 +71,49 @@ 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 (NormalDomain, Set NormalDomain) + make_pair domain = do + -- Lookup the @domain@'s MX records. + mx_list <- lookup_mxs domain + + -- Now convert the MX records *back* to strings, and then to + -- NormalDomains + let normal_mx_list = map (normalize_string . BS.unpack) mx_list + + -- Convert the list into a set... + let normal_mx_set = Set.fromList normal_mx_list + + -- The lookup key. + let normal_domain = normalize_string $ BS.unpack domain + + -- Finally, construct the pair and return it. + return (normal_domain, normal_mx_set)