Stop returning extra information in GitHub result

README.md

@@ -2,11 +2,9 @@
 
 OAuth2 `AuthPlugin`s for Yesod.
 
-## Basic Usage
+## Usage
 
-To use one of the supported providers:
-
-```haskell
+```hs
 import Yesod.Auth
 import Yesod.Auth.OAuth2.Github
 
@@ -25,56 +23,84 @@ clientSecret = "..."
 Some plugins, such as GitHub and Slack, have scoped functions for requesting
 additional information:
 
-```haskell
-import Yesod.Auth
-import Yesod.Auth.OAuth2.Slack
+```hs
+oauth2SlackScoped [SlackBasicScope, SlackEmailScope] clientId clientSecret
+```
 
-instance YesodAuth App where
- -- ...
+## Working with Extra Data
 
- authPlugins _ =
- [oauth2SlackScoped clientId clientSecret slackScopes]
- where
- slackScopes = [SlackEmailScope, SlackAvatarScope, SlackTeamScope]
+We put the minimal amount of user data possible in `credsExtra` -- just enough
+to support you parsing or fetching additional data yourself.
 
-clientId :: Text
-clientId = "..."
+For example, if you work with GitHub and GitHub user profiles, you likely
+already have a model and a way to parse the `/user` response. Rather than
+duplicate all that in our own library, we try to make it easy for you to re-use
+that code yourself:
 
-clientSecret :: Text
-clientSecret = "..."
-```
+```hs
+authenticate creds = do
+ let
+ -- You can run your own FromJSON parser on the respose we already have
+ eGitHubUser :: Either String GitHubUser
+ eGitHubUser = getUserResponseJSON creds
 
-## Advanced Usage
+ -- Avert your eyes, simplified example
+ Just accessToken = getAccessToken creds
+ Right githubUser = eGitHubUser
 
-To use any other provider:
+ -- Or make followup requests using our access token
+ runGitHub accessToken $ userRepositories githubUser
 
-```haskell
-import Yesod.Auth
-import Yesod.Auth.OAuth2
+ -- Or store it for later
+ insert User
+ { userIdent = credsIdent creds
+ , userAccessToken = accessToken
+ }
+```
 
-instance YesodAuth App where
- -- ...
+**NOTE**: Avoid looking up values in `credsExtra` yourself; prefer the provided
+`get` functions. The data representation itself is no longer considered public
+API.
+
+## Local Providers
 
- authPlugins _ = [myPlugin]
+If we don't supply a "Provider" (e.g. GitHub, Google, etc) you need. You can
+write your own within your codebase:
 
-myPlugin :: AuthPlugin m
-myPlugin = authOAuth2 "mysite"
- (OAuth2
- { oauthClientId = "..."
- , oauthClientSecret = "..."
- , oauthOAuthorizeEndpoint = "https://mysite.com/oauth/authorize"
+```haskell
+import Yesod.Auth.OAuth2.Prelude
+
+pluginName :: Text
+pluginName = "mysite"
+
+oauth2MySite :: YesodAuth m => Text -> Text -> AuthPlugin m
+oauth2MySite clientId clientSecret =
+ authOAuth2 pluginName oauth2 $ \manager token -> do
+ -- Fetch a profile using the manager and token, leave it a ByteString
+ userResponse <- -- ...
+
+ -- Parse it to your preferred identifier, e.g. with Data.Aeson
+ userId <- -- ...
+
+ -- See authGetProfile for the typical case
+
+ pure Creds
+ { credsPlugin = pluginName
+ , credsIdent = userId
+ , credsExtra = setExtra token userResponse
+ }
+ where
+ oauth2 = OAuth2
+ { oauthClientId = clientId
+ , oauthClientSecret = clientSecret
+ , oauthOAuthorizeEndpoint = "https://mysite.com/oauth/authorize"
  , oauthAccessTokenEndpoint = "https://mysite.com/oauth/token"
- , oauthCallback = Nothing
- })
- makeCredentials
-
-makeCredentials :: Manager -> AccessToken -> IO (Creds m)
-makeCredentials manager token = do
- result <- authGetJSON manager token "https://mysite.com/api/me.json"
- return $ -- Parse the JSON into (Creds m)
+ , oauthCallback = Nothing
+ }
 ```
 
-*If you write one of these, please consider opening a Pull Request*
+The `Prelude` module is considered public API, though we may build something
+higher-level that is more convenient for this use-case in the future.
 
 ## Development & Tests
 
@@ -84,6 +110,8 @@ stack build --dependencies-only
 stack build --pedantic --test
 ```
 
+Please also run HLint and Weeder before submitting PRs.
+
 ---
 
 [CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE)

package.yaml

@@ -20,6 +20,7 @@ library:
  dependencies:
  - aeson >=0.6 && <1.3
  - bytestring >=0.9.1.4
+ - errors
  - hoauth2 >=1.3.0 && <1.6
  - http-client >=0.4.0 && <0.6
  - http-conduit >=2.0 && <3.0

src/Yesod/Auth/OAuth2.hs

@@ -5,7 +5,7 @@
 --
 -- Generic OAuth2 plugin for Yesod
 --
--- See "Yesod.Auth.OAuth2.GitHub" for example usage.
+-- See @"Yesod.Auth.OAuth2.GitHub"@ for example usage.
 --
 module Yesod.Auth.OAuth2
  ( OAuth2(..)
@@ -16,9 +16,19 @@ module Yesod.Auth.OAuth2
  , oauth2Url
  , authOAuth2
  , authOAuth2Widget
+
+ -- * Reading our @'credsExtra'@ keys
+ , getAccessToken
+ , getUserResponse
+ , getUserResponseJSON
  ) where
 
+import Control.Error.Util (note)
+import Control.Monad ((<=<))
+import Data.Aeson (FromJSON, eitherDecode)
+import Data.ByteString.Lazy (ByteString, fromStrict)
 import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
 import Network.HTTP.Conduit (Manager)
 import Network.OAuth.OAuth2
 import Yesod.Auth
@@ -30,7 +40,7 @@ oauth2Url name = PluginR name ["forward"]
 
 -- | Create an @'AuthPlugin'@ for the given OAuth2 provider
 --
--- Presents a generic @"Login via name"@ link
+-- Presents a generic @"Login via #{name}"@ link
 --
 authOAuth2 :: YesodAuth m => Text -> OAuth2 -> FetchCreds m -> AuthPlugin m
 authOAuth2 name = authOAuth2Widget [whamlet|Login via #{name}|] name
@@ -51,3 +61,22 @@ authOAuth2Widget widget name oauth getCreds =
  AuthPlugin name (dispatchAuthRequest name oauth getCreds) login
  where
  login tm = [whamlet|<a href=@{tm $ oauth2Url name}>^{widget}|]
+
+-- | Read from the values set via @'setExtra'@
+getAccessToken :: Creds m -> Maybe AccessToken
+getAccessToken =
+ (AccessToken <$>) . lookup "accessToken" . credsExtra
+
+-- | Read from the values set via @'setExtra'@
+getUserResponse :: Creds m -> Maybe ByteString
+getUserResponse =
+ (fromStrict . encodeUtf8 <$>) . lookup "userResponse" . credsExtra
+
+-- | Read from the values set via @'setExtra'@, decode as JSON
+--
+-- This is unsafe if the key is missing, but safe with respect to parsing
+-- errors.
+--
+getUserResponseJSON :: FromJSON a => Creds m -> Either String a
+getUserResponseJSON =
+ eitherDecode <=< note "userResponse key not present" . getUserResponse

src/Yesod/Auth/OAuth2/BattleNet.hs

@@ -17,15 +17,14 @@ import Yesod.Auth.OAuth2.Prelude
 import qualified Data.Text as T (pack, toLower)
 import Yesod.Core.Widget
 
-data BattleNetUser = BattleNetUser
- { userId :: Int
- , battleTag :: Text
- }
+newtype User = User Int
 
-instance FromJSON BattleNetUser where
- parseJSON = withObject "BattleNetUser" $ \o -> BattleNetUser
+instance FromJSON User where
+ parseJSON = withObject "User" $ \o -> User
  <$> o .: "id"
- <*> o .: "battletag"
+
+pluginName :: Text
+pluginName = "battle.net"
 
 oAuth2BattleNet
  :: YesodAuth m
@@ -35,32 +34,26 @@ oAuth2BattleNet
  -> WidgetT m IO () -- ^ Login widget
  -> AuthPlugin m
 oAuth2BattleNet clientId clientSecret region widget =
- authOAuth2Widget widget "battle.net" oAuthData $ makeCredentials region
+ authOAuth2Widget widget pluginName oauth2 $ \manager token -> do
+ (User userId, userResponse) <-
+ authGetProfile pluginName manager token
+ $ fromRelative "https" (apiHost $ T.toLower region) "/account/user"
+
+ pure Creds
+ { credsPlugin = pluginName
+ , credsIdent = T.pack $ show userId
+ , credsExtra = setExtra token userResponse
+ }
  where
- oAuthData = OAuth2
+ host = wwwHost $ T.toLower region
+ oauth2 = OAuth2
  { oauthClientId = clientId
  , oauthClientSecret = clientSecret
  , oauthOAuthorizeEndpoint = fromRelative "https" host "/oauth/authorize"
  , oauthAccessTokenEndpoint = fromRelative "https" host "/oauth/token"
  , oauthCallback = Nothing
  }
 
- host = wwwHost $ T.toLower region
-
-makeCredentials :: Text -> Manager -> OAuth2Token -> IO (Creds m)
-makeCredentials region manager token = do
- userResult <- authGetJSON manager (accessToken token)
- $ fromRelative "https" (apiHost $ T.toLower region) "/account/user"
-
- either
- (throwIO . invalidProfileResponse "battle.net")
- (\user ->
- return Creds
- { credsPlugin = "battle.net"
- , credsIdent = T.pack $ show $ userId user
- , credsExtra = [("battletag", battleTag user)]
- }
- ) userResult
 
 apiHost :: Text -> Host
 apiHost "cn" = "api.battlenet.com.cn"