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