SMTPClient 0.2 → 0.3

raw patch · 4 files changed

+180/−113 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Network/SMTP/Client.hs +43/−22
• Network/SMTP/ClientSession.hs +125/−78
• SMTPClient.cabal +2/−2
• example.hs +10/−11

@@ -1,13 +1,28 @@ {-# LANGUAGE DeriveDataTypeable #-} +-- | An SMTP client in the IO Monad.+ module Network.SMTP.Client (         sendSMTP,-        sendSMTP_,-        SMTPException(..)+        sendSMTP',+        SMTPException(..),+        SmtpReply(..),+        SmtpCode(..),+        SuccessCode(..),+        Category(..),+        Message(..),+        Field(..),+        NameAddr(..)     ) where  import Network.SMTP.ClientSession import Control.Exception+import Text.ParserCombinators.Parsec.Rfc2821 (+        SmtpReply(..),+        SmtpCode(..),+        SuccessCode(..),+        Category(..)+    ) import Text.ParserCombinators.Parsec.Rfc2822 (         Message(..),         Field(..),@@ -23,26 +38,32 @@  -- | 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+--+-- The optional IORef is used to store a list of statuses for messages sent so+-- far, where Nothing means success.  The list elements correspond to the elements+-- of the input message list.  If the caller catches an exception, this list is+-- likely to be shorter than the input message list, and so it gives an indication+-- of how many messages were dispatched.+--+-- The message body may use either \"\\n\" or \"\\r\\n\" for an end-of-line+-- marker and in either case it will be sent correctly to the server.+sendSMTP ::+            Maybe (IORef [Maybe SmtpReply]) -- ^ For storing failure statuses of messages sent so far+         -> String      -- ^ Domain name for EHLO command          -> SockAddr    -- ^ Network address of SMTP server          -> [Message]   -- ^ List of messages to send          -> IO ()-sendSMTP = sendSMTP_ (\_ -> return ()) Nothing+sendSMTP = sendSMTP' (\_ -> return ()) --- | 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.+-- | Like sendSMTP but takes an additional function for logging all input and+-- output for diagnostic purposes.+sendSMTP' :: (String -> IO ())  -- ^ Diagnostic log function+          -> Maybe (IORef [Maybe SmtpReply]) -- ^ For storing failure statuses of messages 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+sendSMTP' log mStatuses domain sockAddr messages = do         sock <- socket AF_INET Stream defaultProtocol         connect sock sockAddr         handle <- socketToHandle sock ReadWriteMode@@ -54,17 +75,17 @@                  process :: Handle -> SMTPState -> IO ()         process h state = do-        -            case mSentSoFar of-                Just sentSoFar -> writeIORef sentSoFar (smtpSent state)++            case mStatuses of+                Just statuses -> writeIORef statuses (smtpStatuses state)                 Nothing -> return ()-        -            forM_ (reverse $ smtpOutQueue state) $ \ line -> do++            forM_ (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"@@ -73,11 +94,11 @@                 otherwise -> do                     -- Strip trailing \r. hGetLine has already stripped \n for us.                     reply <- reverse . dropWhile (=='\r') . reverse <$> hGetLine h-                    putStrLn $ "<- "++reply+                    log $ "<- "++reply                     let state' = smtpReceive state reply $ state {smtpOutQueue = []}                     process h state' -+-- | An exception indicating a communications failure at the level of the SMTP protocol. data SMTPException = SMTPException String     deriving (Eq, Show, Typeable) 

@@ -1,6 +1,15 @@+-- | A pure SMTP client state machine.+ module Network.SMTP.ClientSession (         smtpClientSession,-        SMTPState(..)+        SMTPState(..),+        SmtpReply(..),+        SmtpCode(..),+        SuccessCode(..),+        Category(..),+        Message(..),+        Field(..),+        NameAddr(..)         {-, suite-}     ) where @@ -18,7 +27,7 @@     ) import Data.Maybe import qualified Data.Set as Set-import Prelude hiding (fail, return)+import Prelude hiding (fail) import Data.List import System.Time import System.Locale@@ -35,33 +44,36 @@  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\").+        -- | Step 1. Caller must output any lines queued up in this list.  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.+        -- | Step 2. When sends are completed, the caller should wait for a line from+        -- the SMTP server, strip the \"\\n\" end-of-line characters, and pass the+        -- line 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.+        -- | Step 3. Check if this is True, which 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.+        -- | Step 4. Check if this is Just err, which 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+        -- | A list containing a failure status for each message that has been sent so far,+        -- where each element corresponds to one in the list of messages.+        -- If the SMTP session fails part-way through, this list is likely to be+        -- shorter than the input messages list.+        -- "Nothing" means success, and "Just x" is a failure status returned by+        -- the SMTP server.+        smtpStatuses :: [Maybe SmtpReply]     }  send :: String -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState-send txt return state =-    return $+send txt cont state =+    cont $         state {                 smtpOutQueue = txt:smtpOutQueue state             }@@ -72,23 +84,41 @@ receive :: (String -> SMTPState -> SMTPState) -> SMTPState -> SMTPState receive cont state =     state {-            smtpReceive = \line state -> cont line $ state {smtpReceive = nullReceive}+            -- Reverse the out queue before passing it to the caller because we+            -- have been assembling it backwards.+            smtpOutQueue = reverse $ smtpOutQueue state,+            smtpReceive = \line state -> cont line $ state {+                    smtpOutQueue = [],+                    smtpReceive = nullReceive+                }         }  fail :: String -> SMTPState -> SMTPState fail errorText state =     state {+            smtpOutQueue = [],             smtpFailure = Just errorText         }  success :: SMTPState -> SMTPState-success state = state {smtpSuccess = True}+success state =+    state {+            smtpOutQueue = [],+            smtpSuccess = True+        } -check :: SuccessCode -> Category -> String -> SmtpReply -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState-check code cat descr reply return =+equals :: SuccessCode -> Category -> SmtpReply -> Bool+equals code cat reply =     case reply of-        Reply (Code gotCode gotCat _) _ | gotCode == code && gotCat == cat -> return-        _ -> fail $ "SMTP error: got "+++        Reply (Code gotCode gotCat _) _ | gotCode == code && gotCat == cat -> True+        otherwise -> False++check :: (SmtpReply -> Bool) -> String -> SmtpReply -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState+check cond descr reply cont =+    if cond reply+        then cont+        else+            fail $ "SMTP error: got "++                     (cleanUp $ show reply)++                     " when I expected "++descr @@ -99,71 +129,75 @@     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+for :: [a]+       -- loop body, passed: value next+    -> (a -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState)+    -> (SMTPState -> SMTPState)+    -> SMTPState -> SMTPState+for [] _ cont = cont+for (x:xs) body cont =+    body x $+    for xs body cont -incSent :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState-incSent return state = return $ state {smtpSent = smtpSent state + 1}+putStatuses :: [Maybe SmtpReply] -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState+putStatuses statuses cont state = cont $ state {smtpStatuses = statuses}  -- | Receive an SMTP reply, e.g. -- 250-worked -- 250-like -- 250 a charm receiveReply :: (SmtpReply -> SMTPState -> SMTPState) -> SMTPState -> SMTPState-receiveReply return =+receiveReply cont =         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)+                    cont $ mkReply code (reverse $ map (drop 4) revMsgs)                 Nothing ->                     fail ("Malformed SMTP reply: "++final)     where         rec :: [String] -> ([String] -> SMTPState -> SMTPState) -> SMTPState -> SMTPState-        rec msgs return =+        rec msgs cont =             receive $ \line ->             if length(line) < 4 then                 fail ("malformed SMTP reply: "++line)             else if line !! 3 == '-' then-                rec (line:msgs) return+                rec (line:msgs) cont             else-                return (line:msgs)+                cont (line:msgs)          mkReply :: Int -> [String] -> SmtpReply         mkReply code msgs = reply (code `div` 100) ((code `div` 10) `mod` 10) (code `mod` 10) msgs +equalsMailOK :: SmtpReply -> Bool+equalsMailOK = equals Success MailSystem+ checkMailOK :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState-checkMailOK return =+checkMailOK cont =     receiveReply $ \reply ->-    check Success MailSystem "\"mail system OK\" (code 25x)" reply $-    return+    check equalsMailOK "\"mail system OK\" (code 25x)" reply $+    cont  checkConnectionOK :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState-checkConnectionOK return =+checkConnectionOK cont =     receiveReply $ \reply ->-    check Success Connection "\"connection OK\" (code 22x)" reply $-    return+    check (equals Success Connection) "\"connection OK\" (code 22x)" reply $+    cont -checkDataOK :: (SMTPState -> SMTPState) -> SMTPState -> SMTPState-checkDataOK return =-    receiveReply $ \reply ->-    check IntermediateSuccess MailSystem "\"connection OK\" (code 35x)" reply $-    return+equalsDataOK :: SmtpReply -> Bool+equalsDataOK = equals IntermediateSuccess MailSystem --- | 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.+-- | Construct a pure state machine for an SMTP client session.  Caller must+-- handle I/O.  The message body may use either \"\\n\" or \"\\r\\n\" for an+-- end-of-line marker. smtpClientSession :: String     -- ^ Domain name used in EHLO command                   -> [Message]  -- ^ List of messges to send                   -> SMTPState@@ -172,7 +206,7 @@             smtpReceive  = nullReceive,             smtpSuccess  = False,             smtpFailure  = Nothing,-            smtpSent     = 0+            smtpStatuses = []         }  -- Continuation passing style.@@ -181,20 +215,21 @@         checkConnectionOK $         send ("EHLO "++domain) $         checkMailOK $-        sendMessages messages $+        sendMessages messages [] $         send "QUIT" $         checkConnectionOK $         success     where-        sendMessages :: [Message] -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState-        sendMessages messages return =-            for messages (\message cont ->-                    sendMessage message cont-                ) $-            return+        sendMessages :: [Message] -> [Maybe SmtpReply] -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState+        sendMessages [] _ cont = cont+        sendMessages (message:rest) statuses cont =+            sendMessage message $ \status ->+            let statuses' = status:statuses in   -- collate statuses backwards+            putStatuses (reverse statuses') $    -- reverse to write smtpStatuses in correct order+            sendMessages rest statuses' cont -        sendMessage :: Message -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState-        sendMessage message return =+        sendMessage :: Message -> (Maybe SmtpReply -> SMTPState -> SMTPState) -> SMTPState -> SMTPState+        sendMessage message cont =             let Message fields _ = message                  froms = map (\(NameAddr _ addr) -> addr) $@@ -217,23 +252,35 @@                 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+                    receiveReply $ \reply ->+                    if not $ equalsMailOK reply then+                        cont (Just reply)  -- failure status+                    else (+                            for tos (\to next ->+                                    send ((("RCPT TO:"++) . angle_addr to) "") $+                                    receiveReply $ \reply ->+                                    if not $ equalsMailOK reply+                                        then cont (Just reply)  -- failure status+                                        else next+                                ) $+                            send "DATA" $+                            receiveReply $ \reply ->+                            if not $ equalsDataOK reply then+                                cont (Just reply)  -- failure status+                            else (+                                    let msgLines = formatMessage message in+                                    for msgLines (\line cont ->+                                            send (if line == "." then ". " else line) $+                                            cont+                                        ) $+                                    send "." $+                                    receiveReply $ \reply ->+                                    if not $ equalsMailOK reply then+                                        cont (Just reply)  -- failure status+                                    else+                                        cont Nothing  -- success+                                )+                        )                 )  atext_alphabet = Set.fromList $

@@ -1,12 +1,12 @@ name: SMTPClient-version: 0.2+version: 0.3 license: BSD3 license-file: LICENSE cabal-version: >= 1.2 copyright: (c) Stephen Blackheath author: Stephen Blackheath maintainer: http://blacksapphire.com/antispam/-stability: beta+stability: release-candidate synopsis: A simple SMTP client description:     A simple SMTP client

@@ -1,16 +1,11 @@ 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 @@ -29,12 +24,16 @@              "Yours sincerely,\n"++              "Mr. Nobody\n")     addrs <- getAddrInfo Nothing (Just smtpHost) Nothing-    let SockAddrInet _ hostAddr = addrAddress $ (addrs !! 0)-    let sockAddr = SockAddrInet (intToPortNumber 25) hostAddr+    let SockAddrInet _ hostAddr = addrAddress (addrs !! 0)+        sockAddr = SockAddrInet (fromIntegral 25) hostAddr     putStrLn $ "connecting to "++show sockAddr-    sentRef <- newIORef 0-    sendSMTP_ (hPutStrLn stderr) (Just sentRef) myDomain+    sentRef <- newIORef []+    sendSMTP' (hPutStrLn stderr) (Just sentRef) myDomain         sockAddr [message]-    sent <- readIORef sentRef-    putStrLn $ "no of emails sent=" ++ show sent+    statuses <- readIORef sentRef+    -- If no exception was caught, statuses is guaranteed to be+    -- the same length as the list of input messages, therefore head won't fail here.+    case head statuses of+        Nothing     -> putStrLn "Message successfully sent"+        Just status -> putStrLn $ "Message send failed with status "++show status