From 7988569b2e41708f701f3b152b8e731e7f0ecbc8 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Fri, 3 Apr 2015 17:43:56 -0400 Subject: [PATCH 1/3] Introduce OAuth2Plugin, extracted from GitHub - Extract generic OAuth2Plugin construct - Define GitHub in terms of it - The scopes argument is now in first position - access_token is now always added to credsExtra --- Yesod/Auth/OAuth2.hs | 47 ++++++++++++++++++++++- Yesod/Auth/OAuth2/Github.hs | 75 +++++++++++++++++-------------------- 2 files changed, 79 insertions(+), 43 deletions(-) diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs index 63e9800..8d3a151 100644 --- a/Yesod/Auth/OAuth2.hs +++ b/Yesod/Auth/OAuth2.hs @@ -10,8 +10,10 @@ -- * See Yesod.Auth.OAuth2.GitHub for example usage. -- module Yesod.Auth.OAuth2 - ( authOAuth2 + ( OAuth2Plugin(..) , oauth2Url + , oauth2Plugin + , authOAuth2 , YesodOAuth2Exception(..) , module Network.OAuth.OAuth2 ) where @@ -43,9 +45,45 @@ data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString instance Exception YesodOAuth2Exception +data OAuth2Plugin a = OAuth2Plugin + { oapName :: Text + , oapAuthEndpoint :: Text + , oapTokenEndpoint :: Text + , oapFetchProfile :: Manager -> AccessToken -> IO (Either BL.ByteString a) + , oapToCredsIdent :: a -> Text + , oapToCredsExtra :: a -> [(Text, Text)] + } + oauth2Url :: Text -> AuthRoute oauth2Url name = PluginR name ["forward"] +oauth2Plugin :: YesodAuth m + => OAuth2Plugin a + -> Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2Plugin oap clientId clientSecret = + authOAuth2 (oapName oap) oapOauth $ \manager token -> do + result <- oapFetchProfile oap manager token + + case result of + Left err -> throwIO $ InvalidProfileResponse (oapName oap) err + Right user -> return Creds + { credsIdent = oapToCredsIdent oap user + , credsPlugin = oapName oap + , credsExtra = oapToCredsExtra oap user + } + + where + oapOauth :: OAuth2 + oapOauth = OAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = encodeUtf8 $ oapAuthEndpoint oap + , oauthAccessTokenEndpoint = encodeUtf8 $ oapTokenEndpoint oap + , oauthCallback = Nothing + } + authOAuth2 :: YesodAuth m => Text -- ^ Service name -> OAuth2 -- ^ Service details @@ -89,7 +127,7 @@ authOAuth2 name oauth getCreds = AuthPlugin name dispatch login Left _ -> permissionDenied "Unable to retreive OAuth2 token" Right token -> do creds <- liftIO $ getCreds (authHttpManager master) token - lift $ setCredsRedirect creds + lift $ setCredsRedirect $ addAccessToken token creds _ -> permissionDenied "Invalid OAuth2 state token" @@ -104,5 +142,10 @@ authOAuth2 name oauth getCreds = AuthPlugin name dispatch login Login via #{name} |] + addAccessToken token creds = creds + { credsExtra = + ("access_token", bsToText $ accessToken token) : credsExtra creds + } + bsToText :: ByteString -> Text bsToText = decodeUtf8With lenientDecode diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs index 1c41acf..dd23c77 100644 --- a/Yesod/Auth/OAuth2/Github.hs +++ b/Yesod/Auth/OAuth2/Github.hs @@ -18,13 +18,10 @@ module Yesod.Auth.OAuth2.Github import Control.Applicative ((<$>), (<*>), pure) #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 @@ -56,50 +53,46 @@ instance FromJSON GithubUserEmail where parseJSON _ = mzero +data GithubProfile = GithubProfile GithubUser (Maybe GithubUserEmail) + +githubProfileIdent :: GithubProfile -> Text +githubProfileIdent (GithubProfile user _) = T.pack $ show $ githubUserId user + oauth2Github :: YesodAuth m => Text -- ^ Client ID -> Text -- ^ Client Secret -> AuthPlugin m -oauth2Github clientId clientSecret = oauth2GithubScoped clientId clientSecret ["user:email"] +oauth2Github = oauth2GithubScoped ["user:email"] oauth2GithubScoped :: YesodAuth m - => Text -- ^ Client ID - -> Text -- ^ Client Secret - -> [Text] -- ^ List of scopes to request - -> AuthPlugin m -oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile - where - oauth = OAuth2 - { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes - , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token" - , oauthCallback = Nothing - } - -fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m) -fetchGithubProfile manager token = do - userResult <- authGetJSON manager token "https://api.github.com/user" - mailResult <- authGetJSON manager token "https://api.github.com/user/emails" - - case (userResult, mailResult) of - (Right _, Right []) -> throwIO $ InvalidProfileResponse "github" "no mail address for user" - (Right user, Right mails) -> return $ toCreds user mails token - (Left err, _) -> throwIO $ InvalidProfileResponse "github" err - (_, Left err) -> throwIO $ InvalidProfileResponse "github" err - -toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m -toCreds user userMail token = Creds - { credsPlugin = "github" - , credsIdent = T.pack $ show $ githubUserId user - , credsExtra = - [ ("email", githubUserEmail $ head userMail) - , ("login", githubUserLogin user) - , ("avatar_url", githubUserAvatarUrl user) - , ("access_token", decodeUtf8 $ accessToken token) - ] ++ maybeName (githubUserName user) + => [Text] -- ^ Scopes to request + -> Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2GithubScoped scopes = oauth2Plugin OAuth2Plugin + { oapName = "github" + , oapAuthEndpoint = "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes + , oapTokenEndpoint = "https://github.com/login/oauth/access_token" + , oapFetchProfile = fetchProfile + , oapToCredsIdent = githubProfileIdent + , oapToCredsExtra = toCredsExtra } where - maybeName Nothing = [] - maybeName (Just name) = [("name", name)] + fetchProfile manager token = do + user <- authGetJSON manager token "https://api.github.com/user" + emails <- authGetJSON manager token "https://api.github.com/user/emails" + + return $ case emails of + Right (email:_) -> GithubProfile <$> user <*> pure (Just email) + _ -> Left "user has no email" + + toCredsExtra (GithubProfile user email) = + [ ("login", githubUserLogin user) + , ("avatar_url", githubUserAvatarUrl user) + ] + ++ maybeToTuple "name" (githubUserName user) + ++ maybeToTuple "email" (githubUserEmail <$> email) + + maybeToTuple _ Nothing = [] + maybeToTuple k (Just x) = [(k, x)] From fd0881351747d85690699b68e3aa7e2d8c7a82b5 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 13 Apr 2015 11:34:05 -0400 Subject: [PATCH 2/3] Re-write Upcase --- Yesod/Auth/OAuth2/Upcase.hs | 47 +++++++++++++------------------------ 1 file changed, 16 insertions(+), 31 deletions(-) diff --git a/Yesod/Auth/OAuth2/Upcase.hs b/Yesod/Auth/OAuth2/Upcase.hs index ef0b823..fcd975d 100644 --- a/Yesod/Auth/OAuth2/Upcase.hs +++ b/Yesod/Auth/OAuth2/Upcase.hs @@ -14,17 +14,14 @@ module Yesod.Auth.OAuth2.Upcase ) where #if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>), pure) +import Control.Applicative ((<$>), (<*>)) #endif -import Control.Exception.Lifted import Control.Monad (mzero) import Data.Aeson import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) import Yesod.Auth import Yesod.Auth.OAuth2 -import Network.HTTP.Conduit(Manager) import qualified Data.Text as T data UpcaseUser = UpcaseUser @@ -55,31 +52,19 @@ oauth2Upcase :: YesodAuth m => Text -- ^ Client ID -> Text -- ^ Client Secret -> AuthPlugin m -oauth2Upcase clientId clientSecret = authOAuth2 "upcase" - OAuth2 - { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = "http://upcase.com/oauth/authorize" - , oauthAccessTokenEndpoint = "http://upcase.com/oauth/token" - , oauthCallback = Nothing - } - fetchUpcaseProfile - -fetchUpcaseProfile :: Manager -> AccessToken -> IO (Creds m) -fetchUpcaseProfile manager token = do - result <- authGetJSON manager token "http://upcase.com/api/v1/me.json" - - case result of - Right (UpcaseResponse user) -> return $ toCreds user - Left err -> throwIO $ InvalidProfileResponse "upcase" err - -toCreds :: UpcaseUser -> Creds m -toCreds user = Creds - { credsPlugin = "upcase" - , credsIdent = T.pack $ show $ upcaseUserId user - , credsExtra = - [ ("first_name", upcaseUserFirstName user) - , ("last_name" , upcaseUserLastName user) - , ("email" , upcaseUserEmail user) - ] +oauth2Upcase = oauth2Plugin OAuth2Plugin + { oapName = "upcase" + , oapAuthEndpoint = "http://upcase.com/oauth/authorize" + , oapTokenEndpoint = "http://upcase.com/oauth/token" + , oapFetchProfile = \manager token -> + authGetJSON manager token "http://upcase.com/api/v1/me.json" + , oapToCredsIdent = T.pack . show . upcaseUserId + , oapToCredsExtra = toCredsExtra } + +toCredsExtra :: UpcaseUser -> [(Text, Text)] +toCredsExtra user = + [ ("first_name", upcaseUserFirstName user) + , ("last_name" , upcaseUserLastName user) + , ("email" , upcaseUserEmail user) + ] From 46f6a9118d9e00551dd9383399d62092057d39ef Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 13 Apr 2015 11:41:31 -0400 Subject: [PATCH 3/3] Refactor Spotify - Scopes argument is now in first position - Scopes list is given as Text values --- Yesod/Auth/OAuth2/Spotify.hs | 45 ++++++++++++------------------------ 1 file changed, 15 insertions(+), 30 deletions(-) diff --git a/Yesod/Auth/OAuth2/Spotify.hs b/Yesod/Auth/OAuth2/Spotify.hs index e1acfce..0e8d9da 100644 --- a/Yesod/Auth/OAuth2/Spotify.hs +++ b/Yesod/Auth/OAuth2/Spotify.hs @@ -10,21 +10,17 @@ module Yesod.Auth.OAuth2.Spotify ) where #if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>), pure) +import Control.Applicative ((<$>), (<*>)) #endif -import Control.Exception.Lifted import Control.Monad (mzero) import Data.Aeson -import Data.ByteString (ByteString) import Data.Maybe +import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import Network.HTTP.Conduit(Manager) import Yesod.Auth import Yesod.Auth.OAuth2 -import qualified Data.ByteString as B import qualified Data.Text as T data SpotifyUserImage = SpotifyUserImage @@ -66,34 +62,23 @@ instance FromJSON SpotifyUser where parseJSON _ = mzero oauth2Spotify :: YesodAuth m - => Text -- ^ Client ID + => [Text] -- ^ Scopes + -> Text -- ^ Client ID -> Text -- ^ Client Secret - -> [ByteString] -- ^ Scopes -> AuthPlugin m -oauth2Spotify clientId clientSecret scope = authOAuth2 "spotify" - OAuth2 - { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = B.append "https://accounts.spotify.com/authorize?scope=" (B.intercalate "%20" scope) - , oauthAccessTokenEndpoint = "https://accounts.spotify.com/api/token" - , oauthCallback = Nothing - } - fetchSpotifyProfile - -fetchSpotifyProfile :: Manager -> AccessToken -> IO (Creds m) -fetchSpotifyProfile manager token = do - result <- authGetJSON manager token "https://api.spotify.com/v1/me" - case result of - Right user -> return $ toCreds user - Left err -> throwIO $ InvalidProfileResponse "spotify" err - -toCreds :: SpotifyUser -> Creds m -toCreds user = Creds - { credsPlugin = "spotify" - , credsIdent = spotifyUserId user - , credsExtra = mapMaybe getExtra extrasTemplate +oauth2Spotify scopes = oauth2Plugin OAuth2Plugin + { oapName = "spotify" + , oapAuthEndpoint = "https://accounts.spotify.com/authorize?scope=" <> T.intercalate "%20" scopes + , oapTokenEndpoint = "https://accounts.spotify.com/api/token" + , oapFetchProfile = \manager token -> + authGetJSON manager token "https://api.spotify.com/v1/me" + , oapToCredsIdent = spotifyUserId + , oapToCredsExtra = toCredsExtra } +toCredsExtra :: SpotifyUser -> [(Text, Text)] +toCredsExtra user = mapMaybe getExtra extrasTemplate + where userImage :: Maybe SpotifyUserImage userImage = spotifyUserImages user >>= listToMaybe