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
-> Text
-> AuthPlugin m
oauth2Salesforce = oauth2SalesforceScoped ["openid", "email", "api"]
svcName :: Text
svcName = "salesforce"
oauth2SalesforceScoped :: YesodAuth m
=> [Text]
-> Text
-> Text
-> 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
-> Text
-> AuthPlugin m
oauth2SalesforceSandbox = oauth2SalesforceSandboxScoped ["openid", "email"]
oauth2SalesforceSandboxScoped :: YesodAuth m
=> [Text]
-> Text
-> Text
-> 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)
}