diff --git a/Yesod/Auth/OAuth2/Salesforce.hs b/Yesod/Auth/OAuth2/Salesforce.hs new file mode 100644 index 0000000..1a4efaa --- /dev/null +++ b/Yesod/Auth/OAuth2/Salesforce.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | +-- +-- OAuth2 plugin for http://login.salesforce.com +-- +-- * Authenticates against Salesforce +-- * Uses Salesforce user id as credentials identifier +-- * Returns given_name, family_name, email and avatar_url as extras +-- +module Yesod.Auth.OAuth2.Salesforce + ( oauth2Salesforce + , oauth2SalesforceScoped + , oauth2SalesforceSandbox + , oauth2SalesforceSandboxScoped + , module Yesod.Auth.OAuth2 + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>), (<*>)) +#endif + +import Control.Exception.Lifted +import Control.Monad (mzero) +import Data.Aeson +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Network.HTTP.Conduit (Manager) +import Yesod.Auth +import Yesod.Auth.OAuth2 + +import qualified Data.Text as T + +oauth2Salesforce :: YesodAuth m + => Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2Salesforce = oauth2SalesforceScoped ["openid", "email", "api"] + +svcName :: Text +svcName = "salesforce" + +oauth2SalesforceScoped :: YesodAuth m + => [Text] -- ^ List of scopes to request + -> Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2SalesforceScoped scopes clientId clientSecret = + authOAuth2 svcName oauth fetchSalesforceUser + where + oauth = OAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://login.salesforce.com/services/oauth2/authorize?scope=" <> T.intercalate " " scopes + , oauthAccessTokenEndpoint = "https://login.salesforce.com/services/oauth2/token" + , oauthCallback = Nothing + } + +fetchSalesforceUser :: Manager -> AccessToken -> IO (Creds m) +fetchSalesforceUser manager token = do + result <- authGetJSON manager token "https://login.salesforce.com/services/oauth2/userinfo" + case result of + Right user -> return $ toCreds svcName user token + Left err -> throwIO $ InvalidProfileResponse svcName err + +svcNameSb :: Text +svcNameSb = "salesforce-sandbox" + +oauth2SalesforceSandbox :: YesodAuth m + => Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2SalesforceSandbox = oauth2SalesforceSandboxScoped ["openid", "email"] + + +oauth2SalesforceSandboxScoped :: YesodAuth m + => [Text] -- ^ List of scopes to request + -> Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2SalesforceSandboxScoped scopes clientId clientSecret = + authOAuth2 svcNameSb oauth fetchSalesforceSandboxUser + where + oauth = OAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://test.salesforce.com/services/oauth2/authorize?scope=" <> T.intercalate " " scopes + , oauthAccessTokenEndpoint = "https://test.salesforce.com/services/oauth2/token" + , oauthCallback = Nothing + } + +fetchSalesforceSandboxUser :: Manager -> AccessToken -> IO (Creds m) +fetchSalesforceSandboxUser manager token = do + result <- authGetJSON manager token "https://test.salesforce.com/services/oauth2/userinfo" + case result of + Right user -> return $ toCreds svcNameSb user token + Left err -> throwIO $ InvalidProfileResponse svcNameSb err + +data User = User + { userId :: Text + , userOrg :: Text + , userNickname :: Text + , userName :: Text + , userGivenName :: Text + , userFamilyName :: Text + , userTimeZone :: Text + , userEmail :: Text + , userPicture :: Text + , userPhone :: Maybe Text + , userRestUrl :: Text + } + +instance FromJSON User where + parseJSON (Object o) = do + userId <- o .: "user_id" + userOrg <- o .: "organization_id" + userNickname <- o .: "nickname" + userName <- o .: "name" + userGivenName <- o .: "given_name" + userFamilyName <- o .: "family_name" + userTimeZone <- o .: "zoneinfo" + userEmail <- o .: "email" + userPicture <- o .: "picture" + userPhone <- o .:? "phone_number" + urls <- o .: "urls" + userRestUrl <- urls .: "rest" + return User{..} + + parseJSON _ = mzero + +toCreds :: Text -> User -> AccessToken -> Creds m +toCreds name user token = Creds + { credsPlugin = name + , credsIdent = userId user + , credsExtra = + [ ("email", userEmail user) + , ("org", userOrg user) + , ("nickname", userName user) + , ("name", userName user) + , ("given_name", userGivenName user) + , ("family_name", userFamilyName user) + , ("time_zone", userTimeZone user) + , ("avatar_url", userPicture user) + , ("rest_url", userRestUrl user) + , ("access_token", decodeUtf8 $ accessToken token) + ] + ++ maybeExtra "refresh_token" (decodeUtf8 <$> refreshToken token) + ++ maybeExtra "expires_in" ((T.pack . show) <$> expiresIn token) + ++ maybeExtra "phone_number" (userPhone user) + } diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index c4d4d7a..c7b7e2a 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -51,6 +51,7 @@ library Yesod.Auth.OAuth2.EveOnline Yesod.Auth.OAuth2.Nylas Yesod.Auth.OAuth2.Slack + Yesod.Auth.OAuth2.Salesforce ghc-options: -Wall