diff --git a/Data/Email.hs b/Data/Email.hs new file mode 100644 --- /dev/null +++ b/Data/Email.hs @@ -0,0 +1,31 @@ +module Data.Email (sendSimpleEmail) where + +---------------------------------------- +---- STDLIB +---------------------------------------- +import Data.Encoding (encodeStrictByteString) +import Data.Encoding.UTF8 (UTF8(..)) + +---------------------------------------- +---- SITE-PACKAGES +---------------------------------------- +import Network.EmailSend (sendMessage) +import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..)) + +---------------------------------------- +---- LOCAL +---------------------------------------- +import Data.EmailSerializer (serializeMessage) +import Data.EmailRepr (_EMPTY_EMAIL_, Email(..), email2message, Content(..)) + +sendSimpleEmail backend from to subject text = + sendMessage backend from to ( + (serializeMessage . email2message) + _EMPTY_EMAIL_ { em_from=[(NameAddr Nothing from)] + , em_to=[(NameAddr Nothing to)] + , em_subject=subject + , em_optionals=[("Content-Type", + "text/plain; charset=utf-8")] + , em_body=ContentByte + (encodeStrictByteString UTF8 text) + }) diff --git a/Data/EmailRepr.hs b/Data/EmailRepr.hs new file mode 100644 --- /dev/null +++ b/Data/EmailRepr.hs @@ -0,0 +1,114 @@ +-- vim: set encoding=utf-8 : + +module Data.EmailRepr(Email(..), Message, _EMPTY_EMAIL_, encodeHeaders + ,Headers, Content(..), MimePart(..), email2message) where +---------------------------------------- +---- STDLIB +---------------------------------------- +import Data.Time.Calendar (toGregorian) +import Data.Time.Format (formatTime) +import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), TimeZone(..), ZonedTime(..)) + +import System.Time (CalendarTime(..), Day(..), Month(..)) +import System.Locale (defaultTimeLocale) + +---------------------------------------- +---- SITE-PACKAGES +---------------------------------------- +import Text.ParserCombinators.Parsec.Rfc2822 + (Field(..), NameAddr(..), GenericMessage(..)) +import qualified Data.ByteString as BS (ByteString, empty, concat) +import Data.EmailSerializer (Message, encodeHeader, _CRLF_) + +---------------------------------------- +---- LOCAL +---------------------------------------- + +data Email = Email { em_from :: [NameAddr] + , em_to :: [NameAddr] + , em_cc :: [NameAddr] + , em_bcc :: [NameAddr] + , em_subject :: String + , em_date :: Maybe ZonedTime + , em_optionals :: Headers + , em_body :: Content + } deriving Show + +_EMPTY_EMAIL_ = Email [] [] [] [] "" Nothing [] (ContentByte BS.empty) +type Headers = [(String, String)] + +data Content = ContentByte BS.ByteString | ContentMime MimePart deriving Show + +data MimePart = MimePart + { mp_mime_type :: Maybe String -- text/plain \ + , mp_filename :: Maybe String -- test.txt +--> Content-Type + , mp_charset :: Maybe String -- UTF-8 / + , mp_inline :: Bool -- True ----> Content-Disposition + , mp_optionals :: Headers -- [("MIME-Version", "1.0)] + , mp_content :: Content -- "foo bar" + } deriving Show + +append2 :: BS.ByteString -> BS.ByteString -> BS.ByteString +append2 a b = BS.concat [a, _CRLF_, b] + +encodeHeaders :: Headers -> BS.ByteString +encodeHeaders hs = foldr append2 BS.empty $ map (uncurry encodeHeader) hs + +dow2ltDow :: Int -> Day +dow2ltDow day = + case day of + 0 -> Sunday + 1 -> Monday + 2 -> Tuesday + 3 -> Wednesday + 4 -> Thursday + 5 -> Friday + 6 -> Saturday + +dtMonth2ltMonth :: Int -> Month +dtMonth2ltMonth dtMonth = + case dtMonth of + 1 -> January + 2 -> February + 3 -> March + 4 -> April + 5 -> May + 6 -> June + 7 -> July + 8 -> August + 9 -> September + 10 -> October + 11 -> November + 12 -> December + +zonedTimeToCalendarTime :: ZonedTime -> CalendarTime +zonedTimeToCalendarTime (ZonedTime (LocalTime day (TimeOfDay h min s)) (TimeZone tzMin tzDst tzName)) = +-- = + CalendarTime y' m' d h min s' ps wd yd tzName tzSec tzDst + where (y, m, d) = toGregorian day + y' = fromInteger y + m' = dtMonth2ltMonth m + s' = fromInteger (round s) + tzSec = tzMin * 60 + wd = dow2ltDow (read $ formatTime defaultTimeLocale "%w" day) + ps = 0 + yd = read $ formatTime defaultTimeLocale "%j" day + + +email2message :: Email -> Message +email2message (Email ef et ecc ebcc es ed eo (ContentByte eb)) = + Message fields' eb + where fromField = From ef + toField = To et + ccField = Cc ecc + bccField = Bcc ebcc + subjectField = Subject es + optionalFields = map (uncurry OptionalField) eo + fields = [fromField] ++ [toField] ++ [ccField] ++ [bccField] ++ + [subjectField] ++ optionalFields + fields' = case ed of + Just date -> + fields ++ [dateField] + where format = "%a, %d %b %Y %H:%M:%S %z" + dateField = Date (zonedTimeToCalendarTime date) + Nothing -> fields diff --git a/Data/EmailSerializer.hs b/Data/EmailSerializer.hs new file mode 100644 --- /dev/null +++ b/Data/EmailSerializer.hs @@ -0,0 +1,114 @@ +-- vim: set encoding=utf-8 : + +module Data.EmailSerializer(_CRLF_, Message, encodeHeader, encodeAscii, serializeMessage) where +---------------------------------------- +---- STDLIB +---------------------------------------- +import Data.Encoding (encodeStrictByteString) +import System.Time (calendarTimeToString, CalendarTime) + +---------------------------------------- +---- SITE-PACKAGES +---------------------------------------- +import Text.ParserCombinators.Parsec.Rfc2822 (GenericMessage(..), Field(..), + NameAddr(..)) +import qualified Data.ByteString as BS (ByteString, empty, concat) +import Data.Encoding (encodeStrictByteString) +import Data.Encoding.ASCII (ASCII(..)) + +---------------------------------------- +---- LOCAL +---------------------------------------- +import WashUtils.RFC2047 (encodeValueBS) + +_EMPTY_MESSAGE_ = Message [] BS.empty +_CRLF_ = encodeAscii "\r\n" + +encodeAscii :: String -> BS.ByteString +encodeAscii s = encodeStrictByteString ASCII s + +maybeEncodeValue :: [Char] -> String -> BS.ByteString +maybeEncodeValue "Content-Type" v = encodeAscii v +maybeEncodeValue "Content-Disposition" v = encodeAscii v +maybeEncodeValue k v = encodeValueBS v + +encodeHeaderBS :: String -> BS.ByteString -> BS.ByteString +encodeHeaderBS key value = BS.concat [encodeAscii (key++": "), value] + +encodeHeader :: String -> String -> BS.ByteString +encodeHeader key value = encodeHeaderBS key (maybeEncodeValue key value) + +type Message = GenericMessage BS.ByteString + +serializeMessage :: Message -> BS.ByteString +serializeMessage (Message hs msg) = BS.concat [encodeHeaders hs + ,_CRLF_ + ,msg + ] + +crlfAppend :: BS.ByteString -> BS.ByteString -> BS.ByteString +crlfAppend l r = BS.concat [l, _CRLF_, r] + +encodeHeaders :: [Field] -> BS.ByteString +encodeHeaders fs = foldr crlfAppend BS.empty $ map encodeField fs + +encodeField :: Field -> BS.ByteString +encodeField (OptionalField k v) = BS.concat[encodeAscii k + ,encodeAscii ": " + ,maybeEncodeValue k v + ] +encodeField (From ns) = encodeNameAddrs "From" ns +encodeField (Sender n) = encodeNameAddr "Sender" n +encodeField (ReturnPath r) = encodeHeader "Return-Path" r +encodeField (ReplyTo ns) = encodeNameAddrs "Reply-To" ns +encodeField (To ns) = encodeNameAddrs "To" ns +encodeField (Cc ns) = encodeNameAddrs "Cc" ns +encodeField (Bcc ns) = encodeNameAddrs "Bcc" ns +encodeField (MessageID id) = encodeHeader "Message-ID" id +encodeField (InReplyTo sl) = encodeStringList "In-Reply-To" sl +encodeField (References sl) = encodeStringList "References" sl +encodeField (Subject s) = encodeHeader "Subject" s +encodeField (Comments s) = encodeHeader "Comments" s +encodeField (Keywords dsl) = encodeDoubleStringList "Keywords" dsl +encodeField (Date ct) = encodeCalendarTime "Date" ct +encodeField (ResentDate ct) = encodeCalendarTime "Resent-Date" ct +encodeField (ResentFrom ns) = encodeNameAddrs "Resent-From" ns +encodeField (ResentSender n) = encodeNameAddr "Resent-Sender" n +encodeField (ResentTo ns) = encodeNameAddrs "Resent-To" ns +encodeField (ResentCc ns) = encodeNameAddrs "Resent-Cc" ns +encodeField (ResentBcc ns) = encodeNameAddrs "Resent-Bcc" ns +encodeField (ResentMessageID s) = encodeHeader "Resent-Message-ID" s +encodeField (ResentReplyTo ns) = encodeNameAddrs "Resent-Reply-To" ns +encodeField (Received rc) = encodeReceived "Received" rc +encodeField (ObsReceived orc) = encodeObsReceived "Obs-Received" orc + +appendComma :: BS.ByteString -> BS.ByteString -> BS.ByteString +appendComma l r = BS.concat [l, encodeAscii ", ", r] + +encodeNameAddrs :: String -> [NameAddr] -> BS.ByteString +encodeNameAddrs k vs = encodeHeaderBS k $ + foldr appendComma BS.empty $ map encodeNameAddrValue vs + +encodeNameAddr :: String -> NameAddr -> BS.ByteString +encodeNameAddr k v = encodeHeaderBS k $ encodeNameAddrValue v + +encodeNameAddrValue :: NameAddr -> BS.ByteString +encodeNameAddrValue (NameAddr Nothing m) = encodeValueBS m +encodeNameAddrValue (NameAddr (Just n) m) = encodeValueBS (n++" <"++m++">") + + +encodeStringList :: String -> [String] -> BS.ByteString +encodeStringList k vs = encodeHeaderBS k $ foldr appendComma BS.empty $ + map encodeValueBS vs + +encodeCalendarTime :: String -> System.Time.CalendarTime -> BS.ByteString +encodeCalendarTime k v = encodeHeader k (calendarTimeToString v) + +encodeReceived :: String -> ([(String, String)], CalendarTime) -> BS.ByteString +encodeReceived k v = encodeHeader k (show v) + +encodeObsReceived :: String -> [(String, String)] -> BS.ByteString +encodeObsReceived k v = encodeHeader k (show v) + +encodeDoubleStringList :: String -> [[String]] -> BS.ByteString +encodeDoubleStringList k v = encodeHeader k (show v) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright Johannes Weiss, Dirk Spoeri, Gero Kriependorf 2010 +Copyright 2001-2003, Peter Thiemann. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Johannes Weiss nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/EmailSend.hs b/Network/EmailSend.hs new file mode 100644 --- /dev/null +++ b/Network/EmailSend.hs @@ -0,0 +1,8 @@ +module Network.EmailSend(MailBackend(..), SendingReceipt) where + +import Data.ByteString (ByteString) + +type SendingReceipt = Maybe String + +class MailBackend a where + sendMessage :: a -> String -> String -> ByteString -> IO SendingReceipt diff --git a/Network/EmailSend/SMTP.hs b/Network/EmailSend/SMTP.hs new file mode 100644 --- /dev/null +++ b/Network/EmailSend/SMTP.hs @@ -0,0 +1,33 @@ +module Network.EmailSend.SMTP(SMTPBackend(..)) where + +---------------------------------------- +---- STDLIB +---------------------------------------- + +---------------------------------------- +---- SITE-PACKAGES +---------------------------------------- +import Data.ByteString (ByteString) +import qualified Network.HaskellNet.SMTP as SMTP +import Network.EmailSend (MailBackend(..), SendingReceipt) + +---------------------------------------- +---- LOCAL +---------------------------------------- + +data SMTPBackend = SMTPBackend String String + +instance MailBackend SMTPBackend where + sendMessage = smtpSendMessage + +smtpSendMessage :: SMTPBackend -> String -> String -> ByteString -> + IO SendingReceipt +smtpSendMessage (SMTPBackend server hostname) from to message = (do + c <- SMTP.connectSMTP server + SMTP.sendCommand c $ SMTP.EHLO hostname + SMTP.sendCommand c $ SMTP.MAIL from + SMTP.sendCommand c $ SMTP.RCPT to + SMTP.sendCommand c $ SMTP.DATA message + SMTP.sendCommand c SMTP.NOOP + SMTP.sendCommand c SMTP.QUIT + return Nothing) `catch` (\m -> return $ Just $ show m) diff --git a/Network/EmailSend/SendMail.hs b/Network/EmailSend/SendMail.hs new file mode 100644 --- /dev/null +++ b/Network/EmailSend/SendMail.hs @@ -0,0 +1,43 @@ +module Network.EmailSend.SendMail(sendMessageSendMail + , SendMailBackend(..)) where + +---------------------------------------- +---- STDLIB +---------------------------------------- +import qualified System.IO as Sio +import qualified System.Process as Spo +import qualified Data.ByteString as BS +import System.Exit (ExitCode(..)) + +---------------------------------------- +---- SITE-PACKAGES +---------------------------------------- +import Network.EmailSend (MailBackend(..), SendingReceipt) +import Data.Encoding.UTF8 (UTF8(..)) +import Data.Encoding (decodeStrictByteString) + +---------------------------------------- +---- LOCAL +---------------------------------------- + +_SENDMAIL_BINARY_ = "/usr/sbin/sendmail" + +data SendMailBackend = SendMailBackend String | StdSendMailBackend +instance MailBackend SendMailBackend where + sendMessage = sendMessageSendMail + +sendMessageSendMail :: SendMailBackend -> String -> String -> BS.ByteString -> IO SendingReceipt +sendMessageSendMail (SendMailBackend binary) = sendEmail binary +sendMessageSendMail StdSendMailBackend = sendEmail _SENDMAIL_BINARY_ + +sendEmail :: String -> String -> String -> BS.ByteString -> IO SendingReceipt +sendEmail binary from to message = + do (inh, outh, errh, ph) <- + Spo.runInteractiveProcess binary [to] Nothing Nothing + Sio.hClose outh + BS.hPutStr inh message + Sio.hClose inh + ret <- Spo.waitForProcess ph + case ret of + ExitSuccess -> return Nothing + ExitFailure code -> return $ Just $ show code diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/WashUtils/Base64.hs b/WashUtils/Base64.hs new file mode 100644 --- /dev/null +++ b/WashUtils/Base64.hs @@ -0,0 +1,123 @@ +-- © 2002 Peter Thiemann +-- |Implements RFC 2045 MIME coding. +module WashUtils.Base64 + (encode, encode', decode, decode' + ,alphabet_list + ) + where + +import Data.Array +import Data.Char + +-- +-- |Yields encoded input cropped to lines of less than 76 characters. Directly +-- usable as email body. +encode :: String -> String +encode = encode_base64 +-- |yields continuous stream of bytes. +encode' :: String -> String +encode' = encode_base64' +-- |Directly applicable to email body. +decode :: String -> String +decode = decode_base64 +-- |Only applicable to stream of Base64 characters. +decode' :: String -> String +decode' = decode_base64' +-- |Applicable to list of lines. +decode_lines :: [String] -> String +decode_lines = decode_base64_lines + +-- -------------------------------------------------------------------- +-- |Base64 alphabet in encoding order. +alphabet_list :: String +alphabet_list = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + +encode_base64_alphabet_index = + zip [0 .. (63::Int)] alphabet_list + +decode_base64_alphabet_index = + zip alphabet_list [0 .. (63::Int)] + +encode_base64_alphabet = + array (0 :: Int, 63 :: Int) encode_base64_alphabet_index + +decode_base64_alphabet = + array (' ','z') decode_base64_alphabet_index + +base64_character = + array (chr 0, chr 255) [(c, c `elem` alphabet_list || c == '=') | c <- [chr 0 .. chr 255]] + +encode_base64 = linebreak 76 . encode_base64' + +linebreak m xs = lb m xs + where + lb n [] = "\r\n" + lb 0 xs = '\r':'\n': lb m xs + lb n (x:xs) = x: lb (n-1) xs + +encode_base64' [] = [] + +encode_base64' [ch] = + encode_base64_alphabet!b1 : + encode_base64_alphabet!b2 : + "==" + where (b1, b2, _, _) = encode_base64_group (ch, chr 0, chr 0) + +encode_base64' [ch1, ch2] = + encode_base64_alphabet!b1 : + encode_base64_alphabet!b2 : + encode_base64_alphabet!b3 : + "=" + where (b1, b2, b3, _) = encode_base64_group (ch1, ch2, chr 0) + +encode_base64' (ch1: ch2: ch3: rest) = + encode_base64_alphabet!b1 : + encode_base64_alphabet!b2 : + encode_base64_alphabet!b3 : + encode_base64_alphabet!b4 : + encode_base64' rest + where (b1, b2, b3, b4) = encode_base64_group (ch1, ch2, ch3) + +-- 111111 112222 222233 333333 +encode_base64_group (ch1, ch2, ch3) = (b1, b2, b3, b4) + where o1 = ord ch1 + o2 = ord ch2 + o3 = ord ch3 + b1 = o1 `div` 4 + b2 = (o1 `mod` 4) * 16 + o2 `div` 16 + b3 = (o2 `mod` 16) * 4 + o3 `div` 64 + b4 = o3 `mod` 64 + +decode_base64_group (b1, b2, b3, b4) = (ch1, ch2, ch3) + where ch1 = chr (b1 * 4 + b2 `div` 16) + ch2 = chr (b2 `mod` 16 * 16 + b3 `div` 4) + ch3 = chr (b3 `mod` 4 * 64 + b4) + +decode_base64' [] = [] + +decode_base64' [cin1, cin2, '=', '='] = [cout1] + where (cout1, _, _) = + decode_base64_group (decode_base64_alphabet!cin1 + ,decode_base64_alphabet!cin2 + ,0 + ,0) + +decode_base64' [cin1, cin2, cin3, '='] = [cout1, cout2] + where (cout1, cout2, _) = + decode_base64_group (decode_base64_alphabet!cin1 + ,decode_base64_alphabet!cin2 + ,decode_base64_alphabet!cin3 + ,0) + +decode_base64' (cin1: cin2: cin3: cin4: rest) = + cout1: cout2: cout3: decode_base64' rest + where (cout1, cout2, cout3) = + decode_base64_group (decode_base64_alphabet!cin1 + ,decode_base64_alphabet!cin2 + ,decode_base64_alphabet!cin3 + ,decode_base64_alphabet!cin4) + +decode_base64 = decode_base64' . filter (base64_character!) + +decode_base64_lines = decode_base64' . concat diff --git a/WashUtils/Hex.hs b/WashUtils/Hex.hs new file mode 100644 --- /dev/null +++ b/WashUtils/Hex.hs @@ -0,0 +1,48 @@ +-- © 2001, 2003 Peter Thiemann +module WashUtils.Hex where + +import Data.Array +import Data.Char + +hexdigit :: Int -> Char +hexdigit i = hexdigits ! i + +hexdigits' = "0123456789ABCDEF" +alternative_digits = "abcdef" +alternative_indices :: [(Int, Char)] +alternative_indices = zip [10..15] alternative_digits +hexdigits'_indices :: [(Int, Char)] +hexdigits'_indices = [(i, hexdigits'!!i) | i <- [0..15]] + +hexdigits = array (0, 15) hexdigits'_indices + +fromHexdigits = + array (chr 0, chr 127) + (map (\ (x,y) -> (y, x)) (hexdigits'_indices ++ alternative_indices)) + +isHexdigitArray = + array (chr 0, chr 127) + (map (\ c -> (c, isHexdigit c)) [chr 0 .. chr 127]) + where + isHexdigit :: Char -> Bool + isHexdigit x = + (x >= '0' && x <= '9') || + (x >= 'a' && x <= 'f') || + (x >= 'A' && x <= 'F') + +isHexdigit :: Char -> Bool +isHexdigit x = + x <= chr 127 && isHexdigitArray ! x + +showHex2 :: Int -> String +showHex2 ox = showsHex 2 ox "" + +showsHex :: Int -> Int -> ShowS +showsHex 0 x = id +showsHex i x = let (d,m) = x `divMod` 16 in showsHex (i-1) d . showChar (hexdigits ! m) + +hexDigitVal :: Char -> Int +hexDigitVal x | isHexdigit x = fromHexdigits ! x + | otherwise = 0 + +allDigits = hexdigits' ++ alternative_digits diff --git a/WashUtils/QuotedPrintable.hs b/WashUtils/QuotedPrintable.hs new file mode 100644 --- /dev/null +++ b/WashUtils/QuotedPrintable.hs @@ -0,0 +1,49 @@ +-- © 2003 Peter Thiemann +module WashUtils.QuotedPrintable + (encode, encode', decode + -- deprecated: encode_quoted, encode_quoted', decode_quoted + ) where + +import Data.Char +import WashUtils.Hex + +encode, encode', decode :: String -> String +encode = encode_quoted +encode' = encode_quoted' +decode = decode_quoted + + +encode_hexadecimal c = '=' : showHex2 c + +quoted_printable x = + ox >= 33 && ox <= 126 && ox /= 61 && ox /= 63 + where ox = ord x + +end_of_line [] = False +end_of_line ('\r':'\n':_) = True +end_of_line _ = False + +encode_quoted' (x:xs) | x `elem` "\t " = + encode_hexadecimal (ord x) ++ encode_quoted' xs +encode_quoted' (x:xs) | quoted_printable x = x : encode_quoted' xs +encode_quoted' ('\r':'\n':xs) = '\r':'\n': encode_quoted' xs +encode_quoted' (x:xs) = encode_hexadecimal (ord x) ++ encode_quoted' xs +encode_quoted' [] = "" + +encode_quoted = softLineBreak 76 . encode_quoted' + +softLineBreak n [] = [] +softLineBreak 0 xs | not (end_of_line xs) = '=':'\r':'\n': softLineBreak 76 xs +softLineBreak n ('\r':'\n':xs) = '\r':'\n': softLineBreak 76 xs +softLineBreak n (xs@('=':_)) | n < 4 = '=':'\r':'\n': softLineBreak 76 xs +softLineBreak n (x:xs) = x : softLineBreak (n-1) xs + +decode_quoted [] = [] +decode_quoted ('=':'\r':'\n':xs) = + decode_quoted xs +decode_quoted ('=':'\n':xs) = + decode_quoted xs +decode_quoted ('=':upper:lower:xs) | isHexdigit upper && isHexdigit lower = + chr (16 * hexDigitVal upper + hexDigitVal lower) : decode_quoted xs +decode_quoted (x:xs) = + x : decode_quoted xs diff --git a/WashUtils/RFC2047.hs b/WashUtils/RFC2047.hs new file mode 100644 --- /dev/null +++ b/WashUtils/RFC2047.hs @@ -0,0 +1,108 @@ +-- © 2003 Peter Thiemann +module WashUtils.RFC2047 where +-- decoding of header fields +import qualified Data.ByteString as Bs +import qualified Data.ByteString.Char8 as BsChar8 +import Data.Char +import qualified Data.Encoding as DataEnc +import Data.Encoding.ASCII (ASCII(..)) +import Data.Encoding (encodeStrictByteString) +import Data.List + +import qualified WashUtils.Base64 as Base64 +import qualified WashUtils.QuotedPrintable as QuotedPrintable +import qualified WashUtils.Base64 as Base64 +import WashUtils.Hex + +import Text.ParserCombinators.Parsec + +lineString = + do initial <- many (noneOf "\n\r=") + rest <- option "" (do xs <- try encoded_words <|> string "=" + ys <- lineString + return (xs ++ ys)) + return (initial ++ rest) + +especials = "()<>@,;:\\\"/[]?.=" +tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials +p_token = many1 (oneOf tokenchar) +p_encoded_text = many1 $ oneOf "!\"#$%&'()*+,-./0123456789:;<=>@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" +allchar = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\a\b\t\n\v\f\r\SO\SI\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\EM\SUB\ESC\FS\GS\RS\US !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\DEL" + +-- supress linear white space between adjacent encoded_word +encoded_words = + do ew <- encoded_word + ws <- many space + option (ew++ws) (encoded_words >>= \ews -> return (ew++ews)) + +encoded_word = + do string "=?" + charset <- p_token + char '?' + encoding <- p_token + char '?' + encoded_text <- p_encoded_text + string "?=" + return $ decode charset (map toUpper encoding) encoded_text + +decodeCharset charset text = +--encodeCharset charset text = + DataEnc.decodeStrictByteString encoding (BsChar8.pack text) + where encoding = DataEnc.encodingFromString (map toUpper charset) + +decode charset "B" encoded_text = + decodeCharset charset (Base64.decode' encoded_text) +decode charset "Q" encoded_text = + decodeCharset charset (decode_quoted encoded_text) +decode charset encoding encoded_text = + error ("Unknown encoding: " ++ encoding) + +decode_quoted [] = [] +decode_quoted ('=':upper:lower:xs) = + chr (16 * hexDigitVal upper + hexDigitVal lower) : decode_quoted xs +--decode_quoted ('_':xs) = ' ' : decode_quoted xs +decode_quoted (x:xs) = + x : decode_quoted xs + +-- -------------------------------------------------------------------- +-- RFC 2047: encoding of header fields + +encodeCharset :: String -> String -> [Char] +encodeCharset charset text = + BsChar8.unpack (DataEnc.encodeStrictByteString encoder text) + where encoder = DataEnc.encodingFromString charset + +encodeWord :: String -> [Char] +encodeWord w = + "=?" ++ charset ++ "?" ++ encoding ++ "?" ++ encoded ++ "?=" + where encoding = "B" + charset = "UTF-8" + --encoded = QuotedPrintable.encode' converted + encoded = Base64.encode' converted + converted = encodeCharset charset w + +encodeValue :: [Char] -> [Char] +encodeValue v = + case span (not . flip elem "()<>@.!,?") v of + ([], []) -> [] + (word, []) -> maybeEncode word + (word, x:rest) -> maybeEncode word ++ x : encodeValue rest + +maybeEncode :: [Char] -> [Char] +maybeEncode word | all p word = word + | otherwise = encodeWord word + where p x = x /= '?' && let ox = ord x in ox >= 33 && ox <= 126 + +encodeAscii = encodeStrictByteString ASCII + +encodeCharsetBS :: String -> String -> Bs.ByteString +encodeCharsetBS x = encodeAscii . encodeCharset x + +encodeWordBS :: String -> Bs.ByteString +encodeWordBS = encodeAscii . encodeWord + +encodeValueBS :: [Char] -> Bs.ByteString +encodeValueBS = encodeAscii . encodeValue + +maybeEncodeBS :: [Char] -> Bs.ByteString +maybeEncodeBS = encodeAscii . maybeEncode diff --git a/email.cabal b/email.cabal new file mode 100644 --- /dev/null +++ b/email.cabal @@ -0,0 +1,24 @@ +Name: email +Version: 0.1 +Author: Johannes Weiss , Dirk Spoeri, + Gero Kriependorf +License: BSD3 +License-File: LICENSE +Maintainer: Johannes Weiss +Category: Network +Synopsis: Sending eMail in Haskell made easy +Cabal-Version: >=1.6 +Build-Type: Simple +Tested-With: GHC == 6.12.1 +Description: A simple and small library for sending eMail. + +Library + Build-Depends: base == 4.*, bytestring, HaskellNet, encoding, process, + hsemail >= 1.4, old-locale, old-time, time, parsec, + array + Exposed-Modules: Network.EmailSend + Network.EmailSend.SMTP + Network.EmailSend.SendMail + Data.Email + Data.EmailRepr + Data.EmailSerializer diff --git a/testemail.hs b/testemail.hs new file mode 100644 --- /dev/null +++ b/testemail.hs @@ -0,0 +1,28 @@ +{- vim: set encoding=utf-8 : + -*- coding: utf-8 -*- -} +---------------------------------------- +---- STDLIB +---------------------------------------- + +---------------------------------------- +---- SITE-PACKAGES +---------------------------------------- +import Network.EmailSend.SendMail (SendMailBackend(..)) +import Data.Email (sendSimpleEmail) +import Network.EmailSend(sendMessage, MailBackend(..), SendingReceipt, ) +import Network.EmailSend.SMTP (SMTPBackend(..)) +import Network.EmailSend.SendMail (SendMailBackend(..)) + +---------------------------------------- +---- LOCAL +---------------------------------------- + +main = do + putStrLn "Sending Mail..." + let smtp = SMTPBackend "localhost" "localhost" + --sendSimpleEmail StdSendMailBackend "dirk" "weissi" "test ääööüü" "hallo ääüüöö" + x <- sendSimpleEmail smtp "dirk" "weissi" "test ääööüü" "hallo ääüüöö" + case x of + Nothing -> putStrLn "done." + Just m -> putStrLn $ "ERROR: "++m + putStrLn "bye bye"