fcmtp-data/src/Data/SMTP/Parser/Email.hs

{-# 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"