-- |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 (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" -- |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 (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) = do case ec of ExitSuccess -> return () _ -> putStrLn $ concat ["Output: " ++ outs, "\nErrors: " ++ errs, "\nExit Code: " ++ (show ec)]