Last commit before BOOM.

beta
Philippe Pittoli 2023-07-23 15:36:12 +02:00
parent 3314add2fb
commit f81449c100
1 changed files with 27 additions and 33 deletions

View File

@ -102,16 +102,16 @@ render state
should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
-- 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 d
= [ Bulma.strong $ d <> " -> [ldhstr, label, subdomain, domain]"
, p $ d <> " : ldhstr : " <> (show $ runParser d ldhstr)
, p $ d <> " : label : " <> (show $ runParser d label)
, p $ d <> " : subdomain : " <> (show $ runParser d subdomain)
, p $ d <> " : domain : " <> (show $ runParser d domain)
]
= b [ Bulma.strong $ d <> " -> [ldhstr, label, subdomain, domain]"
, p $ d <> " : ldhstr : " <> (show $ runParser d ldhstr)
, p $ d <> " : label : " <> (show $ runParser d label)
, p $ d <> " : subdomain : " <> (show $ runParser d subdomain)
, p $ d <> " : domain : " <> (show $ runParser d domain)
]
aye :: Parser String Char
aye = defer \_ -> char 'a' *> aye
@ -139,21 +139,24 @@ sub_eof = do
sub <- subdomain
-- TODO: optional "." at the end?
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>
subdomain :: Parser String String
subdomain = defer \_ -> sub_point_label <|> label
sub_point_label :: Parser String String
sub_point_label = do
subdomain = do
-- First: read a label. This is bare minimum for a subdomain.
lab <- label
point <- string "."
sub <- defer \_ -> subdomain
let result = lab <> point <> sub
if S.length result > 255
then fail $ "domain length is > 255 bytes (" <> show (S.length result) <> ")"
else pure result
-- Second: the rest is optional. TODO
-- TODO
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
@ -162,7 +165,7 @@ label = let_then_str_then_alpha
let_then_str_then_alpha :: Parser String String
let_then_str_then_alpha = do
l <- letter
s <- many let_dig_hyp
s <- ldhstr
case last s of
Nothing -> pure $ CU.singleton l
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)
-- From RFC 1035: <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
ldhstr :: Parser String String
ldhstr = PC.try ldh_then_str <|> just_ldh
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
ldhstr :: Parser String (Array Char)
ldhstr = many 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 '-'
let_dig_hyp = let_dig <|> char '-' -- TODO: push error
-- From RFC 1035: <let-dig> ::= <letter> | <digit>
let_dig :: Parser String Char
@ -196,8 +190,8 @@ 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
a <- p
pure $ CU.singleton a
character <- p
pure $ CU.singleton character
-- Not used currently.
hyp_then_string :: Parser String String