module Codec.MIME.String.Flatten (flatten, flattenXXX) 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.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 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 -> [(String, FilePath)]
        -> 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 -> [(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
          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)
              = part_start
                -- XXX Can we give a better MIME type than this?
             ++ "Content-type: application/octet-stream\n"
             ++ "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