Add the Reversible class.

[dead/harbl.git] / harbl / src / Network / DNS / RBL / Domain.hs

{-# LANGUAGE DoAndIfThenElse #-}

-- | The 'Domain' data type and its parser. A 'Domain' represents a
--   name in the domain name system (DNS) as described by
--   RFC1035. In particular, we enforce the restrictions from Section
--   2.3.1 \"Preferred name syntax\". See for example,
--
--     <https://tools.ietf.org/html/rfc1035#section-2.3.1>
--
--   We basically work with strings and characters everywhere, even
--   though this isn't really correct. The length specifications in
--   the RFCs are all in terms of octets, so really a ByteString.Char8
--   would be more appropriate. With strings, for example, we could
--   have a unicode mumbo jumbo character that takes up two bytes
--   (octets).
--
module Network.DNS.RBL.Domain (
  Domain(..),
  domain )
where

import Data.Char ( toLower )
import Text.Parsec (
  (<|>),
  char,
  optionMaybe,
  string,
  try )
import qualified Text.Parsec as Parsec ( digit, letter)
import Text.Parsec.String ( Parser )

import Network.DNS.RBL.Pretty ( Pretty(..) )
import Network.DNS.RBL.Reversible ( Reversible(..) )

-- * Digits

-- | A wrapper around a digit character.
--
newtype Digit = Digit Char deriving (Eq, Show)
instance Pretty Digit where pretty_show (Digit d) = [d]

-- | Parse a single digit, but wrap it in our 'Digit' type.
--
digit :: Parser Digit
digit = fmap Digit Parsec.digit


-- * Letters

-- | A wrapper around a letter character.
--
newtype Letter = Letter Char deriving (Show)
instance Pretty Letter where pretty_show (Letter l) = [l]


-- | Parse a single letter, but wrap it in our 'Letter' type.
--
letter :: Parser Letter
letter = fmap Letter Parsec.letter

-- | The derived instance of 'Eq' for letters is incorrect. All
--   comparisons should be made case-insensitively. The following
--   is an excerpt from RFC1035:
--
--     2.3.3. Character Case
--
--     For all parts of the DNS that are part of the official
--     protocol, all comparisons between character strings (e.g.,
--     labels, domain names, etc.)  are done in a case-insensitive
--     manner...
--
--   Since each part of DNS name is composed of our custom types, it
--   suffices to munge the equality for 'Letter'. RFC4343
--   <https://tools.ietf.org/html/rfc4343> clarifies the
--   case-insensitivity rules, but the fact that we're treating DNS
--   names as strings makes most of those problems go away (in
--   exchange for new ones).
--
instance Eq Letter where
  (Letter l1) == (Letter l2) = (toLower l1) == (toLower l2)

-- * Letters/Digits

-- | A sum type representing either a letter or a digit.
--
data LetDig =
  LetDigLetter Letter |
  LetDigDigit  Digit
  deriving (Eq, Show)

instance Pretty LetDig where
  pretty_show (LetDigLetter l) = pretty_show l
  pretty_show (LetDigDigit d) = pretty_show d

-- | Parse a letter or a digit and wrap it in our 'LetDig' type.
--
let_dig :: Parser LetDig
let_dig = (fmap LetDigLetter letter) <|> (fmap LetDigDigit digit)


-- * Hyphens

-- | A wrapper around a single hyphen character.
--
newtype Hyphen = Hyphen Char deriving (Eq, Show)
instance Pretty Hyphen where pretty_show (Hyphen h) = [h]

-- | Parse a single hyphen and wrap it in our 'Hyphen' type.
--
hyphen :: Parser Hyphen
hyphen = fmap Hyphen (char '-')


-- * Letter, Digit, or Hyphen.

-- | A sum type representing a letter, digit, or hyphen.
--
data LetDigHyp =
  LetDigHypLetDig LetDig |
  LetDigHypHyphen Hyphen
  deriving (Eq, Show)

instance Pretty LetDigHyp where
  pretty_show (LetDigHypLetDig ld) = pretty_show ld
  pretty_show (LetDigHypHyphen h) = pretty_show h


-- | The following is the simplest type in the domain grammar that
--   isn't already implemented for us.
--
--     <let-dig> ::= <letter> | <digit>
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parseTest )
--
--   Letters, digits, and hyphens are all parsed:
--
--   >>> parseTest let_dig_hyp "a"
--   LetDigHypLetDig (LetDigLetter (Letter 'a'))
--
--   >>> parseTest let_dig_hyp "7"
--   LetDigHypLetDig (LetDigDigit (Digit '7'))
--
--   >>> parseTest let_dig_hyp "-"
--   LetDigHypHyphen (Hyphen '-')
--
--   However, an underscore (for example) is not:
--
--   >>> parseTest let_dig_hyp "_"
--   parse error at (line 1, column 1):
--   unexpected "_"
--   expecting letter, digit or "-"
--
let_dig_hyp :: Parser LetDigHyp
let_dig_hyp =
  parse_letdig <|> parse_hyphen
  where
    parse_letdig :: Parser LetDigHyp
    parse_letdig = fmap LetDigHypLetDig let_dig

    parse_hyphen :: Parser LetDigHyp
    parse_hyphen = fmap LetDigHypHyphen hyphen


-- * Letter/Digit/Hyphen strings

-- | A string of letters, digits, and hyphens from the RFC1035 grammar:
--
--     <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
--
--   These are represented as either a single instance of a
--   'LetDigHyp', or a string of them (recursive).
--
data LdhStr =
  LdhStrSingleLdh LetDigHyp |
  LdhStrMultipleLdh LetDigHyp LdhStr
  deriving (Eq, Show)

instance Pretty LdhStr where
  pretty_show (LdhStrSingleLdh ldh) = pretty_show ldh
  pretty_show (LdhStrMultipleLdh ldh s) = (pretty_show ldh) ++ (pretty_show s)

-- | Parse a string of letters, digits, and hyphens (an 'LdhStr').
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parseTest )
--
--   Single letters, digits, and hyphens are parsed:
--
--   >>> parseTest ldh_str "a"
--   LdhStrSingleLdh (LetDigHypLetDig (LetDigLetter (Letter 'a')))
--
--   >>> parseTest ldh_str "0"
--   LdhStrSingleLdh (LetDigHypLetDig (LetDigDigit (Digit '0')))
--
--   >>> parseTest ldh_str "-"
--   LdhStrSingleLdh (LetDigHypHyphen (Hyphen '-'))
--
--   As well as strings of them:
--
--   >>> import Text.Parsec ( parse )
--   >>> pretty_print $ parse ldh_str "" "a0-b"
--   a0-b
--
ldh_str :: Parser LdhStr
ldh_str = try both <|> just_one
  where
    both :: Parser LdhStr
    both = do
      ldh1 <- let_dig_hyp
      ldh_tail <- ldh_str
      return $ LdhStrMultipleLdh ldh1 ldh_tail

    just_one :: Parser LdhStr
    just_one = fmap LdhStrSingleLdh let_dig_hyp



-- | A version of 'last' that works on a 'LdhStr' rather than a
--   list. That is, it returns the last 'LetDigHyp' in the
--   string. Since 'LdhStr' contains at least one character, there's
--   no \"nil\" case here.
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parse )
--
--   >>> let (Right r) = parse ldh_str "" "a"
--   >>> last_ldh_str r
--   LetDigHypLetDig (LetDigLetter (Letter 'a'))
--
--   >>> let (Right r) = parse ldh_str "" "abc-def"
--   >>> last_ldh_str r
--   LetDigHypLetDig (LetDigLetter (Letter 'f'))
--
last_ldh_str :: LdhStr -> LetDigHyp
last_ldh_str (LdhStrSingleLdh x) = x
last_ldh_str (LdhStrMultipleLdh _ x) = last_ldh_str x


-- | A version of 'init' that works on a 'LdhStr' rather than a
--   list. That is, it returns everything /except/ the last character in
--   the string.
--
--   Since an 'LdhStr' must contain at least one character, this might
--   not be opssible (when the input is of length one). So, we return
--   a 'Maybe' value.
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parse )
--
--   >>> let (Right r) = parse ldh_str "" "a"
--   >>> init_ldh_str r
--   Nothing
--
--   >>> let (Right r) = parse ldh_str "" "ab"
--   >>> init_ldh_str r
--   Just (LdhStrSingleLdh (LetDigHypLetDig (LetDigLetter (Letter 'a'))))
--
--   >>> let (Right r) = parse ldh_str "" "abc-def"
--   >>> init_ldh_str r
--   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')))))))))
--
init_ldh_str :: LdhStr -> Maybe LdhStr
init_ldh_str (LdhStrSingleLdh _) = Nothing
init_ldh_str (LdhStrMultipleLdh h t) =
  Just $ case (init_ldh_str t) of
           -- We just got the second-to-last character, we're done.
           Nothing   -> LdhStrSingleLdh h

           -- There's still more stuff. Recurse.
           Just rest -> LdhStrMultipleLdh h rest


-- | Compute the length of an 'LdhStr'. It will be at least one, since
--   'LdhStr's are non-empty. And if there's something other than the
--   first character present, we simply recurse.
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parse )
--
--   >>> let (Right r) = parse ldh_str "" "a"
--   >>> length_ldh_str r
--   1
--
--   >>> let (Right r) = parse ldh_str "" "abc-def"
--   >>> length_ldh_str r
--   7
--
length_ldh_str :: LdhStr -> Int
length_ldh_str (LdhStrSingleLdh _) = 1
length_ldh_str (LdhStrMultipleLdh _ t) = 1 + (length_ldh_str t)

-- * Letter/Digit/Hyphen string followed by a trailing Letter/Digit

-- | This type isn't explicitly part of the grammar, but it's what
--   shows up in the square brackets of,
--
--     <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
--
--   The ldh-str is optional, but if one is present, we must also have
--   a trailing let-dig to prevent the name from ending with a
--   hyphen. This can be represented with a @Maybe LdhStrLetDig@,
--   which is why we're about to define it.
--
data LdhStrLetDig = LdhStrLetDig (Maybe LdhStr) LetDig
  deriving (Eq, Show)

instance Pretty LdhStrLetDig where
  pretty_show (LdhStrLetDig Nothing ld) = pretty_show ld
  pretty_show (LdhStrLetDig (Just s) ld) = (pretty_show s) ++ (pretty_show ld)

-- | Parse an 'LdhStrLetDig'. This isn't in the grammar, but we might
--   as well define the parser for it independently since we gave it
--   its own data type.
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parse, parseTest )
--
--   Make sure we can parse a single character:
--
--   >>> parseTest ldh_str_let_dig "a"
--   LdhStrLetDig Nothing (LetDigLetter (Letter 'a'))
--
--   And longer strings:
--
--   >>> pretty_print $ parse ldh_str_let_dig "" "ab"
--   ab
--
--   >>> pretty_print $ parse ldh_str_let_dig "" "-b"
--   -b
--
--   >>> parseTest ldh_str_let_dig "b-"
--   parse error at (line 1, column 3):
--   label cannot end with a hyphen
--
ldh_str_let_dig :: Parser LdhStrLetDig
ldh_str_let_dig = do
  -- This will happily eat up the trailing let-dig...
  full_ldh <- ldh_str

  -- So we have to go back and see what happened.
  case (last_ldh_str full_ldh) of
    (LetDigHypHyphen _) -> fail "label cannot end with a hyphen"
    (LetDigHypLetDig ld) ->
      -- Ok, the label didn't end with a hyphen; now we need to split
      -- off the last letter/digit so we can pack it into our return
      -- type separately.
      return $ case (init_ldh_str full_ldh) of
                 -- We only parsed one letter/digit. This can happen
                 -- if the label contains two characters. For example,
                 -- if we try to parse the label "ab", then the "a"
                 -- will be eaten by the label parser, and this
                 -- function will be left with only "b".
                 Nothing -> LdhStrLetDig Nothing ld

                 -- Usual case: there's was some leading let-dig-hyp junk,
                 -- return it too.
                 leading_ldhs -> LdhStrLetDig leading_ldhs ld



-- | Compute the length of a 'LdhStrLetDig'. It's at least one, since
--   the let-dig at the end is always there. And when there's an
--   ldh-str too, we add its length to one.
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parse )
--
--   >>> let (Right r) = parse ldh_str_let_dig "" "a"
--   >>> length_ldh_str_let_dig r
--   1
--
--   >>> let (Right r) = parse ldh_str_let_dig "" "abc-def"
--   >>> length_ldh_str_let_dig r
--   7
--
length_ldh_str_let_dig :: LdhStrLetDig -> Int
length_ldh_str_let_dig (LdhStrLetDig Nothing _) = 1
length_ldh_str_let_dig (LdhStrLetDig (Just ldhstring) _) =
  1 + (length_ldh_str ldhstring)


-- * Labels

-- | The label type from the RFC1035 grammar:
--
--     <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
--
--   We allow the slightly more general syntax from RFC1123, Section 2.1:
--
--     The syntax of a legal Internet host name was specified in RFC-952
--     [DNS:4].  One aspect of host name syntax is hereby changed: the
--     restriction on the first character is relaxed to allow either a
--     letter or a digit.  Host software MUST support this more liberal
--     syntax.
--
data Label = Label LetDig (Maybe LdhStrLetDig)
  deriving (Eq, Show)

instance Pretty Label where
  pretty_show (Label l Nothing) = pretty_show l
  pretty_show (Label l (Just s)) = (pretty_show l) ++ (pretty_show s)

-- | Parse a 'Label'.
--
--   In addition to the grammar, there's another restriction on
--   labels: their length must be 63 characters or less. Quoting
--   Section 2.3.1, \"Preferred name syntax\", of RFC1035:
--
--     The labels must follow the rules for ARPANET host names.  They
--     must start with a letter, end with a letter or digit, and have
--     as interior characters only letters, digits, and hyphen.  There
--     are also some restrictions on the length.  Labels must be 63
--     characters or less.
--
--   We check this only after we have successfully parsed a label.
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parse, parseTest )
--
--   Make sure we can parse a single character:
--
--   >>> parseTest label "a"
--   Label (LetDigLetter (Letter 'a')) Nothing
--
--   And longer strings:
--
--   >>> pretty_print $ parse label "" "abc-def"
--   abc-def
--
--   But not anything ending in a hyphen:
--
--   >>> parseTest label "abc-"
--   parse error at (line 1, column 5):
--   label cannot end with a hyphen
--
--   Or anything over 63 characters:
--
--   >>> parseTest label (['a'..'z'] ++ ['a'..'z'] ++ ['a'..'z'])
--   parse error at (line 1, column 79):
--   labels must be 63 or fewer characters
--
--   However, /exactly/ 63 characters is acceptable:
--
--   >>> pretty_print $ parse label "" (replicate 63 'x')
--   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--
--   Ensure that a label can begin with a digit:
--
--   >>> pretty_print $ parse label "" "3com"
--   3com
--
label :: Parser Label
label = do
  l <- let_dig -- Guaranteed to be there
  maybe_s <- optionMaybe ldh_str_let_dig -- Might not be there
  case maybe_s of
    -- It can only be one character long, from the letter...
    Nothing -> return $ Label l maybe_s

    -- The letter gives us one character, so we check that the rest is
    -- less than 62 characters long. But in the error message we need
    -- to report 63.
    Just s  -> if (length_ldh_str_let_dig s) <= 62
              then return $ Label l maybe_s
              else fail "labels must be 63 or fewer characters"



-- * Subdomains


-- | The data type representing a \"subdomain\" from RFC1035:
--
--     <subdomain> ::= <label> | <subdomain> "." <label>
--
--   We have reversed the order of the subdomain and label in the
--   second option, however. This is explained in 'subdomain'.
--
data Subdomain =
  SubdomainSingleLabel Label |
  SubdomainMultipleLabel Label Subdomain
  deriving (Eq, Show)



instance Pretty Subdomain where
  pretty_show (SubdomainSingleLabel l) = pretty_show l
  pretty_show (SubdomainMultipleLabel l s) =
    (pretty_show l) ++ "." ++ (pretty_show s)


instance Reversible Subdomain where
  -- | Reverse the labels of the given subdomain.
  --
  --   ==== _Examples_
  --
  --   >>> import Text.Parsec ( parse )
  --
  --   Standard usage:
  --
  --   >>> let (Right r) = parse subdomain "" "com"
  --   >>> pretty_print $ backwards r
  --   com
  --
  --   >>> let (Right r) = parse subdomain "" "example.com"
  --   >>> pretty_print $ backwards r
  --   com.example
  --
  --   >>> let (Right r) = parse subdomain "" "www.example.com"
  --   >>> pretty_print $ backwards r
  --   com.example.www
  --
  --   >>> let (Right r) = parse subdomain "" "new.www.example.com"
  --   >>> pretty_print $ backwards r
  --   com.example.www.new
  --

  -- It's easy to reverse a single label...
  backwards s@(SubdomainSingleLabel _) = s

  -- For multiple labels we have two cases. The first is where we have
  -- exactly two labels, and we just need to swap them.
  backwards (SubdomainMultipleLabel l (SubdomainSingleLabel m)) =
    SubdomainMultipleLabel m (SubdomainSingleLabel l)

  -- And now the hard case. If we reversed @s@, then the "head" of
  -- the result (@last_s@) should be the last label in the entire
  -- subdomain. Stick @last_s@ on the front of the result. That makes
  -- enough sense.
  --
  -- But what to do about the rest? We need to get \"init s\"
  -- somehow. Well, we have the reverse of it... why not waste a bunch
  -- of time and reverse that, too? With @init s@ in hand, we can
  -- prepend @l@ to that, and THEN reverse the entire thing. What we'll
  -- wind up with looks like @[last_s, init_s_rev, l]@ which you can
  -- pretend you recognize as the subdomain in reverse.
  --
  backwards (SubdomainMultipleLabel l s) =
    case (backwards s) of
      SubdomainMultipleLabel last_s init_s_rev ->
        let init_s = backwards init_s_rev
        in
          SubdomainMultipleLabel
            last_s
            (backwards (SubdomainMultipleLabel l init_s))

      -- Reversing a multiple label thing gives you back a multiple
      -- label thing but there's no way to promise that.
      impossible -> impossible



-- | Parse an RFC1035 \"subdomain\". The given grammar is,
--
--     <subdomain> ::= <label> | <subdomain> "." <label>
--
--   However, we have reversed the order of the subdomain and label to
--   prevent infinite recursion. The second option (subdomain + label)
--   is obviously more specific, we we need to try it first. This
--   presents a problem: we're trying to parse a subdomain in terms of
--   a subdomain! The given grammar represents subdomains how we like
--   to think of them; from right to left. But it's better to parse
--   from left to right, so we pick off the leading label and then
--   recurse into the definition of subdomain.
--
--   According to RFC1034, Section 3.1, two neighboring labels in a
--   DNS name cannot be equal:
--
--     Each node has a label, which is zero to 63 octets in length.  Brother
--     nodes may not have the same label, although the same label can be used
--     for nodes which are not brothers.  One label is reserved, and that is
--     the null (i.e., zero length) label used for the root.
--
--   We enforce this restriction, but the result is usually that we
--   only parse the part of the subdomain leading up to the repeated
--   label.
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parse, parseTest )
--
--   Make sure we can parse a single character:
--
--   >>> parseTest subdomain "a"
--   SubdomainSingleLabel (Label (LetDigLetter (Letter 'a')) Nothing)
--
--   >>> pretty_print $ parse subdomain "" "example.com"
--   example.com
--
--   >>> pretty_print $ parse subdomain "" "www.example.com"
--   www.example.com
--
--   We reject a subdomain with equal neighbors, but this leads to
--   only the single first label being parsed instead:
--
--   >>> pretty_print $ parse subdomain "" "www.www.example.com"
--   www
--
--   But not one with a repeated but non-neighboring label:
--
--   >>> pretty_print $ parse subdomain "" "www.example.www.com"
--   www.example.www.com
--
subdomain :: Parser Subdomain
subdomain = try both <|> just_one
  where
    both :: Parser Subdomain
    both = do
      l <- label
      _ <- char '.'
      s <- subdomain
      let result = SubdomainMultipleLabel l s
      if (subdomain_has_equal_neighbors result)
      then fail "subdomain cannot have equal neighboring labels"
      else return result

    just_one :: Parser Subdomain
    just_one = fmap SubdomainSingleLabel label



-- | Retrieve a list of labels contained in a 'Subdomain'.
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parse )
--
--   >>> let (Right r) = parse subdomain "" "a"
--   >>> pretty_print $ subdomain_labels r
--   ["a"]
--
--   >>> let (Right r) = parse subdomain "" "example.com"
--   >>> pretty_print $ subdomain_labels r
--   ["example","com"]
--
--   >>> let (Right r) = parse subdomain "" "www.example.com"
--   >>> pretty_print $ subdomain_labels r
--   ["www","example","com"]
--
subdomain_labels :: Subdomain -> [Label]
subdomain_labels (SubdomainSingleLabel l) = [l]
subdomain_labels (SubdomainMultipleLabel l s) = l : (subdomain_labels s)


-- | Return a list of pairs of neighboring labels in a subdomain.
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parse )
--   >>> let (Right r) = parse subdomain "" "www.example.com"
--   >>> pretty_print $ subdomain_label_neighbors r
--   ["(\"www\",\"example\")","(\"example\",\"com\")"]
--
subdomain_label_neighbors :: Subdomain -> [(Label,Label)]
subdomain_label_neighbors s =
  zip ls (tail ls)
  where
    ls = subdomain_labels s


-- | Return @True@ if the subdomain has any two equal neighboring
--   labels, and @False@ otherwise.
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parse )
--
--   >>> let (Right r) = parse subdomain "" "www.example.com"
--   >>> subdomain_has_equal_neighbors r
--   False
--
--   >>> let (Right l) = parse label "" "www"
--   >>> let (Right s) = parse subdomain "" "www.example.com"
--   >>> let bad_subdomain = SubdomainMultipleLabel l s
--   >>> subdomain_has_equal_neighbors bad_subdomain
--   True
--
subdomain_has_equal_neighbors :: Subdomain -> Bool
subdomain_has_equal_neighbors s =
  or [ x == y | (x,y) <- subdomain_label_neighbors s ]




-- * Domains

-- | An RFC1035 domain. According to RFC1035 a domain can be either a
-- subdomain or \" \", which according to RFC2181
-- <https://tools.ietf.org/html/rfc2181#section-11> means the root:
--
--      The zero length full name is defined as representing the root
--      of the DNS tree, and is typically written and displayed as
--      \".\".
--
--   We let the 'Domain' type remain true to those RFCs, even though
--   they don't support an absolute domain name of e.g. a single dot.
--
data Domain =
  DomainName Subdomain |
  DomainRoot
  deriving (Eq, Show)

instance Pretty Domain where
  pretty_show DomainRoot = ""
  pretty_show (DomainName s) = pretty_show s

-- | Parse an RFC1035 \"domain\"
--
--   ==== _Examples_
--
--   >>> import Text.Parsec ( parse, parseTest )
--
--   Make sure we can parse a single character:
--
--   >>> pretty_print $ parse domain "" "a"
--   a
--
--   And the empty domain:
--
--   >>> parseTest domain ""
--   DomainRoot
--
--   We will in fact parse the \"empty\" domain off the front of
--   pretty much anything:
--
--   >>> parseTest domain "!8===D"
--   DomainRoot
--
--   Equality of domains is case-insensitive:
--
--   >>> let (Right r1) = parse domain "" "example.com"
--   >>> let (Right r2) = parse domain "" "ExaMPle.coM"
--   >>> r1 == r2
--   True
--
--   A single dot IS parsed as the root, but the dot isn't consumed:
--
--   >>> parseTest domain "."
--   DomainRoot
--
--   Anything over 255 characters is an error, so the root will be
--   parsed:
--
--   >>> let big_l1 = replicate 63 'x'
--   >>> let big_l2 = replicate 63 'y' -- Avoid equal neighboring labels!
--   >>> let big_labels = big_l1 ++ "." ++ big_l2 ++ "."
--   >>> let big_subdomain = concat $ replicate 3 big_labels
--   >>> parseTest domain big_subdomain
--   DomainRoot
--
--   But exactly 255 is allowed:
--
--   >>> import Data.List ( intercalate )
--   >>> let l1 = replicate 63 'w'
--   >>> let l2 = replicate 63 'x'
--   >>> let l3 = replicate 63 'y'
--   >>> let l4 = replicate 63 'z'
--   >>> let big_subdomain = intercalate "." [l1,l2,l3,l4]
--   >>> let (Right r) = parse domain "" big_subdomain
--   >>> length (pretty_show r)
--   255
--
domain :: Parser Domain
domain = try parse_subdomain <|> parse_empty
  where
    parse_subdomain :: Parser Domain
    parse_subdomain = do
      s <- subdomain
      if length (pretty_show s) <= 255
      then return $ DomainName s
      else fail "subdomains can be at most 255 characters"

    parse_empty :: Parser Domain
    parse_empty = string "" >> return DomainRoot


instance Reversible Domain where
  -- | Reverse the labels of a 'Domain'.
  --
  --   --   ==== _Examples_
  --
  --   >>> import Text.Parsec ( parse )
  --
  --   The root reverses to itself:
  --
  --   >>> let (Right r) = parse domain "" ""
  --   >>> backwards r
  --   DomainRoot
  --
  --   >>> let (Right r) = parse domain "" "new.www.example.com"
  --   >>> pretty_print $ backwards r
  --   com.example.www.new
  --
  backwards DomainRoot = DomainRoot
  backwards (DomainName s) = DomainName $ backwards s