-- |Email functions and data types. module Mail ( Message(..), default_headers, print_sendmail_result, rfc822_now, sendmail ) where import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, readMVar ) import Control.Exception ( evaluate ) import Control.Monad ( liftM ) import Data.List ( intercalate ) import Data.Time ( formatTime, getZonedTime ) import System.Exit ( ExitCode(..) ) import System.Locale ( defaultTimeLocale, rfc822DateFormat ) import System.Process ( runInteractiveProcess, waitForProcess ) import System.IO ( hClose, hGetContents, hPutStr ) type Header = String -- | A crude model of an RFC821 email message. data Message = Message { headers :: [Header], subject :: String, body :: String, from :: String, to :: String } deriving (Eq) -- | The default headers attached to each message. The MIME junk is -- needed for UTF-8 to work properly. Note that your mail server -- should support the 8BITMIME extension. default_headers :: [Header] default_headers = ["MIME-Version: 1.0", "Content-Type: text/plain; charset=UTF-8", "Content-Transfer-Encoding: 8bit"] -- | Showing a message will print it in roughly RFC-compliant -- form. This form is sufficient for handing the message off to -- sendmail (or compatible). instance Show Message where show m = concat [ formatted_headers, "Subject: " ++ (subject m) ++ "\n", "From: " ++ (from m) ++ "\n", "To: " ++ (to m) ++ "\n", "\n", (body m) ] where formatted_headers = if null (headers m) then "" else (intercalate "\n" (headers m)) ++ "\n" -- | Constructs a 'String' in RFC822 date format for the current -- date/time. rfc822_now :: IO String rfc822_now = liftM (formatTime defaultTimeLocale rfc822DateFormat) getZonedTime -- |Takes a message as an argument, and passes it to the system's -- sendmail (or compatible) binary. sendmail :: FilePath -> Message -> IO (String, String, ExitCode) sendmail sendmail_path message = do let sendmail_args = ["-f", (from message), (to message)] (inh, outh, errh, ph) <- runInteractiveProcess sendmail_path sendmail_args Nothing Nothing outm <- newEmptyMVar outs <- hGetContents outh errm <- newEmptyMVar errs <- hGetContents errh _ <- forkIO $ hPutStr inh (show message) >> hClose inh _ <- forkIO $ evaluate (length outs) >> putMVar outm () _ <- forkIO $ evaluate (length errs) >> putMVar errm () readMVar outm readMVar errm ec <- waitForProcess ph return (outs, errs, ec) -- |The 'sendmail' function returns a three-tuple of its outputs, -- errors, and exit codes. This function pretty-prints one of those -- three-tuples. print_sendmail_result :: (String, String, ExitCode) -> IO () print_sendmail_result (outs, errs, ec) = case ec of ExitSuccess -> return () _ -> putStrLn $ concat ["Output: " ++ outs, "\nErrors: " ++ errs, "\nExit Code: " ++ (show ec)]