-- |Email functions and data types.

module Mail
where

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception (evaluate)
import Data.List (intercalate)
import System.Exit
import System.Process
import System.IO

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)

-- |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) ]


-- |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)]