src/Mail.hs

   1 module Mail
   2 where
   3
   4 import Control.Concurrent
   5 import Control.Concurrent.MVar
   6 import Control.Exception (evaluate)
   7 import Data.List (intercalate)
   8 import System.Exit
   9 import System.Process
  10 import System.IO
  11
  12 type Header = String
  13
  14 data Message = Message { headers :: [Header],
  15                          subject :: String,
  16                          body    :: String,
  17                          from    :: String,
  18                          to      :: String }
  19              deriving (Eq)
  20
  21 instance Show Message where
  22     show m =
  23         concat [ if (length (headers m) == 0) then "" else (intercalate "\n" (headers m)) ++ "\n",
  24                  "Subject: " ++ (subject m) ++ "\n",
  25                  "From: " ++ (from m) ++ "\n",
  26                  "To: " ++ (to m) ++ "\n",
  27                  "\n",
  28                  (body m) ]
  29
  30
  31 sendmail :: Message -> IO (String, String, ExitCode)
  32 sendmail message = do
  33   let sendmail_args = ["-f",
  34                        (from message)]
  35
  36   (inh, outh, errh, ph) <-
  37       runInteractiveProcess "/usr/bin/sendmail" sendmail_args Nothing Nothing
  38
  39   outm <- newEmptyMVar
  40   outs <- hGetContents outh
  41
  42   errm <- newEmptyMVar
  43   errs <- hGetContents errh
  44
  45   forkIO $ hPutStr inh (show message) >> hClose inh
  46   forkIO $ evaluate (length outs) >> putMVar outm ()
  47   forkIO $ evaluate (length errs) >> putMVar errm ()
  48
  49   readMVar outm
  50   readMVar errm
  51
  52   ec <- waitForProcess ph
  53   return (outs, errs, ec)
  54
  55
  56 print_sendmail_result :: (String, String, ExitCode) -> IO ()
  57 print_sendmail_result (outs, errs, ec) = do
  58     case ec of
  59       ExitSuccess -> return ()
  60       _ -> putStrLn $ concat ["Output: " ++ outs,
  61                               "\nErrors: " ++ errs,
  62                               "\nExit Code: " ++ (show ec)]