-- | Email functions and data types.

module Mail (
  Message(..),
  print_sendmail_result,
  rfc822_now,
  sendmail )
where

import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, readMVar )
import Control.Exception ( evaluate )
import Control.Monad ( liftM )
import Data.Time ( formatTime, getZonedTime )
import System.Console.CmdArgs.Default ( Default(..) )
import System.Exit ( ExitCode(..) )
import System.Locale ( defaultTimeLocale, rfc822DateFormat )
import System.Process ( runInteractiveProcess, waitForProcess )
import System.IO ( hClose, hGetContents, hPutStr )


type Header = String

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


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


instance Default Message where
  -- | Construct a message with all of its fields set to their
  --   default values.
  --
  def = Message default_headers def def def def


-- | Print a 'Message' in roughly RFC-compliant form. This form is
--   sufficient for handing the message off to sendmail (or compatible).
--
--   Examples:
--
--   >>> let hs = default_headers
--   >>> let s = "Save up to 20% on garbage!"
--   >>> let b = "Just kidding, now you have a virus!"
--   >>> let f = "savings5000@impenetrable.example"
--   >>> let t = "everyone@everywhere.example"
--   >>> let msg = Message hs s b f t
--   >>> putStrLn $ to_rfc822 msg
--   MIME-Version: 1.0
--   Content-Type: text/plain; charset=UTF-8
--   Content-Transfer-Encoding: 8bit
--   Subject: Save up to 20% on garbage!
--   From: savings5000@impenetrable.example
--   To: everyone@everywhere.example
--   <BLANKLINE>
--   Just kidding, now you have a virus!
--
to_rfc822 :: Message -> String
to_rfc822 m =
  concat [ formatted_headers,
           "Subject: " ++ (subject m) ++ "\n",
           "From: " ++ (from m) ++ "\n",
           "To: " ++ (to m) ++ "\n",
           "\n",
           (body m) ]
  where
    formatted_headers =
      if null (headers m)
      then ""
      else unlines (headers m)



-- | Constructs a 'String' in RFC822 date format for the current
--   date/time.
--
rfc822_now :: IO String
rfc822_now =
  liftM (formatTime defaultTimeLocale rfc822DateFormat) getZonedTime




-- | Takes a message as an argument, and passes it to the system's
--   sendmail (or compatible) binary.
--
sendmail :: FilePath -> Message -> IO (String, String, ExitCode)
sendmail sendmail_path message = do
  -- The arguments we pass to sendmail "on the command line"
  let sendmail_args = ["-f",
                       (from message),
                       (to message)]

  -- Run the sendmail process, passing it our sendmail_args. We'll get
  -- back a bunch of handles, std{in,out,err} and one for the process
  -- itself.
  (inh, outh, errh, ph) <-
      runInteractiveProcess sendmail_path sendmail_args Nothing Nothing

  -- Create mvars for stdout and stderr, then collect their contents.
  outm <- newEmptyMVar
  outs <- hGetContents outh

  errm <- newEmptyMVar
  errs <- hGetContents errh

  -- Pass the message to sendmail on stdin
  _ <- forkIO $ hPutStr inh (to_rfc822 message) >> hClose inh

  -- Fork threads that will read stdout/stderr respectively, and then
  -- stick a dummy unit value in the mvars we created.
  _ <- forkIO $ evaluate (length outs) >> putMVar outm ()
  _ <- forkIO $ evaluate (length errs) >> putMVar errm ()

  -- Now wait for the dummy variables to show up in the mvars. This
  -- will occur only after (length outs) and (length errs) have been
  -- evaluated, which can happen only after we've read them entirely.
  readMVar outm
  readMVar errm

  -- Now wait for the process to finish and return its exit code along
  -- with the output that we collected.
  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.
--
--   If the exit code indicates success, we don't bother to print
--   anything (silence is golden!), but otherwise the contents of both
--   stdout and stderr will be printed.
--
--   Examples:
--
--   >>> let r = ("some output", "no errors", ExitSuccess)
--   >>> print_sendmail_result r
--
--   >>> let r = ("some output", "lots of errors", ExitFailure 1)
--   >>> print_sendmail_result r
--   Output: some output
--   Errors: lots of errors
--   Exit Code: 1
--
print_sendmail_result :: (String, String, ExitCode) -> IO ()
print_sendmail_result (outs, errs, ec) =
  case ec of
    ExitSuccess -> return ()
    ExitFailure (code) ->
      putStrLn $ concat ["Output: " ++ outs,
                         "\nErrors: " ++ errs,
                         "\nExit Code: " ++ (show code)]