Merge pull request #23 from robstewart57/oauth-authentication

Adds support for OAuth authentication

Author: spencerjanssen

CHANGELOG.md

@@ -20,6 +20,10 @@ A template is provided:
   - Indicate if changes are major, minor, or patch changes.
 ```
 
+## 0.5.0.0
+
+- Adds support for OAuth authentication with a new function `sendMailWithLoginOAuthSTARTTLS`.
+
 ## 0.4.0.2
 
 - Switch to `crypton` because the `cryptonite` package is no longer maintained.

Network/Mail/SMTP.hs

@@ -18,6 +18,8 @@ module Network.Mail.SMTP
     , sendMailSTARTTLS'
     , sendMailWithLoginSTARTTLS
     , sendMailWithLoginSTARTTLS'
+    , sendMailWithLoginOAuthSTARTTLS
+    , sendMailWithLoginOAuthSTARTTLS'
     , sendMailWithSenderSTARTTLS
     , sendMailWithSenderSTARTTLS'
     , simpleMail
@@ -260,6 +262,17 @@ sendCommand (SMTPC conn _) (AUTH LOGIN username password) = do
     command = "AUTH LOGIN"
     (userB64, passB64) = encodeLogin username password
 
+sendCommand (SMTPC conn _) (AUTH LOGIN_OAUTH username token) = do
+    bsPutCrLf conn command
+    _ <- parseResponse conn
+    bsPutCrLf conn tokenB64
+    (code, msg) <- parseResponse conn
+    unless (code == 235) $ fail "authentication failed."
+    return (code, msg)
+  where
+    command = "AUTH XOAUTH2"
+    tokenB64 = encodeLoginOAuth username token
+
 sendCommand (SMTPC conn _) (AUTH at username password) = do
     bsPutCrLf conn command
     (code, msg) <- parseResponse conn
@@ -364,6 +377,14 @@ sendMailWithLoginTLS host user pass mail = connectSMTPS host >>= sendMailWithLog
 sendMailWithLoginTLS' :: HostName -> PortNumber -> UserName -> Password -> Mail -> IO ()
 sendMailWithLoginTLS' host port user pass mail = connectSMTPS' host port >>= sendMailWithLoginIntern user pass mail
 
+-- | Connect to an SMTP server, login with OAuth, send a 'Mail', disconnect. Uses STARTTLS with the default port (587).
+sendMailWithLoginOAuthSTARTTLS :: HostName -> UserName -> Token -> Mail -> IO ()
+sendMailWithLoginOAuthSTARTTLS host user token mail = connectSMTPSTARTTLS host >>= sendMailWithLoginOAuthIntern user token mail
+
+-- | Connect to an SMTP server, login with OAuth, send a 'Mail', disconnect. Uses STARTTLS.
+sendMailWithLoginOAuthSTARTTLS' :: HostName -> PortNumber -> UserName -> Token -> Mail -> IO ()
+sendMailWithLoginOAuthSTARTTLS' host port user token mail = connectSMTPSTARTTLS' host port >>= sendMailWithLoginOAuthIntern user token mail
+
 -- | Send a 'Mail' with a given sender. Uses SMTPS with its default port (465).
 sendMailWithSenderTLS :: ByteString -> HostName -> Mail -> IO ()
 sendMailWithSenderTLS sender host mail = connectSMTPS host >>= sendMailWithSenderIntern sender mail
@@ -402,6 +423,12 @@ sendMailWithLoginIntern user pass mail con = do
   renderAndSend con mail
   closeSMTP con
 
+sendMailWithLoginOAuthIntern :: UserName -> Password -> Mail -> SMTPConnection -> IO ()
+sendMailWithLoginOAuthIntern user token mail con = do
+  _ <- sendCommand con (AUTH LOGIN_OAUTH user token)
+  renderAndSend con mail
+  closeSMTP con
+
 sendMailWithSenderIntern :: ByteString -> Mail -> SMTPConnection -> IO ()
 sendMailWithSenderIntern sender mail con = do
   renderAndSendFrom sender con mail

Network/Mail/SMTP/Auth.hs

@@ -1,8 +1,10 @@
 module Network.Mail.SMTP.Auth (
     UserName,
     Password,
+    Token,
     AuthType(..),
     encodeLogin,
+    encodeLoginOAuth,
     auth,
 ) where
 
@@ -19,19 +21,22 @@ import qualified Data.ByteString.Char8 as B8    (unwords)
 
 type UserName = String
 type Password = String
+type Token = String
 
 data AuthType
     = PLAIN
     | LOGIN
+    | LOGIN_OAUTH
     | CRAM_MD5
     deriving Eq
 
 instance Show AuthType where
     showsPrec d at = showParen (d>app_prec) $ showString $ showMain at
         where app_prec = 10
-              showMain PLAIN    = "PLAIN"
-              showMain LOGIN    = "LOGIN"
-              showMain CRAM_MD5 = "CRAM-MD5"
+              showMain PLAIN       = "PLAIN"
+              showMain LOGIN       = "LOGIN"
+              showMain LOGIN_OAUTH = "XOAUTH2"
+              showMain CRAM_MD5    = "CRAM-MD5"
 
 toAscii :: String -> ByteString
 toAscii = B.pack . map (toEnum.fromEnum)
@@ -50,6 +55,12 @@ encodePlain user pass = b64Encode $ intercalate "\0" [user, user, pass]
 encodeLogin :: UserName -> Password -> (ByteString, ByteString)
 encodeLogin user pass = (b64Encode user, b64Encode pass)
 
+-- | Encode the xoauth 2 message based on:
+-- https://docs.microsoft.com/en-us/exchange/client-developer/legacy-protocols/how-to-authenticate-an-imap-pop-smtp-application-by-using-oauth#sasl-xoauth2
+encodeLoginOAuth :: UserName -> Token -> ByteString
+encodeLoginOAuth user oauthToken =
+  b64Encode ("user=" <> user <> "\x01" <> "auth=Bearer " <> oauthToken <> "\x01\x01")
+
 cramMD5 :: String -> UserName -> Password -> ByteString
 cramMD5 challenge user pass =
     B64.encode $ B8.unwords [user', B16.encode (hmacMD5 challenge' pass')]
@@ -59,6 +70,7 @@ cramMD5 challenge user pass =
     pass'      = toAscii pass
 
 auth :: AuthType -> String -> UserName -> Password -> ByteString
-auth PLAIN    _ u p = encodePlain u p
-auth LOGIN    _ u p = let (u', p') = encodeLogin u p in B8.unwords [u', p']
-auth CRAM_MD5 c u p = cramMD5 c u p
+auth PLAIN       _ u p = encodePlain u p
+auth LOGIN       _ u p = let (u', p') = encodeLogin u p in B8.unwords [u', p']
+auth LOGIN_OAUTH _ u t = encodeLoginOAuth u t
+auth CRAM_MD5    c u p = cramMD5 c u p

smtp-mail.cabal

@@ -1,5 +1,5 @@
 name:                smtp-mail
-version:             0.4.0.2
+version:             0.5.0.0
 synopsis:            Simple email sending via SMTP
 description:         This packages provides a simple interface for mail over SMTP. Please see the README for more information.
 homepage:            http://github.com/haskell-github-trust/smtp-mail