src/Mail.hs

   1 -- | Email functions and data types.
   2
   3 module Mail (
   4   Message(..),
   5   print_sendmail_result,
   6   rfc822_now,
   7   sendmail )
   8 where
   9
  10 import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, readMVar )
  11 import Control.Exception ( evaluate )
  12 import Control.Monad ( liftM )
  13 import Data.Time ( formatTime, getZonedTime )
  14 import System.Console.CmdArgs.Default ( Default(..) )
  15 import System.Exit ( ExitCode(..) )
  16 import System.Locale ( defaultTimeLocale, rfc822DateFormat )
  17 import System.Process ( runInteractiveProcess, waitForProcess )
  18 import System.IO ( hClose, hGetContents, hPutStr )
  19
  20
  21 type Header = String
  22
  23 -- | The default headers attached to each message.  The MIME junk is
  24 --   needed for UTF-8 to work properly. Note that your mail server
  25 --   should support the 8BITMIME extension.
  26 --
  27 default_headers :: [Header]
  28 default_headers = ["MIME-Version: 1.0",
  29                    "Content-Type: text/plain; charset=UTF-8",
  30                    "Content-Transfer-Encoding: 8bit"]
  31
  32
  33 -- | A crude model of an RFC822 email message.
  34 --
  35 data Message = Message { headers :: [Header],
  36                          subject :: String,
  37                          body    :: String,
  38                          from    :: String,
  39                          to      :: String }
  40              deriving (Eq)
  41
  42
  43 instance Default Message where
  44   -- | Construct a message with all of its fields set to their
  45   --   default values.
  46   --
  47   def = Message default_headers def def def def
  48
  49
  50 -- | Print a 'Message' in roughly RFC-compliant form. This form is
  51 --   sufficient for handing the message off to sendmail (or compatible).
  52 --
  53 --   Examples:
  54 --
  55 --   >>> let hs = default_headers
  56 --   >>> let s = "Save up to 20% on garbage!"
  57 --   >>> let b = "Just kidding, now you have a virus!"
  58 --   >>> let f = "savings5000@impenetrable.example"
  59 --   >>> let t = "everyone@everywhere.example"
  60 --   >>> let msg = Message hs s b f t
  61 --   >>> putStrLn $ to_rfc822 msg
  62 --   MIME-Version: 1.0
  63 --   Content-Type: text/plain; charset=UTF-8
  64 --   Content-Transfer-Encoding: 8bit
  65 --   Subject: Save up to 20% on garbage!
  66 --   From: savings5000@impenetrable.example
  67 --   To: everyone@everywhere.example
  68 --   <BLANKLINE>
  69 --   Just kidding, now you have a virus!
  70 --
  71 to_rfc822 :: Message -> String
  72 to_rfc822 m =
  73   concat [ formatted_headers,
  74            "Subject: " ++ (subject m) ++ "\n",
  75            "From: " ++ (from m) ++ "\n",
  76            "To: " ++ (to m) ++ "\n",
  77            "\n",
  78            (body m) ]
  79   where
  80     formatted_headers =
  81       if null (headers m)
  82       then ""
  83       else unlines (headers m)
  84
  85
  86
  87 -- | Constructs a 'String' in RFC822 date format for the current
  88 --   date/time.
  89 --
  90 rfc822_now :: IO String
  91 rfc822_now =
  92   liftM (formatTime defaultTimeLocale rfc822DateFormat) getZonedTime
  93
  94
  95
  96
  97 -- | Takes a message as an argument, and passes it to the system's
  98 --   sendmail (or compatible) binary.
  99 --
 100 sendmail :: FilePath -> Message -> IO (String, String, ExitCode)
 101 sendmail sendmail_path message = do
 102   -- The arguments we pass to sendmail "on the command line"
 103   let sendmail_args = ["-f",
 104                        (from message),
 105                        (to message)]
 106
 107   -- Run the sendmail process, passing it our sendmail_args. We'll get
 108   -- back a bunch of handles, std{in,out,err} and one for the process
 109   -- itself.
 110   (inh, outh, errh, ph) <-
 111       runInteractiveProcess sendmail_path sendmail_args Nothing Nothing
 112
 113   -- Create mvars for stdout and stderr, then collect their contents.
 114   outm <- newEmptyMVar
 115   outs <- hGetContents outh
 116
 117   errm <- newEmptyMVar
 118   errs <- hGetContents errh
 119
 120   -- Pass the message to sendmail on stdin
 121   _ <- forkIO $ hPutStr inh (to_rfc822 message) >> hClose inh
 122
 123   -- Fork threads that will read stdout/stderr respectively, and then
 124   -- stick a dummy unit value in the mvars we created.
 125   _ <- forkIO $ evaluate (length outs) >> putMVar outm ()
 126   _ <- forkIO $ evaluate (length errs) >> putMVar errm ()
 127
 128   -- Now wait for the dummy variables to show up in the mvars. This
 129   -- will occur only after (length outs) and (length errs) have been
 130   -- evaluated, which can happen only after we've read them entirely.
 131   readMVar outm
 132   readMVar errm
 133
 134   -- Now wait for the process to finish and return its exit code along
 135   -- with the output that we collected.
 136   ec <- waitForProcess ph
 137   return (outs, errs, ec)
 138
 139
 140 -- | The 'sendmail' function returns a three-tuple of its outputs,
 141 --   errors, and exit codes.  This function pretty-prints one of those
 142 --   three-tuples.
 143 --
 144 --   If the exit code indicates success, we don't bother to print
 145 --   anything (silence is golden!), but otherwise the contents of both
 146 --   stdout and stderr will be printed.
 147 --
 148 --   Examples:
 149 --
 150 --   >>> let r = ("some output", "no errors", ExitSuccess)
 151 --   >>> print_sendmail_result r
 152 --
 153 --   >>> let r = ("some output", "lots of errors", ExitFailure 1)
 154 --   >>> print_sendmail_result r
 155 --   Output: some output
 156 --   Errors: lots of errors
 157 --   Exit Code: 1
 158 --
 159 print_sendmail_result :: (String, String, ExitCode) -> IO ()
 160 print_sendmail_result (outs, errs, ec) =
 161   case ec of
 162     ExitSuccess -> return ()
 163     ExitFailure (code) ->
 164       putStrLn $ concat ["Output: " ++ outs,
 165                          "\nErrors: " ++ errs,
 166                          "\nExit Code: " ++ (show code)]