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

{-# LANGUAGE OverloadedStrings #-}

module Data.SMTP.Parser.Mime where

import Data.Attoparsec.ByteString.Char8.Extras
import Data.SMTP.Types.Mime
import Text.StringConvert

import Data.Default.Class

import Control.Applicative ((<|>))
import Data.Attoparsec.ByteString.Char8
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.Char as C

parseContentType :: Parser (ContentType, ContentTypeParameters)
parseContentType = do
  mime <- (
    stringCI "multipart/" *>
    parseMultipart
    ) <|> (
    stringCI "message/" *>
    parseMessage
    ) <|> (
    ContentMime . s <$> takeTill endType
    )
  A.takeWhile endType
  pars <- parseContentTypeParameters
  return (mime, pars)
  where
    endType c = C.isSpace c || c == ';'
    parseMultipart :: Parser ContentType
    parseMultipart = (
      stringCI "vnd.dFCMTP.Digest" *>
      (return . MultiPartMime $ FcmtpDigest)
      ) <|> (do
                tp <- takeTill endType
                return . MultiPartMime . OtherMultiPartType $ "multipart/" ++ s tp
            )
    parseMessage :: Parser ContentType
    parseMessage = (
      do
        stringCI "vnd.dFCMTP.Resource"
        return . MessageMime $ FcmtpResource
      ) <|> (
      do
        tp <-  takeTill endType
        return . MessageMime . OtherMessageType $ "message/" ++ s tp
      )
parseContentTypeParameters :: Parser ContentTypeParameters
parseContentTypeParameters = parserFold parseContentTypeParameter def
parseContentTypeParameter :: Parser (ContentTypeParameters -> ContentTypeParameters)
parseContentTypeParameter = do
  A.takeWhile isSpace
  k' <- takeTill (\c -> C.isSpace c || c == '=')
  skipWhile isSpace
  let k = map C.toLower . s $ k'
  A.char '='
  A.skipWhile isSpace
  v' <- takeTill (\c -> C.isSpace c || c == ';')
  skipWhile isSpace
  let v = s v'
  case lookup k [
    ("boundary", \pp -> pp{boundary=Just v}),
    ("charset", \pp -> pp{charset=Just v})
    ] of
    Just f -> return f
    Nothing -> return (\pp -> pp{other = (k,v): other pp})


parseTransferEncoding :: Parser TransferEncoding
parseTransferEncoding = parseShowCI allEncodings
  where
    allEncodings = map IdentityEncoding [B7BitEncoding,
                                         B8BitEncoding,
                                         BBinaryEncoding] ++
                   [
                     QPEncodedBody,
                     Base64EncodedBody
                   ]

parseBodyEncoding :: Parser BodyEncoding
parseBodyEncoding = parseEnumCI