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,41 +1,52 @@ -module Codec.MIME.String.Flatten (flatten) where +module Codec.MIME.String.Flatten (flatten, flattenXXX) where import qualified Codec.Binary.Base64.String as Base64 (encode) -import Codec.MIME.String.Date (FullDate, show_full_date, show_mbox_full_date) -import Codec.MIME.String.EncodedWord (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.Internal.Utils +import Codec.MIME.String.Parse +import Codec.MIME.String.Types import Data.List (intersperse) +{- +XXX For message IDs: import Network.BSD (getHostName) import System.Locale (defaultTimeLocale) import System.Random (randomIO) import System.Time (getClockTime, toCalendarTime, formatCalendarTime) +-} --- XXX This should take a headers structure +-- 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 -flatten :: String -> String -> String -> FullDate +flattenXXX :: String -> String -> String -> FullDate -> String -> [(String, FilePath)] -> IO String -flatten from_name from_email subject date body attachments - = do msgid <- mk_msgid +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 -> [(String, FilePath)] -> IO String +flatten headers body 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 - from_full = encode_name from_name ++ "\n <" ++ from_email ++ ">" boundary = "=:" part_start = "\n--" ++ boundary ++ "\n" parts_end = "\n--" ++ boundary ++ "--\n" - text_content = unlines [ + 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"] - common_headers = unlines [ - "From " ++ from_email ++ " " ++ show_mbox_full_date date, - "Date: " ++ show_full_date date, - "Message-ID: " ++ msgid, - "From: " ++ from_full, - "Subject: " ++ mk_subject subject, - "MIME-Version: 1.0"] -- This is overly paranoid safe_char c = isAsciiAlphaNum c || (c `elem` " .-_") mime_attachment (a, fn) @@ -54,7 +65,7 @@ ++ Base64.encode a msg = if single_part then common_headers - ++ text_content + ++ text_content_headers ++ "\n" ++ QP.encode (my_lines body) else common_headers @@ -63,7 +74,7 @@ ++ "\n" ++ "This is a multi-part message in MIME format.\n" ++ part_start - ++ text_content + ++ text_content_headers ++ "\n" ++ QP.encode (my_lines body) ++ concatMap mime_attachment attachments @@ -74,6 +85,7 @@ -- XXX The IO calls used to use liftIOErr. We could use something similar -- but require we are called in a MonadError m? -- XXX We should possibly be including a program name +{- mk_msgid :: IO String mk_msgid = do hostname <- getHostName @@ -85,6 +97,7 @@ lhs = concat $ intersperse "." [timestamp, show (r :: Int)] return (lhs ++ "@" ++ hostname) +-} mk_subject :: String -> String mk_subject subject 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 @@ -274,14 +274,14 @@ [] -> skip_whitespace m_zs ys' -> gather [ys'] m_zs gather :: [String] -> Maybe String -> ([Header], Maybe String) - gather acc Nothing = ([mk_header acc], Nothing) + gather acc Nothing = ([mk_rev_header acc], Nothing) gather acc (Just xs) = case get_line xs of - ([], m_zs) -> ([mk_header acc], m_zs) + ([], m_zs) -> ([mk_rev_header acc], m_zs) (ys, m_zs) | starts_with_white ys -> gather (ys:acc) m_zs | otherwise -> let (hs, m_rest) = gather [ys] m_zs - in (mk_header acc:hs, m_rest) + in (mk_rev_header acc:hs, m_rest) starts_with_white (c:_) = isWhite c starts_with_white [] = False isWhite ' ' = True @@ -290,13 +290,18 @@ -- Takes the lines comprising a header (in reverse order) and constructs -- the corresponding Header +mk_rev_header :: [String] -> Header +mk_rev_header = mk_header . reverse + +-- Takes the lines comprising a header and constructs +-- the corresponding Header mk_header :: [String] -> Header -mk_header xs = let unfolded = concat xs' +mk_header xs = let unfolded = concat xs (raw_name, body) = case break ends_header unfolded of (name, ':':val) -> (name ++ ":", val) (name, val) -> (name, val) in Header { - h_raw_header = xs', + h_raw_header = xs, h_raw_name = raw_name, h_name = map asciiToLower raw_name, h_body = body @@ -305,5 +310,4 @@ ends_header ' ' = True ends_header '\t' = True ends_header _ = False - xs' = reverse xs diff --git a/mime-string.cabal b/mime-string.cabal --- a/mime-string.cabal +++ b/mime-string.cabal @@ -1,16 +1,15 @@ Name: mime-string -Version: 0.1 +Version: 0.2 License: OtherLicense License-File: COPYING Copyright: Ian Lynagh, 2005, 2007 Author: Ian Lynagh Maintainer: igloo@earth.li Stability: experimental -Homepage: http://urchin.earth.li/~ian/cabal/mime-string/ Synopsis: MIME implementation for String's. Description: Implementation of the MIME RFCs 2045-2049. - A bit rough around the edges. + Rather rough around the edges at the moment. Category: Codec Tested-With: GHC==6.6 Build-Depends: base, mtl, network, iconv, base64-string