module Network.Parser.Rfc2822 where
import Control.Applicative as A hiding (many)
import Control.Monad (join)
import Data.Attoparsec
import qualified Data.Attoparsec.Char8 as AC
import Data.ByteString as W hiding (concat, group,
intersperse)
import Data.ByteString.Char8 as C hiding (concat, group,
intersperse)
import Data.ByteString.Internal (c2w, w2c)
import Data.List hiding (group)
import qualified Data.Map as M
import Data.Word (Word8)
import Prelude hiding (take, takeWhile)
import Prelude hiding (id)
import Network.Parser.Rfc2234
import Network.Parser.RfcCommon hiding (ctext)
no_ws_ctlPred w = w == 32 || ctlPred w
no_ws_ctl = satisfy no_ws_ctlPred
text = satisfy $ \w ->
(w >= 1 && w<=9)
|| w == 11
|| w == 12
|| (w >= 14 && w<=127)
specialsPred :: Word8 -> Bool
specialsPred = inClass "()<>[]:;@\\,.\""
specials :: Parser Word8
specials = satisfy specialsPred
wsps :: Parser [Word8]
wsps = many1 wsp
fws :: Parser [Word8]
fws = return [32] <$> many1 (choice [wsps, crlf *> wsps])
ctext :: Parser Word8
ctext = crlf <|> no_ws_ctl <|> satisfy rest
where
rest w = (w >= 33 && w <= 39)
|| (w >= 42 && w <= 91)
|| (w >= 93 && w <= 126)
comment :: Parser [Word8]
comment = do
word8 40
r1 <- many' ccontent
r2 <- option [] fws
word8 41
return $ join r1 ++ r2
where
ccontent :: Parser [Word8]
ccontent = try $ do r1 <- option [] fws
r2 <- choice [many1 ctext, quotedPair, comment]
return $ r1 ++ r2
cfws = concat <$> many1 (choice [fws, comment])
atextPred w = charPred w && not (ctlPred w || spPred w || specialsPred w)
atext = satisfy atextPred
atom :: Parser [Word8]
atom = option [] cfws *> many1 atext <* option [] cfws
dot_atom_text :: Parser [Word8]
dot_atom_text = Data.List.intercalate [46] <$> sepBy (many1 atext) (word8 46)
dot_atom :: Parser [Word8]
dot_atom = option [] cfws *> dot_atom_text <* option [] cfws
qtextPred :: Word8 -> Bool
qtextPred w = no_ws_ctlPred w
|| w == 33
|| (w >= 35 && w <= 91)
|| (w >= 93 && w <= 126)
qtext :: Parser Word8
qtext = satisfy qtextPred
qcontent = option [] (asList qtext) <|> quotedPair
quoted_string = do
option [] cfws
dquote
r1 <- concat <$> many' (do
r1 <- option [] fws
r2 <- qcontent
return (r1 ++ r2))
r2 <- option [] fws
dquote
option [] cfws
return $ [34] ++ r1 ++ r2 ++ [34]
word = atom <|> quotedString
phrase :: Parser [[Word8]]
phrase = many1 word
utext = no_ws_ctl <|> satisfy (\w -> w>=33 && w<=126)
address :: Parser [NameAddress]
address = try (asList mailbox)
<|> group
mailbox :: Parser NameAddress
mailbox = try name_addr
<|> do a <- addr_spec
return $ NameAddress Nothing (W.pack a)
name_addr :: Parser NameAddress
name_addr = do n <- option [] display_name
a <- angle_addr
return $ if Data.List.null n
then NameAddress Nothing (W.pack a)
else NameAddress (Just . W.pack $ n) (W.pack a)
angle_addr :: Parser [Word8]
angle_addr = do
option [] cfws
word8 60
a <- addr_spec
word8 62
option [] cfws
return a
group :: Parser [NameAddress]
group = do
display_name
word8 58
r <- option [] mailbox_list
option [] cfws
word8 59
option [] cfws
return r
display_name = ret <$> phrase
where ret = Data.List.intercalate [32]
mailbox_list = sepBy mailbox (word8 44)
address_list = sepBy address (word8 44)
addr_spec :: Parser [Word8]
addr_spec = ret <$> local_part <*> word8 64 <*> domain
where ret l m r = l ++ [m] ++ r
local_part = dot_atom <|> quotedString
domain = dot_atom <|> domain_literal
domain_literal = do
option [] cfws
word8 91
r <- many' (option [] fws *> dcontent)
word8 92
return $ [91] ++ concat r ++ [92]
dcontent = try (do r <- dtext
return [r])
<|> quotedPair
dtextPred w = no_ws_ctlPred w || (w>=33 && w<=90) || (w>=94 && w<= 126)
dtext = satisfy dtextPred
message_id = AC.stringCI "message-id:" *> msg_id
msg_id = do
option [] cfws
word8 60
r <- res <$> id_left <*> word8 64 <*> id_right
word8 62
option [] cfws
return r
where res l m r = l ++ [m] ++ r
id_left :: Parser [Word8]
id_left = dot_atom_text <|> no_fold_quote
id_right :: Parser [Word8]
id_right = dot_atom_text <|> no_fold_literal
no_fold_quote = do
l <- dquote
m <- concat <$> many' (option [] (asList qtext) <|> quotedPair)
r <- dquote
return $ [l] ++ m ++ [r]
no_fold_literal = do
l <- word8 91
m <- concat <$> many' (option [] (asList dtext) <|> quotedPair)
r <- word8 93
return $ [l] ++ m ++ [r]
data NameAddress
= NameAddress
{ naName :: Maybe ByteString
, naAddr :: ByteString
} deriving (Eq, Show)