src/Mail.hs

   1 -- |Email functions and data types.
   2
   3 module Mail (
   4   Message(..),
   5   default_headers,
   6   print_sendmail_result,
   7   rfc822_now,
   8   sendmail
   9   )
  10 where
  11
  12 import Control.Concurrent
  13 import Control.Exception (evaluate)
  14 import Control.Monad (liftM)
  15 import Data.List (intercalate)
  16 import Data.Time (formatTime, getZonedTime)
  17 import System.Exit
  18 import System.Locale (defaultTimeLocale, rfc822DateFormat)
  19 import System.Process
  20 import System.IO (hClose, hGetContents, hPutStr)
  21
  22
  23 type Header = String
  24
  25 -- | A crude model of an RFC821 email message.
  26 data Message = Message { headers :: [Header],
  27                          subject :: String,
  28                          body    :: String,
  29                          from    :: String,
  30                          to      :: String }
  31              deriving (Eq)
  32
  33 -- | The default headers attached to each message.  The MIME junk is
  34 --   needed for UTF-8 to work properly. Note that your mail server
  35 --   should support the 8BITMIME extension.
  36 default_headers :: [Header]
  37 default_headers = ["MIME-Version: 1.0",
  38                    "Content-Type: text/plain; charset=UTF-8",
  39                    "Content-Transfer-Encoding: 8bit"]
  40
  41 -- | Showing a message will print it in roughly RFC-compliant
  42 --   form. This form is sufficient for handing the message off to
  43 --   sendmail (or compatible).
  44 instance Show Message where
  45   show m =
  46     concat [ formatted_headers,
  47              "Subject: " ++ (subject m) ++ "\n",
  48              "From: " ++ (from m) ++ "\n",
  49              "To: " ++ (to m) ++ "\n",
  50              "\n",
  51              (body m) ]
  52     where
  53       formatted_headers =
  54         if null (headers m)
  55         then ""
  56         else (intercalate "\n" (headers m)) ++ "\n"
  57
  58
  59
  60 -- | Constructs a 'String' in RFC822 date format for the current
  61 --   date/time.
  62 rfc822_now :: IO String
  63 rfc822_now =
  64   liftM (formatTime defaultTimeLocale rfc822DateFormat) getZonedTime
  65
  66
  67
  68
  69 -- |Takes a message as an argument, and passes it to the system's
  70 -- sendmail (or compatible) binary.
  71 sendmail :: FilePath -> Message -> IO (String, String, ExitCode)
  72 sendmail sendmail_path message = do
  73   let sendmail_args = ["-f",
  74                        (from message),
  75                        (to message)]
  76
  77   (inh, outh, errh, ph) <-
  78       runInteractiveProcess sendmail_path sendmail_args Nothing Nothing
  79
  80   outm <- newEmptyMVar
  81   outs <- hGetContents outh
  82
  83   errm <- newEmptyMVar
  84   errs <- hGetContents errh
  85
  86   _ <- forkIO $ hPutStr inh (show message) >> hClose inh
  87   _ <- forkIO $ evaluate (length outs) >> putMVar outm ()
  88   _ <- forkIO $ evaluate (length errs) >> putMVar errm ()
  89
  90   readMVar outm
  91   readMVar errm
  92
  93   ec <- waitForProcess ph
  94   return (outs, errs, ec)
  95
  96
  97 -- |The 'sendmail' function returns a three-tuple of its outputs,
  98 -- errors, and exit codes.  This function pretty-prints one of those
  99 -- three-tuples.
 100 print_sendmail_result :: (String, String, ExitCode) -> IO ()
 101 print_sendmail_result (outs, errs, ec) =
 102   case ec of
 103     ExitSuccess -> return ()
 104     _ -> putStrLn $ concat ["Output: " ++ outs,
 105                             "\nErrors: " ++ errs,
 106                             "\nExit Code: " ++ (show ec)]