smtp-mail 0.1.4.3 → 0.1.4.4
raw patch · 4 files changed
+153/−131 lines, 4 files
Files
- Network/Mail/SMTP.hs +109/−90
- Network/Mail/SMTP/Auth.hs +5/−4
- Network/Mail/SMTP/Types.hs +38/−36
- smtp-mail.cabal +1/−1
Network/Mail/SMTP.hs view
@@ -47,9 +47,9 @@ import Network.Mail.Mime hiding (simpleMail) import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy as B-import qualified Data.ByteString as S+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL@@ -80,100 +80,119 @@ tryCommand :: Int -> SMTPConnection -> Command -> ReplyCode -> IO ByteString tryCommand tries st cmd expectedReply = do- (code, msg) <- sendCommand st cmd- if code == expectedReply + (code, msg) <- tryCommandNoFail tries st cmd expectedReply+ if code == expectedReply then return msg- else if tries > 1- then tryCommand (tries - 1) st cmd expectedReply- else do- closeSMTP st- fail $ "Unexpected reply to: " ++ show cmd ++ - ", Expected reply code: " ++ show expectedReply ++- ", Got this instead: " ++ show code ++ " " ++ show msg+ else do+ closeSMTP st+ fail $ "Unexpected reply to: " ++ show cmd +++ ", Expected reply code: " ++ show expectedReply +++ ", Got this instead: " ++ show code ++ " " ++ show msg +tryCommandNoFail :: Int -> SMTPConnection -> Command -> ReplyCode+ -> IO (ReplyCode, ByteString)+tryCommandNoFail tries st cmd expectedReply = do+ (code, msg) <- sendCommand st cmd+ if code == expectedReply+ then return (code, msg)+ else if tries > 1+ then tryCommandNoFail (tries - 1) st cmd expectedReply+ else return (code, msg)+ -- | Create an 'SMTPConnection' from an already connected Handle connectStream :: Handle -> IO SMTPConnection-connectStream st =- do (code1, _) <- parseResponse st- unless (code1 == 220) $- do hClose st- fail "cannot connect to the server"- senderHost <- getHostName- msg <- tryCommand 3 (SMTPC st []) (EHLO $ BS.pack senderHost) 250- return (SMTPC st (tail $ BS.lines msg))+connectStream st = do+ (code1, _) <- parseResponse st+ unless (code1 == 220) $ do+ hClose st+ fail "cannot connect to the server"+ senderHost <- getHostName+ (code, initialMsg) <- tryCommandNoFail 3 (SMTPC st []) (EHLO $ B8.pack senderHost) 250+ if code == 250+ then return (SMTPC st (tail $ B8.lines initialMsg))+ else do -- EHLO failed, try HELO+ msg <- tryCommand 3 (SMTPC st []) (HELO $ B8.pack senderHost) 250+ return (SMTPC st (tail $ B8.lines msg)) parseResponse :: Handle -> IO (ReplyCode, ByteString)-parseResponse st =- do (code, bdy) <- readLines- return (read $ BS.unpack code, BS.unlines bdy)- where readLines =- do l <- BS.hGetLine st- let (c, bdy) = BS.span isDigit l- if not (BS.null bdy) && BS.head bdy == '-'- then do (c2, ls) <- readLines- return (c2, BS.tail bdy:ls)- else return (c, [BS.tail bdy])+parseResponse st = do+ (code, bdy) <- readLines+ return (read $ B8.unpack code, B8.unlines bdy)+ where+ readLines = do+ l <- B8.hGetLine st+ let (c, bdy) = B8.span isDigit l+ if not (B8.null bdy) && B8.head bdy == '-'+ then do (c2, ls) <- readLines+ return (c2, B8.tail bdy:ls)+ else return (c, [B8.tail bdy]) -- | Send a 'Command' to the SMTP server sendCommand :: SMTPConnection -> Command -> IO (ReplyCode, ByteString)-sendCommand (SMTPC conn _) (DATA dat) =- do bsPutCrLf conn "DATA"- (code, _) <- parseResponse conn- unless (code == 354) $ fail "this server cannot accept any data."- mapM_ sendLine $ split dat- sendLine dot- parseResponse conn- where - sendLine = bsPutCrLf conn- split = map (padDot . stripCR) . BS.lines- -- remove \r at the end of a line- stripCR s = if cr `BS.isSuffixOf` s then BS.init s else s- -- duplicate . at the start of a line- padDot s = if dot `BS.isPrefixOf` s then dot <> s else s- cr = BS.pack "\r"- dot = BS.pack "." +sendCommand (SMTPC conn _) (DATA dat) = do+ bsPutCrLf conn "DATA"+ (code, _) <- parseResponse conn+ unless (code == 354) $ fail "this server cannot accept any data."+ mapM_ sendLine $ split dat+ sendLine dot+ parseResponse conn+ where+ sendLine = bsPutCrLf conn+ split = map (padDot . stripCR) . B8.lines+ -- remove \r at the end of a line+ stripCR s = if cr `B8.isSuffixOf` s then B8.init s else s+ -- duplicate . at the start of a line+ padDot s = if dot `B8.isPrefixOf` s then dot <> s else s+ cr = B8.pack "\r"+ dot = B8.pack "." -sendCommand (SMTPC conn _) (AUTH LOGIN username password) =- do bsPutCrLf conn command- _ <- parseResponse conn- bsPutCrLf conn userB64- _ <- parseResponse conn- bsPutCrLf conn passB64- (code, msg) <- parseResponse conn- unless (code == 235) $ fail "authentication failed."- return (code, msg)- where command = "AUTH LOGIN"- (userB64, passB64) = encodeLogin username password-sendCommand (SMTPC conn _) (AUTH at username password) =- do bsPutCrLf conn command- (code, msg) <- parseResponse conn- unless (code == 334) $ fail "authentication failed."- bsPutCrLf conn $ auth at (BS.unpack msg) username password- parseResponse conn- where command = BS.pack $ unwords ["AUTH", show at]-sendCommand (SMTPC conn _) meth =- do bsPutCrLf conn command- parseResponse conn- where command = case meth of- (HELO param) -> "HELO " <> param- (EHLO param) -> "EHLO " <> param- (MAIL param) -> "MAIL FROM:<" <> param <> ">"- (RCPT param) -> "RCPT TO:<" <> param <> ">"- (EXPN param) -> "EXPN " <> param- (VRFY param) -> "VRFY " <> param- (HELP msg) -> if BS.null msg- then "HELP\r\n"- else "HELP " <> msg- NOOP -> "NOOP"- RSET -> "RSET"- QUIT -> "QUIT"- DATA{} -> - error "BUG: DATA pattern should be matched by sendCommand patterns"- AUTH{} ->- error "BUG: AUTH pattern should be matched by sendCommand patterns"+sendCommand (SMTPC conn _) (AUTH LOGIN username password) = do+ bsPutCrLf conn command+ _ <- parseResponse conn+ bsPutCrLf conn userB64+ _ <- parseResponse conn+ bsPutCrLf conn passB64+ (code, msg) <- parseResponse conn+ unless (code == 235) $ fail "authentication failed."+ return (code, msg)+ where+ command = "AUTH LOGIN"+ (userB64, passB64) = encodeLogin username password +sendCommand (SMTPC conn _) (AUTH at username password) = do+ bsPutCrLf conn command+ (code, msg) <- parseResponse conn+ unless (code == 334) $ fail "authentication failed."+ bsPutCrLf conn $ auth at (B8.unpack msg) username password+ parseResponse conn+ where+ command = B8.pack $ unwords ["AUTH", show at]++sendCommand (SMTPC conn _) meth = do+ bsPutCrLf conn command+ parseResponse conn+ where+ command = case meth of+ (HELO param) -> "HELO " <> param+ (EHLO param) -> "EHLO " <> param+ (MAIL param) -> "MAIL FROM:<" <> param <> ">"+ (RCPT param) -> "RCPT TO:<" <> param <> ">"+ (EXPN param) -> "EXPN " <> param+ (VRFY param) -> "VRFY " <> param+ (HELP msg) -> if B8.null msg+ then "HELP\r\n"+ else "HELP " <> msg+ NOOP -> "NOOP"+ RSET -> "RSET"+ QUIT -> "QUIT"+ DATA{} ->+ error "BUG: DATA pattern should be matched by sendCommand patterns"+ AUTH{} ->+ error "BUG: AUTH pattern should be matched by sendCommand patterns"++ -- | Send 'QUIT' and close the connection. closeSMTP :: SMTPConnection -> IO () closeSMTP c@(SMTPC conn _) = sendCommand c QUIT >> hClose conn@@ -267,14 +286,14 @@ -> FilePath -- ^ path to file -> IO Part filePart ct fp = do- content <- B.readFile fp+ content <- BL.readFile fp return $ Part ct Base64 (Just $ T.pack (takeFileName fp)) [] content -lazyToStrict :: B.ByteString -> S.ByteString-lazyToStrict = S.concat . B.toChunks+lazyToStrict :: BL.ByteString -> B.ByteString+lazyToStrict = B.concat . BL.toChunks -crlf :: BS.ByteString-crlf = BS.pack "\r\n"+crlf :: B8.ByteString+crlf = B8.pack "\r\n" bsPutCrLf :: Handle -> ByteString -> IO ()-bsPutCrLf h s = BS.hPut h s >> BS.hPut h crlf >> hFlush h+bsPutCrLf h s = B8.hPut h s >> B8.hPut h crlf >> hFlush h
Network/Mail/SMTP/Auth.hs view
@@ -20,10 +20,11 @@ type UserName = String type Password = String -data AuthType = PLAIN- | LOGIN- | CRAM_MD5- deriving Eq+data AuthType+ = PLAIN+ | LOGIN+ | CRAM_MD5+ deriving Eq instance Show AuthType where showsPrec d at = showParen (d>app_prec) $ showString $ showMain at
Network/Mail/SMTP/Types.hs view
@@ -17,42 +17,44 @@ import Data.ByteString (ByteString) import Network.Mail.Mime -data Command = HELO ByteString- | EHLO ByteString- | MAIL ByteString- | RCPT ByteString- | DATA ByteString- | EXPN ByteString- | VRFY ByteString- | HELP ByteString- | AUTH AuthType UserName Password- | NOOP- | RSET- | QUIT- deriving (Show, Eq)+data Command+ = HELO ByteString+ | EHLO ByteString+ | MAIL ByteString+ | RCPT ByteString+ | DATA ByteString+ | EXPN ByteString+ | VRFY ByteString+ | HELP ByteString+ | AUTH AuthType UserName Password+ | NOOP+ | RSET+ | QUIT+ deriving (Show, Eq) type ReplyCode = Int -data Response = Ok- | SystemStatus- | HelpMessage- | ServiceReady- | ServiceClosing- | UserNotLocal- | CannotVerify- | StartMailInput- | ServiceNotAvailable- | MailboxUnavailable- | ErrorInProcessing- | InsufficientSystemStorage- | SyntaxError- | ParameterError- | CommandNotImplemented- | BadSequence- | ParameterNotImplemented- | MailboxUnavailableError- | UserNotLocalError- | ExceededStorage- | MailboxNotAllowed- | TransactionFailed- deriving (Show, Eq)+data Response+ = Ok+ | SystemStatus+ | HelpMessage+ | ServiceReady+ | ServiceClosing+ | UserNotLocal+ | CannotVerify+ | StartMailInput+ | ServiceNotAvailable+ | MailboxUnavailable+ | ErrorInProcessing+ | InsufficientSystemStorage+ | SyntaxError+ | ParameterError+ | CommandNotImplemented+ | BadSequence+ | ParameterNotImplemented+ | MailboxUnavailableError+ | UserNotLocalError+ | ExceededStorage+ | MailboxNotAllowed+ | TransactionFailed+ deriving (Show, Eq)
smtp-mail.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: smtp-mail-version: 0.1.4.3+version: 0.1.4.4 synopsis: Simple email sending via SMTP -- description: homepage: http://github.com/jhickner/smtp-mail