1 -- |Email functions and data types.
12 import Control.Concurrent
13 import Control.Exception (evaluate)
14 import Control.Monad (liftM)
15 import Data.List (intercalate)
16 import Data.Time (formatTime, getZonedTime)
18 import System.Locale (defaultTimeLocale, rfc822DateFormat)
20 import System.IO (hClose, hGetContents, hPutStr)
25 -- | A crude model of an RFC821 email message.
26 data Message = Message { headers :: [Header],
33 -- | The default headers attached to each message. The MIME junk is
34 -- needed for UTF-8 to work properly. Note that your mail server
35 -- should support the 8BITMIME extension.
36 default_headers :: [Header]
37 default_headers = ["MIME-Version: 1.0",
38 "Content-Type: text/plain; charset=UTF-8",
39 "Content-Transfer-Encoding: 8bit"]
41 -- | Showing a message will print it in roughly RFC-compliant
42 -- form. This form is sufficient for handing the message off to
43 -- sendmail (or compatible).
44 instance Show Message where
46 concat [ formatted_headers,
47 "Subject: " ++ (subject m) ++ "\n",
48 "From: " ++ (from m) ++ "\n",
49 "To: " ++ (to m) ++ "\n",
56 else (intercalate "\n" (headers m)) ++ "\n"
60 -- | Constructs a 'String' in RFC822 date format for the current
62 rfc822_now :: IO String
64 liftM (formatTime defaultTimeLocale rfc822DateFormat) getZonedTime
69 -- |Takes a message as an argument, and passes it to the system's
70 -- sendmail (or compatible) binary.
71 sendmail :: FilePath -> Message -> IO (String, String, ExitCode)
72 sendmail sendmail_path message = do
73 let sendmail_args = ["-f",
77 (inh, outh, errh, ph) <-
78 runInteractiveProcess sendmail_path sendmail_args Nothing Nothing
81 outs <- hGetContents outh
84 errs <- hGetContents errh
86 _ <- forkIO $ hPutStr inh (show message) >> hClose inh
87 _ <- forkIO $ evaluate (length outs) >> putMVar outm ()
88 _ <- forkIO $ evaluate (length errs) >> putMVar errm ()
93 ec <- waitForProcess ph
94 return (outs, errs, ec)
97 -- |The 'sendmail' function returns a three-tuple of its outputs,
98 -- errors, and exit codes. This function pretty-prints one of those
100 print_sendmail_result :: (String, String, ExitCode) -> IO ()
101 print_sendmail_result (outs, errs, ec) =
103 ExitSuccess -> return ()
104 _ -> putStrLn $ concat ["Output: " ++ outs,
105 "\nErrors: " ++ errs,
106 "\nExit Code: " ++ (show ec)]