More import/export cleanup.
[dead/harbl.git] / src / Domain.hs
1 -- | The 'Domain' data type and its parser. A 'Domain' represents a
2 -- name in the domain name system (DNS) as described by
3 -- RFC1035. In particular, we enforce the restrictions from Section
4 -- 2.3.1 \"Preferred name syntax\". See for example,
5 --
6 -- <https://tools.ietf.org/html/rfc1035#section-2.3.1>
7 --
8 module Domain (
9 UserDomain,
10 user_domain )
11 where
12
13 import Data.Char ( toLower )
14 import Text.Parsec (
15 ParseError,
16 (<|>),
17 alphaNum,
18 char,
19 eof,
20 many1,
21 option,
22 optionMaybe,
23 parse,
24 string,
25 try,
26 unexpected )
27 import qualified Text.Parsec as Parsec ( digit, letter)
28 import Text.Parsec.String ( Parser )
29
30 import Pretty ( Pretty(..) )
31
32 -- * Digits
33
34 -- | A wrapper around a digit character.
35 --
36 newtype Digit = Digit Char deriving (Eq, Show)
37 instance Pretty Digit where pretty_show (Digit d) = [d]
38
39 -- | Parse a single digit, but wrap it in our 'Digit' type.
40 --
41 digit :: Parser Digit
42 digit = fmap Digit Parsec.digit
43
44
45 -- * Letters
46
47 -- | A wrapper around a letter character.
48 --
49 newtype Letter = Letter Char deriving (Show)
50 instance Pretty Letter where pretty_show (Letter l) = [l]
51
52
53 -- | Parse a single letter, but wrap it in our 'Letter' type.
54 --
55 letter :: Parser Letter
56 letter = fmap Letter Parsec.letter
57
58 -- | The derived instance of 'Eq' for letters is incorrect. All
59 -- comparisons should be made case-insensitively. The following
60 -- is an excerpt from RFC1035:
61 --
62 -- 2.3.3. Character Case
63 --
64 -- For all parts of the DNS that are part of the official
65 -- protocol, all comparisons between character strings (e.g.,
66 -- labels, domain names, etc.) are done in a case-insensitive
67 -- manner...
68 --
69 -- Since each part of DNS name is composed of our custom types, it
70 -- suffices to munge the equality for 'Letter'.
71 --
72 instance Eq Letter where
73 (Letter l1) == (Letter l2) = (toLower l1) == (toLower l2)
74
75 -- * Letters/Digits
76
77 -- | A sum type representing either a letter or a digit.
78 --
79 data LetDig =
80 LetDigLetter Letter |
81 LetDigDigit Digit
82 deriving (Eq, Show)
83
84 instance Pretty LetDig where
85 pretty_show (LetDigLetter l) = pretty_show l
86 pretty_show (LetDigDigit d) = pretty_show d
87
88 -- | Parse a letter or a digit and wrap it in our 'LetDig' type.
89 --
90 let_dig :: Parser LetDig
91 let_dig = (fmap LetDigLetter letter) <|> (fmap LetDigDigit digit)
92
93
94 -- * Hyphens
95
96 -- | A wrapper around a single hyphen character.
97 --
98 newtype Hyphen = Hyphen Char deriving (Eq, Show)
99 instance Pretty Hyphen where pretty_show (Hyphen h) = [h]
100
101 -- | Parse a single hyphen and wrap it in our 'Hyphen' type.
102 --
103 hyphen :: Parser Hyphen
104 hyphen = fmap Hyphen (char '-')
105
106
107 -- * Letter, Digit, or Hyphen.
108
109 -- | A sum type representing a letter, digit, or hyphen.
110 --
111 data LetDigHyp =
112 LetDigHypLetDig LetDig |
113 LetDigHypHyphen Hyphen
114 deriving (Eq, Show)
115
116 instance Pretty LetDigHyp where
117 pretty_show (LetDigHypLetDig ld) = pretty_show ld
118 pretty_show (LetDigHypHyphen h) = pretty_show h
119
120
121 -- | The following is the simplest type in the domain grammar that
122 -- isn't already implemented for us.
123 --
124 -- <let-dig> ::= <letter> | <digit>
125 --
126 -- ==== _Examples_
127 --
128 -- >>> import Text.Parsec ( parseTest )
129 --
130 -- Letters, digits, and hyphens are all parsed:
131 --
132 -- >>> parseTest let_dig_hyp "a"
133 -- LetDigHypLetDig (LetDigLetter (Letter 'a'))
134 --
135 -- >>> parseTest let_dig_hyp "7"
136 -- LetDigHypLetDig (LetDigDigit (Digit '7'))
137 --
138 -- >>> parseTest let_dig_hyp "-"
139 -- LetDigHypHyphen (Hyphen '-')
140 --
141 -- However, an underscore (for example) is not:
142 --
143 -- >>> parseTest let_dig_hyp "_"
144 -- parse error at (line 1, column 1):
145 -- unexpected "_"
146 -- expecting letter, digit or "-"
147 --
148 let_dig_hyp :: Parser LetDigHyp
149 let_dig_hyp =
150 parse_letdig <|> parse_hyphen
151 where
152 parse_letdig :: Parser LetDigHyp
153 parse_letdig = fmap LetDigHypLetDig let_dig
154
155 parse_hyphen :: Parser LetDigHyp
156 parse_hyphen = fmap LetDigHypHyphen hyphen
157
158
159 -- * Letter/Digit/Hyphen strings
160
161 -- | A string of letters, digits, and hyphens from the RFC1035 grammar:
162 --
163 -- <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
164 --
165 -- These are represented as either a single instance of a
166 -- 'LetDigHyp', or a string of them (recursive).
167 --
168 data LdhStr =
169 LdhStrSingleLdh LetDigHyp |
170 LdhStrMultipleLdh LetDigHyp LdhStr
171 deriving (Eq, Show)
172
173 instance Pretty LdhStr where
174 pretty_show (LdhStrSingleLdh ldh) = pretty_show ldh
175 pretty_show (LdhStrMultipleLdh ldh s) = (pretty_show ldh) ++ (pretty_show s)
176
177 -- | Parse a string of letters, digits, and hyphens (an 'LdhStr').
178 --
179 -- ==== _Examples_
180 --
181 -- >>> import Text.Parsec ( parseTest )
182 --
183 -- Single letters, digits, and hyphens are parsed:
184 --
185 -- >>> parseTest ldh_str "a"
186 -- LdhStrSingleLdh (LetDigHypLetDig (LetDigLetter (Letter 'a')))
187 --
188 -- >>> parseTest ldh_str "0"
189 -- LdhStrSingleLdh (LetDigHypLetDig (LetDigDigit (Digit '0')))
190 --
191 -- >>> parseTest ldh_str "-"
192 -- LdhStrSingleLdh (LetDigHypHyphen (Hyphen '-'))
193 --
194 -- As well as strings of them:
195 --
196 -- >>> pretty_print $ parse ldh_str "" "a0-b"
197 -- a0-b
198 --
199 ldh_str :: Parser LdhStr
200 ldh_str = try both <|> just_one
201 where
202 both :: Parser LdhStr
203 both = do
204 ldh1 <- let_dig_hyp
205 ldh_tail <- ldh_str
206 return $ LdhStrMultipleLdh ldh1 ldh_tail
207
208 just_one :: Parser LdhStr
209 just_one = fmap LdhStrSingleLdh let_dig_hyp
210
211
212
213 -- | A version of 'last' that works on a 'LdhStr' rather than a
214 -- list. That is, it returns the last 'LetDigHyp' in the
215 -- string. Since 'LdhStr' contains at least one character, there's
216 -- no \"nil\" case here.
217 --
218 -- ==== _Examples_
219 --
220 -- >>> let (Right r) = parse ldh_str "" "a"
221 -- >>> last_ldh_str r
222 -- LetDigHypLetDig (LetDigLetter (Letter 'a'))
223 --
224 -- >>> let (Right r) = parse ldh_str "" "abc-def"
225 -- >>> last_ldh_str r
226 -- LetDigHypLetDig (LetDigLetter (Letter 'f'))
227 --
228 last_ldh_str :: LdhStr -> LetDigHyp
229 last_ldh_str (LdhStrSingleLdh x) = x
230 last_ldh_str (LdhStrMultipleLdh _ x) = last_ldh_str x
231
232
233 -- | A version of 'init' that works on a 'LdhStr' rather than a
234 -- list. That is, it returns everything /except/ the last character in
235 -- the string.
236 --
237 -- Since an 'LdhStr' must contain at least one character, this might
238 -- not be opssible (when the input is of length one). So, we return
239 -- a 'Maybe' value.
240 --
241 -- ==== _Examples_
242 --
243 -- >>> let (Right r) = parse ldh_str "" "a"
244 -- >>> init_ldh_str r
245 -- Nothing
246 --
247 -- >>> let (Right r) = parse ldh_str "" "ab"
248 -- >>> init_ldh_str r
249 -- Just (LdhStrSingleLdh (LetDigHypLetDig (LetDigLetter (Letter 'a'))))
250 --
251 -- >>> let (Right r) = parse ldh_str "" "abc-def"
252 -- >>> init_ldh_str r
253 -- Just (LdhStrMultipleLdh (LetDigHypLetDig (LetDigLetter (Letter 'a'))) (LdhStrMultipleLdh (LetDigHypLetDig (LetDigLetter (Letter 'b'))) (LdhStrMultipleLdh (LetDigHypLetDig (LetDigLetter (Letter 'c'))) (LdhStrMultipleLdh (LetDigHypHyphen (Hyphen '-')) (LdhStrMultipleLdh (LetDigHypLetDig (LetDigLetter (Letter 'd'))) (LdhStrSingleLdh (LetDigHypLetDig (LetDigLetter (Letter 'e')))))))))
254 --
255 init_ldh_str :: LdhStr -> Maybe LdhStr
256 init_ldh_str (LdhStrSingleLdh _) = Nothing
257 init_ldh_str (LdhStrMultipleLdh h t) =
258 Just $ case (init_ldh_str t) of
259 -- We just got the second-to-last character, we're done.
260 Nothing -> LdhStrSingleLdh h
261
262 -- There's still more stuff. Recurse.
263 Just rest -> LdhStrMultipleLdh h rest
264
265
266 -- | Compute the length of an 'LdhStr'. It will be at least one, since
267 -- 'LdhStr's are non-empty. And if there's something other than the
268 -- first character present, we simply recurse.
269 --
270 -- ==== _Examples_
271 --
272 -- >>> let (Right r) = parse ldh_str "" "a"
273 -- >>> length_ldh_str r
274 -- 1
275 --
276 -- >>> let (Right r) = parse ldh_str "" "abc-def"
277 -- >>> length_ldh_str r
278 -- 7
279 --
280 length_ldh_str :: LdhStr -> Int
281 length_ldh_str (LdhStrSingleLdh _) = 1
282 length_ldh_str (LdhStrMultipleLdh _ t) = 1 + (length_ldh_str t)
283
284 -- * Letter/Digit/Hyphen string followed by a trailing Letter/Digit
285
286 -- | This type isn't explicitly part of the grammar, but it's what
287 -- shows up in the square brackets of,
288 --
289 -- <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
290 --
291 -- The ldh-str is optional, but if one is present, we must also have
292 -- a trailing let-dig to prevent the name from ending with a
293 -- hyphen. This can be represented with a @Maybe LdhStrLetDig@,
294 -- which is why we're about to define it.
295 --
296 data LdhStrLetDig = LdhStrLetDig (Maybe LdhStr) LetDig
297 deriving (Eq, Show)
298
299 instance Pretty LdhStrLetDig where
300 pretty_show (LdhStrLetDig Nothing ld) = pretty_show ld
301 pretty_show (LdhStrLetDig (Just s) ld) = (pretty_show s) ++ (pretty_show ld)
302
303 -- | Parse an 'LdhStrLetDig'. This isn't in the grammar, but we might
304 -- as well define the parser for it independently since we gave it
305 -- its own data type.
306 --
307 -- ==== _Examples_
308 --
309 -- >>> import Text.Parsec ( parseTest )
310 --
311 -- Make sure we can parse a single character:
312 --
313 -- >>> parseTest ldh_str_let_dig "a"
314 -- LdhStrLetDig Nothing (LetDigLetter (Letter 'a'))
315 --
316 -- And longer strings:
317 --
318 -- >>> pretty_print $ parse ldh_str_let_dig "" "ab"
319 -- ab
320 --
321 -- >>> pretty_print $ parse ldh_str_let_dig "" "-b"
322 -- -b
323 --
324 -- >>> parseTest ldh_str_let_dig "b-"
325 -- parse error at (line 1, column 3):
326 -- label cannot end with a hyphen
327 --
328 ldh_str_let_dig :: Parser LdhStrLetDig
329 ldh_str_let_dig = do
330 -- This will happily eat up the trailing let-dig...
331 full_ldh <- ldh_str
332
333 -- So we have to go back and see what happened.
334 case (last_ldh_str full_ldh) of
335 (LetDigHypHyphen _) -> fail "label cannot end with a hyphen"
336 (LetDigHypLetDig ld) ->
337 -- Ok, the label didn't end with a hyphen; now we need to split
338 -- off the last letter/digit so we can pack it into our return
339 -- type separately.
340 return $ case (init_ldh_str full_ldh) of
341 -- We only parsed one letter/digit. This can happen
342 -- if the label contains two characters. For example,
343 -- if we try to parse the label "ab", then the "a"
344 -- will be eaten by the label parser, and this
345 -- function will be left with only "b".
346 Nothing -> LdhStrLetDig Nothing ld
347
348 -- Usual case: there's was some leading let-dig-hyp junk,
349 -- return it too.
350 leading_ldhs -> LdhStrLetDig leading_ldhs ld
351
352
353
354 -- | Compute the length of a 'LdhStrLetDig'. It's at least one, since
355 -- the let-dig at the end is always there. And when there's an
356 -- ldh-str too, we add its length to one.
357 --
358 -- ==== _Examples_
359 --
360 -- >>> let (Right r) = parse ldh_str_let_dig "" "a"
361 -- >>> length_ldh_str_let_dig r
362 -- 1
363 --
364 -- >>> let (Right r) = parse ldh_str_let_dig "" "abc-def"
365 -- >>> length_ldh_str_let_dig r
366 -- 7
367 --
368 length_ldh_str_let_dig :: LdhStrLetDig -> Int
369 length_ldh_str_let_dig (LdhStrLetDig Nothing _) = 1
370 length_ldh_str_let_dig (LdhStrLetDig (Just ldhstring) _) =
371 1 + (length_ldh_str ldhstring)
372
373
374 -- * Labels
375
376 -- | The label type from the RFC1035 grammar:
377 --
378 -- <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
379 --
380 data Label = Label Letter (Maybe LdhStrLetDig)
381 deriving (Eq, Show)
382
383 instance Pretty Label where
384 pretty_show (Label l Nothing) = pretty_show l
385 pretty_show (Label l (Just s)) = (pretty_show l) ++ (pretty_show s)
386
387 -- | Parse a 'Label'.
388 --
389 -- In addition to the grammar, there's another restriction on
390 -- labels: their length must be 63 characters or less. Quoting
391 -- Section 2.3.1, \"Preferred name syntax\", of RFC1035:
392 --
393 -- The labels must follow the rules for ARPANET host names. They
394 -- must start with a letter, end with a letter or digit, and have
395 -- as interior characters only letters, digits, and hyphen. There
396 -- are also some restrictions on the length. Labels must be 63
397 -- characters or less.
398 --
399 -- We check this only after we have successfully parsed a label.
400 --
401 -- ==== _Examples_
402 --
403 -- >>> import Text.Parsec ( parseTest )
404 --
405 -- Make sure we can parse a single character:
406 --
407 -- >>> parseTest label "a"
408 -- Label (Letter 'a') Nothing
409 --
410 -- And longer strings:
411 --
412 -- >>> pretty_print $ parse label "" "abc-def"
413 -- abc-def
414 --
415 -- But not anything ending in a hyphen:
416 --
417 -- >>> parseTest label "abc-"
418 -- parse error at (line 1, column 5):
419 -- label cannot end with a hyphen
420 --
421 -- Or anything over 63 characters:
422 --
423 -- >>> parseTest label (['a'..'z'] ++ ['a'..'z'] ++ ['a'..'z'])
424 -- parse error at (line 1, column 79):
425 -- labels must be 63 or fewer characters
426 --
427 -- However, /exactly/ 63 characters is acceptable:
428 --
429 -- >>> pretty_print $ parse label "" (replicate 63 'x')
430 -- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
431 --
432 label :: Parser Label
433 label = do
434 l <- letter -- Guaranteed to be there
435 maybe_s <- optionMaybe ldh_str_let_dig -- Might not be there
436 case maybe_s of
437 -- It can only be one character long, from the letter...
438 Nothing -> return $ Label l maybe_s
439
440 -- The letter gives us one character, so we check that the rest is
441 -- less than 62 characters long. But in the error message we need
442 -- to report 63.
443 Just s -> if (length_ldh_str_let_dig s) <= 62
444 then return $ Label l maybe_s
445 else fail "labels must be 63 or fewer characters"
446
447
448
449 -- * Subdomains
450
451
452 -- | The data type representing a \"subdomain\" from RFC1035:
453 --
454 -- <subdomain> ::= <label> | <subdomain> "." <label>
455 --
456 -- We have reversed the order of the subdomain and label in the
457 -- second option, however. This is explained in 'subdomain'.
458 --
459 data Subdomain =
460 SubdomainSingleLabel Label |
461 SubdomainMultipleLabel Label Subdomain
462 deriving (Eq, Show)
463
464 instance Pretty Subdomain where
465 pretty_show (SubdomainSingleLabel l) = pretty_show l
466 pretty_show (SubdomainMultipleLabel l s) =
467 (pretty_show l) ++ "." ++ (pretty_show s)
468
469 -- | Parse an RFC1035 \"subdomain\". The given grammar is,
470 --
471 -- <subdomain> ::= <label> | <subdomain> "." <label>
472 --
473 -- However, we have reversed the order of the subdomain and label to
474 -- prevent infinite recursion. The second option (subdomain + label)
475 -- is obviously more specific, we we need to try it first. This
476 -- presents a problem: we're trying to parse a subdomain in terms of
477 -- a subdomain! The given grammar represents subdomains how we like
478 -- to think of them; from right to left. But it's better to parse
479 -- from left to right, so we pick off the leading label and then
480 -- recurse into the definition of subdomain.
481 --
482 -- ==== _Examples_
483 --
484 -- >>> import Text.Parsec ( parseTest )
485 --
486 -- Make sure we can parse a single character:
487 --
488 -- >>> parseTest subdomain "a"
489 -- SubdomainSingleLabel (Label (Letter 'a') Nothing)
490 --
491 -- >>> pretty_print $ parse subdomain "" "example.com"
492 -- example.com
493 --
494 -- >>> pretty_print $ parse subdomain "" "www.example.com"
495 -- www.example.com
496 --
497 subdomain :: Parser Subdomain
498 subdomain = try both <|> just_one
499 where
500 both :: Parser Subdomain
501 both = do
502 l <- label
503 char '.'
504 s <- subdomain
505 return (SubdomainMultipleLabel l s)
506
507 just_one :: Parser Subdomain
508 just_one = fmap SubdomainSingleLabel label
509
510
511
512 -- * Domains
513
514 -- | An RFC1035 domain. According to RFC1035 a domain can be either a
515 -- subdomain or \" \", which according to RFC2181
516 -- <https://tools.ietf.org/html/rfc2181#section-11> means the root:
517 --
518 -- The zero length full name is defined as representing the root
519 -- of the DNS tree, and is typically written and displayed as
520 -- \".\".
521 --
522 -- We let the 'Domain' type remain true to those RFCs, even though
523 -- they don't support an absolute domain name of e.g. a single dot.
524 -- We have one more data type 'UserDomain' which handles the possibility
525 -- of an absolute path.
526 --
527 data Domain =
528 DomainName Subdomain |
529 DomainRoot
530 deriving (Eq, Show)
531
532 instance Pretty Domain where
533 pretty_show DomainRoot = ""
534 pretty_show (DomainName s) = pretty_show s
535
536 -- | Parse an RFC1035 \"domain\"
537 --
538 -- ==== _Examples_
539 --
540 -- >>> import Text.Parsec ( parseTest )
541 --
542 -- Make sure we can parse a single character:
543 --
544 -- >>> parseTest domain "a"
545 -- DomainName (SubdomainSingleLabel (Label (Letter 'a') Nothing))
546 --
547 -- And the empty domain:
548 --
549 -- >>> parseTest domain ""
550 -- DomainRoot
551 --
552 -- We will in fact parse the \"empty\" domain off the front of
553 -- pretty much anything:
554 --
555 -- >>> parseTest domain "8===D"
556 -- DomainRoot
557 --
558 -- Equality of domains is case-insensitive:
559 --
560 -- >>> let (Right r1) = parse domain "" "example.com"
561 -- >>> let (Right r2) = parse domain "" "ExaMPle.coM"
562 -- >>> r1 == r2
563 -- True
564 --
565 -- A single dot IS parsed as the root, but the dot isn't consumed:
566 --
567 -- >>> parseTest domain "."
568 -- DomainRoot
569 --
570 domain :: Parser Domain
571 domain = try parse_subdomain <|> parse_empty
572 where
573 parse_subdomain = fmap DomainName subdomain
574 parse_empty = string "" >> return DomainRoot
575
576
577
578 -- * User domains
579
580 -- | This type helps clarify some murkiness in the DNS \"domain\" name
581 -- specification. In RFC1034, it is acknowledged that a domain name
582 -- input with a trailing \".\" will represent an absolute domain
583 -- name (i.e. with respect to the DNS root). However, the grammar in
584 -- RFC1035 disallows a trailing dot.
585 --
586 -- This makes some sense: within the DNS, everything knows its
587 -- position in the tree. The relative/absolute distinction only
588 -- makes sense on the client side, where a user's resolver might
589 -- decide to append some suffix to a relative
590 -- request. Unfortunately, that's where we live. So we have to deal
591 -- with the possibility of having a trailing dot at the end of any
592 -- domain name.
593 --
594 data UserDomain =
595 UserDomainRelative Domain |
596 UserDomainAbsolute Domain
597 deriving (Eq, Show)
598
599 instance Pretty UserDomain where
600 pretty_show (UserDomainRelative d) = pretty_show d
601 pretty_show (UserDomainAbsolute d) = (pretty_show d) ++ "."
602
603
604 -- | Parse a 'UserDomain'. This is what we'll be using to read user
605 -- input, since it supports both relative and absolute domain names
606 -- (unlike the implicitly-absolute 'Domain').
607 --
608 -- ==== _Examples_
609 --
610 -- >>> import Text.Parsec ( parseTest )
611 --
612 -- We can really parse the root now!
613 --
614 -- >>> parseTest user_domain "."
615 -- UserDomainAbsolute DomainRoot
616 --
617 -- But multiple dots aren't (only the first):
618 --
619 -- >>> pretty_print $ parse user_domain "" ".."
620 -- .
621 --
622 -- We can also optionally have a trailing dot at the end of a
623 -- non-empty name:
624 --
625 -- >>> pretty_print $ parse user_domain "" "www.example.com"
626 -- www.example.com
627 --
628 -- >>> pretty_print $ parse user_domain "" "www.example.com."
629 -- www.example.com.
630 --
631 -- A \"relative root\" can also be parsed, letting the user's
632 -- resolver deal with it:
633 --
634 -- >>> parseTest user_domain ""
635 -- UserDomainRelative DomainRoot
636 --
637 user_domain :: Parser UserDomain
638 user_domain = try absolute <|> relative
639 where
640 absolute :: Parser UserDomain
641 absolute = do
642 d <- domain
643 r <- char '.'
644 return $ UserDomainAbsolute d
645
646 relative :: Parser UserDomain
647 relative = fmap UserDomainRelative domain