src/Mail.hs

   1 -- |Email functions and data types.
   2
   3 module Mail
   4 where
   5
   6 import Control.Concurrent
   7 import Control.Concurrent.MVar
   8 import Control.Exception (evaluate)
   9 import Data.List (intercalate)
  10 import System.Exit
  11 import System.Process
  12 import System.IO
  13
  14 type Header = String
  15
  16 -- |A crude model of an RFC821 email message.
  17 data Message = Message { headers :: [Header],
  18                          subject :: String,
  19                          body    :: String,
  20                          from    :: String,
  21                          to      :: String }
  22              deriving (Eq)
  23
  24 -- |Showing a message will print it in roughly RFC-compliant
  25 -- form. This form is sufficient for handing the message off to
  26 -- sendmail.
  27 instance Show Message where
  28     show m =
  29         concat [ if (length (headers m) == 0) then "" else (intercalate "\n" (headers m)) ++ "\n",
  30                  "Subject: " ++ (subject m) ++ "\n",
  31                  "From: " ++ (from m) ++ "\n",
  32                  "To: " ++ (to m) ++ "\n",
  33                  "\n",
  34                  (body m) ]
  35
  36
  37 -- |Takes a message as an argument, and passes it to the system's
  38 -- sendmail binary.
  39 sendmail :: Message -> IO (String, String, ExitCode)
  40 sendmail message = do
  41   let sendmail_args = ["-f",
  42                        (from message)]
  43
  44   (inh, outh, errh, ph) <-
  45       runInteractiveProcess "/usr/bin/sendmail" sendmail_args Nothing Nothing
  46
  47   outm <- newEmptyMVar
  48   outs <- hGetContents outh
  49
  50   errm <- newEmptyMVar
  51   errs <- hGetContents errh
  52
  53   forkIO $ hPutStr inh (show message) >> hClose inh
  54   forkIO $ evaluate (length outs) >> putMVar outm ()
  55   forkIO $ evaluate (length errs) >> putMVar errm ()
  56
  57   readMVar outm
  58   readMVar errm
  59
  60   ec <- waitForProcess ph
  61   return (outs, errs, ec)
  62
  63
  64 -- |The 'sendmail' function returns a three-tuple of its outputs,
  65 -- errors, and exit codes.  This function pretty-prints one of those
  66 -- three-tuples.
  67 print_sendmail_result :: (String, String, ExitCode) -> IO ()
  68 print_sendmail_result (outs, errs, ec) = do
  69     case ec of
  70       ExitSuccess -> return ()
  71       _ -> putStrLn $ concat ["Output: " ++ outs,
  72                               "\nErrors: " ++ errs,
  73                               "\nExit Code: " ++ (show ec)]