1 {-# LANGUAGE DoAndIfThenElse #-}
3 -- | This module contains the 'Subdomain' type and a Parsec parser to
4 -- parse one. We don't export its constructor because then you could
5 -- do something dumb like stick a period inside one.
7 -- These are defined in RFC1035, Section 2.3.1, \"Preferred name
8 -- syntax\" <https://tools.ietf.org/html/rfc1035#section-2.3.1>:
10 -- <subdomain> ::= <label> | <subdomain> "." <label>
12 module Network.DNS.RBL.Domain.Subdomain (
17 import Text.Parsec ( (<|>), char, try )
18 import Text.Parsec.String ( Parser )
20 import Network.DNS.RBL.Domain.Label ( Label, label )
21 import Network.DNS.RBL.Pretty ( Pretty(..) )
22 import Network.DNS.RBL.Reversible ( Reversible(..) )
25 -- | The data type representing a \"subdomain\" from RFC1035. We have
26 -- reversed the order of the subdomain and label in the second
27 -- option (from the grammar), however. This is explained in the
28 -- 'subdomain' parser.
33 -- >>> import Text.Parsec ( parse )
35 -- >>> let (Right r) = parse label "" "x"
36 -- >>> SubdomainSingleLabel r
37 -- SubdomainSingleLabel (Label (LetDigLetter (Letter 'x')) Nothing)
40 SubdomainSingleLabel Label |
41 SubdomainMultipleLabel Label Subdomain
45 -- | Pretty-print a 'Subdomain'. We print additional \".\" characters
46 -- between our labels when there are more than one of them.
48 instance Pretty Subdomain where
49 pretty_show (SubdomainSingleLabel l) = pretty_show l
50 pretty_show (SubdomainMultipleLabel l s) =
51 (pretty_show l) ++ "." ++ (pretty_show s)
54 instance Reversible Subdomain where
55 -- | Reverse the labels of the given subdomain.
59 -- >>> import Text.Parsec ( parse )
63 -- >>> let (Right r) = parse subdomain "" "com"
64 -- >>> pretty_print $ backwards r
67 -- >>> let (Right r) = parse subdomain "" "example.com"
68 -- >>> pretty_print $ backwards r
71 -- >>> let (Right r) = parse subdomain "" "www.example.com"
72 -- >>> pretty_print $ backwards r
75 -- >>> let (Right r) = parse subdomain "" "new.www.example.com"
76 -- >>> pretty_print $ backwards r
77 -- com.example.www.new
80 -- It's easy to reverse a single label...
81 backwards s@(SubdomainSingleLabel _) = s
83 -- For multiple labels we have two cases. The first is where we have
84 -- exactly two labels, and we just need to swap them.
85 backwards (SubdomainMultipleLabel l (SubdomainSingleLabel m)) =
86 SubdomainMultipleLabel m (SubdomainSingleLabel l)
88 -- And now the hard case. See the 'LdhStr' implementation for an
91 backwards (SubdomainMultipleLabel l s) = build (SubdomainSingleLabel l) s
93 -- Build up the first Subdomain on the left by peeling off the
94 -- leading elements of the second Subdomain.
95 build :: Subdomain -> Subdomain -> Subdomain
96 build dst (SubdomainSingleLabel final) = SubdomainMultipleLabel final dst
97 build dst (SubdomainMultipleLabel leading rest) =
98 build (SubdomainMultipleLabel leading dst) rest
102 -- | Parse a 'Subdomain'. Here is the RFC1035 grammar for reference:
104 -- <subdomain> ::= <label> | <subdomain> "." <label>
106 -- In contrast with the grammar, we have reversed the order of the
107 -- subdomain and label to prevent infinite recursion. The second
108 -- option (subdomain + label) is obviously more specific, we we need
109 -- to try it first. This presents a problem: we're trying to parse a
110 -- subdomain in terms of a subdomain! The given grammar represents
111 -- subdomains how we like to think of them; from right to left. But
112 -- it's better to parse from left to right, so we pick off the
113 -- leading label and then recurse into the definition of subdomain.
115 -- According to RFC1034 <https://tools.ietf.org/html/rfc1034>
116 -- Section 3.1, \"3.1. Name space specifications and terminology\"
117 -- two neighboring labels in a DNS name cannot be equal:
119 -- Each node has a label, which is zero to 63 octets in length. Brother
120 -- nodes may not have the same label, although the same label can be used
121 -- for nodes which are not brothers. One label is reserved, and that is
122 -- the null (i.e., zero length) label used for the root.
124 -- We enforce this restriction, but the result is usually that we
125 -- only parse the part of the subdomain leading up to the repeated
130 -- >>> import Text.Parsec ( parse, parseTest )
132 -- Make sure we can parse a single character:
134 -- >>> parseTest subdomain "a"
135 -- SubdomainSingleLabel (Label (LetDigLetter (Letter 'a')) Nothing)
137 -- >>> pretty_print $ parse subdomain "" "example.com"
140 -- >>> pretty_print $ parse subdomain "" "www.example.com"
143 -- We reject a subdomain with equal neighbors, but this leads to
144 -- only the single first label being parsed instead:
146 -- >>> pretty_print $ parse subdomain "" "www.www.example.com"
149 -- But not one with a repeated but non-neighboring label:
151 -- >>> pretty_print $ parse subdomain "" "www.example.www.com"
152 -- www.example.www.com
154 subdomain :: Parser Subdomain
155 subdomain = try both <|> just_one
157 both :: Parser Subdomain
162 let result = SubdomainMultipleLabel l s
163 if (subdomain_has_equal_neighbors result)
164 then fail "subdomain cannot have equal neighboring labels"
167 just_one :: Parser Subdomain
168 just_one = fmap SubdomainSingleLabel label
172 -- | Retrieve a list of labels contained in a 'Subdomain'.
176 -- >>> import Text.Parsec ( parse )
178 -- >>> let (Right r) = parse subdomain "" "a"
179 -- >>> pretty_print $ subdomain_labels r
182 -- >>> let (Right r) = parse subdomain "" "example.com"
183 -- >>> pretty_print $ subdomain_labels r
186 -- >>> let (Right r) = parse subdomain "" "www.example.com"
187 -- >>> pretty_print $ subdomain_labels r
188 -- ["www","example","com"]
190 subdomain_labels :: Subdomain -> [Label]
191 subdomain_labels (SubdomainSingleLabel l) = [l]
192 subdomain_labels (SubdomainMultipleLabel l s) = l : (subdomain_labels s)
195 -- | Return a list of pairs of neighboring labels in a subdomain.
199 -- >>> import Text.Parsec ( parse )
200 -- >>> let (Right r) = parse subdomain "" "www.example.com"
201 -- >>> pretty_print $ subdomain_label_neighbors r
202 -- ["(\"www\",\"example\")","(\"example\",\"com\")"]
204 subdomain_label_neighbors :: Subdomain -> [(Label,Label)]
205 subdomain_label_neighbors s =
208 ls = subdomain_labels s
211 -- | Return @True@ if the subdomain has any two equal neighboring
212 -- labels, and @False@ otherwise.
216 -- >>> import Text.Parsec ( parse )
218 -- >>> let (Right r) = parse subdomain "" "www.example.com"
219 -- >>> subdomain_has_equal_neighbors r
222 -- >>> let (Right l) = parse label "" "www"
223 -- >>> let (Right s) = parse subdomain "" "www.example.com"
224 -- >>> let bad_subdomain = SubdomainMultipleLabel l s
225 -- >>> subdomain_has_equal_neighbors bad_subdomain
228 subdomain_has_equal_neighbors :: Subdomain -> Bool
229 subdomain_has_equal_neighbors s =
230 or [ x == y | (x,y) <- subdomain_label_neighbors s ]