123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687 |
- {-# LANGUAGE OverloadedStrings #-}
- -- Parser of email text
- module Data.SMTP.Parser.Email (parseHeaders, takeHeaders) where
- import Data.SMTP.Types.Email
- import Text.StringConvert
- import Control.Applicative ((<|>))
- import Control.Monad
- import Data.Attoparsec.ByteString.Char8
- import qualified Data.Attoparsec.ByteString.Char8 as A
- import qualified Data.Attoparsec.ByteString.Lazy as Alz
- import qualified Data.ByteString as BS
- import Data.ByteString (ByteString)
- import qualified Data.Word8 as W
- import qualified Data.Char as C
- {- |
- Splits the data into headers and body,
- also, parses the headers, returning both
- the bare headers data and the parsed result.
- Returns: (headers data, headers, body)
- Notice that this function chomps the lone CRLF
- that separates the body from the headers.
- -}
- takeHeaders :: EmailData -> ([ByteString], [Header], EmailData)
- takeHeaders dt = case Alz.parse parseHeadersAndReturn dt of
- Alz.Fail{} -> ([], [], dt)
- Alz.Done dtb (dth, hh) -> (dth, hh, dtb)
- parseHeaders :: Parser [Header]
- parseHeaders = snd <$> parseHeadersAndReturn
- parseHeadersAndReturn :: Parser ([ByteString], [Header])
- parseHeadersAndReturn = (
- do
- blankLine
- return ([], [])
- ) <|> (
- do
- (dth, h) <- headerAndReturn
- (dthh, hh) <- parseHeadersAndReturn
- return (dth:dthh, h:hh)
- )
- -- header :: Parser Header
- -- header = do
- -- key <- A.takeTill (== ':')
- -- char ':'
- -- if BS.null key then failParser else return ()
- -- skipSpace
- -- value <- scan Value headerValueScanner
- -- let key' = s . BS.reverse . (BS.dropWhile W.isSpace) . BS.reverse . (BS.dropWhile W.isSpace) $ key
- -- let value' = s . BS.reverse . (BS.dropWhile A.isEndOfLine) . BS.reverse $ value
- -- return $ Header (key', value')
- headerAndReturn :: Parser (ByteString, Header)
- headerAndReturn = do
- key <- A.takeTill (== ':')
- char ':'
- when (BS.null key) $ fail "email header must have a name"
- sp <- A.takeWhile isSpace
- value <- scan Value headerValueScanner
- let key' = s . BS.reverse . BS.dropWhile W.isSpace . BS.reverse . BS.dropWhile W.isSpace $ key
- let value' = s . BS.reverse . BS.dropWhile A.isEndOfLine . BS.reverse $ value
- return (BS.concat [key, sp, value], Header (key', value'))
- data HeaderScanStatus = Value | CR | LF
- headerValueScanner :: HeaderScanStatus -> Char -> Maybe HeaderScanStatus
- headerValueScanner Value c
- | c == '\r' = Just CR
- | c == '\n' = Just LF
- | otherwise = Just Value
- headerValueScanner CR c
- | c == '\r' = Just CR
- | c == '\n' = Just LF
- | otherwise = Nothing
- headerValueScanner LF c
- | isHorizontalSpace . fromIntegral .C.ord $ c = Just Value
- | otherwise = Nothing
- blankLine :: Parser ByteString
- blankLine = string "\n" <|> string "\r\n"
|