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