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 Text.StringConvert as SC

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

{- |
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 $ originalData hh else replaceEncodingHeader newEncoding hh,
  "\r\n",
  reencodeBody'
  ]
  where
    (hh, dtb) = takeHeaders dt
    (ct, fromEncoding) = getMimeData . public $ 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 -> PlainHeaders -> LBS.ByteString
replaceEncodingHeader enc hh = LBS.fromStrict . originalData $ hh{public = map replaceHeader . public $ hh}
  where
    k = transferEncodingHeaderName
    replaceHeader h = if hasKey k h
                      then Header{key=k, value=show enc,
                                  bare = BS.concat [SC.s k, ": ", SC.s . show $ enc, "\r\n"]}
                      else h