module HackMail.Data.ParseEmail
( Email (..)
, Header (..)
, Body (..)
, HeaderTok (..)
, parseEmail
, parseEmailFromFile
, matchHdr) where
import Text.ParserCombinators.Parsec
import Data.Char
import Data.Typeable
data Email = Email Header Body
deriving (Eq, Typeable)
instance Show Email where
show (Email header (Body ss)) = show header
++ (unlines (filter (/="\r") ss))
newtype Body = Body [String]
deriving (Eq, Typeable)
instance Show Body where
show (Body []) = "\n"
show (Body (x:xs)) = trim x ++ "\n" ++ (show xs)
data Header = HDR HeaderTok String Header
| STOP
deriving (Eq, Typeable)
instance Show Header where
show STOP = "\n"
show (HDR ht s nextHdr) = show ht ++ ": " ++ s ++ "\n"
++ show nextHdr
data HeaderTok = TO | DATE | FROM | SENDER | REPLYTO | CC | BCC | MESSAGEID | INREPLYTO | REFERENCES
| SUBJECT | KEYWORDS | XFIELD String
deriving (Eq, Read, Typeable)
instance Show HeaderTok where
show TO = "To"
show DATE = "Date"
show FROM = "From"
show SENDER = "Sender"
show REPLYTO = "Reply-To"
show CC = "Cc"
show BCC = "Bcc"
show MESSAGEID = "Message-ID"
show INREPLYTO = "In-Reply-To"
show REFERENCES = "References"
show SUBJECT = "Subject"
show KEYWORDS = "Keywords"
show (XFIELD s) = s
parseEmail e = parse parserEmail "" e
parseEmailFromFile path = parseFromFile parserEmail path
eol = try (string "\n\r")
<|> try (string "\r\n")
<|> string "\n"
<|> string "\r"
<?> "EOL character"
valueChar = anyChar
fieldChar = oneOf fieldChar'
fieldChar' = "<>"++['\33'..'\57']++['\59'..'\126']
parserEmail = do
header <- many1 parseHeaderline
eol
body <- buildBody
eof
let headerRet = buildHeader header
let bodyRet = Body body
return (Email headerRet bodyRet)
parseHeaderline = do
field <- many1 fieldChar
choice [try $ string ": \n", try $ string ": ", try $ string ":"]
value <- manyTill valueChar (try trueEndCond)
return (field, value)
buildHeader [] = STOP
buildHeader ((f,v):xs) = HDR (matchHdr f) v
$ buildHeader xs
matchHdr :: String -> HeaderTok
matchHdr s = match (map toUpper $ filter (isAlpha) s) s
match :: String -> String -> HeaderTok
match "TO" _ = TO
match "DATE" _ = DATE
match "FROM" _ = FROM
match "SENDER" _ = SENDER
match "REPLYTO" _ = REPLYTO
match "CC" _ = CC
match "BCC" _ = BCC
match "MESSAGEID" _ = MESSAGEID
match "INREPLYTO" _ = INREPLYTO
match "REFERENCES" _ = REFERENCES
match "SUBJECT" _ = SUBJECT
match "KEYWORDS" _ = KEYWORDS
match _ s' = XFIELD s'
buildBody = sepBy (many $ noneOf "\n\r") eol
trimLeft s = dropWhile isSpace s
trimRight s = reverse . trimLeft . reverse
trim = trimRight $ trimLeft
whitespace = oneOf "\t "
trueEndCond = do
eol
notFollowedBy whitespace