WIP: RFC5322.
This commit is contained in:
parent
97b769133d
commit
59ce971e96
@ -8,7 +8,7 @@ import Control.Alt ((<|>))
|
||||
import Data.Array as A
|
||||
import Data.Char as C
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Maybe (Maybe(..), maybe)
|
||||
import Data.String.CodeUnits as CU
|
||||
|
||||
import GenericParser.Parser (Parser(..)
|
||||
@ -24,6 +24,9 @@ data EmailError
|
||||
= InvalidCharacter
|
||||
| InvalidDomain (Maybe DomainError)
|
||||
|
||||
id :: forall a. a -> a
|
||||
id x = x
|
||||
|
||||
-- | obs-FWS: obsolete folding white space.
|
||||
-- |
|
||||
-- | obs-FWS = 1*WSP *(CRLF 1*WSP)
|
||||
@ -95,44 +98,45 @@ cfws = do void $ many1 $ do _ <- tryMaybe fws
|
||||
-- | TODO: `address`: email address.
|
||||
-- |
|
||||
-- | address = mailbox / group
|
||||
--address :: forall e. Parser e String
|
||||
--address = mailbox <|> group
|
||||
address :: forall e. Parser e String
|
||||
address = mailbox <|> group
|
||||
|
||||
-- | TODO: `mailbox`: mail address.
|
||||
-- |
|
||||
-- | mailbox = name-addr / addr-spec
|
||||
--mailbox :: forall e. Parser e String
|
||||
--mailbox = name_addr <|> addr_spec
|
||||
mailbox :: forall e. Parser e String
|
||||
mailbox = name_addr <|> addr_spec
|
||||
|
||||
-- | TODO: `name_addr`: address name.
|
||||
-- |
|
||||
-- | name-addr = [display-name] angle-addr
|
||||
--name_addr :: forall e. Parser e String
|
||||
--name_addr = do _ <- tryMaybe display_name
|
||||
-- angle_addr
|
||||
name_addr :: forall e. Parser e String
|
||||
name_addr = do _ <- tryMaybe display_name
|
||||
angle_addr
|
||||
|
||||
-- | TODO: `angle_addr` address specification between '<' and '>' characters.
|
||||
-- |
|
||||
-- | angle-addr = [CFWS] "<" addr-spec ">" [CFWS] / obs-angle-addr
|
||||
--angle_addr :: forall e. Parser e String
|
||||
--angle_addr = do _ <- tryMaybe cfws
|
||||
-- _ <- char '<'
|
||||
-- a <- addr_spec
|
||||
-- _ <- char '>'
|
||||
-- _ <- tryMaybe cfws
|
||||
-- pure a
|
||||
-- <|> obs_angle_addr
|
||||
angle_addr :: forall e. Parser e String
|
||||
angle_addr = do _ <- tryMaybe cfws
|
||||
_ <- char '<'
|
||||
a <- addr_spec
|
||||
_ <- char '>'
|
||||
_ <- tryMaybe cfws
|
||||
pure a
|
||||
<|> obs_angle_addr
|
||||
|
||||
-- | TODO: `group`: a list of email addresses.
|
||||
-- |
|
||||
-- | group = display-name ":" [group-list] ";" [CFWS]
|
||||
--group :: forall e. Parser e (Array String)
|
||||
--group = do _ <- display_name
|
||||
-- _ <- char ':'
|
||||
-- mg <- tryMaybe group_list
|
||||
-- _ <- char ';'
|
||||
-- _ <- tryMaybe cfws
|
||||
-- pure $ maybe [] xs
|
||||
group :: forall e. Parser e String
|
||||
group = do _ <- display_name
|
||||
_ <- char ':'
|
||||
xs <- tryMaybe group_list
|
||||
_ <- char ';'
|
||||
_ <- tryMaybe cfws
|
||||
let res = ":" <> maybe "" id xs <> ";"
|
||||
pure res
|
||||
|
||||
-- | `display_name`: displayed name, not the actual email address.
|
||||
-- |
|
||||
@ -140,11 +144,25 @@ cfws = do void $ many1 $ do _ <- tryMaybe fws
|
||||
display_name :: forall e. Parser e String
|
||||
display_name = phrase
|
||||
|
||||
--mailbox-list = (mailbox *("," mailbox)) / obs-mbox-list
|
||||
--
|
||||
-- | `mailbox_list`
|
||||
-- |
|
||||
-- | mailbox-list = (mailbox *("," mailbox)) / obs-mbox-list
|
||||
mailbox_list :: forall e. Parser e String
|
||||
mailbox_list = do mb <- mailbox
|
||||
xs <- A.many $ do _ <- char ','
|
||||
mx <- mailbox
|
||||
pure $ "," <> mx
|
||||
pure $ mb <> A.fold xs
|
||||
<|> obs_mbox_list
|
||||
|
||||
--address-list = (address *("," address)) / obs-addr-list
|
||||
--
|
||||
--group-list = mailbox-list / CFWS / obs-group-list
|
||||
|
||||
-- | `group_list`
|
||||
-- |
|
||||
-- | group-list = mailbox-list / CFWS / obs-group-list
|
||||
group_list :: forall e. Parser e String
|
||||
group_list = mailbox_list <|> do _ <- cfws <|> obs_group_list
|
||||
pure ""
|
||||
|
||||
|
||||
-- | `atext`: atom accepted characters.
|
||||
@ -221,9 +239,21 @@ specials = char '('
|
||||
<|> char '"'
|
||||
|
||||
|
||||
-- addr-spec = local-part "@" domain
|
||||
--
|
||||
-- local-part = dot-atom / quoted-string / obs-local-part
|
||||
-- | `addr_spec`
|
||||
-- |
|
||||
-- | addr-spec = local-part "@" domain
|
||||
addr_spec :: forall e. Parser e String
|
||||
addr_spec = do lpart <- local_part
|
||||
_ <- char '@'
|
||||
dom <- domain
|
||||
pure $ lpart <> "@" <> dom
|
||||
|
||||
-- | `local_part`
|
||||
-- |
|
||||
-- | local-part = dot-atom / quoted-string / obs-local-part
|
||||
local_part :: forall e. Parser e String
|
||||
local_part = dot_atom <|> quoted_string <|> obs_local_part
|
||||
|
||||
|
||||
-- | `domain`
|
||||
-- |
|
||||
@ -258,14 +288,14 @@ dtext = CU.singleton <$> sat cond <|> obs_dtext
|
||||
-- | TODO: `obs_angle_addr`: obsolete address specification between '<' and '>' characters.
|
||||
-- |
|
||||
-- | obs-angle-addr = [CFWS] "<" obs-route addr-spec ">" [CFWS]
|
||||
--obs_angle_addr :: forall e. Parser e String
|
||||
--obs_angle_addr = do _ <- tryMaybe cfws
|
||||
-- _ <- char '<'
|
||||
-- r <- obs_route
|
||||
-- a <- addr_spec
|
||||
-- _ <- char '>'
|
||||
-- _ <- tryMaybe cfws
|
||||
-- pure $ r <> a
|
||||
obs_angle_addr :: forall e. Parser e String
|
||||
obs_angle_addr = do _ <- tryMaybe cfws
|
||||
_ <- char '<'
|
||||
r <- obs_route
|
||||
a <- addr_spec
|
||||
_ <- char '>'
|
||||
_ <- tryMaybe cfws
|
||||
pure $ r <> a
|
||||
|
||||
-- | `obs_route`
|
||||
-- |
|
||||
@ -285,14 +315,41 @@ obs_domain_list = do _ <- A.many $ cfws <|> do _ <- char ','
|
||||
_ <- char '@'
|
||||
domain
|
||||
|
||||
--obs-mbox-list = *([CFWS] ",") mailbox *("," [mailbox / CFWS])
|
||||
--
|
||||
-- | `obs_mbox_list`
|
||||
-- |
|
||||
-- | obs-mbox-list = *([CFWS] ",") mailbox *("," [mailbox / CFWS])
|
||||
obs_mbox_list :: forall e. Parser e String
|
||||
obs_mbox_list = do _ <- A.many $ do _ <- cfws
|
||||
_ <- char ','
|
||||
pure unit
|
||||
mb <- mailbox
|
||||
xs <- A.many $ do _ <- char ','
|
||||
x <- mailbox <|> do _ <- cfws
|
||||
pure ""
|
||||
pure x
|
||||
pure $ mb <> A.fold xs
|
||||
|
||||
--obs-addr-list = *([CFWS] ",") address *("," [address / CFWS])
|
||||
--
|
||||
--obs-group-list = 1*([CFWS] ",") [CFWS]
|
||||
--
|
||||
--obs-local-part = word *("." word)
|
||||
--
|
||||
|
||||
-- | `obs_group_list`
|
||||
-- |
|
||||
-- | obs-group-list = 1*([CFWS] ",") [CFWS]
|
||||
obs_group_list :: forall e. Parser e Unit
|
||||
obs_group_list = do _ <- many1 $ do _ <- tryMaybe cfws
|
||||
char ','
|
||||
_ <- tryMaybe cfws
|
||||
pure unit
|
||||
|
||||
-- | `obs_local_part`
|
||||
-- |
|
||||
-- | obs-local-part = word *("." word)
|
||||
obs_local_part :: forall e. Parser e String
|
||||
obs_local_part = do w <- word
|
||||
ws <- A.many $ do _ <- char '.'
|
||||
w1 <- word
|
||||
pure $ "." <> w1
|
||||
pure $ w <> A.fold ws
|
||||
|
||||
-- | `obs_domain`
|
||||
-- |
|
||||
-- | obs-domain = atom *("." atom)
|
||||
@ -476,20 +533,20 @@ quoted_string = do _ <- tryMaybe cfws
|
||||
-- | (a) the first character is a letter,
|
||||
-- | (b) the last character is either a letter or a digit.
|
||||
-- | The rest can be any letter, digit, '-' or '.'.
|
||||
local_part :: Parser EmailError String
|
||||
local_part = do firstchar <- letter
|
||||
rest <- until end (letter <|> digit <|> char '-' <|> char '.')
|
||||
lastchar <- letter <|> digit
|
||||
pure $ CU.fromCharArray $ [firstchar] <> rest <> [lastchar]
|
||||
where
|
||||
end :: forall e. Parser e Char
|
||||
end = do c <- item
|
||||
_ <- char '@'
|
||||
pure c
|
||||
local_part' :: Parser EmailError String
|
||||
local_part' = do firstchar <- letter
|
||||
rest <- until end (letter <|> digit <|> char '-' <|> char '.')
|
||||
lastchar <- letter <|> digit
|
||||
pure $ CU.fromCharArray $ [firstchar] <> rest <> [lastchar]
|
||||
where
|
||||
end :: forall e. Parser e Char
|
||||
end = do c <- item
|
||||
_ <- char '@'
|
||||
pure c
|
||||
|
||||
-- | `email` is the parser for email addresses.
|
||||
email :: Parser EmailError String
|
||||
email = do login <- local_part
|
||||
email = do login <- local_part'
|
||||
_ <- char '@'
|
||||
input <- current_input
|
||||
case parse sub_eof input of
|
||||
|
||||
Loading…
Reference in New Issue
Block a user