From 3d4ff8da39b9bc1dab1df098e1ff20a3f79ebf88 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Sat, 27 Jan 2018 08:43:39 -0500 Subject: [PATCH] Stop returning extra information in GitHub result See #71. New `credsExtra` keys: - `accessToken`: so you can make your own follow-up requests - `userResponseJSON`: so you can get more information out of the request we already made (you just have to parse it yourself) Removed keys: - `access_token`: renamed to `accessToken` - `avatar_url`: can be re-parsed - `email`: requires your own request to `/emails` - `login`: can be re-parsed from `userResponseJSON` - `location`: can be re-parsed, was not always present - `name`: can be re-parse, was not not always present - `public_email`: can be re-parsed, was not not always present Also re-orders arguments between default and scoped to allow better partial application -- taking advantage of API breakage already. --- src/Yesod/Auth/OAuth2/Github.hs | 91 +++++++++----------------------- src/Yesod/Auth/OAuth2/Prelude.hs | 52 ++++++++++++++++-- 2 files changed, 72 insertions(+), 71 deletions(-) diff --git a/src/Yesod/Auth/OAuth2/Github.hs b/src/Yesod/Auth/OAuth2/Github.hs index 815fb59..4f9d775 100644 --- a/src/Yesod/Auth/OAuth2/Github.hs +++ b/src/Yesod/Auth/OAuth2/Github.hs @@ -14,52 +14,40 @@ module Yesod.Auth.OAuth2.Github import Yesod.Auth.OAuth2.Prelude -import Data.List (find) -import Data.Maybe (fromMaybe) +import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T -data GithubUser = GithubUser - { githubUserId :: Int - , githubUserName :: Maybe Text - , githubUserLogin :: Text - , githubUserAvatarUrl :: Text - , githubUserLocation :: Maybe Text - , githubUserPublicEmail :: Maybe Text - } +newtype User = User Int -instance FromJSON GithubUser where - parseJSON = withObject "GithubUser" $ \o -> GithubUser +instance FromJSON User where + parseJSON = withObject "User" $ \o -> User <$> o .: "id" - <*> o .:? "name" - <*> o .: "login" - <*> o .: "avatar_url" - <*> o .:? "location" - <*> o .:? "email" -data GithubUserEmail = GithubUserEmail - { githubUserEmailAddress :: Text - , githubUserEmailPrimary :: Bool - } +pluginName :: Text +pluginName = "github" -instance FromJSON GithubUserEmail where - parseJSON = withObject "GithubUserEmail" $ \o -> GithubUserEmail - <$> o .: "email" - <*> o .: "primary" +defaultScopes :: [Text] +defaultScopes = ["user:email"] -oauth2Github :: YesodAuth m - => Text -- ^ Client ID - -> Text -- ^ Client Secret - -> AuthPlugin m -oauth2Github clientId clientSecret = oauth2GithubScoped clientId clientSecret ["user:email"] +oauth2Github :: YesodAuth m => Text -> Text -> AuthPlugin m +oauth2Github = oauth2GithubScoped defaultScopes -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 +oauth2GithubScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m +oauth2GithubScoped scopes clientId clientSecret = + authOAuth2 pluginName oauth2 $ \manager token -> do + (User userId, userResponseJSON) <- + authGetProfile pluginName manager token "https://api.github.com/user" + + pure Creds + { credsPlugin = pluginName + , credsIdent = T.pack $ show userId + , credsExtra = + [ ("accessToken", atoken $ accessToken token) + , ("userResponseJSON", decodeUtf8 $ BL.toStrict userResponseJSON) + ] + } where - oauth = OAuth2 + oauth2 = OAuth2 { oauthClientId = clientId , oauthClientSecret = clientSecret , oauthOAuthorizeEndpoint = "https://github.com/login/oauth/authorize" `withQuery` @@ -68,32 +56,3 @@ oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetc , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token" , oauthCallback = Nothing } - -fetchGithubProfile :: Manager -> OAuth2Token -> IO (Creds m) -fetchGithubProfile manager token = do - userResult <- authGetJSON manager (accessToken token) "https://api.github.com/user" - mailResult <- authGetJSON manager (accessToken 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] -> OAuth2Token -> Creds m -toCreds user userMails token = Creds - { credsPlugin = "github" - , credsIdent = T.pack $ show $ githubUserId user - , credsExtra = - [ ("email", githubUserEmailAddress email) - , ("login", githubUserLogin user) - , ("avatar_url", githubUserAvatarUrl user) - , ("access_token", atoken $ accessToken token) - ] - ++ maybeExtra "name" (githubUserName user) - ++ maybeExtra "public_email" (githubUserPublicEmail user) - ++ maybeExtra "location" (githubUserLocation user) - } - - where - email = fromMaybe (head userMails) $ find githubUserEmailPrimary userMails diff --git a/src/Yesod/Auth/OAuth2/Prelude.hs b/src/Yesod/Auth/OAuth2/Prelude.hs index 18bc0fc..adc0099 100644 --- a/src/Yesod/Auth/OAuth2/Prelude.hs +++ b/src/Yesod/Auth/OAuth2/Prelude.hs @@ -12,7 +12,7 @@ module Yesod.Auth.OAuth2.Prelude , invalidProfileResponse -- * Helpers - , fromProfileURL + , authGetProfile , scopeParam , maybeExtra @@ -43,7 +43,6 @@ module Yesod.Auth.OAuth2.Prelude -- * HTTP , Manager - , authGetJSON -- * Yesod , YesodAuth(..) @@ -59,12 +58,17 @@ module Yesod.Auth.OAuth2.Prelude -- * Temporary, until I finish re-structuring modules , authOAuth2 , authOAuth2Widget + + -- * Deprecated, until everything's moved over to @'authGetProfile'@ + , authGetJSON + , fromProfileURL ) where import Control.Exception.Safe import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Semigroup ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -80,15 +84,52 @@ import Yesod.Auth.OAuth2 -- -- The error is a lazy bytestring because it's most often encoded JSON. -- +-- Deprecated. Eventually, we'll return @Either@s all the way up. +-- data YesodOAuth2Exception = InvalidProfileResponse Text BSL.ByteString deriving (Show, Typeable) instance Exception YesodOAuth2Exception +-- | Retrieve a user's profile as JSON +-- +-- The response should be parsed only far enough to read the required +-- @'credsIdent'@. The raw response is returned as well, to be set in +-- @'credsExtra'@for consumers to re-use if information they seek is in the +-- response already. +-- +-- Information requiring other requests should use the access token (also in +-- @'credsExtra'@ to make subsequent requests themselves. +-- +authGetProfile + :: FromJSON a + => Text -- ^ Plugin name + -> Manager + -> OAuth2Token + -> URI + -> IO (a, BSL.ByteString) +authGetProfile name manager token url = do + resp <- fromAuthGet name =<< authGetBS manager (accessToken token) url + decoded <- fromAuthJSON name resp + pure (decoded, resp) + +-- | Throws a @Left@ result as an @'InvalidProfileResponse'@ +fromAuthGet :: Text -> Either (OAuth2Error Value) BSL.ByteString -> IO BSL.ByteString +fromAuthGet _ (Right bs) = pure bs -- nice +fromAuthGet name (Left err) = throwIO $ invalidProfileResponse name err + +-- | Throws a decoding error as an @'InvalidProfileResponse'@ +fromAuthJSON :: FromJSON a => Text -> BSL.ByteString -> IO a +fromAuthJSON name = + -- FIXME: unique exception constructors + either (throwIO . InvalidProfileResponse name . BSL8.pack) pure . eitherDecode + -- | Construct an @'InvalidProfileResponse'@ exception from an @'OAuth2Error'@ -- -- This forces the @e@ in @'OAuth2Error' e@ to parse as a JSON @'Value'@ which -- is then re-encoded for the exception message. -- +-- Deprecated. +-- invalidProfileResponse :: Text -> OAuth2Error Value -> YesodOAuth2Exception invalidProfileResponse name = InvalidProfileResponse name . encode @@ -96,10 +137,11 @@ invalidProfileResponse name = InvalidProfileResponse name . encode -- -- Throws @'InvalidProfileResponse'@ if JSON parsing fails -- +-- Deprecated. +-- fromProfileURL :: FromJSON a => Text -> URI -> (a -> Creds m) -> FetchCreds m -fromProfileURL name url toCreds manager token = do - result <- authGetJSON manager (accessToken token) url - either (throwIO . invalidProfileResponse name) (return . toCreds) result +fromProfileURL name url toCreds manager token = + toCreds . fst <$> authGetProfile name manager token url -- | A tuple of @scope@ and the given scopes separated by a delimiter scopeParam :: Text -> [Text] -> (ByteString, ByteString)