Update code and doctests to support the new version of the dns library.
[haeredes.git] / src / DNS.hs
1 module DNS (
2 LookupResult,
3 dns_properties,
4 dns_tests,
5 lookupMX',
6 lookupNS',
7 normalize,
8 normalize_case,
9 resolve_address )
10 where
11
12 import Control.Monad (liftM)
13 import qualified Data.ByteString.Char8 as BS (
14 append,
15 last,
16 map,
17 null,
18 pack )
19 import Data.Char (toLower)
20 import Data.IP (IPv4)
21 import Network.DNS (
22 Domain,
23 DNSError,
24 Resolver,
25 defaultResolvConf,
26 lookupA,
27 lookupMX,
28 lookupNS,
29 lookupNSAuth,
30 makeResolvSeed,
31 withResolver )
32 import Test.Framework (Test, testGroup)
33 import Test.Framework.Providers.HUnit (testCase)
34 import Test.Framework.Providers.QuickCheck2 (testProperty)
35 import Test.HUnit (assertEqual)
36 import Text.Read (readMaybe)
37
38 type LookupResult = (Domain, Either DNSError [Domain])
39
40 -- | Takes a String representing either a hostname or an IP
41 -- address. If a hostname was supplied, it is resolved to either an
42 -- [IPv4] or an error. If an IP address is supplied, it is returned
43 -- as a singleton [IPv4].
44 --
45 -- Examples:
46 --
47 -- >>> resolve_address "example.com"
48 -- Right [93.184.216.119]
49 -- >>> resolve_address "93.184.216.119"
50 -- Right [93.184.216.119]
51 --
52 resolve_address :: String -> IO (Either DNSError [IPv4])
53 resolve_address s =
54 case read_result of
55 Just addr -> return $ Right [addr]
56 Nothing -> do
57 default_rs <- makeResolvSeed defaultResolvConf
58 withResolver default_rs $ \resolver ->
59 lookupA resolver (BS.pack s)
60 where
61 read_result :: Maybe IPv4
62 read_result = readMaybe s
63
64
65 -- | This calls lookupMX, and returns the result as the second
66 -- component of a tuple whose first component is the domain name
67 -- itself.
68 --
69 -- Examples:
70 --
71 -- The example domain, example.com, has no MX record.
72 --
73 -- >>> rs <- makeResolvSeed defaultResolvConf
74 -- >>> let domain = BS.pack "example.com."
75 -- >>> withResolver rs $ \resolver -> lookupMX' resolver domain
76 -- ("example.com.",Right [])
77 --
78 lookupMX' :: Resolver -> Domain -> IO LookupResult
79 lookupMX' resolver domain =
80 liftM (pair_em . drop_priority) $ lookupMX resolver domain
81 where
82 drop_priority :: Either DNSError [(Domain, Int)]
83 -> Either DNSError [Domain]
84 drop_priority = fmap (map fst)
85
86 pair_em :: a -> (Domain, a)
87 pair_em = (,) domain
88
89
90 -- | This calls lookupNS, and returns the result as the second
91 -- component of a tuple whose first component is the domain name
92 -- itself.
93 --
94 -- Examples:
95 --
96 -- The example domain, example.com, does have NS records, but the
97 -- order in which they are returned is variable, so we have to sort
98 -- them to get a reliable result.
99 --
100 -- >>> import Data.List (sort)
101 -- >>> import Control.Applicative ((<$>))
102 -- >>>
103 -- >>> let sort_snd (x,y) = (x, sort <$> y)
104 -- >>> rs <- makeResolvSeed defaultResolvConf
105 -- >>> let domain = BS.pack "example.com."
106 -- >>> withResolver rs $ \resolver -> sort_snd <$> lookupNS' resolver domain
107 -- ("example.com.",Right ["a.iana-servers.net.","b.iana-servers.net."])
108 --
109 lookupNS' :: Resolver -> Domain -> IO LookupResult
110 lookupNS' resolver domain = do
111 answer_result <- lookupNS resolver domain
112 auth_result <- lookupNSAuth resolver domain
113 liftM pair_em $ return $ combine answer_result auth_result
114 where
115 pair_em :: a -> (Domain, a)
116 pair_em = (,) domain
117
118 combine :: (Either DNSError [Domain])
119 -> (Either DNSError [Domain])
120 -> (Either DNSError [Domain])
121 combine e1 e2 = do
122 l1 <- e1
123 l2 <- e2
124 return (l1 ++ l2)
125
126 -- | Perform both normalize_case and normalize_root.
127 normalize :: Domain -> Domain
128 normalize = normalize_case . normalize_root
129
130 -- | Normalize the given name by appending a trailing dot (the DNS
131 -- root) if necessary.
132 normalize_root :: Domain -> Domain
133 normalize_root d
134 | BS.null d = BS.pack "."
135 | BS.last d == '.' = d
136 | otherwise = d `BS.append` trailing_dot
137 where
138 trailing_dot = BS.pack "."
139
140
141 -- | Normalize the given name by lowercasing it.
142 normalize_case :: Domain -> Domain
143 normalize_case = BS.map toLower
144
145
146 test_normalize_case :: Test
147 test_normalize_case =
148 testCase desc $
149 assertEqual desc expected actual
150 where
151 desc = "normalize_case lowercases DNS names"
152 expected = BS.pack "example.com"
153 actual = normalize_case $ BS.pack "ExAmPlE.COM"
154
155 prop_normalize_case_idempotent :: String -> Bool
156 prop_normalize_case_idempotent s =
157 (normalize_case . normalize_case) bs == normalize_case bs
158 where
159 bs = BS.pack s
160
161 test_normalize_root_adds_dot :: Test
162 test_normalize_root_adds_dot =
163 testCase desc $
164 assertEqual desc expected actual
165 where
166 desc = "normalize_root adds a trailing dot"
167 expected = BS.pack "example.com."
168 actual = normalize_root $ BS.pack "example.com"
169
170 prop_normalize_root_idempotent :: String -> Bool
171 prop_normalize_root_idempotent s =
172 (normalize_root . normalize_root) bs == normalize_root bs
173 where
174 bs = BS.pack s
175
176 dns_tests :: Test
177 dns_tests =
178 testGroup "DNS Tests" [
179 test_normalize_case,
180 test_normalize_root_adds_dot ]
181
182 dns_properties :: Test
183 dns_properties =
184 testGroup "DNS Properties" [
185 testProperty
186 "normalize_case is idempotent"
187 prop_normalize_case_idempotent,
188 testProperty
189 "normalize_root is idempotent"
190 prop_normalize_root_idempotent ]