Clean up a bunch of code and comments.
[dead/halcyon.git] / src / Mail.hs
1 -- | Email functions and data types.
2
3 module Mail (
4 Message(..),
5 print_sendmail_result,
6 rfc822_now,
7 sendmail )
8 where
9
10 import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, readMVar )
11 import Control.Exception ( evaluate )
12 import Control.Monad ( liftM )
13 import Data.List ( intercalate )
14 import Data.Time ( formatTime, getZonedTime )
15 import System.Console.CmdArgs.Default ( Default(..) )
16 import System.Exit ( ExitCode(..) )
17 import System.Locale ( defaultTimeLocale, rfc822DateFormat )
18 import System.Process ( runInteractiveProcess, waitForProcess )
19 import System.IO ( hClose, hGetContents, hPutStr )
20
21
22 type Header = String
23
24 -- | The default headers attached to each message. The MIME junk is
25 -- needed for UTF-8 to work properly. Note that your mail server
26 -- should support the 8BITMIME extension.
27 --
28 default_headers :: [Header]
29 default_headers = ["MIME-Version: 1.0",
30 "Content-Type: text/plain; charset=UTF-8",
31 "Content-Transfer-Encoding: 8bit"]
32
33
34 -- | A crude model of an RFC822 email message.
35 --
36 data Message = Message { headers :: [Header],
37 subject :: String,
38 body :: String,
39 from :: String,
40 to :: String }
41 deriving (Eq)
42
43
44 instance Default Message where
45 -- | Construct a message with all of its fields set to their
46 -- default values.
47 --
48 def = Message default_headers def def def def
49
50
51 -- | Print a 'Message' in roughly RFC-compliant form. This form is
52 -- sufficient for handing the message off to sendmail (or compatible).
53 --
54 -- Examples:
55 --
56 -- >>> let hs = default_headers
57 -- >>> let s = "Save up to 20% on garbage!"
58 -- >>> let b = "Just kidding, now you have a virus!"
59 -- >>> let f = "savings5000@impenetrable.example"
60 -- >>> let t = "everyone@everywhere.example"
61 -- >>> let msg = Message hs s b f t
62 -- >>> putStrLn $ to_rfc822 msg
63 -- MIME-Version: 1.0
64 -- Content-Type: text/plain; charset=UTF-8
65 -- Content-Transfer-Encoding: 8bit
66 -- Subject: Save up to 20% on garbage!
67 -- From: savings5000@impenetrable.example
68 -- To: everyone@everywhere.example
69 -- <BLANKLINE>
70 -- Just kidding, now you have a virus!
71 --
72 to_rfc822 :: Message -> String
73 to_rfc822 m =
74 concat [ formatted_headers,
75 "Subject: " ++ (subject m) ++ "\n",
76 "From: " ++ (from m) ++ "\n",
77 "To: " ++ (to m) ++ "\n",
78 "\n",
79 (body m) ]
80 where
81 formatted_headers =
82 if null (headers m)
83 then ""
84 else (intercalate "\n" (headers m)) ++ "\n"
85
86
87
88 -- | Constructs a 'String' in RFC822 date format for the current
89 -- date/time.
90 --
91 rfc822_now :: IO String
92 rfc822_now =
93 liftM (formatTime defaultTimeLocale rfc822DateFormat) getZonedTime
94
95
96
97
98 -- | Takes a message as an argument, and passes it to the system's
99 -- sendmail (or compatible) binary.
100 --
101 sendmail :: FilePath -> Message -> IO (String, String, ExitCode)
102 sendmail sendmail_path message = do
103 -- The arguments we pass to sendmail "on the command line"
104 let sendmail_args = ["-f",
105 (from message),
106 (to message)]
107
108 -- Run the sendmail process, passing it our sendmail_args. We'll get
109 -- back a bunch of handles, std{in,out,err} and one for the process
110 -- itself.
111 (inh, outh, errh, ph) <-
112 runInteractiveProcess sendmail_path sendmail_args Nothing Nothing
113
114 -- Create mvars for stdout and stderr, then collect their contents.
115 outm <- newEmptyMVar
116 outs <- hGetContents outh
117
118 errm <- newEmptyMVar
119 errs <- hGetContents errh
120
121 -- Pass the message to sendmail on stdin
122 _ <- forkIO $ hPutStr inh (to_rfc822 message) >> hClose inh
123
124 -- Fork threads that will read stdout/stderr respectively, and then
125 -- stick a dummy unit value in the mvars we created.
126 _ <- forkIO $ evaluate (length outs) >> putMVar outm ()
127 _ <- forkIO $ evaluate (length errs) >> putMVar errm ()
128
129 -- Now wait for the dummy variables to show up in the mvars. This
130 -- will occur only after (length outs) and (length errs) have been
131 -- evaluated, which can happen only after we've read them entirely.
132 readMVar outm
133 readMVar errm
134
135 -- Now wait for the process to finish and return its exit code along
136 -- with the output that we collected.
137 ec <- waitForProcess ph
138 return (outs, errs, ec)
139
140
141 -- | The 'sendmail' function returns a three-tuple of its outputs,
142 -- errors, and exit codes. This function pretty-prints one of those
143 -- three-tuples.
144 --
145 -- If the exit code indicates success, we don't bother to print
146 -- anything (silence is golden!), but otherwise the contents of both
147 -- stdout and stderr will be printed.
148 --
149 -- Examples:
150 --
151 -- >>> let r = ("some output", "no errors", ExitSuccess)
152 -- >>> print_sendmail_result r
153 --
154 -- >>> let r = ("some output", "lots of errors", ExitFailure 1)
155 -- >>> print_sendmail_result r
156 -- Output: some output
157 -- Errors: lots of errors
158 -- Exit Code: 1
159 --
160 print_sendmail_result :: (String, String, ExitCode) -> IO ()
161 print_sendmail_result (outs, errs, ec) =
162 case ec of
163 ExitSuccess -> return ()
164 ExitFailure (code) ->
165 putStrLn $ concat ["Output: " ++ outs,
166 "\nErrors: " ++ errs,
167 "\nExit Code: " ++ (show code)]