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 -- |Showing a message will print it in roughly RFC-compliant
26 -- form. This form is sufficient for handing the message off to
28 instance Show Message where
30 concat [ if (length (headers m) == 0) then "" else (intercalate "\n" (headers m)) ++ "\n",
31 "Subject: " ++ (subject m) ++ "\n",
32 "From: " ++ (from m) ++ "\n",
33 "To: " ++ (to m) ++ "\n",
39 -- |Pad a string on the left with zeros until the entire string has
41 pad_left :: String -> Int -> String
43 | n < (length str) = str
44 | otherwise = (replicate num_zeros '0') ++ str
45 where num_zeros = n - (length str)
49 -- |Formats a month name according to RFC822.
50 format_month :: Month -> String
51 format_month month = take 3 (show month)
54 -- |Takes an offset from UTC (in seconds) and returns the four-digit
55 -- offset as a 'String' in +hhmm format.
56 format_timezone :: Int -> String
57 format_timezone seconds =
58 sign ++ pad_hh ++ pad_mm
60 seconds_norm = abs seconds
61 hh = seconds_norm `div` 3600
62 mm = (seconds_norm - (hh*3600)) `div` 60
63 pad_hh = pad_left (show hh) 2
64 pad_mm = pad_left (show mm) 2
65 sign = if seconds < 0 then "-" else "+"
68 -- |Takes a 'ClockTime' as an argument, and formats it as an RFC822 Date header.
72 -- <http://cr.yp.to/immhf/date.html>
75 format_clocktime :: ClockTime -> IO String
76 format_clocktime ct = do
77 caltime <- (toCalendarTime ct)
79 let days = pad_left (show (ctDay caltime)) 2
80 let month = format_month (ctMonth caltime)
81 let year = show $ ctYear caltime
82 let hours = pad_left (show (ctHour caltime)) 2
83 let minutes = pad_left (show (ctMin caltime)) 2
84 let seconds = pad_left (show (ctSec caltime)) 2
85 let timezone = format_timezone (ctTZ caltime)
87 return $ concat [(show $ ctWDay caltime) ++ ", ",
97 -- |Constructs an RFC822 Date header with the current date/time.
98 construct_date_header :: IO String
99 construct_date_header = do
101 format_clocktime date
105 -- |Takes a message as an argument, and passes it to the system's
107 sendmail :: Message -> IO (String, String, ExitCode)
108 sendmail message = do
109 let sendmail_args = ["-f",
112 (inh, outh, errh, ph) <-
113 runInteractiveProcess "/usr/bin/sendmail" sendmail_args Nothing Nothing
116 outs <- hGetContents outh
119 errs <- hGetContents errh
121 forkIO $ hPutStr inh (show message) >> hClose inh
122 forkIO $ evaluate (length outs) >> putMVar outm ()
123 forkIO $ evaluate (length errs) >> putMVar errm ()
128 ec <- waitForProcess ph
129 return (outs, errs, ec)
132 -- |The 'sendmail' function returns a three-tuple of its outputs,
133 -- errors, and exit codes. This function pretty-prints one of those
135 print_sendmail_result :: (String, String, ExitCode) -> IO ()
136 print_sendmail_result (outs, errs, ec) = do
138 ExitSuccess -> return ()
139 _ -> putStrLn $ concat ["Output: " ++ outs,
140 "\nErrors: " ++ errs,
141 "\nExit Code: " ++ (show ec)]