-- |Email functions and data types.

module Mail
where

import Control.Concurrent
import Control.Exception (evaluate)
import Data.List (intercalate)
import System.Exit
import System.Process
import System.Time (CalendarTime(..), ClockTime, getClockTime, Month, toCalendarTime)
import System.IO (hClose, hGetContents, hPutStr)


type Header = String

-- |A crude model of an RFC821 email message.
data Message = Message { headers :: [Header],
                         subject :: String,
                         body    :: String,
                         from    :: String,
                         to      :: String }
             deriving (Eq)

-- |The default headers attached to each message.
-- The MIME junk is needed for UTF-8 to work properly.
-- Note that your mail server should support the 8BITMIME extension.
default_headers :: [Header]
default_headers = ["MIME-Version: 1.0",
                   "Content-Type: text/plain; charset=UTF-8",
                   "Content-Transfer-Encoding: 8bit"]

-- |Showing a message will print it in roughly RFC-compliant
-- form. This form is sufficient for handing the message off to
-- sendmail.
instance Show Message where
    show m =
        concat [ if (length (headers m) == 0) then "" else (intercalate "\n" (headers m)) ++ "\n",
                 "Subject: " ++ (subject m) ++ "\n",
                 "From: " ++ (from m) ++ "\n",
                 "To: " ++ (to m) ++ "\n",
                 "\n",
                 (body m) ]



-- |Pad a string on the left with zeros until the entire string has
-- length n.
pad_left :: String -> Int -> String
pad_left str n
         | n < (length str) = str
         | otherwise = (replicate num_zeros '0') ++ str
    where num_zeros = n - (length str)



-- |Formats a month name according to RFC822.
format_month :: Month -> String
format_month month = take 3 (show month)


-- |Takes an offset from UTC (in seconds) and returns the four-digit
-- offset as a 'String' in +hhmm format.
format_timezone :: Int -> String
format_timezone seconds =
    sign ++ pad_hh ++ pad_mm
    where
      seconds_norm = abs seconds
      hh = seconds_norm `div` 3600
      mm = (seconds_norm - (hh*3600)) `div` 60
      pad_hh = pad_left (show hh) 2
      pad_mm = pad_left (show mm) 2
      sign = if seconds < 0 then "-" else "+"


-- |Takes a 'ClockTime' as an argument, and formats it as an RFC822 Date header.
--
-- See,
--
--   <http://cr.yp.to/immhf/date.html>
--
-- for information.
format_clocktime :: ClockTime -> IO String
format_clocktime ct = do
  caltime <- (toCalendarTime ct)

  let days = pad_left (show (ctDay caltime)) 2
  let month = format_month (ctMonth caltime)
  let year = show $ ctYear caltime
  let hours = pad_left (show (ctHour caltime)) 2
  let minutes = pad_left (show (ctMin caltime)) 2
  let seconds = pad_left (show (ctSec caltime)) 2
  let timezone = format_timezone (ctTZ caltime)

  return $ concat [(show $ ctWDay caltime) ++ ", ",
                   days ++ " ",
                   month ++ " ",
                   year ++ " ",
                   hours ++ ":",
                   minutes ++ ":",
                   seconds ++ " ",
                   timezone]


-- |Constructs an RFC822 Date header with the current date/time.
construct_date_header :: IO String
construct_date_header = do
  date <- getClockTime
  format_clocktime date



-- |Takes a message as an argument, and passes it to the system's
-- sendmail binary.
sendmail :: Message -> IO (String, String, ExitCode)
sendmail message = do
  let sendmail_args = ["-f",
                       (from message)]

  (inh, outh, errh, ph) <-
      runInteractiveProcess "/usr/bin/sendmail" sendmail_args Nothing Nothing

  outm <- newEmptyMVar
  outs <- hGetContents outh

  errm <- newEmptyMVar
  errs <- hGetContents errh

  _ <- forkIO $ hPutStr inh (show message) >> hClose inh
  _ <- forkIO $ evaluate (length outs) >> putMVar outm ()
  _ <- forkIO $ evaluate (length errs) >> putMVar errm ()

  readMVar outm
  readMVar errm

  ec <- waitForProcess ph
  return (outs, errs, ec)


-- |The 'sendmail' function returns a three-tuple of its outputs,
-- errors, and exit codes.  This function pretty-prints one of those
-- three-tuples.
print_sendmail_result :: (String, String, ExitCode) -> IO ()
print_sendmail_result (outs, errs, ec) = do
    case ec of
      ExitSuccess -> return ()
      _ -> putStrLn $ concat ["Output: " ++ outs,
                              "\nErrors: " ++ errs,
                              "\nExit Code: " ++ (show ec)]