module Codec.MIME.String.Flatten
    (flatten, flattenXXX, 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)
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 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
 = 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"
          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"]
          -- 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 part_start
                ++ 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 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
      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)
-}

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