From 192dde89af5024abee31e0a9d0250ab711433465 Mon Sep 17 00:00:00 2001 From: Santiago Saavedra Date: Sun, 7 Jun 2015 18:05:22 +0200 Subject: [PATCH 1/3] Add Google OAuth provider --- Yesod/Auth/OAuth2/Google.hs | 98 +++++++++++++++++++++++++++++++++++++ yesod-auth-oauth2.cabal | 1 + 2 files changed, 99 insertions(+) create mode 100644 Yesod/Auth/OAuth2/Google.hs diff --git a/Yesod/Auth/OAuth2/Google.hs b/Yesod/Auth/OAuth2/Google.hs new file mode 100644 index 0000000..942e7f3 --- /dev/null +++ b/Yesod/Auth/OAuth2/Google.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- +-- OAuth2 plugin for http://www.google.com +-- +-- * Authenticates against Google +-- * Uses Google user id as credentials identifier +-- * Returns given_name, family_name, email, and avatar_url as extras +-- +module Yesod.Auth.OAuth2.Google + ( oauth2Google + , oauth2GoogleScoped + , module Yesod.Auth.OAuth2 + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>), (<*>)) +#endif + +import Control.Exception.Lifted +import Control.Monad (mzero, liftM) +import Data.Aeson +import Data.Monoid ((<>)) +import Data.Maybe (maybeToList) +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 + +oauth2Google :: YesodAuth m + => Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2Google clientId clientSecret = oauth2GoogleScoped clientId clientSecret ["openid", "email"] + +oauth2GoogleScoped :: YesodAuth m + => 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 + +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 + + +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 diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index b10e454..8d29085 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -39,6 +39,7 @@ library exposed-modules: Yesod.Auth.OAuth2 Yesod.Auth.OAuth2.Github + Yesod.Auth.OAuth2.Google Yesod.Auth.OAuth2.Spotify Yesod.Auth.OAuth2.Twitter Yesod.Auth.OAuth2.Upcase From 1e40d18a093c421db784a5038ef6414de7b48e56 Mon Sep 17 00:00:00 2001 From: Santiago Saavedra Date: Tue, 9 Jun 2015 17:04:23 +0200 Subject: [PATCH 2/3] Fix a linting warning --- Yesod/Auth/OAuth2/Google.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Yesod/Auth/OAuth2/Google.hs b/Yesod/Auth/OAuth2/Google.hs index 942e7f3..4faa610 100644 --- a/Yesod/Auth/OAuth2/Google.hs +++ b/Yesod/Auth/OAuth2/Google.hs @@ -19,7 +19,7 @@ import Control.Applicative ((<$>), (<*>)) #endif import Control.Exception.Lifted -import Control.Monad (mzero, liftM) +import Control.Monad (mzero) import Data.Aeson import Data.Monoid ((<>)) import Data.Maybe (maybeToList) @@ -47,7 +47,8 @@ oauth2GoogleScoped clientId clientSecret scopes = authOAuth2 "google" oauth fetc oauth = OAuth2 { oauthClientId = encodeUtf8 clientId , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://accounts.google.com/o/oauth2/auth?scope=" <> T.intercalate "+" scopes + , oauthOAuthorizeEndpoint = encodeUtf8 $ + "https://accounts.google.com/o/oauth2/auth?scope=" <> T.intercalate "+" scopes , oauthAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token" , oauthCallback = Nothing } From 8fa938d7ea2f0422dd4035e8d5a00c7889fecf66 Mon Sep 17 00:00:00 2001 From: Santiago Saavedra Date: Tue, 9 Jun 2015 17:04:41 +0200 Subject: [PATCH 3/3] Allow email to be used as an identifier of this module --- Yesod/Auth/OAuth2/Google.hs | 128 +++++++++++++++++++++--------------- 1 file changed, 75 insertions(+), 53 deletions(-) diff --git a/Yesod/Auth/OAuth2/Google.hs b/Yesod/Auth/OAuth2/Google.hs index 4faa610..3498aad 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 - } +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 :: 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 + +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 (Object o) = GoogleUser + <$> o .: "sub" + <*> o .: "name" + <*> o .: "email" + <*> o .: "picture" + <*> o .: "given_name" + <*> o .: "family_name" + <*> o .:? "hd" - parseJSON _ = mzero + 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