97 lines
3.6 KiB
Plaintext
97 lines
3.6 KiB
Plaintext
-- | `DomainParser` is a simple parser for domain names as described in RFC 1035.
|
|
module DomainParser where
|
|
|
|
import Prelude (bind, discard, pure, show, ($), (<>), (>))
|
|
|
|
import Control.Alt ((<|>))
|
|
import Control.Lazy (defer)
|
|
import Data.Array.NonEmpty as NonEmpty
|
|
import Data.Either (Either(..))
|
|
import Data.Maybe (Maybe(..))
|
|
import Data.String as S -- length
|
|
import Data.String.CodeUnits as CU
|
|
-- import Data.String.Regex as R
|
|
-- import Data.String.Regex.Flags as RF
|
|
import Data.Tuple (Tuple(..))
|
|
import Parsing.Combinators.Array (many1)
|
|
import Parsing.Combinators as PC
|
|
import Parsing (Parser, fail, runParser)
|
|
import Parsing.String.Basic (alphaNum, letter)
|
|
import Parsing.String (char, string, eof)
|
|
|
|
-- | From RFC 1035: <domain> ::= <subdomain> | " "
|
|
-- |
|
|
-- | Accepting an optional '.' at the end of the subdomain doesn't conform
|
|
-- | to the (prefered) syntax of a domain as described in RFC 1035.
|
|
-- | However, this last '.' character should be acceptable in most applications.
|
|
-- | In some cases, a fully qualified domain name (FQDN) such as `example.com.`
|
|
-- | has to be differenciated from a "relative" name (www).
|
|
domain :: Parser String String
|
|
domain = PC.try (string " ") <|> sub_eof
|
|
|
|
sub_eof :: Parser String String
|
|
sub_eof = do
|
|
sub <- subdomain
|
|
maybe_final_point <- PC.optionMaybe (char '.')
|
|
eof
|
|
let parsed_domain = did_we_parsed_the_final_point maybe_final_point sub
|
|
if S.length parsed_domain > 255
|
|
then fail $ "domain length is > 255 bytes (" <> show (S.length parsed_domain) <> ")"
|
|
else pure parsed_domain
|
|
where
|
|
did_we_parsed_the_final_point Nothing sub = sub
|
|
did_we_parsed_the_final_point (Just _) sub = sub <> "."
|
|
|
|
-- From RFC 1035: <subdomain> ::= <label> | <subdomain> "." <label>
|
|
subdomain :: Parser String String
|
|
subdomain = do
|
|
-- First: read a label. This is bare minimum for a subdomain.
|
|
lab <- label
|
|
-- Second: the rest is optional.
|
|
r <- PC.optionMaybe (PC.try point_sub)
|
|
case r of
|
|
Nothing -> pure lab
|
|
Just sub -> pure $ lab <> sub
|
|
|
|
where
|
|
point_sub :: Parser String String
|
|
point_sub = do
|
|
point <- string "."
|
|
sub <- defer \_ -> subdomain
|
|
pure $ point <> sub
|
|
|
|
-- From RFC 1035: <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
|
|
label :: Parser String String
|
|
label = let_then_str_then_alpha <|> char_to_string letter
|
|
where
|
|
let_then_str_then_alpha :: Parser String String
|
|
let_then_str_then_alpha = do
|
|
Tuple whole_label last_char <- PC.try do
|
|
l <- letter
|
|
s <- ldhstr
|
|
pure $ Tuple (CU.singleton l <> (CU.fromCharArray $ NonEmpty.toArray s)) (NonEmpty.last s)
|
|
case runParser (CU.singleton last_char) let_dig of
|
|
Left _ -> fail $ "Label is wrong: last char is '" <> (CU.singleton last_char) <> "' which isn't an alphanum"
|
|
Right _ -> if S.length whole_label > 63 -- Remember: we already did read a letter (l).
|
|
then fail $ "Label is larger than expected (max 63 characters, current: " <> show (S.length whole_label) <> ")"
|
|
else pure whole_label
|
|
|
|
-- From RFC 1035: <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
|
|
ldhstr :: Parser String (NonEmpty.NonEmptyArray Char)
|
|
ldhstr = many1 let_dig_hyp
|
|
|
|
-- From RFC 1035: <let-dig-hyp> ::= <let-dig> | "-"
|
|
-- Either a Letter, Digital or an Hyphenation character.
|
|
let_dig_hyp :: Parser String Char
|
|
let_dig_hyp = let_dig <|> char '-' <|> fail "invalid character"
|
|
|
|
-- From RFC 1035: <let-dig> ::= <letter> | <digit>
|
|
let_dig :: Parser String Char
|
|
let_dig = alphaNum
|
|
|
|
-- | Converting a single letter parser to a String parser.
|
|
char_to_string :: Parser String Char -> Parser String String
|
|
char_to_string p = do
|
|
character <- p
|
|
pure $ CU.singleton character
|