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