From 2f2c14c2890fd2d67aa0479f4446f272e38303b9 Mon Sep 17 00:00:00 2001 From: Santiago Saavedra Date: Tue, 9 Jun 2015 17:04:41 +0200 Subject: [PATCH] Allow email to be used as an identifier of this module --- Yesod/Auth/OAuth2/Google.hs | 134 +++++++++++++++++++++--------------- 1 file changed, 78 insertions(+), 56 deletions(-) diff --git a/Yesod/Auth/OAuth2/Google.hs b/Yesod/Auth/OAuth2/Google.hs index 4faa610..c540964 100644 --- a/Yesod/Auth/OAuth2/Google.hs +++ b/Yesod/Auth/OAuth2/Google.hs @@ -9,10 +9,13 @@ -- * Returns given_name, family_name, email, and avatar_url as extras -- module Yesod.Auth.OAuth2.Google - ( oauth2Google - , oauth2GoogleScoped - , module Yesod.Auth.OAuth2 - ) where + ( oauth2Google + , oauth2GoogleScoped + , oauth2GoogleScopedWithCustomId + , googleUid + , emailUid + , module Yesod.Auth.OAuth2 + ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) @@ -35,65 +38,84 @@ oauth2Google :: YesodAuth m => Text -- ^ Client ID -> Text -- ^ Client Secret -> AuthPlugin m -oauth2Google clientId clientSecret = oauth2GoogleScoped clientId clientSecret ["openid", "email"] +oauth2Google = oauth2GoogleScoped ["openid", "email"] oauth2GoogleScoped :: YesodAuth m - => Text -- ^ Client ID + => [Text] -- ^ List of scopes to request + -> Text -- ^ Client ID -> Text -- ^ Client Secret - -> [Text] -- ^ List of scopes to request -> AuthPlugin m -oauth2GoogleScoped clientId clientSecret scopes = authOAuth2 "google" oauth fetchGoogleProfile - where - oauth = OAuth2 - { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = encodeUtf8 $ - "https://accounts.google.com/o/oauth2/auth?scope=" <> T.intercalate "+" scopes - , oauthAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token" - , oauthCallback = Nothing - } - - -fetchGoogleProfile :: Manager -> AccessToken -> IO (Creds m) -fetchGoogleProfile manager token = do - user <- authGetJSON manager token "https://www.googleapis.com/oauth2/v3/userinfo" - case user of - Right user -> return $ toCreds user token - Left err -> throwIO $ InvalidProfileResponse "google" err +oauth2GoogleScoped = oauth2GoogleScopedWithCustomId emailUid + +oauth2GoogleScopedWithCustomId :: YesodAuth m + => (GoogleUser -> AccessToken -> Creds m) -- ^ A function to generate the credentials + -> [Text] -- ^ List of scopes to request + -> Text -- ^ Client ID + -> Text -- ^ Client secret + -> AuthPlugin m +oauth2GoogleScopedWithCustomId toCreds scopes clientId clientSecret = authOAuth2 "google" oauth $ fetchGoogleProfile toCreds + where + oauth = OAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = encodeUtf8 $ + "https://accounts.google.com/o/oauth2/auth?scope=" <> T.intercalate "+" scopes + , oauthAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token" + , oauthCallback = Nothing + } + + + +fetchGoogleProfile :: (GoogleUser -> AccessToken -> Creds m) -> Manager -> AccessToken -> IO (Creds m) +fetchGoogleProfile toCreds manager token = do + userInfo <- authGetJSON manager token "https://www.googleapis.com/oauth2/v3/userinfo" + case userInfo of + Right user -> return $ toCreds user token + Left err -> throwIO $ InvalidProfileResponse "google" err data GoogleUser = GoogleUser - { googleUserId :: Text - , googleUserName :: Text - , googleUserEmail :: Text - , googleUserPicture :: Text - , googleUserGivenName :: Text - , googleUserFamilyName :: Text - , googleUserHostedDomain :: Maybe Text - } + { googleUserId :: Text + , googleUserName :: Text + , googleUserEmail :: Text + , googleUserPicture :: Text + , googleUserGivenName :: Text + , googleUserFamilyName :: Text + , googleUserHostedDomain :: Maybe Text + } instance FromJSON GoogleUser where - parseJSON (Object o) = GoogleUser - <$> o .: "sub" - <*> o .: "name" - <*> o .: "email" - <*> o .: "picture" - <*> o .: "given_name" - <*> o .: "family_name" - <*> o .:? "hd" - - parseJSON _ = mzero + parseJSON (Object o) = GoogleUser + <$> o .: "sub" + <*> o .: "name" + <*> o .: "email" + <*> o .: "picture" + <*> o .: "given_name" + <*> o .: "family_name" + <*> o .:? "hd" + + parseJSON _ = mzero -toCreds :: GoogleUser -> AccessToken -> Creds m -toCreds user token = Creds { credsPlugin = "google" - , credsIdent = "google-uid:" <> googleUserId user - , credsExtra = - [ ("email", googleUserEmail user) - , ("name", googleUserName user) - , ("given_name", googleUserGivenName user) - , ("family_name", googleUserFamilyName user) - , ("avatar_url", googleUserPicture user) - , ("access_token", decodeUtf8 $ accessToken token) - ] ++ maybeHostedDomain - } - where maybeHostedDomain = maybeToList $ ((,) "hosted_domain") `fmap` googleUserHostedDomain user +googleUid :: GoogleUser -> AccessToken -> Creds m +googleUid = uidBuilder $ ("google-uid:" <>) . googleUserId + + +emailUid :: GoogleUser -> AccessToken -> Creds m +emailUid = uidBuilder googleUserEmail + +uidBuilder :: (GoogleUser -> Text) -> GoogleUser -> AccessToken -> Creds m +uidBuilder f user token = Creds + { credsPlugin = "google" + , credsIdent = f user + , credsExtra = + [ ("email", googleUserEmail user) + , ("name", googleUserName user) + , ("given_name", googleUserGivenName user) + , ("family_name", googleUserFamilyName user) + , ("avatar_url", googleUserPicture user) + , ("access_token", decodeUtf8 $ accessToken token) + ] ++ maybeHostedDomain + } + + where + maybeHostedDomain = maybeToList $ ((,) "hosted_domain") <$> googleUserHostedDomain user