8d94de51e9c7772d33adcb6cf5ec3e40c9479105
[list-remote-forwards.git] / src / DNS.hs
1 module DNS (
2 MxSetMap,
3 mx_set_map,
4 normalize_string_domain )
5 where
6
7 import qualified Data.ByteString.Char8 as BS ( pack, unpack )
8 import Data.List ( nub )
9 import Data.Map ( Map )
10 import qualified Data.Map as Map ( fromList )
11 import Data.Set ( Set )
12 import qualified Data.Set as Set ( fromList )
13 import Network.DNS (
14 Domain,
15 defaultResolvConf,
16 lookupMX,
17 makeResolvSeed,
18 normalize,
19 withResolver )
20
21 -- | A map from domain names (represented as 'String's) to sets of
22 -- mail exchanger names (also represented as 'String's).
23 --
24 type MxSetMap = Map String MxSet
25
26 -- | A set of mail exchanger names, represented as 'String's.
27 type MxSet = Set String
28
29
30 -- | Normalize a domain name string by converting to a 'Domain',
31 -- calling 'normalize', and then converting back.
32 --
33 -- ==== __Examples__
34 --
35 -- >>> normalize_string_domain "ExAMplE.com"
36 -- "example.com."
37 --
38 normalize_string_domain :: String -> String
39 normalize_string_domain = BS.unpack . normalize . BS.pack
40
41
42 -- | Retrieve all MX records for the given domain. This is somewhat
43 -- inefficient, since we create the resolver every time.
44 --
45 lookup_mxs :: Domain -> IO [Domain]
46 lookup_mxs domain = do
47 default_rs <- makeResolvSeed defaultResolvConf
48 withResolver default_rs $ \resolver -> do
49 mxs <- lookupMX resolver domain
50 return $ case mxs of
51 Left _ -> []
52 Right pairs -> map fst pairs
53
54
55 -- | Takes a list of domain names represented as 'String's and
56 -- constructs a map from domain names to sets of mail exchangers
57 -- (for those domain names) also represented as 'String's.
58 --
59 -- During construction, we have to switch to the DNS internal
60 -- representation of a 'Domain' which uses ByteStrings, but before
61 -- we return the map to the client, we want everything to be in
62 -- terms of standard 'String's for comparison purposes.
63 --
64 -- The list of domains is normalized and de-duped before lookups are
65 -- performed to avoid doing lookups twice for identical domains.
66 --
67 mx_set_map :: [String] -> IO MxSetMap
68 mx_set_map domains = do
69 -- Construct a list of pairs.
70 pairs <- mapM make_pair unique_domains
71
72 -- And make a map from the pairs.
73 return $ Map.fromList pairs
74
75 where
76 -- Convert, normalize, and de-dupe the @domains@.
77 unique_domains :: [Domain]
78 unique_domains = nub $ map (normalize . BS.pack) domains
79
80 -- | Convert a string domain name into a pair containing the
81 -- domain name in the first component and a set of its mail
82 -- exchangers (as strings) in the second component.
83 --
84 make_pair :: Domain -> IO (String, Set String)
85 make_pair domain = do
86 -- Lookup the @domain@'s MX records.
87 mx_list <- lookup_mxs domain
88
89 -- Now convert the MX records *back* to strings.
90 let string_mx_list = map BS.unpack mx_list
91
92 -- Convert the list into a set
93 let string_mx_set = Set.fromList string_mx_list
94
95 -- Finally, construct the pair and return it.
96 return (BS.unpack domain, string_mx_set)