SMTPClient (empty) → 0.1
raw patch · 6 files changed
+583/−0 lines, 6 filesdep +basedep +containersdep +hsemailsetup-changed
Dependencies added: base, containers, hsemail, network, old-locale, old-time
Files
- LICENSE +27/−0
- Network/SMTP/Client.hs +84/−0
- Network/SMTP/ClientSession.hs +405/−0
- SMTPClient.cabal +24/−0
- Setup.hs +3/−0
- example.hs +40/−0
+ LICENSE view
@@ -0,0 +1,27 @@+/*+ * Copyright (c) 2008, Stephen Blackheath+ * 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 the <organization> nor the+ * names of its contributors may be used to endorse or promote products+ * derived from this software without specific prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY STEPHEN BLACKHEATH ''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 STEPHEN BLACKHEATH 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.+ */+
+ Network/SMTP/Client.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Network.SMTP.Client (+ sendSMTP,+ sendSMTP_,+ SMTPException(..)+ ) where++import Network.SMTP.ClientSession+import Control.Exception+import Text.ParserCombinators.Parsec.Rfc2822 (+ Message(..),+ Field(..),+ NameAddr(..)+ )+import Network.Socket+import Control.Applicative+import System.IO+import Control.Monad+import Data.Typeable+import Data.IORef+++-- | Send a list of email messages to an SMTP server. Throws SMTPException on+-- failure at the communication protocol level.+-- The message body may contain either \"\n\" or \"\\r\\n\" for an end-of-line+-- marker and in all cases it will be sent correctly to the server.+sendSMTP :: String -- ^ Domain name for EHLO command+ -> SockAddr -- ^ Network address of SMTP server+ -> [Message] -- ^ List of messages to send+ -> IO ()+sendSMTP = sendSMTP_ (\_ -> return ()) Nothing++-- | Like sendSMTP_ but takes an additional function for logging all input and+-- output for diagnostic purposes. Also an optional IORef for storing the+-- number of emails sent so far. The emails are sent strictly in order, so this+-- count can be used when an exception is caught to mark sent emails.+sendSMTP_ :: (String -> IO ()) -- ^ Diagnostic log function+ -> Maybe (IORef Int) -- ^ Optional IORef for storing the number of+ -- emails successfully sent so far.+ -> String -- ^ Domain name for EHLO command+ -> SockAddr -- ^ Network address of SMTP server+ -> [Message] -- ^ List of messages to send+ -> IO ()+sendSMTP_ log mSentSoFar domain sockAddr messages = do+ sock <- socket AF_INET Stream defaultProtocol+ connect sock sockAddr+ handle <- socketToHandle sock ReadWriteMode+ (do+ let smtp = smtpClientSession domain messages+ process handle smtp+ ) `finally` hClose handle+ where+ + process :: Handle -> SMTPState -> IO ()+ process h state = do+ + case mSentSoFar of+ Just sentSoFar -> writeIORef sentSoFar (smtpSent state)+ Nothing -> return ()+ + forM_ (reverse $ smtpOutQueue state) $ \ line -> do+ log $ "-> "++line+ hPutStr h line+ hPutStr h "\r\n"+ hFlush h+ + case (smtpSuccess state, smtpFailure state) of+ (True, _) -> do+ log "SUCCEEDED"+ (False, Just err) ->+ throwIO $ SMTPException err+ otherwise -> do+ -- Strip trailing \r. hGetLine has already stripped \n for us.+ reply <- reverse . dropWhile (=='\r') . reverse <$> hGetLine h+ putStrLn $ "<- "++reply+ let state' = smtpReceive state reply $ state {smtpOutQueue = []}+ process h state'+++data SMTPException = SMTPException String+ deriving (Eq, Show, Typeable)++instance Exception SMTPException where
+ Network/SMTP/ClientSession.hs view
@@ -0,0 +1,405 @@+module Network.SMTP.ClientSession (+ smtpClientSession,+ SMTPState(..)+ {-, suite-}+ ) where++import Text.ParserCombinators.Parsec.Rfc2821 (+ SmtpReply(..),+ SmtpCode(..),+ SuccessCode(..),+ Category(..),+ reply+ )+import Text.ParserCombinators.Parsec.Rfc2822 (+ Message(..),+ Field(..),+ NameAddr(..)+ )+import Data.Maybe+import qualified Data.Set as Set+import Prelude hiding (fail, return)+import Data.List+import System.Time+import System.Locale+++{-import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit-}++{-suite = testGroup "MetaBarter.SMTP.SMTP" [+ testCase "dotAtomAllowed" test_dotAtomAllowed,+ testCase "quoted_string" test_quoted_string+ ]-}++data SMTPState = SMTPState {++ -- | Caller must output any lines queued up in this list, making sure to+ -- clear them in the state passed back to smtpReceive. These lines are in+ -- reverse order, so the caller must reverse them before processing.+ -- They do not have end-of-line characters, so the caller must add \"\\r\\n\"+ -- on the end (as required by RFC2821 - not just \"\\n\").+ smtpOutQueue :: [String],++ -- | When there is nothing to send, the caller should wait for a line from+ -- the SMTP server, strip any end-of-line characters, and pass it to this+ -- function for processing.+ smtpReceive :: String -> SMTPState -> SMTPState,++ -- | When True, this flag indicates that the SMTP session has completed+ -- successfully and there is no more work to do.+ smtpSuccess :: Bool,++ -- | When Just err, this indicates that a protocol error has occurred, and+ -- that the caller must terminate the session.+ smtpFailure :: Maybe String,++ -- | The number of emails successfully sent so far.+ smtpSent :: Int+ }++send :: String -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState+send txt return state =+ return $+ state {+ smtpOutQueue = txt:smtpOutQueue state+ }++nullReceive :: String -> SMTPState -> SMTPState+nullReceive _ state = state++receive :: (String -> SMTPState -> SMTPState) -> SMTPState -> SMTPState+receive cont state =+ state {+ smtpReceive = \line state -> cont line $ state {smtpReceive = nullReceive}+ }++fail :: String -> SMTPState -> SMTPState+fail errorText state =+ state {+ smtpFailure = Just errorText+ }++success :: SMTPState -> SMTPState+success state = state {smtpSuccess = True}++check :: SuccessCode -> Category -> String -> SmtpReply -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState+check code cat descr reply return =+ case reply of+ Reply (Code gotCode gotCat _) _ | gotCode == code && gotCat == cat -> return+ _ -> fail $ "SMTP error: got "+++ (cleanUp $ show reply)+++ " when I expected "++descr++cleanUp :: String -> String+cleanUp =+ map (\x -> if x == '\n' then '/' else x) .+ reverse .+ dropWhile (\x -> x == '\n') .+ reverse .+ filter (/= '\r')+ +maybeRead :: Read a => String -> Maybe a+maybeRead s = case reads s of+ [(x, "")] -> Just x+ _ -> Nothing++for :: [a] -> (a -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState) -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState+for [] _ return = return+for (x:xs) code return =+ code x $+ for xs code return++incSent :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState+incSent return state = return $ state {smtpSent = smtpSent state + 1}++-- | Receive an SMTP reply, e.g.+-- 250-worked+-- 250-like+-- 250 a charm+receiveReply :: (SmtpReply -> SMTPState -> SMTPState) -> SMTPState -> SMTPState+receiveReply return =+ rec [] $ \revMsgs@(final:_) ->+ if length(final) < 4 || final !! 3 /= ' ' then+ fail ("malformed SMTP reply: "++final)+ else+ case maybeRead (take 3 final) of+ Just code ->+ return $ mkReply code (reverse $ map (drop 4) revMsgs)+ Nothing ->+ fail ("Malformed SMTP reply: "++final)+ where+ rec :: [String] -> ([String] -> SMTPState -> SMTPState) -> SMTPState -> SMTPState+ rec msgs return =+ receive $ \line ->+ if length(line) < 4 then+ fail ("malformed SMTP reply: "++line)+ else if line !! 3 == '-' then+ rec (line:msgs) return+ else+ return (line:msgs)++ mkReply :: Int -> [String] -> SmtpReply+ mkReply code msgs = reply (code `div` 100) ((code `div` 10) `mod` 10) (code `mod` 10) msgs++checkMailOK :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState+checkMailOK return =+ receiveReply $ \reply ->+ check Success MailSystem "\"mail system OK\" (code 25x)" reply $+ return++checkConnectionOK :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState+checkConnectionOK return =+ receiveReply $ \reply ->+ check Success Connection "\"connection OK\" (code 22x)" reply $+ return++checkDataOK :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState+checkDataOK return =+ receiveReply $ \reply ->+ check IntermediateSuccess MailSystem "\"connection OK\" (code 35x)" reply $+ return++-- | Pure state machine for an SMTP client session. Caller must handle I/O.+-- The message body may contain either \"\n\" or \"\\r\\n\" for an end-of-line+-- marker. All are stripped before passing to caller for dispatch.+smtpClientSession :: String -- ^ Domain name used in EHLO command+ -> [Message] -- ^ List of messges to send+ -> SMTPState+smtpClientSession domain messages = talk domain messages $ SMTPState {+ smtpOutQueue = [],+ smtpReceive = nullReceive,+ smtpSuccess = False,+ smtpFailure = Nothing,+ smtpSent = 0+ }++-- Continuation passing style.+talk :: String -> [Message] -> SMTPState -> SMTPState+talk domain messages =+ checkConnectionOK $+ send ("EHLO "++domain) $+ checkMailOK $+ sendMessages messages $+ send "QUIT" $+ checkConnectionOK $+ success+ where+ sendMessages :: [Message] -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState+ sendMessages messages return =+ for messages (\message cont ->+ sendMessage message cont+ ) $+ return++ sendMessage :: Message -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState+ sendMessage message return =+ let Message fields _ = message++ froms = map (\(NameAddr _ addr) -> addr) $+ concatMap (\f ->+ case f of+ From from -> from+ _ -> []) fields++ tos = map (\(NameAddr _ addr) -> addr) $+ concatMap (\f ->+ case f of+ To to -> to+ Cc to -> to+ Bcc to -> to+ _ -> []) fields in++ if null froms then+ fail "email contains no From: field"+ else if null tos then+ fail "email contains to To: field"+ else (+ send ((("MAIL FROM:"++) . angle_addr (head froms)) "") $+ checkMailOK $+ for tos (\to return ->+ send ((("RCPT TO:"++) . angle_addr to) "") $+ checkMailOK $+ return+ ) $+ send "DATA" $+ checkDataOK $+ let msgLines = formatMessage message in+ for msgLines (\line return ->+ send (if line == "." then ". " else line) $+ return+ ) $+ send "." $+ checkMailOK $+ incSent+ return+ )++atext_alphabet = Set.fromList $+ "abcdefghijklmnopqrstuvwxyz"+++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"+++ "0123456789"+++ "!#$%&'*+-/=?^_`{|}~"++atomAllowed :: String -> Bool+atomAllowed "" = False+atomAllowed txt = all (`Set.member` atext_alphabet) txt++dotAtomAllowed :: String -> Bool+dotAtomAllowed str =+ let (at, rest) = break (== '.') str in+ if not $ atomAllowed at then+ False+ else+ if null rest then+ True+ else+ dotAtomAllowed (tail rest)++{-+test_dotAtomAllowed = do+ assertEqual "" False (dotAtomAllowed "")+ assertEqual "a" True (dotAtomAllowed "a")+ assertEqual "a<" False (dotAtomAllowed "a<")+ assertEqual ".a" False (dotAtomAllowed ".a")+ assertEqual "abc.012$" True (dotAtomAllowed "abc.012$")+ assertEqual "01.%^.xyzzy" True (dotAtomAllowed "01.%^.xyzzy")+ assertEqual "01..xyzzy" False (dotAtomAllowed "01..xyzzy")+ assertEqual "01.xyzzy." False (dotAtomAllowed "01.xyzzy.")+-}++addr_spec :: String -> ShowS+addr_spec addr =+ let (local, at_domain) = break (=='@') addr+ domain = if "@" `isPrefixOf` at_domain then tail at_domain else at_domain in+ dotatom_or_quoted local . ("@"++) . dotatom_or_domain_literal domain++angle_addr :: String -> ShowS+angle_addr addr =+ ("<"++) . addr_spec addr . (">"++)++msg_id :: String -> ShowS+msg_id mid = angle_addr mid++atom_or_quoted :: String -> ShowS+atom_or_quoted text =+ if atomAllowed text then+ (text++)+ else+ quoted_string text++phrase = atom_or_quoted+display_name = phrase++dotatom_or_quoted :: String -> ShowS+dotatom_or_quoted text =+ if dotAtomAllowed text then+ (text++)+ else+ quoted_string text++quoted_string :: String -> ShowS+quoted_string text = ("\""++) . (quoted_ text++) . ("\""++)+ where+ quoted_ [] = []+ quoted_ (x:xs) =+ case x of+ '\\' -> '\\':'\\':quoted_ xs+ '"' -> '\\':'"':quoted_ xs+ _ -> x:quoted_ xs++{-+test_quoted_string = do+ assertEqual "" (quoted_string "" "") "\"\""+ assertEqual "Hello" (quoted_string "Hello" "") "\"Hello\""+ assertEqual "Say, \"Hello\"" (quoted_string "Say, \"Hello\"" "") "\"Say, \\\"Hello\\\"\""+ assertEqual "Backslash\\" (quoted_string "Backslash\\" "") "\"Backslash\\\\\""+-}++dotatom_or_domain_literal :: String -> ShowS+dotatom_or_domain_literal text =+ if dotAtomAllowed text then+ (text++)+ else+ domain_literal text++domain_literal :: String -> ShowS+domain_literal text = ("["++) . (quoted_ text++) . ("]"++)+ where+ quoted_ [] = []+ quoted_ (x:xs) =+ case x of+ '\\' -> '\\':'\\':quoted_ xs+ '[' -> '\\':'[':quoted_ xs+ ']' -> '\\':']':quoted_ xs+ _ -> x:quoted_ xs++name_addr :: NameAddr -> ShowS+name_addr (NameAddr mName addr) =+ (case mName of+ Just name -> display_name name . (" "++)+ Nothing -> id) .+ angle_addr addr++address_list :: [NameAddr] -> ShowS+address_list addrs =+ foldr (.) id $ intersperse (",\n"++) $ map name_addr addrs++formatMessage :: Message -> [String]+formatMessage (Message fields body) =+ concatMap (indent . formatField) fields +++ [""] +++ map (reverse . dropWhile (=='\r') . reverse) (lines body)++indent :: String -> [String]+indent text =+ case lines text of+ [] -> []+ (l:ls) -> l:map (" "++) ls++formatField :: Field -> String+formatField (OptionalField name value) = name ++ ": " ++ value+formatField (From addrs) = (("From: "++) . address_list addrs) ""+formatField (Sender addr) = (("From: "++) . name_addr addr) ""+formatField (ReturnPath txt) = "Return-Path: "++txt+formatField (ReplyTo addrs) = (("Reply-To: "++) . address_list addrs) ""+formatField (To addrs) = (("To: "++) . address_list addrs) ""+formatField (Cc addrs) = (("Cc: "++) . address_list addrs) ""+formatField (Bcc addrs) = (("Bcc: "++) . address_list addrs) ""+formatField (MessageID mid) = (("Message-ID: "++) . msg_id mid) ""+formatField (InReplyTo mids) = (("In-Reply-To: "++) . foldr (.) id (map msg_id mids)) ""+formatField (References mids) = (("References: "++) . foldr (.) id (map msg_id mids)) ""+formatField (Subject txt) = "Subject: "++txt+formatField (Comments txt) = "Comments: "++txt+formatField (Keywords kws) = (("Keywords: "++) . foldr (.) id (intersperse (",\n"++) $ map phrase (concat kws))) ""+formatField (Date date) = "Date: "++formatDate date+formatField (ResentDate date) = "Resent-Date: "++formatDate date+formatField (ResentFrom addrs) = (("Resent-From: "++) . address_list addrs) ""+formatField (ResentSender addr) = (("Resent-From: "++) . name_addr addr) ""+formatField (ResentTo addrs) = (("Resent-To: "++) . address_list addrs) ""+formatField (ResentCc addrs) = (("Resent-Cc: "++) . address_list addrs) ""+formatField (ResentBcc addrs) = (("Resent-Bcc: "++) . address_list addrs) ""+formatField (ResentMessageID mid) = (("Resent-Message-ID: "++) . msg_id mid) ""+formatField (ResentReplyTo addrs) = (("Resent-Reply-To: "++) . address_list addrs) ""+formatField (Received (ps, date)) = (("Received: "++) . pairs ps . (";"++) . (formatDate date++)) ""+formatField (ObsReceived ps) = (("Received: "++) . pairs ps) ""++formatDate :: CalendarTime -> String+formatDate ct = formatCalendarTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S " ct ++ formatTimeZone (ctTZ ct)++formatTimeZone :: Int -> String+formatTimeZone offset =+ if offset < 0 then+ "-"++ftz (-offset)+ else+ "+"++ftz offset+ where+ ftz offset = dig2 (offset `div` 3600) ++ dig2 ((offset `div` 60) `mod` 60)+ dig2 n = (\n -> if n < 10 then "0"++show n else show n) (n `mod` 100)++pairs :: [(String, String)] -> ShowS+pairs ps = foldr (.) id $ intersperse ("\n"++) $ map pair ps+ where+ pair (name, value) =+ (name++) . (" "++) . (value++)
+ SMTPClient.cabal view
@@ -0,0 +1,24 @@+name: SMTPClient+version: 0.1+license: BSD3+license-file: LICENSE+cabal-version: >= 1.2+copyright: (c) Stephen Blackheath+author: Stephen Blackheath+maintainer: http://blacksapphire.com/antispam/+stability: beta+synopsis: A simple SMTP client+description:+ A simple SMTP client+ .+ DARCS repository:+ <http://blacksapphire.com/SMTPClient/>+extra-source-files:+ example.hs+ LICENSE+category: Database+build-type: Simple+Library+ exposed-modules: Network.SMTP.Client, Network.SMTP.ClientSession+ build-depends: base >= 4, hsemail, network, old-time, old-locale, containers+
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ example.hs view
@@ -0,0 +1,40 @@+import Network.SMTP.ClientSession+import Network.SMTP.Client+import Network.Socket+import Text.ParserCombinators.Parsec.Rfc2822+import System.Time+import System.IO+import Data.Bits+import Data.IORef++-- To do: Find out the proper way of doing this.+intToPortNumber :: Int -> PortNumber+intToPortNumber v = PortNum $ fromIntegral $ ((v `shiftR` 8) .|. (v `shiftL` 8)) .&. 0xffff++myDomain = "example.com"+smtpHost = "smtp.example.com" -- <-- Your SMTP server here++-- This will send the author an email. I don't mind!+main = do+ now <- getClockTime+ nowCT <- toCalendarTime now+ let message = Message [+ From [NameAddr (Just "Mr. Nobody") "nobody@example.com"],+ To [NameAddr (Just "Stephen Blackheath") "unprintable.distances.stephen@blacksapphire.com"],+ Subject "I'm using SMTPClient!",+ Date nowCT+ ]+ ("Dear Sir,\n"+++ "It has come to my attention that this is an email.\n"+++ "Yours sincerely,\n"+++ "Mr. Nobody\n")+ addrs <- getAddrInfo Nothing (Just smtpHost) Nothing+ let SockAddrInet _ hostAddr = addrAddress $ (addrs !! 0)+ let sockAddr = SockAddrInet (intToPortNumber 25) hostAddr+ putStrLn $ "connecting to "++show sockAddr+ sentRef <- newIORef 0+ sendSMTP_ (hPutStrLn stderr) (Just sentRef) myDomain+ sockAddr [message]+ sent <- readIORef sentRef+ putStrLn $ "no of emails sent=" ++ show sent+