Initial commit of something working.
[list-remote-forwards.git] / src / DNS.hs
1 module DNS (
2 dns_properties,
3 dns_tests,
4 lookup_mxs,
5 normalize )
6 where
7
8 import qualified Data.ByteString.Char8 as BS (
9 append,
10 last,
11 map,
12 null,
13 pack )
14 import Data.Char ( toLower )
15 import Network.DNS (
16 Domain,
17 defaultResolvConf,
18 lookupMX,
19 makeResolvSeed,
20 withResolver )
21 import Test.Tasty ( TestTree, testGroup )
22 import Test.Tasty.HUnit ( (@?=), testCase )
23 import Test.Tasty.QuickCheck ( testProperty )
24
25 -- Slow since we create the resolver every time.
26 lookup_mxs :: Domain -> IO [Domain]
27 lookup_mxs domain = do
28 default_rs <- makeResolvSeed defaultResolvConf
29 withResolver default_rs $ \resolver -> do
30 mxs <- lookupMX resolver domain
31 return $ case mxs of
32 Left _ -> []
33 Right pairs -> map fst pairs
34
35
36 -- | Perform both normalize_case and normalize_root.
37 normalize :: Domain -> Domain
38 normalize = normalize_case . normalize_root
39
40 -- | Normalize the given name by appending a trailing dot (the DNS
41 -- root) if necessary.
42 --
43 normalize_root :: Domain -> Domain
44 normalize_root d
45 | BS.null d = BS.pack "."
46 | BS.last d == '.' = d
47 | otherwise = d `BS.append` trailing_dot
48 where
49 trailing_dot = BS.pack "."
50
51
52 -- | Normalize the given name by lowercasing it.
53 --
54 normalize_case :: Domain -> Domain
55 normalize_case = BS.map toLower
56
57 -- * Tests
58
59 test_normalize_case :: TestTree
60 test_normalize_case =
61 testCase desc $ actual @?= expected
62 where
63 desc = "normalize_case lowercases DNS names"
64 expected = BS.pack "example.com"
65 actual = normalize_case $ BS.pack "ExAmPlE.COM"
66
67 prop_normalize_case_idempotent :: TestTree
68 prop_normalize_case_idempotent =
69 testProperty desc $ prop
70 where
71 desc = "normalize_case is idempotent"
72
73 prop :: String -> Bool
74 prop s = (normalize_case . normalize_case) bs == normalize_case bs
75 where
76 bs = BS.pack s
77
78 test_normalize_root_adds_dot :: TestTree
79 test_normalize_root_adds_dot =
80 testCase desc $ actual @?= expected
81 where
82 desc = "normalize_root adds a trailing dot"
83 expected = BS.pack "example.com."
84 actual = normalize_root $ BS.pack "example.com"
85
86 prop_normalize_root_idempotent :: TestTree
87 prop_normalize_root_idempotent =
88 testProperty desc prop
89 where
90 desc = "normalize_root is idempotent"
91
92 prop :: String -> Bool
93 prop s = (normalize_root . normalize_root) bs == normalize_root bs
94 where
95 bs = BS.pack s
96
97 dns_tests :: TestTree
98 dns_tests =
99 testGroup "DNS Tests" [
100 test_normalize_case,
101 test_normalize_root_adds_dot ]
102
103 dns_properties :: TestTree
104 dns_properties =
105 testGroup "DNS Properties" [
106 prop_normalize_case_idempotent,
107 prop_normalize_root_idempotent ]