Last commit before BOOM.
parent
3314add2fb
commit
f81449c100
|
@ -102,11 +102,11 @@ render state
|
||||||
should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
|
should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
|
||||||
|
|
||||||
-- test_domains :: Array String -> _
|
-- test_domains :: Array String -> _
|
||||||
test_domains doms = fold $ map tests_on_domain doms
|
test_domains doms = map tests_on_domain doms
|
||||||
|
|
||||||
-- tests_on_domain :: String -> _
|
-- tests_on_domain :: String -> _
|
||||||
tests_on_domain d
|
tests_on_domain d
|
||||||
= [ Bulma.strong $ d <> " -> [ldhstr, label, subdomain, domain]"
|
= b [ Bulma.strong $ d <> " -> [ldhstr, label, subdomain, domain]"
|
||||||
, p $ d <> " : ldhstr : " <> (show $ runParser d ldhstr)
|
, p $ d <> " : ldhstr : " <> (show $ runParser d ldhstr)
|
||||||
, p $ d <> " : label : " <> (show $ runParser d label)
|
, p $ d <> " : label : " <> (show $ runParser d label)
|
||||||
, p $ d <> " : subdomain : " <> (show $ runParser d subdomain)
|
, p $ d <> " : subdomain : " <> (show $ runParser d subdomain)
|
||||||
|
@ -139,21 +139,24 @@ sub_eof = do
|
||||||
sub <- subdomain
|
sub <- subdomain
|
||||||
-- TODO: optional "." at the end?
|
-- TODO: optional "." at the end?
|
||||||
eof
|
eof
|
||||||
pure sub
|
if S.length sub > 255
|
||||||
|
then fail $ "domain length is > 255 bytes (" <> show (S.length sub) <> ")"
|
||||||
|
else pure sub
|
||||||
|
|
||||||
-- From RFC 1035: <subdomain> ::= <label> | <subdomain> "." <label>
|
-- From RFC 1035: <subdomain> ::= <label> | <subdomain> "." <label>
|
||||||
subdomain :: Parser String String
|
subdomain :: Parser String String
|
||||||
subdomain = defer \_ -> sub_point_label <|> label
|
subdomain = do
|
||||||
|
-- First: read a label. This is bare minimum for a subdomain.
|
||||||
sub_point_label :: Parser String String
|
|
||||||
sub_point_label = do
|
|
||||||
lab <- label
|
lab <- label
|
||||||
|
-- Second: the rest is optional. TODO
|
||||||
|
-- TODO
|
||||||
|
where
|
||||||
|
point_sub :: Parser String String
|
||||||
|
point_sub = do
|
||||||
point <- string "."
|
point <- string "."
|
||||||
sub <- defer \_ -> subdomain
|
sub <- defer \_ -> subdomain
|
||||||
let result = lab <> point <> sub
|
pure $ point <> sub
|
||||||
if S.length result > 255
|
|
||||||
then fail $ "domain length is > 255 bytes (" <> show (S.length result) <> ")"
|
|
||||||
else pure result
|
|
||||||
|
|
||||||
-- From RFC 1035: <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
|
-- From RFC 1035: <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
|
||||||
label :: Parser String String
|
label :: Parser String String
|
||||||
|
@ -162,7 +165,7 @@ label = let_then_str_then_alpha
|
||||||
let_then_str_then_alpha :: Parser String String
|
let_then_str_then_alpha :: Parser String String
|
||||||
let_then_str_then_alpha = do
|
let_then_str_then_alpha = do
|
||||||
l <- letter
|
l <- letter
|
||||||
s <- many let_dig_hyp
|
s <- ldhstr
|
||||||
case last s of
|
case last s of
|
||||||
Nothing -> pure $ CU.singleton l
|
Nothing -> pure $ CU.singleton l
|
||||||
Just last_char -> case runParser (CU.singleton last_char) alphaNum of
|
Just last_char -> case runParser (CU.singleton last_char) alphaNum of
|
||||||
|
@ -172,22 +175,13 @@ label = let_then_str_then_alpha
|
||||||
else pure $ CU.singleton l <> CU.fromCharArray (foldl (\acc x -> snoc acc x) [] s)
|
else pure $ CU.singleton l <> CU.fromCharArray (foldl (\acc x -> snoc acc x) [] s)
|
||||||
|
|
||||||
-- From RFC 1035: <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
|
-- From RFC 1035: <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
|
||||||
ldhstr :: Parser String String
|
ldhstr :: Parser String (Array Char)
|
||||||
ldhstr = PC.try ldh_then_str <|> just_ldh
|
ldhstr = many let_dig_hyp
|
||||||
where
|
|
||||||
just_ldh :: Parser String String
|
|
||||||
just_ldh = char_to_string let_dig_hyp
|
|
||||||
|
|
||||||
ldh_then_str :: Parser String String
|
|
||||||
ldh_then_str = do
|
|
||||||
ldh <- let_dig_hyp
|
|
||||||
str <- defer \_ -> ldhstr
|
|
||||||
pure $ CU.singleton ldh <> str
|
|
||||||
|
|
||||||
-- From RFC 1035: <let-dig-hyp> ::= <let-dig> | "-"
|
-- From RFC 1035: <let-dig-hyp> ::= <let-dig> | "-"
|
||||||
-- Either a Letter, Digital or an Hyphenation character.
|
-- Either a Letter, Digital or an Hyphenation character.
|
||||||
let_dig_hyp :: Parser String Char
|
let_dig_hyp :: Parser String Char
|
||||||
let_dig_hyp = let_dig <|> char '-'
|
let_dig_hyp = let_dig <|> char '-' -- TODO: push error
|
||||||
|
|
||||||
-- From RFC 1035: <let-dig> ::= <letter> | <digit>
|
-- From RFC 1035: <let-dig> ::= <letter> | <digit>
|
||||||
let_dig :: Parser String Char
|
let_dig :: Parser String Char
|
||||||
|
@ -196,8 +190,8 @@ let_dig = alphaNum
|
||||||
-- | Converting a single letter parser to a String parser.
|
-- | Converting a single letter parser to a String parser.
|
||||||
char_to_string :: Parser String Char -> Parser String String
|
char_to_string :: Parser String Char -> Parser String String
|
||||||
char_to_string p = do
|
char_to_string p = do
|
||||||
a <- p
|
character <- p
|
||||||
pure $ CU.singleton a
|
pure $ CU.singleton character
|
||||||
|
|
||||||
-- Not used currently.
|
-- Not used currently.
|
||||||
hyp_then_string :: Parser String String
|
hyp_then_string :: Parser String String
|
||||||
|
|
Loading…
Reference in New Issue