{-# LANGUAGE OverloadedStrings #-} -- Parser of email text module Data.SMTP.Parser.Resource (takeHeaders, parseHeaders) where import Data.SMTP.Types.Resource import qualified Data.SMTP.Types.Mime as Mime import Text.StringConvert import Control.Applicative ((<|>)) import Control.Monad import Data.Default.Class 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 :: ResourceData -> (PlainHeaders, ResourceData) takeHeaders dt = case Alz.parse parseHeaders dt of Alz.Fail{} -> (def, dt) Alz.Done dtb hh -> (hh, dtb) parseHeaders :: Parser PlainHeaders parseHeaders = do (pp, psep) <- parseHeadersGroup let (Mime.ContentTypeHeader ct _) = (fst $ getMimeData pp) if ct == Mime.MessageMime Mime.FcmtpResource then do -- Has sealed headers (ss, ssep) <- parseHeadersGroup return $ PlainHeaders pp ss (psep, ssep) else return $ PlainHeaders pp [] (psep, "") parseHeadersGroup :: Parser ([Header], ByteString) parseHeadersGroup = ( blankLine >>= (\l -> return ([], l)) ) <|> ( do h <- header (hh, l) <- parseHeadersGroup return (h:hh, l) ) -- 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') header :: Parser Header header = do k <- A.takeTill (\x -> elem x [':', '\r', '\n']) -- OverloadedStrings! char ':' when (BS.null k) $ fail "email header must have a name" sp <- A.takeWhile isSpace v <- scan Value headerValueScanner let k' = s . BS.reverse . BS.dropWhile W.isSpace . BS.reverse . BS.dropWhile W.isSpace $ k let v' = s . BS.reverse . BS.dropWhile A.isEndOfLine . BS.reverse $ v let b = BS.concat [k, ":", sp, v] return $ Header k' v' b 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"