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