-- |Email functions and data types. module Mail where import Control.Concurrent import Control.Exception (evaluate) import Data.List (intercalate) import Data.Time (formatTime, getZonedTime) import System.Exit import System.Locale (defaultTimeLocale, rfc822DateFormat) import System.Process 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. instance Show Message where show m = concat [ if (length (headers m) == 0) then "" else (intercalate "\n" (headers m)) ++ "\n", "Subject: " ++ (subject m) ++ "\n", "From: " ++ (from m) ++ "\n", "To: " ++ (to m) ++ "\n", "\n", (body m) ] -- |Pad a string on the left with zeros until the entire string has -- length n. pad_left :: String -> Int -> String pad_left str n | n < (length str) = str | otherwise = (replicate num_zeros '0') ++ str where num_zeros = n - (length str) -- | Constructs a 'String' in RFC822 date format for the current -- date/time. rfc822_now :: IO String rfc822_now = do date <- getZonedTime return $ formatTime defaultTimeLocale rfc822DateFormat date -- |Takes a message as an argument, and passes it to the system's -- sendmail binary. sendmail :: Message -> IO (String, String, ExitCode) sendmail message = do let sendmail_args = ["-f", (from message)] (inh, outh, errh, ph) <- runInteractiveProcess "/usr/bin/sendmail" 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) = do case ec of ExitSuccess -> return () _ -> putStrLn $ concat ["Output: " ++ outs, "\nErrors: " ++ errs, "\nExit Code: " ++ (show ec)]