12 import Control.Monad (liftM)
13 import qualified Data.ByteString.Char8 as BS (
19 import Data.Char (toLower)
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)
38 type LookupResult = (Domain, Either DNSError [Domain])
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].
47 -- >>> resolve_address "example.com"
48 -- Right [93.184.216.119]
49 -- >>> resolve_address "93.184.216.119"
50 -- Right [93.184.216.119]
52 resolve_address :: String -> IO (Either DNSError [IPv4])
55 Just addr -> return $ Right [addr]
57 default_rs <- makeResolvSeed defaultResolvConf
58 withResolver default_rs $ \resolver ->
59 lookupA resolver (BS.pack s)
61 read_result :: Maybe IPv4
62 read_result = readMaybe s
65 -- | This calls lookupMX, and returns the result as the second
66 -- component of a tuple whose first component is the domain name
71 -- The example domain, example.com, has no MX record.
73 -- >>> rs <- makeResolvSeed defaultResolvConf
74 -- >>> let domain = BS.pack "example.com."
75 -- >>> withResolver rs $ \resolver -> lookupMX' resolver domain
76 -- ("example.com.",Right [])
78 lookupMX' :: Resolver -> Domain -> IO LookupResult
79 lookupMX' resolver domain =
80 liftM (pair_em . drop_priority) $ lookupMX resolver domain
82 drop_priority :: Either DNSError [(Domain, Int)]
83 -> Either DNSError [Domain]
84 drop_priority = fmap (map fst)
86 pair_em :: a -> (Domain, a)
90 -- | This calls lookupNS, and returns the result as the second
91 -- component of a tuple whose first component is the domain name
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.
100 -- >>> import Data.List (sort)
101 -- >>> import Control.Applicative ((<$>))
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."])
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
115 pair_em :: a -> (Domain, a)
118 combine :: (Either DNSError [Domain])
119 -> (Either DNSError [Domain])
120 -> (Either DNSError [Domain])
126 -- | Perform both normalize_case and normalize_root.
127 normalize :: Domain -> Domain
128 normalize = normalize_case . normalize_root
130 -- | Normalize the given name by appending a trailing dot (the DNS
131 -- root) if necessary.
132 normalize_root :: Domain -> Domain
134 | BS.null d = BS.pack "."
135 | BS.last d == '.' = d
136 | otherwise = d `BS.append` trailing_dot
138 trailing_dot = BS.pack "."
141 -- | Normalize the given name by lowercasing it.
142 normalize_case :: Domain -> Domain
143 normalize_case = BS.map toLower
146 test_normalize_case :: Test
147 test_normalize_case =
149 assertEqual desc expected actual
151 desc = "normalize_case lowercases DNS names"
152 expected = BS.pack "example.com"
153 actual = normalize_case $ BS.pack "ExAmPlE.COM"
155 prop_normalize_case_idempotent :: String -> Bool
156 prop_normalize_case_idempotent s =
157 (normalize_case . normalize_case) bs == normalize_case bs
161 test_normalize_root_adds_dot :: Test
162 test_normalize_root_adds_dot =
164 assertEqual desc expected actual
166 desc = "normalize_root adds a trailing dot"
167 expected = BS.pack "example.com."
168 actual = normalize_root $ BS.pack "example.com"
170 prop_normalize_root_idempotent :: String -> Bool
171 prop_normalize_root_idempotent s =
172 (normalize_root . normalize_root) bs == normalize_root bs
178 testGroup "DNS Tests" [
180 test_normalize_root_adds_dot ]
182 dns_properties :: Test
184 testGroup "DNS Properties" [
186 "normalize_case is idempotent"
187 prop_normalize_case_idempotent,
189 "normalize_root is idempotent"
190 prop_normalize_root_idempotent ]