haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-03-05 21:04:35 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Allow email to be used as an identifier of this module

Browse Source
This commit is contained in:
Santiago Saavedra 2015-06-09 17:04:41 +02:00
parent 1e40d18a09
commit 8fa938d7ea
1 changed files with 75 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
Yesod/Auth/OAuth2/Google.hs
View File

@ -9,10 +9,13 @@
-- * Returns given_name, family_name, email, and avatar_url as extras -- * Returns given_name, family_name, email, and avatar_url as extras
-- --
module Yesod.Auth.OAuth2.Google module Yesod.Auth.OAuth2.Google
( oauth2Google ( oauth2Google
, oauth2GoogleScoped , oauth2GoogleScoped
, module Yesod.Auth.OAuth2 , oauth2GoogleScopedWithCustomId
) where , googleUid
, emailUid
, module Yesod.Auth.OAuth2
) where
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
@ -35,65 +38,84 @@ oauth2Google :: YesodAuth m
=> Text -- ^ Client ID => Text -- ^ Client ID
-> Text -- ^ Client Secret -> Text -- ^ Client Secret
-> AuthPlugin m -> AuthPlugin m
oauth2Google clientId clientSecret = oauth2GoogleScoped clientId clientSecret ["openid", "email"] oauth2Google = oauth2GoogleScoped ["openid", "email"]
oauth2GoogleScoped :: YesodAuth m oauth2GoogleScoped :: YesodAuth m
=> Text -- ^ Client ID => [Text] -- ^ List of scopes to request
-> Text -- ^ Client ID
-> Text -- ^ Client Secret -> Text -- ^ Client Secret
-> [Text] -- ^ List of scopes to request
-> AuthPlugin m -> AuthPlugin m
oauth2GoogleScoped clientId clientSecret scopes = authOAuth2 "google" oauth fetchGoogleProfile oauth2GoogleScoped = oauth2GoogleScopedWithCustomId emailUid
where
oauth = OAuth2 oauth2GoogleScopedWithCustomId :: YesodAuth m
{ oauthClientId = encodeUtf8 clientId => (GoogleUser -> AccessToken -> Creds m) -- ^ A function to generate the credentials
, oauthClientSecret = encodeUtf8 clientSecret -> [Text] -- ^ List of scopes to request
, oauthOAuthorizeEndpoint = encodeUtf8 $ -> Text -- ^ Client ID
"https://accounts.google.com/o/oauth2/auth?scope=" <> T.intercalate "+" scopes -> Text -- ^ Client secret
, oauthAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token" -> AuthPlugin m
, oauthCallback = Nothing 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 :: Manager -> AccessToken -> IO (Creds m)
fetchGoogleProfile manager token = do fetchGoogleProfile :: (GoogleUser -> AccessToken -> Creds m) -> Manager -> AccessToken -> IO (Creds m)
user <- authGetJSON manager token "https://www.googleapis.com/oauth2/v3/userinfo" fetchGoogleProfile toCreds manager token = do
case user of userInfo <- authGetJSON manager token "https://www.googleapis.com/oauth2/v3/userinfo"
Right user -> return $ toCreds user token case userInfo of
Left err -> throwIO $ InvalidProfileResponse "google" err Right user -> return $ toCreds user token
Left err -> throwIO $ InvalidProfileResponse "google" err
data GoogleUser = GoogleUser data GoogleUser = GoogleUser
{ googleUserId :: Text { googleUserId :: Text
, googleUserName :: Text , googleUserName :: Text
, googleUserEmail :: Text , googleUserEmail :: Text
, googleUserPicture :: Text , googleUserPicture :: Text
, googleUserGivenName :: Text , googleUserGivenName :: Text
, googleUserFamilyName :: Text , googleUserFamilyName :: Text
, googleUserHostedDomain :: Maybe Text , googleUserHostedDomain :: Maybe Text
} }
instance FromJSON GoogleUser where instance FromJSON GoogleUser where
parseJSON (Object o) = GoogleUser parseJSON (Object o) = GoogleUser
<$> o .: "sub" <$> o .: "sub"
<*> o .: "name" <*> o .: "name"
<*> o .: "email" <*> o .: "email"
<*> o .: "picture" <*> o .: "picture"
<*> o .: "given_name" <*> o .: "given_name"
<*> o .: "family_name" <*> o .: "family_name"
<*> o .:? "hd" <*> o .:? "hd"
parseJSON _ = mzero parseJSON _ = mzero
toCreds :: GoogleUser -> AccessToken -> Creds m googleUid :: GoogleUser -> AccessToken -> Creds m
toCreds user token = Creds { credsPlugin = "google" googleUid = uidBuilder $ ("google-uid:" <>) . googleUserId
, credsIdent = "google-uid:" <> googleUserId user
, credsExtra =
[ ("email", googleUserEmail user) emailUid :: GoogleUser -> AccessToken -> Creds m
, ("name", googleUserName user) emailUid = uidBuilder googleUserEmail
, ("given_name", googleUserGivenName user)
, ("family_name", googleUserFamilyName user) uidBuilder :: (GoogleUser -> Text) -> GoogleUser -> AccessToken -> Creds m
, ("avatar_url", googleUserPicture user) uidBuilder f user token = Creds
, ("access_token", decodeUtf8 $ accessToken token) { credsPlugin = "google"
] ++ maybeHostedDomain , credsIdent = f user
} , credsExtra =
where maybeHostedDomain = maybeToList $ ((,) "hosted_domain") `fmap` googleUserHostedDomain user [ ("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