Remove extra fields from Salesforce

src/Yesod/Auth/OAuth2/Prelude.hs

@@ -50,6 +50,7 @@ module Yesod.Auth.OAuth2.Prelude
     , Creds(..)
 
     -- * Bytestring URI types
+    , URI
     , Host(..)
 
     -- * Bytestring URI extensions

src/Yesod/Auth/OAuth2/Salesforce.hs

@@ -1,12 +1,10 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
 -- |
 --
 -- OAuth2 plugin for http://login.salesforce.com
 --
--- * Authenticates against Salesforce
+-- * Authenticates against Salesforce (or sandbox)
 -- * Uses Salesforce user id as credentials identifier
--- * Returns given_name, family_name, email and avatar_url as extras
 --
 module Yesod.Auth.OAuth2.Salesforce
     ( oauth2Salesforce
@@ -17,124 +15,60 @@ module Yesod.Auth.OAuth2.Salesforce
 
 import Yesod.Auth.OAuth2.Prelude
 
-import qualified Data.Text as T
+newtype User = User Text
-
-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            = clientId
-        , oauthClientSecret        = clientSecret
-        , oauthOAuthorizeEndpoint  = "https://login.salesforce.com/services/oauth2/authorize" `withQuery`
-            [ scopeParam " " scopes
-            ]
-        , oauthAccessTokenEndpoint = "https://login.salesforce.com/services/oauth2/token"
-        , oauthCallback            = Nothing
-        }
-
-fetchSalesforceUser :: Manager -> OAuth2Token -> IO (Creds m)
-fetchSalesforceUser manager token = do
-    result <- authGetJSON manager (accessToken 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            = clientId
-        , oauthClientSecret        = clientSecret
-        , oauthOAuthorizeEndpoint  = "https://test.salesforce.com/services/oauth2/authorize" `withQuery`
-            [ scopeParam " " scopes
-            ]
-        , oauthAccessTokenEndpoint = "https://test.salesforce.com/services/oauth2/token"
-        , oauthCallback            = Nothing
-        }
-
-fetchSalesforceSandboxUser :: Manager -> OAuth2Token -> IO (Creds m)
-fetchSalesforceSandboxUser manager token = do
-    result <- authGetJSON manager (accessToken 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 = withObject "User" $ \o -> do
+    parseJSON = withObject "User" $ \o -> User
-        userId          <- o .: "user_id"
+        <$> 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{..}
 
-toCreds :: Text -> User -> OAuth2Token -> Creds m
+pluginName :: Text
-toCreds name user token = Creds
+pluginName = "salesforce"
-    { credsPlugin = name
+
-    , credsIdent = userId user
+defaultScopes :: [Text]
-    , credsExtra =
+defaultScopes = ["openid", "email", "api"]
-        [ ("email", userEmail user)
+
-        , ("org", userOrg user)
+oauth2Salesforce :: YesodAuth m => Text -> Text -> AuthPlugin m
-        , ("nickname", userName user)
+oauth2Salesforce = oauth2SalesforceScoped defaultScopes
-        , ("name", userName user)
+
-        , ("given_name", userGivenName user)
+oauth2SalesforceScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
-        , ("family_name", userFamilyName user)
+oauth2SalesforceScoped = salesforceHelper pluginName
-        , ("time_zone", userTimeZone user)
+    "https://login.salesforce.com/services/oauth2/userinfo"
-        , ("avatar_url", userPicture user)
+    "https://login.salesforce.com/services/oauth2/authorize"
-        , ("rest_url", userRestUrl user)
+    "https://login.salesforce.com/services/oauth2/token"
-        , ("access_token", atoken $ accessToken token)
+
-        ]
+oauth2SalesforceSandbox :: YesodAuth m => Text -> Text -> AuthPlugin m
-        ++ maybeExtra "refresh_token" (rtoken <$> refreshToken token)
+oauth2SalesforceSandbox = oauth2SalesforceSandboxScoped defaultScopes
-        ++ maybeExtra "expires_in" (T.pack . show <$> expiresIn token)
+
-        ++ maybeExtra "phone_number" (userPhone user)
+oauth2SalesforceSandboxScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
-    }
+oauth2SalesforceSandboxScoped = salesforceHelper (pluginName <> "-sandbox")
+    "https://test.salesforce.com/services/oauth2/userinfo"
+    "https://test.salesforce.com/services/oauth2/authorize"
+    "https://test.salesforce.com/services/oauth2/token"
+
+salesforceHelper
+    :: YesodAuth m
+    => Text
+    -> URI -- ^ User profile
+    -> URI -- ^ Authorize
+    -> URI -- ^ Token
+    -> [Text]
+    -> Text
+    -> Text
+    -> AuthPlugin m
+salesforceHelper name profileUri authorizeUri tokenUri scopes clientId clientSecret =
+    authOAuth2 name oauth2 $ \manager token -> do
+        (User userId, userResponseJSON) <- authGetProfile name manager token profileUri
+
+        pure Creds
+            { credsPlugin = pluginName
+            , credsIdent = userId
+            , credsExtra = setExtra token userResponseJSON
+            }
+  where
+    oauth2 = OAuth2
+        { oauthClientId = clientId
+        , oauthClientSecret = clientSecret
+        , oauthOAuthorizeEndpoint = authorizeUri `withQuery` [scopeParam " " scopes]
+        , oauthAccessTokenEndpoint = tokenUri
+        , oauthCallback = Nothing
+        }