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

{-# LANGUAGE OverloadedStrings #-}

module Data.SMTP.Mime (
  module Data.SMTP.Types.Mime,
  module Data.SMTP.Parser.Mime,
  getMimeData,
  reencodeMessage,
  requiredEncoding,
  splitEach
  ) where

import Data.SMTP.Types.Mime
import Data.SMTP.Parser.Mime

import Data.SMTP.Types.Resource
import Data.SMTP.Parser.Resource

import Text.StringConvert

import qualified Data.Attoparsec.ByteString.Char8.Extras as P
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.Char as C
import Data.ByteString (ByteString)
import Data.Word8 (Word8)
import qualified Data.Word8 as W
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Base64.Lazy as B64
import qualified Data.ByteString.Lazy.Search as LSearch
--import qualified Data.ByteString.Search as SSearch

import Data.Default.Class

getMimeData :: [Header] -> (ContentTypeHeader, TransferEncoding)
getMimeData hh = (ct, te)
  where
    ct = case getHeader hh contentTypeHeaderName of
      Nothing -> def
      Just (Header (_, cth)) -> case A.parseOnly parseContentType (s cth) of
        Left _ -> def
        Right (ctv, ctp) -> ContentTypeHeader ctv ctp
    te = case getHeader hh transferEncodingHeaderName of
      Nothing -> def
      Just (Header (_, teh)) -> case A.parseOnly parseTransferEncoding (C8.pack teh) of
        Left _ -> def
        Right t -> t

{- |
Required encoding for the given data.

Will evaluate the entire data, thus using a lot of memory.

7/8 bit mime is available for data where all lines are shorter then 1000 bytes.

7 bit mime is available ofr that where no byte is larger than 128 or equal 0.

othersiwe data requires binarymime.
-}
requiredEncoding :: ResourceData -> BodyEncoding
requiredEncoding dt = case requiredFeatures 0 $ LBS.unpack dt of
  (False, False) -> B7BitEncoding
  (False, True) -> B8BitEncoding
  (True, _) -> BBinaryEncoding
  where
    requiredFeatures :: Int -> [Word8] -> (Bool, Bool)
    requiredFeatures _ [] = (False, False)
    requiredFeatures len (c:cc) = let
      nlen = if c == (fromIntegral . C.ord $ '\n') then 0 else len+1
      (ll, ee) = requiredFeatures nlen cc
      in (len >= 1000 || ll, c == 0 || c >= 128 || ee)


reencodeMessage :: BodyEncoding -> ResourceData -> ResourceData
reencodeMessage toEncoding dt = LBS.concat [
  if newEncoding == fromEncoding then LBS.fromStrict $ BS.concat dthh else replaceEncodingHeader newEncoding dthh,
  "\r\n",
  reencodeBody'
  ]
  where
    (dthh, hh, dtb) = takeHeaders dt
    (ct, fromEncoding) = getMimeData hh
    fromEncoding' = transferToBody fromEncoding
    (message, multiPart, separator) = case ct of
      (ContentTypeHeader (MultiPartMime _) (ContentTypeParameters (Just sep) _ _)) -> (False, True, C8.pack sep)
      (ContentTypeHeader (MessageMime _) _ ) -> (True, False, "")
      _ -> (False, False, "")
    newEncoding :: TransferEncoding
    newEncoding = case (fromEncoding', toEncoding, multiPart) of
      (_, BBinaryEncoding, _) -> fromEncoding
      (BBinaryEncoding, B8BitEncoding, True) -> IdentityEncoding B7BitEncoding
      (_, B8BitEncoding, _) -> fromEncoding
      (_, B7BitEncoding, True) -> IdentityEncoding B7BitEncoding
      (BBinaryEncoding, B7BitEncoding, False) -> Base64EncodedBody
      (B8BitEncoding, B7BitEncoding, False) -> Base64EncodedBody
      _ -> fromEncoding
    newEncoding' = transferToBody newEncoding
    reencodeBody' :: ResourceData
    reencodeBody'
      | newEncoding == fromEncoding = dtb
      | message = reencodeBody newEncoding dtb
      | multiPart = concatParts separator . map (reencodeMessage newEncoding') . splitParts separator $ dtb
      | otherwise = reencodeBody newEncoding dtb

reencodeBody :: TransferEncoding -> ResourceData -> ResourceData
reencodeBody (IdentityEncoding _) dt = dt
reencodeBody Base64EncodedBody dt = LBS.intercalate "\r\n" $ splitEach 76 $ B64.encode dt
reencodeBody QPEncodedBody dt = dt

splitEach :: Int -> LBS.ByteString -> [LBS.ByteString]
splitEach n t
  | LBS.null t = []
  | otherwise = let (p, pp) = LBS.splitAt (fromIntegral n) t
                in p : splitEach n pp

splitParts :: ByteString -> LBS.ByteString -> [LBS.ByteString]
splitParts sep dt = map manageChunk chunks
  where
    sep' = BS.concat ["\r\n--", sep]
    chunks = LSearch.split sep' dt
    manageChunk = LBS.dropWhile (== P.asW8 '-') . LBS.dropWhile A.isHorizontalSpace . LBS.dropWhile A.isEndOfLine

concatParts :: ByteString -> [LBS.ByteString] -> LBS.ByteString
concatParts sep = joinChunks (LBS.fromStrict sep)
  where
    joinChunks _ [] = ""
    joinChunks _ [c] = c
    joinChunks sep' [c1, c2] = LBS.concat [c1, "\r\n--", sep', "--\r\n", c2]
    joinChunks sep' (c:cc2) = LBS.concat [c, "\r\n--", sep', "\r\n", joinChunks sep' cc2]

replaceEncodingHeader :: TransferEncoding -> [ByteString] -> LBS.ByteString
replaceEncodingHeader enc = LBS.concat . map LBS.fromStrict . echoAndReplace
  where
    h = transferEncodingHeaderName
    echoAndReplace [] = []
    echoAndReplace (l:ll) = if isPrefixCI h l
                            then BS.concat [C8.pack h, ": ", C8.pack . show $ enc, "\r\n"] :
                                 dropWhile (\x -> BS.null x || (W.isSpace . BS.head $ x)) ll
                            else l : echoAndReplace ll
                                 

isPrefixCI :: String -> ByteString -> Bool
isPrefixCI [] _ = True
isPrefixCI (c:cc) bs = case BS.uncons bs of
  Nothing -> False
  Just (h, t) -> (C.toUpper . C.chr . fromIntegral $ h) == C.toUpper c && isPrefixCI cc t