Introduce a NormalDomain newtype to ensure comparisons are made safely.
[list-remote-forwards.git] / src / DNS.hs
1 module DNS (
2 MxSetMap,
3 NormalDomain,
4 mx_set_map,
5 normalize_string )
6 where
7
8 import qualified Data.ByteString.Char8 as BS ( pack, unpack )
9 import Data.List ( nub )
10 import Data.Map ( Map )
11 import qualified Data.Map as Map ( fromList )
12 import Data.Set ( Set )
13 import qualified Data.Set as Set ( fromList )
14 import Network.DNS (
15 Domain,
16 defaultResolvConf,
17 lookupMX,
18 makeResolvSeed,
19 normalize,
20 withResolver )
21
22 -- | A type-safe wrapper around a domain name (represented as a
23 -- string) that ensures we've created it by calling
24 -- 'normalize_string'. This prevents us from making
25 -- comparisons on un-normalized 'Domain's or 'String's.
26 --
27 newtype NormalDomain =
28 NormalDomain String
29 deriving ( Eq, Ord, Show )
30
31
32 -- | A set of mail exchanger names, represented as 'String's. The use
33 -- of 'NormalDomain' prevents us from constructing a set of names
34 -- that aren't normalized first.
35 --
36 type MxSet = Set NormalDomain
37
38
39 -- | A map from domain names (represented as 'String's) to sets of
40 -- mail exchanger names (also represented as 'String's). The use of
41 -- 'NormalDomain' in the key prevents us from using keys that aren't
42 -- normalized; this is important because we'll be using them for
43 -- lookups and want e.g. \"foo.com\" and \"FOO.com\" to look up the
44 -- same MX records.
45 --
46 type MxSetMap = Map NormalDomain MxSet
47
48
49 -- | Normalize a domain name string by converting to a 'Domain',
50 -- calling 'normalize', and then converting back.
51 --
52 -- ==== __Examples__
53 --
54 -- >>> normalize_string "ExAMplE.com"
55 -- NormalDomain "example.com."
56 --
57 normalize_string :: String -> NormalDomain
58 normalize_string = NormalDomain . BS.unpack . normalize . BS.pack
59
60
61 -- | Retrieve all MX records for the given domain. This is somewhat
62 -- inefficient, since we create the resolver every time.
63 --
64 lookup_mxs :: Domain -> IO [Domain]
65 lookup_mxs domain = do
66 default_rs <- makeResolvSeed defaultResolvConf
67 withResolver default_rs $ \resolver -> do
68 mxs <- lookupMX resolver domain
69 return $ case mxs of
70 Left _ -> []
71 Right pairs -> map fst pairs
72
73
74 -- | Takes a list of domain names represented as 'String's and
75 -- constructs a map from domain names to sets of mail exchangers
76 -- (for those domain names) also represented as 'String's.
77 --
78 -- During construction, we have to switch to the DNS internal
79 -- representation of a 'Domain' which uses ByteStrings, but before
80 -- we return the map to the client, we want everything to be in
81 -- terms of standard 'String's for comparison purposes.
82 --
83 -- The list of domains is normalized and de-duped before lookups are
84 -- performed to avoid doing lookups twice for identical domains.
85 --
86 mx_set_map :: [String] -> IO MxSetMap
87 mx_set_map domains = do
88 -- Construct a list of pairs.
89 pairs <- mapM make_pair unique_domains
90
91 -- And make a map from the pairs.
92 return $ Map.fromList pairs
93
94 where
95 -- Convert, normalize, and de-dupe the @domains@.
96 unique_domains :: [Domain]
97 unique_domains = nub $ map (normalize . BS.pack) domains
98
99 -- | Convert a string domain name into a pair containing the
100 -- domain name in the first component and a set of its mail
101 -- exchangers (as strings) in the second component.
102 --
103 make_pair :: Domain -> IO (NormalDomain, Set NormalDomain)
104 make_pair domain = do
105 -- Lookup the @domain@'s MX records.
106 mx_list <- lookup_mxs domain
107
108 -- Now convert the MX records *back* to strings, and then to
109 -- NormalDomains
110 let normal_mx_list = map (normalize_string . BS.unpack) mx_list
111
112 -- Convert the list into a set...
113 let normal_mx_set = Set.fromList normal_mx_list
114
115 -- The lookup key.
116 let normal_domain = normalize_string $ BS.unpack domain
117
118 -- Finally, construct the pair and return it.
119 return (normal_domain, normal_mx_set)