Remove extra information from Google plugin

Also removes the ability to parse a custom identifier. See the module
documentation for a workaround.

src/Yesod/Auth/OAuth2/Google.hs

@@ -4,64 +4,68 @@
 -- OAuth2 plugin for http://www.google.com
 --
 -- * Authenticates against Google
--- * Uses Google user id or email as credentials identifier
+-- * Uses Google user id as credentials identifier
--- * Returns given_name, family_name, email, and avatar_url as extras
+--
+-- If you were previously relying on the ability to parse email as the creds
+-- identifier, you can still do that by overriding it in the creds returned by
+-- the plugin. For example:
+--
+-- > --
+-- > -- NOTE: proper use of Maybe/Either omitted for clarity.
+-- > --
+-- >
+-- > parseEmail :: ByteString -> Text
+-- > parseEmail = undefined
+-- >
+-- > authenticate creds = do
+-- >     let userResponseJSON = fromJust $ lookup "userResponseJSON" credsExtra creds
+-- >         userEmail = parseEmail userResponseJSON
+-- >         updatedCreds = creds { credsIdent = userEmail }
+-- >
+-- >     -- continue normally with updatedCreds
 --
--- Note: This may eventually replace Yesod.Auth.GoogleEmail2. Currently it
--- provides the same functionality except that GoogleEmail2 returns more profile
--- information.
 --
 module Yesod.Auth.OAuth2.Google
     ( oauth2Google
     , oauth2GoogleScoped
-    , oauth2GoogleScopedWithCustomId
-    , googleUid
-    , emailUid
     ) where
 
 import Yesod.Auth.OAuth2.Prelude
 
--- | Auth with Google
+import qualified Data.ByteString.Lazy as BL
---
--- Requests @openid@ and @email@ scopes and uses email as the @'Creds'@
--- identifier.
---
-oauth2Google :: YesodAuth m
-             => Text -- ^ Client ID
-             -> Text -- ^ Client Secret
-             -> AuthPlugin m
-oauth2Google = oauth2GoogleScoped ["openid", "email"]
 
--- | Auth with Google
+newtype User = User Text
---
--- Requests custom scopes and uses email as the @'Creds'@ identifier.
---
-oauth2GoogleScoped :: YesodAuth m
-                   => [Text] -- ^ List of scopes to request
-                   -> Text -- ^ Client ID
-                   -> Text -- ^ Client Secret
-                   -> AuthPlugin m
-oauth2GoogleScoped = oauth2GoogleScopedWithCustomId emailUid
 
--- | Auth with Google
+instance FromJSON User where
---
+    parseJSON = withObject "User" $ \o -> User
--- Requests custom scopes and uses the given function to create credentials
+        -- Required for data backwards-compatibility
--- which allows for using any attribute as the identifier.
+        <$> (("google-uid:" <>) <$> o .: "sub")
---
--- See @'emailUid'@ and @'googleUid'@.
---
-oauth2GoogleScopedWithCustomId :: YesodAuth m
-                               => (GoogleUser -> OAuth2Token -> 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
 
+pluginName :: Text
+pluginName = "google"
+
+defaultScopes :: [Text]
+defaultScopes = ["openid", "email"]
+
+oauth2Google :: YesodAuth m => Text -> Text -> AuthPlugin m
+oauth2Google = oauth2GoogleScoped defaultScopes
+
+oauth2GoogleScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
+oauth2GoogleScoped scopes clientId clientSecret =
+    authOAuth2 pluginName oauth2 $ \manager token -> do
+        (User userId, userResponseJSON) <-
+            authGetProfile pluginName manager token "https://www.googleapis.com/oauth2/v3/userinfo"
+
+        pure Creds
+            { credsPlugin = pluginName
+            , credsIdent = userId
+            , credsExtra =
+                [ ("accessToken", atoken $ accessToken token)
+                , ("userResponseJSON", decodeUtf8 $ BL.toStrict userResponseJSON)
+                ]
+            }
   where
-    oauth = OAuth2
+    oauth2 = OAuth2
         { oauthClientId = clientId
         , oauthClientSecret = clientSecret
         , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" `withQuery`
@@ -70,53 +74,3 @@ oauth2GoogleScopedWithCustomId toCreds scopes clientId clientSecret =
         , oauthAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token"
         , oauthCallback = Nothing
         }
-
-fetchGoogleProfile :: (GoogleUser -> OAuth2Token -> Creds m) -> Manager -> OAuth2Token -> IO (Creds m)
-fetchGoogleProfile toCreds manager token = do
-    userInfo <- authGetJSON manager (accessToken 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
-    }
-
-instance FromJSON GoogleUser where
-    parseJSON = withObject "GoogleUser" $ \o -> GoogleUser
-        <$> o .: "sub"
-        <*> o .: "name"
-        <*> o .: "email"
-        <*> o .: "picture"
-        <*> o .: "given_name"
-        <*> o .: "family_name"
-        <*> o .:? "hd"
-
--- | Build a @'Creds'@ using the user's google-uid as the identifier
-googleUid :: GoogleUser -> OAuth2Token -> Creds m
-googleUid = uidBuilder $ ("google-uid:" <>) . googleUserId
-
--- | Build a @'Creds'@ using the user's email as the identifier
-emailUid :: GoogleUser -> OAuth2Token -> Creds m
-emailUid = uidBuilder googleUserEmail
-
-uidBuilder :: (GoogleUser -> Text) -> GoogleUser -> OAuth2Token -> 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", atoken $ accessToken token)
-        ]
-        ++ maybeExtra "hosted_domain" (googleUserHostedDomain user)
-    }