module Network.Parser.Rfc2822 where
import Control.Monad (join)
import Control.Applicative as A hiding (many)
import Data.Attoparsec
import qualified Data.Attoparsec.Char8 as AC
import qualified Data.Attoparsec.FastSet as F (fromList, memberWord8)
import Data.ByteString as W hiding (concat,intersperse, group)
import Data.ByteString.Char8 as C hiding (concat,intersperse,group)
import Data.ByteString.Internal (c2w, w2c)
import Data.Word (Word8)
import Prelude hiding (take, takeWhile)
import Network.Parser.RfcCommon hiding (ctext)
import Network.Parser.Rfc2234
import qualified Data.Map as M
import Prelude hiding (id)
import Data.List hiding (group)
no_ws_ctl_pred w = w == 32 || ctl_pred w
no_ws_ctl = satisfy no_ws_ctl_pred
text = satisfy $ \w ->
(w >= 1 && w<=9)
|| w == 11
|| w == 12
|| (w >= 14 && w<=127)
specialsSet ::[Word8]
specialsSet = [40,41,60,62,91,93,58,59,64,92,44,46,34]
specials_pred :: Word8 -> Bool
specials_pred w = F.memberWord8 w (F.fromList specialsSet)
specials :: Parser Word8
specials = satisfy specials_pred
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])
atext_pred w = char_pred w && not (ctl_pred w || sp_pred w || specials_pred w)
atext = satisfy atext_pred
atom :: Parser [Word8]
atom = option [] cfws *> many1 atext <* option [] cfws
dot_atom_text :: Parser [Word8]
dot_atom_text = concat . intersperse [46] <$> sepBy (many1 atext) (word8 46)
dot_atom :: Parser [Word8]
dot_atom = option [] cfws *> dot_atom_text <* option [] cfws
qtext_pred :: Word8 -> Bool
qtext_pred w = no_ws_ctl_pred w
|| w == 33
|| (w >= 35 && w <= 91)
|| (w >= 93 && w <= 126)
qtext :: Parser Word8
qtext = satisfy qtext_pred
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
if Data.List.null n
then return (NameAddress Nothing (W.pack a))
else return (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 l = concat . intersperse [32] $ l
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
dtext_pred w = no_ws_ctl_pred w || (w>=33 && w<=90) || (w>=94 && w<= 126)
dtext = satisfy dtext_pred
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)