Flatten.hs

module Codec.MIME.String.Flatten
    (flatten, Attachments, Attachment)
    where

import qualified Codec.Binary.Base64.String as Base64 (encode)
import qualified Codec.MIME.String.QuotedPrintable as QP (encode)
import Codec.MIME.String.Headers
import Codec.MIME.String.Internal.Utils
import Codec.MIME.String.Types

{-
XXX For message IDs:
import Network.BSD (getHostName)
import System.Locale (defaultTimeLocale)
import System.Random (randomIO)
import System.Time (getClockTime, toCalendarTime, formatCalendarTime)
-}

type Attachments = [Attachment]
type Attachment = (String, FilePath, Maybe ContentType)

-- 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
          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)
              = let -- XXX showParam and ct should do some sanity checking
                    -- of the values they are passed
                    showParam (Parameter k v) = "; " ++ k ++ "=\"" ++ v ++ "\""
                    ct = case mct of
                         Just (ContentType x y ps) ->
                             "Content-type: " ++ x ++ "/" ++ y
                          ++ concatMap showParam ps ++ "\n"
                         Nothing -> "Content-type: application/octet-stream\n"
                in mixedPartStart
                ++ ct
                ++ "Content-transfer-encoding: base64\n"
                ++ "Content-Disposition: attachment; filename=\""
                       ++ (case reverse $ filter safe_char
                                        $ takeWhile ('/' /=)
                                        $ reverse fn of
                               [] -> "unknown"
                               fn' -> fn')
                       ++ "\"\n"
                ++ "\n"
                ++ Base64.encode a
          msg = if single_part
                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

-- 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
      clock_time <- getClockTime
      calendar_time <- toCalendarTime clock_time
      r <- randomIO
      let timestamp = formatCalendarTime defaultTimeLocale
                                         "%Y%m%d%H%M%S" calendar_time
          lhs = concat $ intersperse "."
                [timestamp, show (r :: Int)]
      return (lhs ++ "@" ++ hostname)
-}