mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-01-17 22:58:29 +01:00
64b65ca4c6
Marks "location" as Maybe in GitHub responses. Without this, users could experience an InvalidProfileResponse error when missing. Also fixes cases where fields were Maybe, but the (.:?) combinator was not being used in the parser.
140 lines
4.6 KiB
Haskell
140 lines
4.6 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
-- |
|
|
--
|
|
-- OAuth2 plugin for http://www.google.com
|
|
--
|
|
-- * Authenticates against Google
|
|
-- * Uses Google user id or email as credentials identifier
|
|
-- * Returns given_name, family_name, email, and avatar_url as extras
|
|
--
|
|
-- 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
|
|
, module Yesod.Auth.OAuth2
|
|
) where
|
|
|
|
#if __GLASGOW_HASKELL__ < 710
|
|
import Control.Applicative ((<$>), (<*>))
|
|
#endif
|
|
|
|
import Control.Exception.Lifted
|
|
import Control.Monad (mzero)
|
|
import Data.Aeson
|
|
import Data.Monoid ((<>))
|
|
import Data.Text (Text)
|
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
|
import Network.HTTP.Conduit (Manager)
|
|
import Yesod.Auth
|
|
import Yesod.Auth.OAuth2
|
|
|
|
import qualified Data.Text as T
|
|
|
|
-- | Auth with Google
|
|
--
|
|
-- 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
|
|
--
|
|
-- 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
|
|
--
|
|
-- Requests custom scopes and uses the given function to create credentials
|
|
-- which allows for using any attribute as the identifier.
|
|
--
|
|
-- See @'emailUid'@ and @'googleUid'@.
|
|
--
|
|
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
|
|
}
|
|
|
|
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
|
|
|
|
-- | Build a @'Creds'@ using the user's google-uid as the identifier
|
|
googleUid :: GoogleUser -> AccessToken -> Creds m
|
|
googleUid = uidBuilder $ ("google-uid:" <>) . googleUserId
|
|
|
|
-- | Build a @'Creds'@ using the user's email as the identifier
|
|
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)
|
|
]
|
|
++ maybeExtra "hosted_domain" (googleUserHostedDomain user)
|
|
}
|