Allow email to be used as an identifier of this module

Yesod/Auth/OAuth2/Google.hs

@@ -11,6 +11,9 @@
 module Yesod.Auth.OAuth2.Google
     ( oauth2Google
     , oauth2GoogleScoped
+    , oauth2GoogleScopedWithCustomId
+    , googleUid
+    , emailUid
     , module Yesod.Auth.OAuth2
     ) where
 
@@ -35,14 +38,22 @@ 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
+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
@@ -54,10 +65,11 @@ oauth2GoogleScoped clientId clientSecret scopes = authOAuth2 "google" oauth fetc
           }
 
 
-fetchGoogleProfile :: Manager -> AccessToken -> IO (Creds m)
-fetchGoogleProfile manager token = do
-  user <- authGetJSON manager token "https://www.googleapis.com/oauth2/v3/userinfo"
-  case user of
+
+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
 
@@ -84,9 +96,17 @@ instance FromJSON GoogleUser where
     parseJSON _ = mzero
   
 
-toCreds :: GoogleUser -> AccessToken -> Creds m
-toCreds user token = Creds { credsPlugin = "google"
-                           , credsIdent = "google-uid:" <> googleUserId 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)
@@ -96,4 +116,6 @@ toCreds user token = Creds { credsPlugin = "google"
         , ("access_token", decodeUtf8 $ accessToken token)
         ] ++ maybeHostedDomain
     }
-  where maybeHostedDomain = maybeToList $ ((,) "hosted_domain") `fmap` googleUserHostedDomain user
+
+  where
+    maybeHostedDomain = maybeToList $ (,) "hosted_domain" <$> googleUserHostedDomain user