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

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