diff --git a/Codec/MIME/String/Flatten.hs b/Codec/MIME/String/Flatten.hs --- a/Codec/MIME/String/Flatten.hs +++ b/Codec/MIME/String/Flatten.hs @@ -1,18 +1,14 @@ module Codec.MIME.String.Flatten - (flatten, flattenXXX, Attachments, Attachment) + (flatten, Attachments, Attachment) where import qualified Codec.Binary.Base64.String as Base64 (encode) -import Codec.MIME.String.Date -import Codec.MIME.String.EncodedWord import qualified Codec.MIME.String.QuotedPrintable as QP (encode) import Codec.MIME.String.Headers import Codec.MIME.String.Internal.Utils -import Codec.MIME.String.Parse import Codec.MIME.String.Types -import Data.List (intersperse) {- XXX For message IDs: import Network.BSD (getHostName) @@ -24,34 +20,27 @@ type Attachments = [Attachment] type Attachment = (String, FilePath, Maybe ContentType) --- XXX This has the API of the old function. Should go at some point. --- Flatten {meta info, message body and list of attachments} to a raw message -flattenXXX :: String -> String -> String -> FullDate -> String -> Attachments - -> IO String -flattenXXX from_name from_email subject date body attachments - = let -- XXX This (\n) could be prettier - check llengths of bits - from_full = encode_name from_name ++ "\n <" ++ from_email ++ ">" - headers = [mk_header ["From " ++ from_email - ++ " " ++ show_mbox_full_date date], - mk_header ["Date: " ++ show_full_date date], - mk_header ["From: " ++ from_full], - mk_header ["Subject: " ++ mk_subject subject]] - in flatten headers body attachments - --- XXX This should take a headers structure -flatten :: Headers -> String -> Attachments -> IO String -flatten headers body attachments +-- XXX This should be rewritten in a more compositional way! +flatten :: Headers -> String -> Maybe String -> Attachments -> IO String +flatten headers body maybeHtmlBody attachments = do -- XXX Could add one of one isn't already found? msgid <- mk_msgid let -- XXX This (\n) could be prettier - check llengths of bits - boundary = "=:" - part_start = "\n--" ++ boundary ++ "\n" - parts_end = "\n--" ++ boundary ++ "--\n" + alternativeBoundary = "=:A" + alternativePartStart = "\n--" ++ alternativeBoundary ++ "\n" + alternativePartsEnd = "\n--" ++ alternativeBoundary ++ "--\n" + mixedBoundary = "=:M" + mixedPartStart = "\n--" ++ mixedBoundary ++ "\n" + mixedPartsEnd = "\n--" ++ mixedBoundary ++ "--\n" common_headers = unlines (concatMap h_raw_header headers) ++ "MIME-Version: 1.0\n" text_content_headers = unlines [ "Content-type: text/plain; charset=utf-8", "Content-transfer-encoding: quoted-printable", "Content-Disposition: inline"] + html_content_headers = unlines [ + "Content-type: text/html; charset=utf-8", + "Content-transfer-encoding: quoted-printable", + "Content-Disposition: inline"] -- This is overly paranoid safe_char c = isAsciiAlphaNum c || (c `elem` " .-_") mime_attachment (a, fn, mct) @@ -63,7 +52,7 @@ "Content-type: " ++ x ++ "/" ++ y ++ concatMap showParam ps ++ "\n" Nothing -> "Content-type: application/octet-stream\n" - in part_start + in mixedPartStart ++ ct ++ "Content-transfer-encoding: base64\n" ++ "Content-Disposition: attachment; filename=\"" @@ -76,21 +65,63 @@ ++ "\n" ++ Base64.encode a msg = if single_part - then common_headers - ++ text_content_headers - ++ "\n" - ++ QP.encode (my_lines body) - else common_headers - ++ "Content-type: multipart/mixed; boundary=\"" - ++ boundary ++ "\"\n" - ++ "\n" - ++ "This is a multi-part message in MIME format.\n" - ++ part_start - ++ text_content_headers - ++ "\n" - ++ QP.encode (my_lines body) - ++ concatMap mime_attachment attachments - ++ parts_end + then case maybeHtmlBody of + Nothing -> + common_headers + ++ text_content_headers + ++ "\n" + ++ QP.encode (my_lines body) + Just htmlBody -> + common_headers + ++ "Content-type: multipart/alternative; boundary=\"" + ++ alternativeBoundary ++ "\"\n" + ++ "\n" + ++ "This is a multi-part message in MIME format.\n" + ++ alternativePartStart + ++ text_content_headers + ++ "\n" + ++ QP.encode (my_lines body) + ++ alternativePartStart + ++ html_content_headers + ++ "\n" + ++ QP.encode (my_lines htmlBody) + ++ alternativePartsEnd + else case maybeHtmlBody of + Nothing -> + common_headers + ++ "Content-type: multipart/mixed; boundary=\"" + ++ mixedBoundary ++ "\"\n" + ++ "\n" + ++ "This is a multi-part message in MIME format.\n" + ++ mixedPartStart + ++ text_content_headers + ++ "\n" + ++ QP.encode (my_lines body) + ++ concatMap mime_attachment attachments + ++ mixedPartsEnd + Just htmlBody -> + common_headers + ++ "Content-type: multipart/mixed; boundary=\"" + ++ mixedBoundary ++ "\"\n" + ++ "\n" + ++ "This is a multi-part message in MIME format.\n" + ++ mixedPartStart + -- Start of the body + ++ "Content-type: multipart/alternative; boundary=\"" + ++ alternativeBoundary ++ "\"\n" + ++ "\n" + ++ alternativePartStart + ++ text_content_headers + ++ "\n" + ++ QP.encode (my_lines body) + ++ alternativePartStart + ++ html_content_headers + ++ "\n" + ++ QP.encode (my_lines htmlBody) + ++ alternativePartsEnd + -- End of the body + ++ concatMap mime_attachment attachments + ++ mixedPartsEnd return msg where single_part = null attachments @@ -110,27 +141,4 @@ [timestamp, show (r :: Int)] return (lhs ++ "@" ++ hostname) -} - -mk_subject :: String -> String -mk_subject subject - = if can_send_clear subject && - length_at_most (76 - length "Subject: ") subject - then subject - else encode_string (length "Subject: ") subject - -can_send_clear :: String -> Bool -can_send_clear = all isAsciiPrint - -length_at_most :: Int -> [a] -> Bool -length_at_most _ [] = True -length_at_most 0 _ = False -length_at_most i (_:xs) = length_at_most (i-1) xs - -encode_name :: String -> String -encode_name rn = encode_string (length "From: ") rn - -encode_string :: Int -> String -> String -encode_string n s - = concat $ intersperse "\n " $ map (base64_encode "utf-8") (splits n' s) - where n' = ((76 - n - length "=?utf-8?B??=") * 3) `div` 4 diff --git a/Codec/MIME/String/Headers.hs b/Codec/MIME/String/Headers.hs --- a/Codec/MIME/String/Headers.hs +++ b/Codec/MIME/String/Headers.hs @@ -24,7 +24,6 @@ ) where -import Text.Iconv import Codec.MIME.String.Internal.ABNF ( Parser, parse, pSucceed, pFail, @@ -35,6 +34,8 @@ import qualified Codec.Binary.EncodingQ.String as EncodingQ (decode) import Codec.MIME.String.Internal.Utils +import Codec.Text.IConv +import qualified Data.ByteString.Lazy.Char8 as BS import Data.Char import Data.List @@ -100,11 +101,9 @@ <$> p_encoded_word <*> pMany (id <$ cws <*> p_encoded_word) +-- XXX What happens if iconv doesn't understand the charset "cs"? p_encoded_word :: Parser Char String -p_encoded_word = (\cs dec text -> case convert Fuzzy cs "utf8" (dec text) of - ConversionSuccess xs -> xs - ConversionFailed -> error "p_encoded_word: Can't happen XXX" - ConversionUnsupported -> error "p_encoded_word: Unknown charset XXX") +p_encoded_word = (\cs dec text -> BS.unpack $ convertFuzzy Transliterate cs "utf8" $ BS.pack $ dec text) <$ pString "=?" <*> p_charset <* pChar '?' diff --git a/Codec/MIME/String/Parse.hs b/Codec/MIME/String/Parse.hs --- a/Codec/MIME/String/Parse.hs +++ b/Codec/MIME/String/Parse.hs @@ -1,7 +1,6 @@ module Codec.MIME.String.Parse where -import Text.Iconv import qualified Codec.Binary.Base64.String as Base64 (decode) import Codec.MIME.String.ContentDisposition ( @@ -37,8 +36,11 @@ ) import Codec.MIME.String.Internal.Utils +import Codec.Text.IConv import Control.Monad (liftM) import Control.Monad.State (evalState, get, put) +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.ByteString.Lazy.Char8 (ByteString) import Data.Maybe (fromMaybe) mkMessage :: MessageInfo -> ParseM MessageContent -> ParseM Message @@ -83,12 +85,7 @@ convertAsciiToUtf8 :: String -> String convertAsciiToUtf8 xs - = case convert Fuzzy "US-ASCII" "utf8" xs of - ConversionSuccess xs' -> xs' - ConversionFailed -> - error "convertAsciiToUtf8: Can't happen XXX: Fuzzy conversion failed" - ConversionUnsupported -> - error "convertAsciiToUtf8: Can't happen XXX: Conversion unsupported" + = BS.unpack $ convertFuzzy Transliterate "US-ASCII" "utf8" $ BS.pack xs parse_mime_message :: ContentType -> String -> ParseM Message parse_mime_message def_content_type msg @@ -138,13 +135,12 @@ ContentType "text" _ ps -> let charset = fromMaybe "US-ASCII" $ lookup_param "charset" ps - in case convert Fuzzy charset "utf8" decoded_body of - ConversionSuccess xs -> - mkBody content_type filename xs - ConversionUnsupported -> + decoded_body' = BS.pack decoded_body + in case tryConvertFuzzy Transliterate charset "utf8" decoded_body' of + Just xs -> + mkBody content_type filename $ BS.unpack xs + Nothing -> mkData Nothing content_type filename decoded_body - ConversionFailed -> - error "make_mime_message_content: Fuzzy conversion failed: Can't happen XXX" ContentType "multipart" st ps | Just raw_b <- lookup_param "boundary" ps, Just b <- get_boundary raw_b @@ -187,6 +183,15 @@ -- Don't worry if 8-bit data is in 7-bit transfer-encoded data Just body else Nothing + +-- XXX This is rather hacky. We really want convertFuzzy to tell us if +-- the conversion is supported itself +tryConvertFuzzy :: Fuzzy -> EncodingName -> EncodingName -> ByteString + -> Maybe ByteString +tryConvertFuzzy fuzzy from_charset to_charset decoded_body = + case convertStrictly from_charset to_charset decoded_body of + Right (UnsuportedConversion {}) -> Nothing + _ -> Just $ convertFuzzy fuzzy from_charset to_charset decoded_body get_filename :: ContentDisposition -> ContentType -> FilePath get_filename (ContentDisposition _ params) (ContentType _ _ params') diff --git a/mime-string.cabal b/mime-string.cabal --- a/mime-string.cabal +++ b/mime-string.cabal @@ -1,5 +1,5 @@ Name: mime-string -Version: 0.3 +Version: 0.4 License: OtherLicense License-File: COPYING Copyright: Ian Lynagh, 2005, 2007 @@ -7,12 +7,12 @@ Maintainer: igloo@earth.li Stability: experimental Synopsis: MIME implementation for String's. +Build-Type: Simple Description: Implementation of the MIME RFCs 2045-2049. Rather rough around the edges at the moment. Category: Codec -Tested-With: GHC==6.6 -Build-Depends: base, mtl, network, iconv, base64-string +Build-Depends: base, mtl, network, iconv, base64-string, old-time, bytestring Extensions: PatternGuards Extra-source-files: "BSD3", "GPL-2" Exposed-modules: @@ -29,5 +29,5 @@ Other-Modules: Codec.MIME.String.Internal.ABNF Codec.MIME.String.Internal.Utils -GHC-Options: -O -Wall -Werror +GHC-Options: -Wall