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

@@ -14,52 +14,40 @@ module Yesod.Auth.OAuth2.Github
 
 import Yesod.Auth.OAuth2.Prelude
 
-import Data.List (find)
+import qualified Data.ByteString.Lazy as BL
-import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 
-data GithubUser = GithubUser
+newtype User = User Int
-    { githubUserId :: Int
-    , githubUserName :: Maybe Text
-    , githubUserLogin :: Text
-    , githubUserAvatarUrl :: Text
-    , githubUserLocation :: Maybe Text
-    , githubUserPublicEmail :: Maybe Text
-    }
 
-instance FromJSON GithubUser where
+instance FromJSON User where
-    parseJSON = withObject "GithubUser" $ \o -> GithubUser
+    parseJSON = withObject "User" $ \o -> User
         <$> o .: "id"
-        <*> o .:? "name"
-        <*> o .: "login"
-        <*> o .: "avatar_url"
-        <*> o .:? "location"
-        <*> o .:? "email"
 
-data GithubUserEmail = GithubUserEmail
+pluginName :: Text
-    { githubUserEmailAddress :: Text
+pluginName = "github"
-    , githubUserEmailPrimary :: Bool
-    }
 
-instance FromJSON GithubUserEmail where
+defaultScopes :: [Text]
-    parseJSON = withObject "GithubUserEmail" $ \o -> GithubUserEmail
+defaultScopes = ["user:email"]
-        <$> o .: "email"
-        <*> o .: "primary"
 
-oauth2Github :: YesodAuth m
+oauth2Github :: YesodAuth m => Text -> Text -> AuthPlugin m
-             => Text -- ^ Client ID
+oauth2Github = oauth2GithubScoped defaultScopes
-             -> Text -- ^ Client Secret
-             -> AuthPlugin m
-oauth2Github clientId clientSecret = oauth2GithubScoped clientId clientSecret ["user:email"]
 
-oauth2GithubScoped :: YesodAuth m
+oauth2GithubScoped :: YesodAuth m => [Text] -> Text -> Text -> AuthPlugin m
-             => Text -- ^ Client ID
+oauth2GithubScoped scopes clientId clientSecret =
-             -> Text -- ^ Client Secret
+    authOAuth2 pluginName oauth2 $ \manager token -> do
-             -> [Text] -- ^ List of scopes to request
+        (User userId, userResponseJSON) <-
-             -> AuthPlugin m
+            authGetProfile pluginName manager token "https://api.github.com/user"
-oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile
+
+        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

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
+fromProfileURL name url toCreds manager token =
-    result <- authGetJSON manager (accessToken token) url
+    toCreds . fst <$> authGetProfile name manager token url
-    either (throwIO . invalidProfileResponse name) (return . toCreds) result
 
 -- | A tuple of @scope@ and the given scopes separated by a delimiter
 scopeParam :: Text -> [Text] -> (ByteString, ByteString)