1 -- |Email functions and data types.
6 import Control.Concurrent
7 import Control.Concurrent.MVar
8 import Control.Exception (evaluate)
9 import Data.List (intercalate)
12 import System.Time (CalendarTime(..), ClockTime, getClockTime, Month, toCalendarTime)
17 -- |A crude model of an RFC821 email message.
18 data Message = Message { headers :: [Header],
25 default_headers :: [Header]
26 default_headers = ["MIME-Version: 1.0",
27 "Content-type: text/plain; charset=UTF-8"]
29 -- |Showing a message will print it in roughly RFC-compliant
30 -- form. This form is sufficient for handing the message off to
32 instance Show Message where
34 concat [ if (length (headers m) == 0) then "" else (intercalate "\n" (headers m)) ++ "\n",
35 "Subject: " ++ (subject m) ++ "\n",
36 "From: " ++ (from m) ++ "\n",
37 "To: " ++ (to m) ++ "\n",
43 -- |Pad a string on the left with zeros until the entire string has
45 pad_left :: String -> Int -> String
47 | n < (length str) = str
48 | otherwise = (replicate num_zeros '0') ++ str
49 where num_zeros = n - (length str)
53 -- |Formats a month name according to RFC822.
54 format_month :: Month -> String
55 format_month month = take 3 (show month)
58 -- |Takes an offset from UTC (in seconds) and returns the four-digit
59 -- offset as a 'String' in +hhmm format.
60 format_timezone :: Int -> String
61 format_timezone seconds =
62 sign ++ pad_hh ++ pad_mm
64 seconds_norm = abs seconds
65 hh = seconds_norm `div` 3600
66 mm = (seconds_norm - (hh*3600)) `div` 60
67 pad_hh = pad_left (show hh) 2
68 pad_mm = pad_left (show mm) 2
69 sign = if seconds < 0 then "-" else "+"
72 -- |Takes a 'ClockTime' as an argument, and formats it as an RFC822 Date header.
76 -- <http://cr.yp.to/immhf/date.html>
79 format_clocktime :: ClockTime -> IO String
80 format_clocktime ct = do
81 caltime <- (toCalendarTime ct)
83 let days = pad_left (show (ctDay caltime)) 2
84 let month = format_month (ctMonth caltime)
85 let year = show $ ctYear caltime
86 let hours = pad_left (show (ctHour caltime)) 2
87 let minutes = pad_left (show (ctMin caltime)) 2
88 let seconds = pad_left (show (ctSec caltime)) 2
89 let timezone = format_timezone (ctTZ caltime)
91 return $ concat [(show $ ctWDay caltime) ++ ", ",
101 -- |Constructs an RFC822 Date header with the current date/time.
102 construct_date_header :: IO String
103 construct_date_header = do
105 format_clocktime date
109 -- |Takes a message as an argument, and passes it to the system's
111 sendmail :: Message -> IO (String, String, ExitCode)
112 sendmail message = do
113 let sendmail_args = ["-f",
116 (inh, outh, errh, ph) <-
117 runInteractiveProcess "/usr/bin/sendmail" sendmail_args Nothing Nothing
120 outs <- hGetContents outh
123 errs <- hGetContents errh
125 forkIO $ hPutStr inh (show message) >> hClose inh
126 forkIO $ evaluate (length outs) >> putMVar outm ()
127 forkIO $ evaluate (length errs) >> putMVar errm ()
132 ec <- waitForProcess ph
133 return (outs, errs, ec)
136 -- |The 'sendmail' function returns a three-tuple of its outputs,
137 -- errors, and exit codes. This function pretty-prints one of those
139 print_sendmail_result :: (String, String, ExitCode) -> IO ()
140 print_sendmail_result (outs, errs, ec) = do
142 ExitSuccess -> return ()
143 _ -> putStrLn $ concat ["Output: " ++ outs,
144 "\nErrors: " ++ errs,
145 "\nExit Code: " ++ (show ec)]