diff --git a/Network/SMTP/Client.hs b/Network/SMTP/Client.hs --- a/Network/SMTP/Client.hs +++ b/Network/SMTP/Client.hs @@ -1,10 +1,15 @@ {-# LANGUAGE DeriveDataTypeable #-} -- | An SMTP client in the IO Monad. +-- +-- Data structures for representing SMTP status codes and email messages are +-- re-exported here from /Text.ParserCombinators.Parsec.Rfc2821/ and +-- /Text.ParserCombinators.Parsec.Rfc2822/ in the /hsemail/ package. module Network.SMTP.Client ( sendSMTP, sendSMTP', + processSMTP, SMTPException(..), SmtpReply(..), SmtpCode(..), @@ -37,15 +42,17 @@ -- | Send a list of email messages to an SMTP server. Throws SMTPException on --- failure at the communication protocol level. +-- failure at the communication protocol level, and it can also throw +-- socket-level exceptions. -- -- 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. +-- likely to be shorter than the input message list: The length of the list +-- indicates how many messages were dispatched. If no exception is caught, the +-- length of the statuses will equal the length of the input messages list. -- --- The message body may use either \"\\n\" or \"\\r\\n\" for an end-of-line +-- The message body may use either \"\\n\" or \"\\r\\n\" as 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 @@ -64,39 +71,47 @@ -> [Message] -- ^ List of messages to send -> IO () sendSMTP' log mStatuses domain sockAddr messages = do - sock <- socket AF_INET Stream defaultProtocol - connect sock sockAddr - handle <- socketToHandle sock ReadWriteMode + handle <- bracketOnError + (socket AF_INET Stream defaultProtocol) + sClose + (\sock -> do + connect sock sockAddr + socketToHandle sock ReadWriteMode + ) (do let smtp = smtpClientSession domain messages - process handle smtp + processSMTP log mStatuses handle smtp ) `finally` hClose handle - where - - process :: Handle -> SMTPState -> IO () - process h state = do - case mStatuses of - Just statuses -> writeIORef statuses (smtpStatuses state) - Nothing -> return () +-- | A lower level function that does the I/O processing for an SMTP client session on a handle. +-- Returns when the session has completed, with the handle still open. +processSMTP :: (String -> IO ()) -- ^ Diagnostic log function + -> Maybe (IORef [Maybe SmtpReply]) -- ^ For storing failure statuses of messages sent so far + -> Handle + -> SMTPState -> IO () +processSMTP log mStatuses h state = do - forM_ (smtpOutQueue state) $ \line -> do - log $ "-> "++line - hPutStr h line - hPutStr h "\r\n" - hFlush h + case mStatuses of + Just statuses -> writeIORef statuses (smtpStatuses state) + Nothing -> return () - 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 - log $ "<- "++reply - let state' = smtpReceive state reply $ state {smtpOutQueue = []} - process h state' + 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" + (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 + log $ "<- "++reply + let state' = smtpReceive state reply $ state {smtpOutQueue = []} + processSMTP log mStatuses h state' -- | An exception indicating a communications failure at the level of the SMTP protocol. data SMTPException = SMTPException String diff --git a/Network/SMTP/ClientSession.hs b/Network/SMTP/ClientSession.hs --- a/Network/SMTP/ClientSession.hs +++ b/Network/SMTP/ClientSession.hs @@ -1,4 +1,8 @@ -- | A pure SMTP client state machine. +-- +-- Data structures for representing SMTP status codes and email messages are +-- re-exported here from /Text.ParserCombinators.Parsec.Rfc2821/ and +-- /Text.ParserCombinators.Parsec.Rfc2822/ in the /hsemail/ package. module Network.SMTP.ClientSession ( smtpClientSession, @@ -44,29 +48,32 @@ data SMTPState = SMTPState { - -- | 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\"). + -- | Step 1. Caller must send any lines queued up in this list to the SMTP + -- server. They do not have end-of-line characters, so you must add + -- \"\\r\\n\" on the end (both characters are required by RFC2821 - do not + -- just send \"\\n\"). smtpOutQueue :: [String], - -- | 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, - - -- | Step 3. Check if this is True, which indicates that the SMTP session + -- | Step 2. Check if this is True, which indicates that the SMTP session -- has completed successfully and there is no more work to do. smtpSuccess :: Bool, - -- | Step 4. Check if this is Just err, which indicates that a protocol error + -- | Step 3. 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, + -- | Step 4. The caller should wait for a line from the SMTP server, + -- strip the \"\\r\\n\" end-of-line characters, and pass the stripped + -- line to this function for processing. Go to step 1. + smtpReceive :: String -> SMTPState -> SMTPState, + -- | 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 + -- If the SMTP session does not complete successfully, then this list is + -- likely to be shorter than the input messages list. When smtpSuccess is + -- true, this list is guaranteed to be the same length as the list of input + -- messages. + -- /Nothing/ means success, and /Just x/ is a failure status returned by -- the SMTP server. smtpStatuses :: [Maybe SmtpReply] } @@ -78,6 +85,7 @@ smtpOutQueue = txt:smtpOutQueue state } +-- | A 'null' smtpReceive callback that discards anything given to it. nullReceive :: String -> SMTPState -> SMTPState nullReceive _ state = state @@ -114,14 +122,15 @@ otherwise -> False check :: (SmtpReply -> Bool) -> String -> SmtpReply -> (SMTPState -> SMTPState) -> SMTPState -> SMTPState -check cond descr reply cont = - if cond reply +check isOK descr reply cont = + if isOK reply then cont else fail $ "SMTP error: got "++ (cleanUp $ show reply)++ " when I expected "++descr +-- | Squish the SMTP reply description into one line. cleanUp :: String -> String cleanUp = map (\x -> if x == '\n' then '/' else x) . @@ -155,7 +164,7 @@ receiveReply :: (SmtpReply -> SMTPState -> SMTPState) -> SMTPState -> SMTPState receiveReply cont = rec [] $ \revMsgs@(final:_) -> - if length(final) < 4 || final !! 3 /= ' ' then + if length final < 4 || final !! 3 /= ' ' then fail ("malformed SMTP reply: "++final) else case maybeRead (take 3 final) of @@ -167,7 +176,7 @@ rec :: [String] -> ([String] -> SMTPState -> SMTPState) -> SMTPState -> SMTPState rec msgs cont = receive $ \line -> - if length(line) < 4 then + if length line < 4 then fail ("malformed SMTP reply: "++line) else if line !! 3 == '-' then rec (line:msgs) cont @@ -196,7 +205,7 @@ equalsDataOK = equals IntermediateSuccess MailSystem -- | 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 +-- handle I/O. The message body may use either \"\\n\" or \"\\r\\n\" as an -- end-of-line marker. smtpClientSession :: String -- ^ Domain name used in EHLO command -> [Message] -- ^ List of messges to send @@ -225,7 +234,7 @@ 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 + putStatuses (reverse statuses') $ -- reverse to store in correct order sendMessages rest statuses' cont sendMessage :: Message -> (Maybe SmtpReply -> SMTPState -> SMTPState) -> SMTPState -> SMTPState @@ -249,7 +258,7 @@ if null froms then fail "email contains no From: field" else if null tos then - fail "email contains to To: field" + fail "email contains no To:, Cc: or Bcc: field" else ( send ((("MAIL FROM:"++) . angle_addr (head froms)) "") $ receiveReply $ \reply -> diff --git a/SMTPClient.cabal b/SMTPClient.cabal --- a/SMTPClient.cabal +++ b/SMTPClient.cabal @@ -1,15 +1,15 @@ name: SMTPClient -version: 0.3 +version: 1.0 license: BSD3 license-file: LICENSE cabal-version: >= 1.2 copyright: (c) Stephen Blackheath author: Stephen Blackheath maintainer: http://blacksapphire.com/antispam/ -stability: release-candidate +stability: stable synopsis: A simple SMTP client description: - A simple SMTP client + A simple SMTP client for applications that want to send emails. . DARCS repository: