module Text.Email.Parser
(addrSpec
,localPart
,domainPart
,EmailAddress
,toByteString)
where
import Control.Applicative
import qualified Data.ByteString.Char8 as BS
import Data.ByteString (ByteString)
import Data.Char (chr)
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.Combinator
import Data.Data (Data, Typeable)
import GHC.Generics (Generic)
import qualified Text.Read as Read
data EmailAddress = EmailAddress ByteString ByteString
deriving (Eq, Ord, Data, Typeable, Generic)
instance Show EmailAddress where
show = show . toByteString
instance Read EmailAddress where
readListPrec = Read.readListPrecDefault
readPrec = Read.parens (do
bs <- Read.readPrec
case parseOnly addrSpec bs of
Left _ -> Read.pfail
Right a -> return a)
toByteString (EmailAddress l d) = BS.concat [l, BS.singleton '@', d]
localPart :: EmailAddress -> ByteString
localPart (EmailAddress local _) = local
domainPart :: EmailAddress -> ByteString
domainPart (EmailAddress _ domain) = domain
addrSpec = do
localPart <- local
char '@'
domainPart <- domain
endOfInput
return (EmailAddress localPart domainPart)
local = dottedAtoms
domain = dottedAtoms <|> domainLiteral
dottedAtoms = BS.intercalate (BS.singleton '.') <$>
(optional cfws *> (atom <|> quotedString) <* optional cfws) `sepBy1` (char '.')
atom = takeWhile1 isAtomText
isAtomText x = isAlphaNum x || inClass "!#$%&'*+/=?^_`{|}~-" x
domainLiteral = (BS.cons '[' . flip BS.snoc ']' . BS.concat) <$> (between (optional cfws *> char '[') (char ']' <* optional cfws) $
many (optional fws >> takeWhile1 isDomainText) <* optional fws)
isDomainText x = inClass "\33-\90\94-\126" x || isObsNoWsCtl x
quotedString = (\x -> BS.concat $ [BS.singleton '"', BS.concat x, BS.singleton '"']) <$> (between (char '"') (char '"') $
many (optional fws >> quotedContent) <* optional fws)
quotedContent = takeWhile1 isQuotedText <|> quotedPair
isQuotedText x = inClass "\33\35-\91\93-\126" x || isObsNoWsCtl x
quotedPair = (BS.cons '\\' . BS.singleton) <$> (char '\\' *> (vchar <|> wsp <|> lf <|> cr <|> obsNoWsCtl <|> nullChar))
cfws = ignore $ many (comment <|> fws)
fws :: Parser ()
fws = ignore $
ignore (wsp1 >> optional (crlf >> wsp1))
<|> ignore (many1 (crlf >> wsp1))
ignore :: Parser a -> Parser ()
ignore x = x >> return ()
between l r x = l *> x <* r
comment :: Parser ()
comment = ignore ((between (char '(') (char ')') $
many (ignore commentContent <|> fws)))
commentContent = skipWhile1 isCommentText <|> ignore quotedPair <|> comment
isCommentText x = inClass "\33-\39\42-\91\93-\126" x || isObsNoWsCtl x
nullChar = char '\0'
skipWhile1 x = satisfy x >> skipWhile x
wsp1 = skipWhile1 isWsp
wsp = satisfy isWsp
isWsp x = x == ' ' || x == '\t'
isAlphaNum x = isDigit x || isAlpha_ascii x
cr = char '\r'
lf = char '\n'
crlf = cr >> lf >> return ()
isVchar = inClass "\x21-\x7e"
vchar = satisfy isVchar
isObsNoWsCtl = inClass "\1-\8\11-\12\14-\31\127"
obsNoWsCtl = satisfy isObsNoWsCtl