12 import Control.Monad (liftM)
13 import qualified Data.ByteString.Char8 as BS (
19 import Data.Char (toLower)
32 import Test.Tasty ( TestTree, testGroup )
33 import Test.Tasty.HUnit ( (@?=), testCase )
34 import Test.Tasty.QuickCheck ( testProperty )
35 import Text.Read (readMaybe)
37 type LookupResult = (Domain, Either DNSError [Domain])
39 -- | Takes a String representing either a hostname or an IP
40 -- address. If a hostname was supplied, it is resolved to either an
41 -- [IPv4] or an error. If an IP address is supplied, it is returned
42 -- as a singleton [IPv4].
46 -- >>> resolve_address "example.com"
47 -- Right [93.184.216.119]
48 -- >>> resolve_address "93.184.216.119"
49 -- Right [93.184.216.119]
51 resolve_address :: String -> IO (Either DNSError [IPv4])
54 Just addr -> return $ Right [addr]
56 default_rs <- makeResolvSeed defaultResolvConf
57 withResolver default_rs $ \resolver ->
58 lookupA resolver (BS.pack s)
60 read_result :: Maybe IPv4
61 read_result = readMaybe s
64 -- | This calls lookupMX, and returns the result as the second
65 -- component of a tuple whose first component is the domain name
70 -- The example domain, example.com, has no MX record.
72 -- >>> rs <- makeResolvSeed defaultResolvConf
73 -- >>> let domain = BS.pack "example.com."
74 -- >>> withResolver rs $ \resolver -> lookupMX' resolver domain
75 -- ("example.com.",Right [])
77 lookupMX' :: Resolver -> Domain -> IO LookupResult
78 lookupMX' resolver domain =
79 liftM (pair_em . drop_priority) $ lookupMX resolver domain
81 drop_priority :: Either DNSError [(Domain, Int)]
82 -> Either DNSError [Domain]
83 drop_priority = fmap (map fst)
85 pair_em :: a -> (Domain, a)
89 -- | This calls lookupNS, and returns the result as the second
90 -- component of a tuple whose first component is the domain name
95 -- The example domain, example.com, does have NS records, but the
96 -- order in which they are returned is variable, so we have to sort
97 -- them to get a reliable result.
99 -- >>> import Data.List (sort)
100 -- >>> import Control.Applicative ((<$>))
102 -- >>> let sort_snd (x,y) = (x, sort <$> y)
103 -- >>> rs <- makeResolvSeed defaultResolvConf
104 -- >>> let domain = BS.pack "example.com."
105 -- >>> withResolver rs $ \resolver -> sort_snd <$> lookupNS' resolver domain
106 -- ("example.com.",Right ["a.iana-servers.net.","b.iana-servers.net."])
108 lookupNS' :: Resolver -> Domain -> IO LookupResult
109 lookupNS' resolver domain = do
110 answer_result <- lookupNS resolver domain
111 auth_result <- lookupNSAuth resolver domain
112 liftM pair_em $ return $ combine answer_result auth_result
114 pair_em :: a -> (Domain, a)
117 combine :: (Either DNSError [Domain])
118 -> (Either DNSError [Domain])
119 -> (Either DNSError [Domain])
125 -- | Perform both normalize_case and normalize_root.
126 normalize :: Domain -> Domain
127 normalize = normalize_case . normalize_root
129 -- | Normalize the given name by appending a trailing dot (the DNS
130 -- 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.
143 normalize_case :: Domain -> Domain
144 normalize_case = BS.map toLower
150 test_normalize_case :: TestTree
151 test_normalize_case =
152 testCase desc $ actual @?= expected
154 desc = "normalize_case lowercases DNS names"
155 expected = BS.pack "example.com"
156 actual = normalize_case $ BS.pack "ExAmPlE.COM"
158 prop_normalize_case_idempotent :: TestTree
159 prop_normalize_case_idempotent =
160 testProperty desc $ prop
162 desc = "normalize_case is idempotent"
164 prop :: String -> Bool
165 prop s = (normalize_case . normalize_case) bs == normalize_case bs
169 test_normalize_root_adds_dot :: TestTree
170 test_normalize_root_adds_dot =
171 testCase desc $ actual @?= expected
173 desc = "normalize_root adds a trailing dot"
174 expected = BS.pack "example.com."
175 actual = normalize_root $ BS.pack "example.com"
177 prop_normalize_root_idempotent :: TestTree
178 prop_normalize_root_idempotent =
179 testProperty desc prop
181 desc = "normalize_root is idempotent"
183 prop :: String -> Bool
184 prop s = (normalize_root . normalize_root) bs == normalize_root bs
188 dns_tests :: TestTree
190 testGroup "DNS Tests" [
192 test_normalize_root_adds_dot ]
194 dns_properties :: TestTree
196 testGroup "DNS Properties" [
197 prop_normalize_case_idempotent,
198 prop_normalize_root_idempotent ]