-- | 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, -- -- -- module Domain where import Data.Char ( toLower ) import Text.Parsec ( ParseError, (<|>), alphaNum, char, eof, many1, option, optionMaybe, parse, string, try, unexpected ) import qualified Text.Parsec as Parsec ( digit, letter) import Text.Parsec.String ( Parser ) newtype Domain = Domain String deriving Show -- | The derived instance of 'Eq' for domain names is incorrect. All -- comparisons are currently 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... -- -- So to compare two DNS names, we compare their lower-case -- counterparts. -- instance Eq Domain where (Domain d1) == (Domain d2) = (map toLower d1) == (map toLower d2) -- * Digits newtype Digit = Digit Char deriving (Eq, Show) digit :: Parser Digit digit = fmap Digit Parsec.digit -- * Letters newtype Letter = Letter Char deriving (Eq, Show) letter :: Parser Letter letter = fmap Letter Parsec.letter -- * Letters/Digits data LetDig = LetDigLetter Letter | LetDigDigit Digit deriving (Eq, Show) let_dig :: Parser LetDig let_dig = (fmap LetDigLetter letter) <|> (fmap LetDigDigit digit) -- * Hyphens newtype Hyphen = Hyphen Char deriving (Eq, Show) hyphen :: Parser Hyphen hyphen = fmap Hyphen (char '-') -- * Letter, Digit, or Hyphen. data LetDigHyp = LetDigHypLetDig LetDig | LetDigHypHyphen Hyphen deriving (Eq, Show) -- | The following is the simplest type in the domain grammar that -- isn't already implemented for us. -- -- ::= | -- -- ==== _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: -- -- ::= | -- -- These are represented as either a single instance of a -- 'LetDigHyp', or a string of them (recursive). -- -- ==== _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: -- -- LdhStr (LetDigHypLetter (Letter 'a')) (LdhStr (LetDigHypDigit (Digit '0')) (LdhStr (LetDigHypHyphen (Hyphen '-')) (LdhStrSingleLdh (LetDigHypLetter (Letter 'b'))))) -- data LdhStr = LdhStrSingleLdh LetDigHyp | LdhStrMultipleLdh LetDigHyp LdhStr deriving (Eq, Show) 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_ -- -- >>> 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_ -- -- >>> 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_ -- -- >>> 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, -- --