packages feed

hoauth2 2.6.0 → 2.15.1

raw patch · 35 files changed

Files

+ CHANGELOG.md view
@@ -0,0 +1,161 @@+# hoauth2 Changelog++## 2.15.1 (2026-04-17)+- Dependency changes+  - Relax the `containers` upper bound to `< 0.9` so `containers-0.8` is supported.+  - No API or behavior changes.++## 2.15.0 (2025-10-05)+- Breaking changes+  - Type and class renames+    - `OAuth2Token` renamed to `TokenResponse`.+    - `TokenRequestAuthenicationMethod` renamed to `ClientAuthenticationMethod`.+    - `HasTokenRequestClientAuthenticationMethod` renamed to `HasClientAuthenticationMethod`.+    - Removed several `Has*` type classes (e.g., `HasOAuth2Key`, `HasOAuthKey` from `HasTokenRequest`).+  - Removed deprecated API in `Network.OAuth2.HttpClient`+    - Deprecated functions have been removed. Use `authGetJSON`/`authGetBS`/`authPostJSON`/`authPostBS` and the `WithAuthMethod` variants with `APIAuthenticationMethod`.+  - Request body encoding behavior+    - `authPostJSON` now sends JSON with `Content-Type: application/json`. If an endpoint requires form-encoded data, use `authPostBS` or construct a custom request body.+  - Import/module path cleanup+    - Consumers should import `Network.OAuth2` (not `Network.OAuth.OAuth2`).+- Behavioral changes and bug fixes+  - Client authentication handling+    - Append `client_id` and `client_secret` for `ClientSecretPost` in client credentials flow.+    - Refresh token flow honors the configured client authentication method.+    - Authorization Code flow supports client authentication methods.+  - Device Authorization flow+    - Updated handling of device authorization requests and polling behavior.+- Refactors and internal cleanup+  - Refactored header handling, simplified URI-to-Request conversion, removed deprecated or unused internals, and general cleanups.+- Dependency changes+  - Allow `microlens` 0.5 (`microlens` >= 0.4 && < 0.6).+  - Raise lower bound to `uri-bytestring` >= 0.4 (< 0.5).++## 2.14.3 (2025-03-14)++- Fixes and improvements:+  - Append client_id and client_secret for ClientSecretPost in client credentials flow+  - Add raw response to token response and derive Show instances+  - Skip empty scope; assorted refactors and cleanups++## 2.14.2 (2025-01-30)++* Updated uri-bytestring to version 0.4++## 2.14.1 (2024-11-19)++* Updated data-default to version 0.8++## 2.14.0 (2024-11-19)++* Updated crypton to version 1.0++## 2.13.0 (2024-03-07)++* Replaced cryptonite with crypton++## 2.12.0 (2024-01-19)++* Updated base64 to version 1.0++## 2.11.0 (2023-12-30)++* Updated aeson to version 2.2+* Updated binary to version 0.10+* Updated bytestring to version 0.12+* Updated container to version 0.7++## 2.10.0 (2023-11-17)++* Added support for text 2.2++## 2.9.0 (2023-10-26)++* Refactored oauth2 Experiment module implementation+* Removed generics+* Added Device Authorization grant+* Moved IdpName to hoauth2 and enabled DataKinds+* Changed the type parameter in HttpClient methods+* Removed data family `RefreshTokenRequest`++## 2.8.1 (2023-06-17)++* Added support for GHC-9.6+* Updated CI configuration for GHC 9.6.1+* Added hiedb integration++## 2.8.0 (2023-03-15)++* Added support for GHC-9.4.4+* Added support for text-2.0++## 2.7 (2022-11-17)++* Added GrantType jwt-bearer+* Added JWT authentication method for ClientCredential flow+* Replaced `OAuth2Error` with `TokenRequestError`+* Moved `HasIdpName` class to hoauth2-demo+* Improved error handling when response body is empty in `HttpClient.handleResponse`+* Removed the following modules from exposure list:+    - Network.OAuth2.Experiment.Pkce+    - Network.OAuth2.Experiment.Types+    - Network.OAuth2.Experiment.Utils+    - Network.OAuth.OAuth2.Internal++## 2.6 (2022-10-04)++* Changed type parameter order in http client JSON method+* Modified http client to only accept one Authentication Method instead of a Set+* Removed `authPostBS1` (non-standard approach to sending credentials)+* Removed Douban IdP (discontinued OAuth2 support)+* Deprecated all *Internal methods, added *WithAuthMethod alternatives+* Changed license to MIT+* Added support for PKCE flow in `Network.OAuth2.Experiment` module+* Added support for Resource Owner Password and Client Credentials flows+* Added `hoauth2-providers` and `hoauth2-providers-tutorial` modules+* Added `hoauth2-tutorial` module++## 2.5 (2022-08-17)++* Updated aeson to version 2.1++## 2.4 (2022-08-17)++* Relaxed binary and bytestring version constraints++## 2.1 (2022-02-19)++* Added documentation for OAuth2 specification+* Updated aeson to version 2++## 2.0 (2022-02-15)++* Breaking change: Refactored naming convention of `OAuth2` data type+  ```diff+  -  { oauthClientId            = "xxxxxxxxxxxxxxx"+  -  , oauthClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxx"+  -  , oauthCallback            = Just [uri|http://127.0.0.1:9988/oauthCallback|]+  -  , oauthOAuthorizeEndpoint  = [uri|https://api.weibo.com/oauth2/authorize|]+  -  , oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]+  +  { oauth2ClientId           = "xxxxxxxxxxxxxxx"+  +  , oauth2ClientSecret       = Just "xxxxxxxxxxxxxxxxxxxxxx"+  +  , oauth2RedirectUri        = Just [uri|http://127.0.0.1:9988/oauthCallback|]+  +  , oauth2AuthorizeEndpoint  = [uri|https://api.weibo.com/oauth2/authorize|]+  +  , oauth2TokenEndpoint      = [uri|https://api.weibo.com/oauth2/access_token|]+  +  }+  ```++## 1.7.0 (2018-03-03)++* Added sample server and removed individual sample tests+* Added `fetchAccessToken2` function+* Added `refreshAccessToken` function and deprecated `fetchRefreshToken`+* Renamed `authGetBS'` to `authGetBS2`+* Renamed `authPostBS'` to `authPostBS2`+* Added `authPostBS3` function++## 1.0.0 (2017-04-07)++* Added umbrella type `OAuth2Token` to accommodate `AccessToken` and `RefreshToken`+* Typed the intermediate authentication code as `ExchangeToken`+* Fixed missing client_id error in tests by appending client_id and client_secret to header
+ README.md view
@@ -0,0 +1,11 @@+Haskell bindings for++-   [The OAuth 2.0 Authorization Framework](https://datatracker.ietf.org/doc/html/rfc6749)+    -   If the Identity Provider also implements [OIDC+        spec](https://openid.net/specs/openid-connect-core-1_0.html), ID+        Token will also be present in the token response (see+        `TokenResponse`).+-   [JWT Profile for OAuth2 Client Authentication and Authorization+    Grants](https://www.rfc-editor.org/rfc/rfc7523.html)+-   [The OAuth 2.0 Authorization Framework: Bearer Token+    Usage](https://www.rfc-editor.org/rfc/rfc6750)
− README.org 
@@ -1,8 +0,0 @@-* Introduction--Lightweight Haskell binding for--- [The OAuth 2.0 Authorization Framework](https://datatracker.ietf.org/doc/html/rfc6749)-  - If the provider does implement [OIDC spec](https://openid.net/specs/openid-connect-core-1_0.html),-    ID Token would also be included in token response (see `OAuth2Token`).-- [The OAuth 2.0 Authorization Framework: Bearer Token Usage](https://www.rfc-editor.org/rfc/rfc6750)
hoauth2.cabal view
@@ -2,14 +2,10 @@ name:               hoauth2  -- http://wiki.haskell.org/Package_versioning_policy-version:            2.6.0+version:            2.15.1 synopsis:           Haskell OAuth2 authentication client description:-  Haskell OAuth2 authentication client.-  .-  Tutorial <https://github.com/freizl/hoauth2/tree/main/hoauth2-tutorial/>-  .-  Demo application <https://github.com/freizl/hoauth2-demo/tree/main/hoauth2-demo/>+  This package provides Haskell bindings for the OAuth2 Authorization Framework and Bearer Token Usage.  homepage:           https://github.com/freizl/hoauth2 license:            MIT@@ -20,56 +16,107 @@ category:           Network build-type:         Simple stability:          Beta-tested-with:        GHC <=9.2.2-extra-source-files: README.org+tested-with:+  GHC ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4 || ==9.6.1 || ==9.8.2 +extra-source-files:+  CHANGELOG.md+  README.md+ source-repository head   type:     git-  location: git://github.com/freizl/hoauth2.git+  location: https://github.com/freizl/hoauth2.git  library   hs-source-dirs:     src   default-language:   Haskell2010+  autogen-modules:    Paths_hoauth2+  other-modules:+    Network.HTTP.Client.Contrib+    Network.OAuth2.Internal+    Network.OAuth2.Experiment.Grants+    Network.OAuth2.Experiment.Utils+    Paths_hoauth2+   exposed-modules:-    Network.OAuth.OAuth2-    Network.OAuth.OAuth2.AuthorizationRequest-    Network.OAuth.OAuth2.HttpClient-    Network.OAuth.OAuth2.Internal-    Network.OAuth.OAuth2.TokenRequest+    Network.OAuth2+    Network.OAuth2.AuthorizationRequest+    Network.OAuth2.HttpClient+    Network.OAuth2.TokenRequest     Network.OAuth2.Experiment+    Network.OAuth2.Experiment.Flows+    Network.OAuth2.Experiment.Flows.AuthorizationRequest+    Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest+    Network.OAuth2.Experiment.Flows.RefreshTokenRequest+    Network.OAuth2.Experiment.Flows.TokenRequest+    Network.OAuth2.Experiment.Flows.UserInfoRequest+    Network.OAuth2.Experiment.Grants.AuthorizationCode+    Network.OAuth2.Experiment.Grants.ClientCredentials+    Network.OAuth2.Experiment.Grants.DeviceAuthorization+    Network.OAuth2.Experiment.Grants.JwtBearer+    Network.OAuth2.Experiment.Grants.ResourceOwnerPassword     Network.OAuth2.Experiment.Pkce     Network.OAuth2.Experiment.Types-    Network.OAuth2.Experiment.Utils    default-extensions:-    DataKinds     DeriveGeneric     GeneralizedNewtypeDeriving     ImportQualifiedPost+    InstanceSigs     OverloadedStrings+    PolyKinds     RecordWildCards-    TypeApplications     TypeFamilies    build-depends:-    , aeson                 >=2.0   && <2.2-    , base                  >=4     && <5-    , base64                ^>=0.4-    , binary                ^>=0.8-    , bytestring            >=0.9   && <0.12-    , containers            ^>=0.6-    , cryptonite            ^>=0.30-    , data-default          ^>=0.7-    , exceptions            >=0.8.3 && <0.11-    , http-conduit          >=2.1   && <2.4-    , http-types            >=0.11  && <0.13-    , memory                ^>=0.17-    , microlens             ^>=0.4.0-    , text                  >=0.11  && <1.3-    , transformers          ^>=0.5-    , uri-bytestring        >=0.2.3 && <0.4+    , aeson                 >=2.0    && <2.3+    , base                  >=4.11   && <5+    , base64                >=1.0    && <1.1+    , binary                >=0.8    && <0.11+    , binary-instances      >=1.0    && <1.1+    , bytestring            >=0.9    && <0.13+    , containers            >=0.6    && <0.9+    , crypton               >=0.32   && <1.1+    , data-default          ^>=0.8+    , exceptions            >=0.8.3  && <0.11+    , http-conduit          >=2.1    && <2.4+    , http-types            >=0.11   && <0.13+    , memory                ^>=0.18+    , microlens             >=0.4 && <0.6+    , text                  >=2.0    && <2.3+    , transformers          >=0.4    && <0.7+    , uri-bytestring        >=0.4    && <0.5     , uri-bytestring-aeson  ^>=0.1    ghc-options:     -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields-    -Wwarnings-deprecations+    -Wwarn -Wwarnings-deprecations++test-suite hoauth-tests+  type:               exitcode-stdio-1.0+  main-is:            Spec.hs+  hs-source-dirs:     test+  ghc-options:        -Wall+  build-depends:+    , aeson           >=2.0  && <2.3+    , base            >=4.11 && <5+    , binary          >=0.8  && <0.11+    , hoauth2+    , hspec           >=2    && <3+    , uri-bytestring  >=0.4  && <0.5+    , http-conduit          >=2.1    && <2.4++  other-modules:+    Network.OAuth2.InternalSpec+    Network.OAuth2.TokenRequestSpec+    Network.OAuth2.TokenResponseSpec++  default-language:   Haskell2010+  default-extensions:+    ImportQualifiedPost+    OverloadedStrings++  build-tool-depends: hspec-discover:hspec-discover >=2 && <3+  ghc-options:+    -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields+    -Wwarn -Wwarnings-deprecations
+ src/Network/HTTP/Client/Contrib.hs view
@@ -0,0 +1,25 @@+module Network.HTTP.Client.Contrib where++import Data.Aeson+import Data.Bifunctor+import Data.ByteString.Lazy.Char8 qualified as BSL+import Network.HTTP.Conduit+import Network.HTTP.Types qualified as HT++-- | Get response body out of a @Response@+handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString+handleResponse rsp+  | HT.statusIsSuccessful (responseStatus rsp) = Right (responseBody rsp)+  -- TODO: better to surface up entire resp so that client can decide what to do when error happens.+  -- e.g. when 404, the response body could be empty hence library user has no idea what's happening.+  -- Which will be breaking changes.+  -- The current work around is surface up entire response as string.+  | BSL.null (responseBody rsp) = Left (BSL.pack $ show rsp)+  | otherwise = Left (responseBody rsp)++handleResponseJSON ::+  FromJSON a =>+  Response BSL.ByteString ->+  Either BSL.ByteString a+handleResponseJSON =+  either Left (first BSL.pack . eitherDecode) . handleResponse
− src/Network/OAuth/OAuth2.hs 
@@ -1,19 +0,0 @@--- | A lightweight oauth2 Haskell binding.--- See Readme for more details----module Network.OAuth.OAuth2-  ( module Network.OAuth.OAuth2.HttpClient,-    module Network.OAuth.OAuth2.AuthorizationRequest,-    module Network.OAuth.OAuth2.TokenRequest,-    module Network.OAuth.OAuth2.Internal,-  )-where--{--  Hiding Errors data type from default.-  Shall qualified import given the naming collision.--}-import Network.OAuth.OAuth2.AuthorizationRequest hiding (Errors(..))-import Network.OAuth.OAuth2.HttpClient-import Network.OAuth.OAuth2.Internal-import Network.OAuth.OAuth2.TokenRequest hiding (Errors(..))
− src/Network/OAuth/OAuth2/AuthorizationRequest.hs 
@@ -1,68 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}---- | Bindings Authorization part of The OAuth 2.0 Authorization Framework--- RFC6749 <https://www.rfc-editor.org/rfc/rfc6749>-module Network.OAuth.OAuth2.AuthorizationRequest where--import Data.Aeson-import Data.Function (on)-import qualified Data.List as List-import qualified Data.Text.Encoding as T-import GHC.Generics (Generic)-import Lens.Micro (over)-import Network.OAuth.OAuth2.Internal-import URI.ByteString-------------------------------------------------------- * Errors------------------------------------------------------instance FromJSON Errors where-  parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}--instance ToJSON Errors where-  toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}---- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1--- I found hard time to figure a way to test the authorization error flow--- When anything wrong in @/authorize@ request (redirect to OAuth2 provider),--- it will end-up at the Provider page hence no way for this library to parse error response.--- In other words, @/authorize@ ends up with 4xx or 5xx.--- Revisit this whenever find a case OAuth2 provider redirects back to Relying party with errors.-data Errors-  = InvalidRequest-  | UnauthorizedClient-  | AccessDenied-  | UnsupportedResponseType-  | InvalidScope-  | ServerError-  | TemporarilyUnavailable-  deriving (Show, Eq, Generic)-------------------------------------------------------- * URLs-------------------------------------------------------- | See 'authorizationUrlWithParams'-authorizationUrl :: OAuth2 -> URI-authorizationUrl = authorizationUrlWithParams []---- | Prepare the authorization URL.  Redirect to this URL--- asking for user interactive authentication.------ @since 2.6.0-authorizationUrlWithParams :: QueryParams -> OAuth2 -> URI-authorizationUrlWithParams qs oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa)-  where-    queryParts =-      List.nubBy ((==) `on` fst) $-        qs-          ++ [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa),-               ("response_type", "code"),-               ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)-             ]
− src/Network/OAuth/OAuth2/HttpClient.hs 
@@ -1,341 +0,0 @@-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}---- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage--- RFC6750 <https://www.rfc-editor.org/rfc/rfc6750>-module Network.OAuth.OAuth2.HttpClient-  ( -- * AUTH requests-    authGetJSON,-    authGetBS,-    authGetBS2,-    authGetJSONWithAuthMethod,-    authGetJSONInternal,-    authGetBSWithAuthMethod,-    authGetBSInternal,-    authPostJSON,-    authPostBS,-    authPostBS2,-    authPostBS3,-    authPostJSONWithAuthMethod,-    authPostJSONInternal,-    authPostBSWithAuthMethod,-    authPostBSInternal,--    -- * Types-    APIAuthenticationMethod (..),-  )-where--import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Except (ExceptT (..), throwE)-import Data.Aeson (FromJSON, eitherDecode)-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Maybe (fromJust, isJust)-import qualified Data.Text.Encoding as T-import Lens.Micro (over)-import Network.HTTP.Conduit-import qualified Network.HTTP.Types as HT-import Network.OAuth.OAuth2.Internal-import URI.ByteString (URI, URIRef, queryL, queryPairsL)-------------------------------------------------------- * AUTH requests---- Making request with Access Token appended to Header, Request body or query string.---------------------------------------------------------- | Conduct an authorized GET request and return response as JSON.---   Inject Access Token to Authorization Header.-authGetJSON ::-  (FromJSON a, MonadIO m) =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as JSON-  ExceptT BSL.ByteString m a-authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader--authGetJSONInternal ::-  (FromJSON a, MonadIO m) =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as JSON-  ExceptT BSL.ByteString m a-authGetJSONInternal = authGetJSONWithAuthMethod-{-# DEPRECATED authGetJSONInternal "use authGetJSONWithAuthMethod" #-}---- | Conduct an authorized GET request and return response as JSON.---   Allow to specify how to append AccessToken.------ @since 2.6.0-authGetJSONWithAuthMethod ::-  (MonadIO m, FromJSON a) =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as JSON-  ExceptT BSL.ByteString m a-authGetJSONWithAuthMethod authTypes manager t uri = do-  resp <- authGetBSWithAuthMethod authTypes manager t uri-  either (throwE . BSL.pack) return (eitherDecode resp)---- | Conduct an authorized GET request.---   Inject Access Token to Authorization Header.-authGetBS ::-  (MonadIO m) =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authGetBS = authGetBSWithAuthMethod AuthInRequestHeader---- | Same to 'authGetBS' but set access token to query parameter rather than header-authGetBS2 ::-  (MonadIO m) =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authGetBS2 = authGetBSWithAuthMethod AuthInRequestQuery-{-# DEPRECATED authGetBS2 "use authGetBSWithAuthMethod" #-}--authGetBSInternal ::-  (MonadIO m) =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authGetBSInternal = authGetBSWithAuthMethod-{-# DEPRECATED authGetBSInternal "use authGetBSWithAuthMethod" #-}---- | Conduct an authorized GET request and return response as ByteString.---   Allow to specify how to append AccessToken.------ @since 2.6.0-authGetBSWithAuthMethod ::-  (MonadIO m) =>-  -- | Specify the way that how to append the 'AccessToken' in the request-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authGetBSWithAuthMethod authTypes manager token url = do-  let appendToUrl = AuthInRequestQuery == authTypes-  let appendToHeader = AuthInRequestHeader == authTypes-  let uri = if appendToUrl then url `appendAccessToken` token else url-  let upReq = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.GET-  req <- liftIO $ uriToRequest uri-  authRequest req upReq manager---- | Conduct POST request and return response as JSON.---   Inject Access Token to Authorization Header.-authPostJSON ::-  (FromJSON a, MonadIO m) =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as JSON-  ExceptT BSL.ByteString m a-authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader--authPostJSONInternal ::-  (FromJSON a, MonadIO m) =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m a-authPostJSONInternal = authPostJSONWithAuthMethod-{-# DEPRECATED authPostJSONInternal "use 'authPostJSONWithAuthMethod'" #-}---- | Conduct POST request and return response as JSON.---   Allow to specify how to append AccessToken.------ @since 2.6.0-authPostJSONWithAuthMethod ::-  (FromJSON a, MonadIO m) =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m a-authPostJSONWithAuthMethod authTypes manager token url body = do-  resp <- authPostBSWithAuthMethod authTypes manager token url body-  either (throwE . BSL.pack) return (eitherDecode resp)---- | Conduct POST request.---   Inject Access Token to http header (Authorization)-authPostBS ::-  (MonadIO m) =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authPostBS = authPostBSWithAuthMethod AuthInRequestHeader---- | Conduct POST request with access token only in the request body but header.-authPostBS2 ::-  (MonadIO m) =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authPostBS2 = authPostBSWithAuthMethod AuthInRequestBody-{-# DEPRECATED authPostBS2 "use 'authPostBSWithAuthMethod'" #-}---- | Conduct POST request with access token only in the header and not in body-authPostBS3 ::-  (MonadIO m) =>-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authPostBS3 = authPostBSWithAuthMethod AuthInRequestHeader-{-# DEPRECATED authPostBS3 "use 'authPostBSWithAuthMethod'" #-}--authPostBSInternal ::-  (MonadIO m) =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authPostBSInternal = authPostBSWithAuthMethod-{-# DEPRECATED authPostBSInternal "use 'authPostBSWithAuthMethod'" #-}---- | Conduct POST request and return response as ByteString.---   Allow to specify how to append AccessToken.------ @since 2.6.0-authPostBSWithAuthMethod ::-  (MonadIO m) =>-  APIAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  AccessToken ->-  URI ->-  PostBody ->-  -- | Response as ByteString-  ExceptT BSL.ByteString m BSL.ByteString-authPostBSWithAuthMethod authTypes manager token url body = do-  let appendToBody = AuthInRequestBody == authTypes-  let appendToHeader = AuthInRequestHeader == authTypes-  let reqBody = if appendToBody then body ++ accessTokenToParam token else body-  -- TODO: urlEncodedBody send request as 'application/x-www-form-urlencoded'-  -- seems shall go with application/json which is more common?-  let upBody = if null reqBody then id else urlEncodedBody reqBody-  let upHeaders = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.POST-  let upReq = upHeaders . upBody--  req <- liftIO $ uriToRequest url-  authRequest req upReq manager-------------------------------------------------------- * Types-------------------------------------------------------- | https://www.rfc-editor.org/rfc/rfc6750#section-2-data APIAuthenticationMethod-  = -- | Provides in Authorization header-    AuthInRequestHeader-  | -- | Provides in request body-    AuthInRequestBody-  | -- | Provides in request query parameter-    AuthInRequestQuery-  deriving (Eq, Ord)-------------------------------------------------------- * Utilities-------------------------------------------------------- | Send an HTTP request.-authRequest ::-  (MonadIO m) =>-  -- | Request to perform-  Request ->-  -- | Modify request before sending-  (Request -> Request) ->-  -- | HTTP connection manager.-  Manager ->-  ExceptT BSL.ByteString m BSL.ByteString-authRequest req upReq manage = ExceptT $ handleResponse <$> httpLbs (upReq req) manage---- | Get response body out of a @Response@-handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString-handleResponse rsp =-  if HT.statusIsSuccessful (responseStatus rsp)-    then Right $ responseBody rsp-    else -- TODO: better to surface up entire resp so that client can decide what to do when error happens.-      Left $ responseBody rsp---- | Set several header values:---   + userAgennt    : `hoauth2`---   + accept        : `application/json`---   + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided.-updateRequestHeaders :: Maybe AccessToken -> Request -> Request-updateRequestHeaders t req =-  let bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (atoken (fromJust t))) | isJust t]-      headers = bearer ++ defaultRequestHeaders ++ requestHeaders req-   in req {requestHeaders = headers}---- | Set the HTTP method to use.-setMethod :: HT.StdMethod -> Request -> Request-setMethod m req = req {method = HT.renderStdMethod m}---- | For `GET` method API.-appendAccessToken ::-  -- | Base URI-  URIRef a ->-  -- | Authorized Access Token-  AccessToken ->-  -- | Combined Result-  URIRef a-appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri---- | Create 'QueryParams' with given access token value.-accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)]-accessTokenToParam t = [("access_token", T.encodeUtf8 $ atoken t)]
− src/Network/OAuth/OAuth2/Internal.hs 
@@ -1,219 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}--module Network.OAuth.OAuth2.Internal where--import Control.Applicative-import Control.Arrow (second)-import Control.Monad.Catch-import Data.Aeson-import Data.Aeson.Types (Parser, explicitParseFieldMaybe)-import Data.Binary (Binary)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import Data.Default-import Data.Maybe-import Data.Text (Text, pack, unpack)-import Data.Text.Encoding-import GHC.Generics-import Lens.Micro-import Lens.Micro.Extras-import Network.HTTP.Conduit as C-import qualified Network.HTTP.Types as H-import qualified Network.HTTP.Types as HT-import URI.ByteString-import URI.ByteString.Aeson ()-import URI.ByteString.QQ-------------------------------------------------------- * Data Types-------------------------------------------------------- | Query Parameter Representation-data OAuth2 = OAuth2-  { oauth2ClientId :: Text,-    oauth2ClientSecret :: Text,-    oauth2AuthorizeEndpoint :: URIRef Absolute,-    oauth2TokenEndpoint :: URIRef Absolute,-    oauth2RedirectUri :: URIRef Absolute-  }-  deriving (Show, Eq)--instance Default OAuth2 where-  def =-    OAuth2-      { oauth2ClientId = "",-        oauth2ClientSecret = "",-        oauth2AuthorizeEndpoint = [uri|https://www.example.com/|],-        oauth2TokenEndpoint = [uri|https://www.example.com/|],-        oauth2RedirectUri = [uri|https://www.example.com/|]-      }--newtype AccessToken = AccessToken {atoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON)--newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON)--newtype IdToken = IdToken {idtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON)---- | Authorization Code-newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON)---- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4-data OAuth2Token = OAuth2Token-  { accessToken :: AccessToken,-    -- | Exists when @offline_access@ scope is in the 'authorizeUrl' and the provider supports Refresh Access Token.-    refreshToken :: Maybe RefreshToken,-    expiresIn :: Maybe Int,-    -- | See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release.-    tokenType :: Maybe Text,-    -- | Exists when @openid@ scope is in the 'authorizeUrl' and the provider supports OpenID.-    idToken :: Maybe IdToken-  }-  deriving (Eq, Show, Generic)--instance Binary OAuth2Token---- | Parse JSON data into 'OAuth2Token'-instance FromJSON OAuth2Token where-  parseJSON = withObject "OAuth2Token" $ \v ->-    OAuth2Token-      <$> v-      .: "access_token"-      <*> v-      .:? "refresh_token"-      <*> explicitParseFieldMaybe parseIntFlexible v "expires_in"-      <*> v-      .:? "token_type"-      <*> v-      .:? "id_token"-    where-      parseIntFlexible :: Value -> Parser Int-      parseIntFlexible (String s) = pure . read $ unpack s-      parseIntFlexible v = parseJSON v--instance ToJSON OAuth2Token where-  toJSON = genericToJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}-  toEncoding = genericToEncoding defaultOptions {fieldLabelModifier = camelTo2 '_'}--data OAuth2Error a = OAuth2Error-  { error :: Either Text a,-    errorDescription :: Maybe Text,-    errorUri :: Maybe (URIRef Absolute)-  }-  deriving (Show, Eq, Generic)--instance FromJSON err => FromJSON (OAuth2Error err) where-  parseJSON (Object a) =-    do-      err <- (a .: "error") >>= (\str -> Right <$> parseJSON str <|> Left <$> parseJSON str)-      desc <- a .:? "error_description"-      errorUri <- a .:? "error_uri"-      return $ OAuth2Error err desc errorUri-  parseJSON _ = fail "Expected an object"--instance ToJSON err => ToJSON (OAuth2Error err) where-  toJSON = genericToJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}-  toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}--parseOAuth2Error :: FromJSON err => BSL.ByteString -> OAuth2Error err-parseOAuth2Error string =-  either (mkDecodeOAuth2Error string) id (eitherDecode string)--mkDecodeOAuth2Error :: BSL.ByteString -> String -> OAuth2Error err-mkDecodeOAuth2Error response err =-  OAuth2Error-    (Left "Decode error")-    (Just $ pack $ "Error: " <> err <> "\n Original Response:\n" <> show (decodeUtf8 $ BSL.toStrict response))-    Nothing---- | https://www.rfc-editor.org/rfc/rfc6749#section-2.3--- According to spec:------ The client MUST NOT use more than one authentication method in each request.------ Which means use Authorization header or Post body.------ However, in reality, I always have to include authentication in the header.------ In other words, 'ClientSecrectBasic' is always assured. 'ClientSecretPost' is optional.------ Maybe consider an alternative implementation that boolean kind of data type is good enough.-data ClientAuthenticationMethod-  = ClientSecretBasic-  | ClientSecretPost-  deriving (Eq, Ord)-------------------------------------------------------- * Types Synonym-------------------------------------------------------- | type synonym of post body content-type PostBody = [(BS.ByteString, BS.ByteString)]--type QueryParams = [(BS.ByteString, BS.ByteString)]-------------------------------------------------------- * Utilies------------------------------------------------------defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)]-defaultRequestHeaders =-  [ (HT.hUserAgent, "hoauth2"),-    (HT.hAccept, "application/json")-  ]--appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a-appendQueryParams params =-  over (queryL . queryPairsL) (params ++)--uriToRequest :: MonadThrow m => URI -> m Request-uriToRequest auri = do-  ssl <- case view (uriSchemeL . schemeBSL) auri of-    "http" -> return False-    "https" -> return True-    s -> throwM $ InvalidUrlException (show auri) ("Invalid scheme: " ++ show s)-  let query = fmap (second Just) (view (queryL . queryPairsL) auri)-      hostL = authorityL . _Just . authorityHostL . hostBSL-      portL = authorityL . _Just . authorityPortL . _Just . portNumberL-      defaultPort = (if ssl then 443 else 80) :: Int--      req =-        setQueryString query $-          defaultRequest-            { secure = ssl,-              path = view pathL auri-            }-      req2 = (over hostLens . maybe id const . preview hostL) auri req-      req3 = (over portLens . (const . fromMaybe defaultPort) . preview portL) auri req2-  return req3--requestToUri :: Request -> URI-requestToUri req =-  URI-    ( Scheme-        ( if secure req-            then "https"-            else "http"-        )-    )-    (Just (Authority Nothing (Host $ host req) (Just $ Port $ port req)))-    (path req)-    (Query $ H.parseSimpleQuery $ queryString req)-    Nothing--hostLens :: Lens' Request BS.ByteString-hostLens f req = f (C.host req) <&> \h' -> req {C.host = h'}-{-# INLINE hostLens #-}--portLens :: Lens' Request Int-portLens f req = f (C.port req) <&> \p' -> req {C.port = p'}-{-# INLINE portLens #-}
− src/Network/OAuth/OAuth2/TokenRequest.hs 
@@ -1,310 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}---- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework--- RFC6749 <https://www.rfc-editor.org/rfc/rfc6749>-module Network.OAuth.OAuth2.TokenRequest where--import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Except (ExceptT (..), throwE)-import Data.Aeson-import qualified Data.Aeson.Key as Key-import qualified Data.Aeson.KeyMap as KeyMap-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.Text.Encoding as T-import GHC.Generics (Generic)-import Network.HTTP.Conduit-import qualified Network.HTTP.Types as HT-import Network.HTTP.Types.URI (parseQuery)-import Network.OAuth.OAuth2.Internal-import URI.ByteString (URI, serializeURIRef')-------------------------------------------------------- * Token Request Errors------------------------------------------------------instance FromJSON Errors where-  parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}--instance ToJSON Errors where-  toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}---- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2-data Errors-  = InvalidRequest-  | InvalidClient-  | InvalidGrant-  | UnauthorizedClient-  | UnsupportedGrantType-  | InvalidScope-  deriving (Show, Eq, Generic)-------------------------------------------------------- * URL-------------------------------------------------------- | Prepare the URL and the request body query for fetching an access token.-accessTokenUrl ::-  OAuth2 ->-  -- | access code gained via authorization URL-  ExchangeToken ->-  -- | access token request URL plus the request body.-  (URI, PostBody)-accessTokenUrl oa code =-  let uri = oauth2TokenEndpoint oa-      body =-        [ ("code", T.encodeUtf8 $ extoken code),-          ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa),-          ("grant_type", "authorization_code")-        ]-   in (uri, body)---- | Obtain a new access token by sending a Refresh Token to the Authorization server.-refreshAccessTokenUrl ::-  OAuth2 ->-  -- | Refresh Token gained via authorization URL-  RefreshToken ->-  -- | Refresh Token request URL plus the request body.-  (URI, PostBody)-refreshAccessTokenUrl oa token = (uri, body)-  where-    uri = oauth2TokenEndpoint oa-    body =-      [ ("grant_type", "refresh_token"),-        ("refresh_token", T.encodeUtf8 $ rtoken token)-      ]-------------------------------------------------------- * Token management-------------------------------------------------------- | Exchange @code@ for an Access Token with authenticate in request header.-fetchAccessToken ::-  (MonadIO m) =>-  -- | HTTP connection manager-  Manager ->-  -- | OAuth Data-  OAuth2 ->-  -- | OAuth2 Code-  ExchangeToken ->-  -- | Access Token-  ExceptT (OAuth2Error Errors) m OAuth2Token-fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic--fetchAccessToken2 ::-  (MonadIO m) =>-  -- | HTTP connection manager-  Manager ->-  -- | OAuth Data-  OAuth2 ->-  -- | Authorization Code-  ExchangeToken ->-  -- | Access Token-  ExceptT (OAuth2Error Errors) m OAuth2Token-fetchAccessToken2 = fetchAccessTokenWithAuthMethod ClientSecretPost-{-# DEPRECATED fetchAccessToken2 "use 'fetchAccessTokenWithAuthMethod'" #-}--fetchAccessTokenInternal ::-  (MonadIO m) =>-  ClientAuthenticationMethod ->-  -- | HTTP connection manager-  Manager ->-  -- | OAuth Data-  OAuth2 ->-  -- | Authorization Code-  ExchangeToken ->-  -- | Access Token-  ExceptT (OAuth2Error Errors) m OAuth2Token-fetchAccessTokenInternal = fetchAccessTokenWithAuthMethod-{-# DEPRECATED fetchAccessTokenInternal "use 'fetchAccessTokenWithAuthMethod'" #-}---- | Exchange @code@ for an Access Token------ OAuth2 spec allows credential (`client_id`, `client_secret`) to be sent--- either in the header (a.k.a 'ClientSecretBasic').--- or as form/url params (a.k.a 'ClientSecretPost').------ The OAuth provider can choose to implement only one, or both.--- Look for API document from the OAuth provider you're dealing with.--- If you're uncertain, try 'fetchAccessToken' which sends credential--- in authorization http header, which is common case.------ @since 2.6.0-fetchAccessTokenWithAuthMethod ::-  (MonadIO m) =>-  ClientAuthenticationMethod ->-  -- | HTTP connection manager-  Manager ->-  -- | OAuth Data-  OAuth2 ->-  -- | Authorization Code-  ExchangeToken ->-  -- | Access Token-  ExceptT (OAuth2Error Errors) m OAuth2Token-fetchAccessTokenWithAuthMethod authMethod manager oa code = do-  let (uri, body) = accessTokenUrl oa code-  let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []-  doJSONPostRequest manager oa uri (body ++ extraBody)---- | Fetch a new AccessToken using the Refresh Token with authentication in request header.-refreshAccessToken ::-  (MonadIO m) =>-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth context-  OAuth2 ->-  -- | Refresh Token gained after authorization-  RefreshToken ->-  ExceptT (OAuth2Error Errors) m OAuth2Token-refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic--refreshAccessToken2 ::-  (MonadIO m) =>-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth context-  OAuth2 ->-  -- | Refresh Token gained after authorization-  RefreshToken ->-  ExceptT (OAuth2Error Errors) m OAuth2Token-refreshAccessToken2 = refreshAccessTokenWithAuthMethod ClientSecretPost-{-# DEPRECATED refreshAccessToken2 "use 'refreshAccessTokenWithAuthMethod'" #-}--refreshAccessTokenInternal ::-  (MonadIO m) =>-  ClientAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth context-  OAuth2 ->-  -- | Refresh Token gained after authorization-  RefreshToken ->-  ExceptT (OAuth2Error Errors) m OAuth2Token-refreshAccessTokenInternal = refreshAccessTokenWithAuthMethod-{-# DEPRECATED refreshAccessTokenInternal "use 'refreshAccessTokenWithAuthMethod'" #-}---- | Fetch a new AccessToken using the Refresh Token.------ OAuth2 spec allows credential (`client_id`, `client_secret`) to be sent--- either in the header (a.k.a 'ClientSecretBasic').--- or as form/url params (a.k.a 'ClientSecretPost').------ The OAuth provider can choose to implement only one, or both.--- Look for API document from the OAuth provider you're dealing with.--- If you're uncertain, try 'refreshAccessToken' which sends credential--- in authorization http header, which is common case.------ @since 2.6.0-refreshAccessTokenWithAuthMethod ::-  (MonadIO m) =>-  ClientAuthenticationMethod ->-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth context-  OAuth2 ->-  -- | Refresh Token gained after authorization-  RefreshToken ->-  ExceptT (OAuth2Error Errors) m OAuth2Token-refreshAccessTokenWithAuthMethod authMethod manager oa token = do-  let (uri, body) = refreshAccessTokenUrl oa token-  let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []-  doJSONPostRequest manager oa uri (body ++ extraBody)-------------------------------------------------------- * Utilies-------------------------------------------------------- | Conduct post request and return response as JSON.-doJSONPostRequest ::-  (MonadIO m, FromJSON err, FromJSON a) =>-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth options-  OAuth2 ->-  -- | The URL-  URI ->-  -- | request body-  PostBody ->-  -- | Response as JSON-  ExceptT (OAuth2Error err) m a-doJSONPostRequest manager oa uri body = do-  resp <- doSimplePostRequest manager oa uri body-  case parseResponseFlexible resp of-    Right obj -> return obj-    Left e -> throwE e---- | Conduct post request.-doSimplePostRequest ::-  (MonadIO m, FromJSON err) =>-  -- | HTTP connection manager.-  Manager ->-  -- | OAuth options-  OAuth2 ->-  -- | URL-  URI ->-  -- | Request body.-  PostBody ->-  -- | Response as ByteString-  ExceptT (OAuth2Error err) m BSL.ByteString-doSimplePostRequest manager oa url body =-  ExceptT . liftIO $ fmap handleOAuth2TokenResponse go-  where-    addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa)-    go = do-      req <- uriToRequest url-      let req' = (addBasicAuth . addDefaultRequestHeaders) req-      httpLbs (urlEncodedBody body req') manager---- | Gets response body from a @Response@ if 200 otherwise assume 'OAuth2Error'-handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> Either (OAuth2Error err) BSL.ByteString-handleOAuth2TokenResponse rsp =-  if HT.statusIsSuccessful (responseStatus rsp)-    then Right $ responseBody rsp-    else Left $ parseOAuth2Error (responseBody rsp)---- | Try to parses response as JSON, if failed, try to parse as like query string.-parseResponseFlexible ::-  (FromJSON err, FromJSON a) =>-  BSL.ByteString ->-  Either (OAuth2Error err) a-parseResponseFlexible r = case eitherDecode r of-  Left _ -> parseResponseString r-  Right x -> Right x---- | Parses the response that contains not JSON but a Query String-parseResponseString ::-  (FromJSON err, FromJSON a) =>-  BSL.ByteString ->-  Either (OAuth2Error err) a-parseResponseString b = case parseQuery $ BSL.toStrict b of-  [] -> Left errorMessage-  a -> case fromJSON $ queryToValue a of-    Error _ -> Left errorMessage-    Success x -> Right x-  where-    queryToValue = Object . KeyMap.fromList . map paramToPair-    paramToPair (k, mv) = (Key.fromText $ T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)-    errorMessage = parseOAuth2Error b---- | Set several header values:---   + userAgennt    : `hoauth2`---   + accept        : `application/json`-addDefaultRequestHeaders :: Request -> Request-addDefaultRequestHeaders req =-  let headers = defaultRequestHeaders ++ requestHeaders req-   in req {requestHeaders = headers}---- | Add Credential (client_id, client_secret) to the request post body.-clientSecretPost :: OAuth2 -> PostBody-clientSecretPost oa =-  [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa),-    ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)-  ]
+ src/Network/OAuth2.hs view
@@ -0,0 +1,26 @@+-- | A lightweight oauth2 Haskell binding.+-- See Readme for more details+module Network.OAuth2 (+  module Network.OAuth2.Internal,++  -- * Authorization Requset+  module Network.OAuth2.AuthorizationRequest,++  -- * Token Request+  module Network.OAuth2.TokenRequest,++  -- * OAuth'ed http client utilities+  module Network.OAuth2.HttpClient,+) where++{-+  Hiding Errors data type from default.+  Shall qualified import given the naming collision.+-}+import Network.OAuth2.AuthorizationRequest hiding (+  AuthorizationResponseError (..),+  AuthorizationResponseErrorCode (..),+ )+import Network.OAuth2.HttpClient+import Network.OAuth2.Internal+import Network.OAuth2.TokenRequest
+ src/Network/OAuth2/AuthorizationRequest.hs view
@@ -0,0 +1,88 @@+-- | Bindings Authorization part of The OAuth 2.0 Authorization Framework+-- RFC6749 <https://www.rfc-editor.org/rfc/rfc6749>+module Network.OAuth2.AuthorizationRequest where++import Data.Aeson+import Data.Function (on)+import Data.List qualified as List+import Data.Text (Text)+import Data.Text.Encoding qualified as T+import Lens.Micro (over)+import Network.OAuth2.Internal+import URI.ByteString+import Prelude hiding (error)++--------------------------------------------------++-- * Authorization Request Errors++--------------------------------------------------++-- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1+--+-- I found it hard to figure out a way to test the authorization error flow.+-- When anything goes wrong in an @/authorize@ request, it gets stuck at the provider page,+-- hence no way for this library to parse error response.+-- In other words, @/authorize@ ends up with 4xx or 5xx.+-- Revisit this whenever you find a case where an OAuth2 provider redirects back to the relying party with errors.+data AuthorizationResponseError = AuthorizationResponseError+  { authorizationResponseError :: AuthorizationResponseErrorCode+  , authorizationResponseErrorDescription :: Maybe Text+  , authorizationResponseErrorUri :: Maybe (URIRef Absolute)+  }+  deriving (Show, Eq)++data AuthorizationResponseErrorCode+  = InvalidRequest+  | UnauthorizedClient+  | AccessDenied+  | UnsupportedResponseType+  | InvalidScope+  | ServerError+  | TemporarilyUnavailable+  | UnknownErrorCode Text+  deriving (Show, Eq)++instance FromJSON AuthorizationResponseErrorCode where+  parseJSON = withText "parseJSON AuthorizationResponseErrorCode" $ \t ->+    pure $ case t of+      "invalid_request" -> InvalidRequest+      "unauthorized_client" -> UnauthorizedClient+      "access_denied" -> AccessDenied+      "unsupported_response_type" -> UnsupportedResponseType+      "invalid_scope" -> InvalidScope+      "server_error" -> ServerError+      "temporarily_unavailable" -> TemporarilyUnavailable+      _ -> UnknownErrorCode t++instance FromJSON AuthorizationResponseError where+  parseJSON = withObject "parseJSON AuthorizationResponseError" $ \t -> do+    authorizationResponseError <- t .: "error"+    authorizationResponseErrorDescription <- t .:? "error_description"+    authorizationResponseErrorUri <- t .:? "error_uri"+    pure AuthorizationResponseError {..}++--------------------------------------------------++-- * URLs++--------------------------------------------------++-- | See 'authorizationUrlWithParams'+authorizationUrl :: OAuth2 -> URI+authorizationUrl = authorizationUrlWithParams []++-- | Prepare the authorization URL.  Redirect to this URL+-- asking for user interactive authentication.+--+-- @since 2.6.0+authorizationUrlWithParams :: QueryParams -> OAuth2 -> URI+authorizationUrlWithParams qs oa = over (queryL . queryPairsL) (++ queryParts) (oauth2AuthorizeEndpoint oa)+  where+    queryParts =+      List.nubBy ((==) `on` fst) $+        qs+          ++ [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa)+             , ("response_type", "code")+             , ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)+             ]
src/Network/OAuth2/Experiment.hs view
@@ -1,97 +1,157 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}- -- | This module contains a new way of doing OAuth2 authorization and authentication--- in order to obtain Access Token and maybe Refresh Token base on rfc6749.+-- in order to obtain an access token and maybe a refresh token based on RFC 6749. ----- This module will become default in future release. (TBD but likely 3.0).+-- This module will become the default in a future release. ----- The key concept/change is to introduce the 'GrantTypeFlow', which determines the entire work flow per spec.--- Each work flow will have slight different request parameters, which often time you'll see--- different configuration when creating OAuth2 application in the IdP developer application page.+-- The key concept is introducing grant flows, which determine the entire workflow per the spec.+-- Each workflow has slightly different request parameters, which is why you'll often see+-- different configuration options when creating an OAuth2 application in an IdP developer console. ----- Here are supported flows+-- Here are the supported flows: ----- 1. Authorization Code. This flow requires authorize call to obtain an authorize code,+-- 1. Authorization Code. This flow requires an authorize call to obtain an authorization code, -- then exchange the code for tokens. ----- 2. Resource Owner Password. This flow only requires to hit token endpoint with, of course,+-- 2. Resource Owner Password. This flow only requires hitting the token endpoint with, of course, -- username and password, to obtain tokens. ----- 3. Client Credentials. This flow also only requires to hit token endpoint but with different parameters.--- Client credentials flow does not involve an end user hence you won't be able to hit userinfo endpoint--- with access token obtained.+-- 3. Client Credentials. This flow also only requires hitting the token endpoint, but with different parameters.+-- The client credentials flow does not involve an end user, so you won't be able to hit the userinfo endpoint+-- with the access token you obtain. ----- 5. PKCE (rfc7636). This is enhancement on top of authorization code flow.+-- 4. PKCE (RFC 7636). This is an enhancement on top of the authorization code flow. ----- Implicit flow is not supported because it is more for SPA (single page app)--- and more or less obsolete by Authorization Code flow with PKCE.+-- The implicit flow is not supported because it is primarily for SPAs (single-page apps),+-- and it has been deprecated in favor of the authorization code flow with PKCE. ----- Here is quick sample for how to use vocabularies from this new module.+-- Here is a quick sample showing how to use the vocabulary from this module. ----- Firstly, initialize your IdP (use google as example) and the application.+-- First, initialize your IdP (using Google as an example) and the application. -- -- @+--+-- import Network.OAuth2.Experiment+-- import URI.ByteString.QQ+-- -- data Google = Google deriving (Eq, Show)--- googleIdp = Idp Google+--+-- googleIdp :: Idp Google+-- googleIdp = --   Idp---     { idpFetchUserInfo = authGetJSON @(IdpUserInfo Google),---       idpAuthorizeEndpoint = [uri|https:\/\/accounts.google.com\/o\/oauth2\/v2\/auth|],---       idpTokenEndpoint = [uri|https:\/\/oauth2.googleapis.com\/token|],---       idpUserInfoEndpoint = [uri|https:\/\/www.googleapis.com\/oauth2\/v2\/userinfo|]+--     { idpAuthorizeEndpoint = [uri|https:\/\/accounts.google.com\/o\/oauth2\/v2\/auth|]+--     , idpTokenEndpoint = [uri|https:\/\/oauth2.googleapis.com\/token|]+--     , idpUserInfoEndpoint = [uri|https:\/\/www.googleapis.com\/oauth2\/v2\/userinfo|]+--     , idpDeviceAuthorizationEndpoint = Just [uri|https:\/\/oauth2.googleapis.com\/device\/code|] --     } ----- fooApp :: IdpApplication 'AuthorizationCode Google+-- fooApp :: AuthorizationCodeApplication -- fooApp =---   AuthorizationCodeIdpApplication---     { idpAppClientId = "xxxxx",---       idpAppClientSecret = "xxxxx",---       idpAppScope =+--   AuthorizationCodeApplication+--     { acClientId = "xxxxx",+--       acClientSecret = "xxxxx",+--       acScope = --         Set.fromList --           [ \"https:\/\/www.googleapis.com\/auth\/userinfo.email\", --             \"https:\/\/www.googleapis.com\/auth\/userinfo.profile\" --           ],---       idpAppAuthorizeState = \"CHANGE_ME\",---       idpAppAuthorizeExtraParams = Map.empty,---       idpAppRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|],---       idpAppName = "default-google-App",---       idpAppTokenRequestAuthenticationMethod = ClientSecretBasic,---       idp = googleIdp+--       acAuthorizeState = \"CHANGE_ME\",+--       acAuthorizeRequestExtraParams = Map.empty,+--       acRedirectUri = [uri|http:\/\/localhost\/oauth2\/callback|],+--       acName = "sample-google-authorization-code-app",+--       acClientAuthenticationMethod = ClientSecretBasic, --     }+--+-- fooIdpApplication :: IdpApplication AuthorizationCodeApplication Google+-- fooIdpApplication = IdpApplication fooApp googleIdp -- @ ----- Secondly, construct the authorize URL.+-- Second, construct the authorize URL. -- -- @--- authorizeUrl = mkAuthorizeRequest fooApp+-- authorizeUrl = mkAuthorizationRequest fooIdpApplication -- @ ----- Thirdly, after a successful redirect with authorize code,--- you could exchange for access token+-- Third, after a successful redirect with an authorization code,+-- you can exchange it for an access token. -- -- @ -- mgr <- liftIO $ newManager tlsManagerSettings--- tokenResp <- conduitTokenRequest fooApp mgr authorizeCode+-- tokenResp <- conduitTokenRequest fooIdpApplication mgr authorizeCode -- @ ----- Lastly, you probably like to fetch user info+-- If you'd like to fetch user info, use this method: -- -- @--- conduitUserInfoRequest fooApp mgr (accessToken tokenResp)+-- conduitUserInfoRequest fooIdpApplication mgr (accessToken tokenResp) -- @ ----- Also you could find example from @hoauth2-providers-tutorials@ module.----module Network.OAuth2.Experiment-  ( module Network.OAuth2.Experiment.Types,-    module Network.OAuth2.Experiment.Pkce-  )-where+-- You can also find an example in the @hoauth2-providers-tutorial@ module.+module Network.OAuth2.Experiment (+  -- * Application per Grant type+  module Network.OAuth2.Experiment.Grants, -import Network.OAuth2.Experiment.Pkce-import Network.OAuth2.Experiment.Types+  -- * Authorization Code+  mkAuthorizationRequest,+  mkPkceAuthorizeRequest,++  -- * Device Authorization+  module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest,+  conduitDeviceAuthorizationRequest,+  pollDeviceTokenRequest,++  -- * Token Request+  module Network.OAuth2.Experiment.Flows.TokenRequest,+  conduitPkceTokenRequest,+  conduitTokenRequest,++  -- * Refresh Token Request+  module Network.OAuth2.Experiment.Flows.RefreshTokenRequest,+  conduitRefreshTokenRequest,++  -- * UserInfo Request+  module Network.OAuth2.Experiment.Flows.UserInfoRequest,+  conduitUserInfoRequest,+  conduitUserInfoRequestWithCustomMethod,++  -- * Types+  module Network.OAuth2.Experiment.Types,+  module Network.OAuth2.Experiment.Pkce,+  module Network.OAuth2,++  -- * Utils+  module Network.OAuth2.Experiment.Utils,+) where++import Network.OAuth2 (ClientAuthenticationMethod (..))+import Network.OAuth2.Experiment.Flows+import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest (+  DeviceAuthorizationResponse (..),+ )+import Network.OAuth2.Experiment.Flows.RefreshTokenRequest (+  HasRefreshTokenRequest,+ )+import Network.OAuth2.Experiment.Flows.TokenRequest (+  ExchangeTokenInfo,+  HasTokenRequest,+  NoNeedExchangeToken (..),+  TokenRequest,+ )+import Network.OAuth2.Experiment.Flows.UserInfoRequest (+  HasUserInfoRequest,+ )+import Network.OAuth2.Experiment.Grants+import Network.OAuth2.Experiment.Pkce (+  CodeVerifier (..),+ )+import Network.OAuth2.Experiment.Types (+  AuthorizeState (..),+  ClientId (..),+  ClientSecret (..),+  Idp (..),+  IdpApplication (..),+  Password (..),+  RedirectUri (..),+  Scope (..),+  Username (..),+ )+import Network.OAuth2.Experiment.Utils (uriToText)
+ src/Network/OAuth2/Experiment/Flows.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE FlexibleContexts #-}++-- | Module implementing various OAuth2 flow types and their request/response handling.+-- Provides support for:+--+--   * Authorization Code Grant+--   * Device Authorization Grant+--   * PKCE Extension+--   * Token Refresh+--   * User Info Endpoints+module Network.OAuth2.Experiment.Flows where++import Control.Concurrent+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Except+import Data.Aeson (FromJSON)+import Data.Bifunctor+import Data.ByteString.Lazy.Char8 qualified as BSL+import Data.Map.Strict qualified as Map+import Data.Maybe+import Network.HTTP.Client.Contrib+import Network.HTTP.Conduit+import Network.OAuth2+import Network.OAuth2 qualified as OAuth2+import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest+import Network.OAuth2.Experiment.Flows.RefreshTokenRequest+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Flows.UserInfoRequest+import Network.OAuth2.Experiment.Grants.AuthorizationCode+import Network.OAuth2.Experiment.Grants.DeviceAuthorization+import Network.OAuth2.Experiment.Pkce+import Network.OAuth2.Experiment.Types+import Network.OAuth2.Experiment.Utils+import URI.ByteString hiding (UserInfo)++-------------------------------------------------------------------------------+--                           Authorization Requests                          --+-------------------------------------------------------------------------------++-- | Constructs an Authorization Code request URI according to+-- <https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1 RFC 6749 Section 4.1.1>.+--+-- The generated URI includes:+--   * client_id+--   * response_type (always "code")+--   * redirect_uri+--   * state (if provided)+--   * scope (if provided)+mkAuthorizationRequest :: IdpApplication i AuthorizationCodeApplication -> URI+mkAuthorizationRequest idpApp =+  let req = mkAuthorizationRequestParam (application idpApp)+      allParams =+        map (bimap tlToBS tlToBS) $+          Map.toList $+            toQueryParam req+   in appendQueryParams allParams $+        idpAuthorizeEndpoint (idp idpApp)++-- | Constructs an Authorization Code request URI with PKCE support according to+-- <https://datatracker.ietf.org/doc/html/rfc7636 RFC 7636>.+--+-- Returns both the authorization URI and the generated code verifier.+-- The code verifier must be stored securely for later use in the token request.+mkPkceAuthorizeRequest ::+  MonadIO m =>+  IdpApplication i AuthorizationCodeApplication ->+  m (URI, CodeVerifier)+mkPkceAuthorizeRequest IdpApplication {..} = do+  (req, codeVerifier) <- mkPkceAuthorizeRequestParam application+  let allParams = map (bimap tlToBS tlToBS) $ Map.toList $ toQueryParam req+  let url =+        appendQueryParams allParams $+          idpAuthorizeEndpoint idp+  pure (url, codeVerifier)++-------------------------------------------------------------------------------+--                                Device Auth                                --+-------------------------------------------------------------------------------++-- | Makes Device Authorization Request+-- https://www.rfc-editor.org/rfc/rfc8628#section-3.1+conduitDeviceAuthorizationRequest ::+  MonadIO m =>+  IdpApplication i DeviceAuthorizationApplication ->+  Manager ->+  ExceptT BSL.ByteString m DeviceAuthorizationResponse+conduitDeviceAuthorizationRequest IdpApplication {..} mgr = do+  case idpDeviceAuthorizationEndpoint idp of+    Nothing -> throwE "[conduitDeviceAuthorizationRequest] Device Authorization Flow is not supported: missing device_authorization_endpoint."+    Just deviceAuthEndpoint -> do+      let deviceAuthReq = mkDeviceAuthorizationRequestParam application+          body = unionMapsToQueryParams [toQueryParam deviceAuthReq]+      ExceptT . liftIO $ do+        req <- addDefaultRequestHeaders <$> uriToRequest deviceAuthEndpoint+        let req' =+              if daAuthorizationRequestAuthenticationMethod application == ClientSecretBasic+                then addSecretToHeader (daClientId application) (daClientSecret application) req+                else req+        resp <- httpLbs (urlEncodedBody body req') mgr+        pure $ first ("[conduitDeviceAuthorizationRequest] " <>) $ handleResponseJSON resp++-- | Polls for a token using the device authorization flow.+--+-- This implements the polling mechanism described in+-- <https://www.rfc-editor.org/rfc/rfc8628#section-3.5 RFC 8628 Section 3.5>.+-- Handles automatic retries and interval adjustments based on IdP responses.+pollDeviceTokenRequest ::+  MonadIO m =>+  IdpApplication i DeviceAuthorizationApplication ->+  Manager ->+  DeviceAuthorizationResponse ->+  ExceptT TokenResponseError m TokenResponse+pollDeviceTokenRequest idpApp mgr deviceAuthResp = do+  pollDeviceTokenRequestInternal+    idpApp+    mgr+    (deviceCode deviceAuthResp)+    (fromMaybe 5 $ interval deviceAuthResp)++pollDeviceTokenRequestInternal ::+  MonadIO m =>+  IdpApplication i DeviceAuthorizationApplication ->+  Manager ->+  DeviceCode ->+  Int ->+  -- | Polling Interval+  ExceptT TokenResponseError m TokenResponse+pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds = do+  resp <- runExceptT (conduitTokenRequest idpApp mgr deviceCode)+  case resp of+    Left trRespError -> do+      case tokenResponseError trRespError of+        -- TODO: Didn't have a good idea to expand the error code+        -- specifically for device token request flow+        -- Device Token Response additional error code: https://www.rfc-editor.org/rfc/rfc8628#section-3.5+        UnknownErrorCode "authorization_pending" -> do+          liftIO $ threadDelay $ intervalSeconds * 1000000+          pollDeviceTokenRequestInternal idpApp mgr deviceCode intervalSeconds+        UnknownErrorCode "slow_down" -> do+          let newIntervalSeconds = intervalSeconds + 5+          liftIO $ threadDelay $ newIntervalSeconds * 1000000+          pollDeviceTokenRequestInternal idpApp mgr deviceCode newIntervalSeconds+        _ -> throwE trRespError+    Right v -> pure v++-------------------------------------------------------------------------------+--                               Token Request                               --+-------------------------------------------------------------------------------++-- | Sends a token request according to+-- <https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3 RFC 6749 Section 4.1.3>.+--+-- This is used for exchanging authorization codes, device codes, or other+-- grant types for access tokens.+conduitTokenRequest ::+  (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>+  IdpApplication i a ->+  Manager ->+  ExchangeTokenInfo a ->+  ExceptT TokenResponseError m TokenResponse+conduitTokenRequest idpApp mgr exchangeToken = do+  let req = mkTokenRequestParam (application idpApp) exchangeToken+      body =+        unionMapsToQueryParams+          [ toQueryParam req+          ]+   in conduitTokenRequestInternal idpApp mgr body++-------------------------------------------------------------------------------+--                             PKCE Token Request                            --+-------------------------------------------------------------------------------++-- | https://datatracker.ietf.org/doc/html/rfc7636#section-4.5+conduitPkceTokenRequest ::+  (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>+  IdpApplication i a ->+  Manager ->+  (ExchangeTokenInfo a, CodeVerifier) ->+  ExceptT TokenResponseError m TokenResponse+conduitPkceTokenRequest idpApp mgr (exchangeToken, codeVerifier) =+  let req = mkTokenRequestParam (application idpApp) exchangeToken+      body =+        unionMapsToQueryParams+          [ toQueryParam req+          , toQueryParam codeVerifier+          ]+   in conduitTokenRequestInternal idpApp mgr body++-------------------------------------------------------------------------------+--                              Refresh Token                               --+-------------------------------------------------------------------------------++-- | Makes a Refresh Token Request according to+-- <https://www.rfc-editor.org/rfc/rfc6749#section-6 RFC 6749 Section 6>.+--+-- Used to obtain a new access token using a refresh token.+conduitRefreshTokenRequest ::+  (MonadIO m, HasRefreshTokenRequest a) =>+  IdpApplication i a ->+  Manager ->+  OAuth2.RefreshToken ->+  ExceptT TokenResponseError m TokenResponse+conduitRefreshTokenRequest ia mgr rt =+  let tokenReq = mkRefreshTokenRequestParam (application ia) rt+      body = unionMapsToQueryParams [toQueryParam tokenReq]+   in conduitTokenRequestInternal ia mgr body++-------------------------------------------------------------------------------+--                                 User Info                                 --+-------------------------------------------------------------------------------++-- | Makes a standard request to the userinfo endpoint using GET method.+--+-- This is commonly used with OpenID Connect providers to fetch+-- user profile information using an access token.+conduitUserInfoRequest ::+  (MonadIO m, HasUserInfoRequest a, FromJSON b) =>+  IdpApplication i a ->+  Manager ->+  AccessToken ->+  ExceptT BSL.ByteString m b+conduitUserInfoRequest = conduitUserInfoRequestWithCustomMethod authGetJSON++-- | Makes a request to the userinfo endpoint using a custom HTTP method.+--+-- Some IdPs may require different HTTP methods (instead of GET) or custom headers+-- for fetching user information. This function provides that flexibility.+conduitUserInfoRequestWithCustomMethod ::+  (MonadIO m, HasUserInfoRequest a, FromJSON b) =>+  ( Manager ->+    AccessToken ->+    URI ->+    ExceptT BSL.ByteString m b+  ) ->+  IdpApplication i a ->+  Manager ->+  AccessToken ->+  ExceptT BSL.ByteString m b+conduitUserInfoRequestWithCustomMethod fetchMethod IdpApplication {..} mgr at =+  fetchMethod mgr at (idpUserInfoEndpoint idp)++-------------------------------------------------------------------------------+--                              Internal helpers                             --+-------------------------------------------------------------------------------++conduitTokenRequestInternal ::+  ( MonadIO m+  , HasClientAuthenticationMethod a+  , FromJSON b+  ) =>+  IdpApplication i a ->+  -- | HTTP connection manager.+  Manager ->+  -- | Request body.+  PostBody ->+  -- | Response as ByteString+  ExceptT TokenResponseError m b+conduitTokenRequestInternal IdpApplication {..} manager body = do+  let clientAuthMethod = getClientAuthenticationMethod application+      url = idpTokenEndpoint idp+      updateAuthHeader =+        case clientAuthMethod of+          ClientSecretBasic -> addClientAuthToHeader application+          ClientSecretPost -> id+          ClientAssertionJwt -> id+      go = do+        req <- uriToRequest url+        let req' = (updateAuthHeader . addDefaultRequestHeaders) req+        httpLbs (urlEncodedBody body req') manager+  resp <- ExceptT . liftIO $ fmap handleOAuth2TokenResponse go+  case parseResponseFlexible resp of+    Right obj -> return obj+    Left e -> throwE e
+ src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs view
@@ -0,0 +1,33 @@+module Network.OAuth2.Experiment.Flows.AuthorizationRequest where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth2.Experiment.Types++-------------------------------------------------------------------------------+--                           Authorization Request                           --+-------------------------------------------------------------------------------++data AuthorizationRequestParam = AuthorizationRequestParam+  { arScope :: Set Scope+  , arState :: AuthorizeState+  , arClientId :: ClientId+  , arRedirectUri :: Maybe RedirectUri+  , arResponseType :: ResponseType+  -- ^ It could be optional there is only one redirect_uri registered.+  -- See: https://www.rfc-editor.org/rfc/rfc6749#section-3.1.2.3+  , arExtraParams :: Map Text Text+  }++instance ToQueryParam AuthorizationRequestParam where+  toQueryParam AuthorizationRequestParam {..} =+    Map.unions+      [ toQueryParam arResponseType+      , toQueryParam arScope+      , toQueryParam arClientId+      , toQueryParam arState+      , toQueryParam arRedirectUri+      , arExtraParams+      ]
+ src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DerivingStrategies #-}++module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest where++import Control.Applicative+import Data.Aeson.Types+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth2.Experiment.Types+import URI.ByteString hiding (UserInfo)++-------------------------------------------------------------------------------+--                    Device Authorization Request                           --+-------------------------------------------------------------------------------+newtype DeviceCode = DeviceCode Text+  deriving newtype (FromJSON)++instance ToQueryParam DeviceCode where+  toQueryParam :: DeviceCode -> Map Text Text+  toQueryParam (DeviceCode dc) = Map.singleton "device_code" dc++-- | https://www.rfc-editor.org/rfc/rfc8628#section-3.2+data DeviceAuthorizationResponse = DeviceAuthorizationResponse+  { deviceCode :: DeviceCode+  , userCode :: Text+  , verificationUri :: URI+  , verificationUriComplete :: Maybe URI+  , expiresIn :: Integer+  , interval :: Maybe Int+  }++instance FromJSON DeviceAuthorizationResponse where+  parseJSON :: Value -> Parser DeviceAuthorizationResponse+  parseJSON = withObject "parse DeviceAuthorizationResponse" $ \t -> do+    deviceCode <- t .: "device_code"+    userCode <- t .: "user_code"+    -- https://stackoverflow.com/questions/76696956/shall-it-be-verification-uri-instead-of-verification-url-in-the-device-autho+    verificationUri <- t .: "verification_uri" <|> t .: "verification_url"+    verificationUriComplete <- t .:? "verification_uri_complete"+    expiresIn <- t .: "expires_in"+    interval <- t .:? "interval"+    pure DeviceAuthorizationResponse {..}++data DeviceAuthorizationRequestParam = DeviceAuthorizationRequestParam+  { darScope :: Set Scope+  , darClientId :: Maybe ClientId+  , darExtraParams :: Map Text Text+  }++instance ToQueryParam DeviceAuthorizationRequestParam where+  toQueryParam :: DeviceAuthorizationRequestParam -> Map Text Text+  toQueryParam DeviceAuthorizationRequestParam {..} =+    Map.unions+      [ toQueryParam darScope+      , toQueryParam darClientId+      , darExtraParams+      ]
+ src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.OAuth2.Experiment.Flows.RefreshTokenRequest where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth2 qualified as OAuth2+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Types++-------------------------------------------------------------------------------+--                            RefreshToken Requset                           --+-------------------------------------------------------------------------------++data RefreshTokenRequest = RefreshTokenRequest+  { rrRefreshToken :: OAuth2.RefreshToken+  , rrGrantType :: GrantTypeValue+  , rrScope :: Set Scope+  , rrClientId :: Maybe ClientId+  , rrClientSecret :: Maybe ClientSecret+  }++instance ToQueryParam RefreshTokenRequest where+  toQueryParam :: RefreshTokenRequest -> Map Text Text+  toQueryParam RefreshTokenRequest {..} =+    Map.unions+      [ toQueryParam rrGrantType+      , toQueryParam rrScope+      , toQueryParam rrRefreshToken+      , toQueryParam rrClientId+      , toQueryParam rrClientSecret+      ]++class HasClientAuthenticationMethod a => HasRefreshTokenRequest a where+  -- | Make Refresh Token Request parameters+  -- | https://www.rfc-editor.org/rfc/rfc6749#section-6+  mkRefreshTokenRequestParam :: a -> OAuth2.RefreshToken -> RefreshTokenRequest
+ src/Network/OAuth2/Experiment/Flows/TokenRequest.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.OAuth2.Experiment.Flows.TokenRequest where++import Data.Text.Encoding qualified as T+import Data.Text.Lazy qualified as TL+import Network.HTTP.Conduit+import Network.OAuth2 (+  ClientAuthenticationMethod (..),+ )+import Network.OAuth2.Experiment.Types (+  ClientId (unClientId),+  ClientSecret (unClientSecret),+ )++addSecretToHeader :: ClientId -> ClientSecret -> Request -> Request+addSecretToHeader cid csecret =+  applyBasicAuth+    (T.encodeUtf8 $ TL.toStrict $ unClientId cid)+    (T.encodeUtf8 $ TL.toStrict $ unClientSecret csecret)++class HasClientAuthenticationMethod a where+  getClientAuthenticationMethod :: a -> ClientAuthenticationMethod+  addClientAuthToHeader :: a -> Request -> Request+  addClientAuthToHeader _ = id++-- | Only Authorization Code Grant involves a Exchange Token (Authorization Code).+-- ResourceOwnerPassword and Client Credentials make token request directly.+data NoNeedExchangeToken = NoNeedExchangeToken++class HasClientAuthenticationMethod a => HasTokenRequest a where+  -- Each GrantTypeFlow has slightly different request parameter to /token endpoint.+  data TokenRequest a+  type ExchangeTokenInfo a++  -- | Only 'AuthorizationCode flow (but not resource owner password nor client credentials) will use 'ExchangeToken' in the token request+  -- create type family to be explicit on it.+  -- with 'type instance WithExchangeToken a b = b' implies no exchange token+  -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token+  -- type WithExchangeToken a b+  mkTokenRequestParam :: a -> ExchangeTokenInfo a -> TokenRequest a
+ src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs view
@@ -0,0 +1,7 @@+module Network.OAuth2.Experiment.Flows.UserInfoRequest where++-------------------------------------------------------------------------------+--                             User Info Request                             --+-------------------------------------------------------------------------------++class HasUserInfoRequest a
+ src/Network/OAuth2/Experiment/Grants.hs view
@@ -0,0 +1,15 @@+module Network.OAuth2.Experiment.Grants (+  module Network.OAuth2.Experiment.Grants.AuthorizationCode,+  module Network.OAuth2.Experiment.Grants.DeviceAuthorization,+  module Network.OAuth2.Experiment.Grants.ClientCredentials,+  module Network.OAuth2.Experiment.Grants.ResourceOwnerPassword,+  module Network.OAuth2.Experiment.Grants.JwtBearer,+) where++import Network.OAuth2.Experiment.Grants.AuthorizationCode (AuthorizationCodeApplication (..))+import Network.OAuth2.Experiment.Grants.ClientCredentials (ClientCredentialsApplication (..))+import Network.OAuth2.Experiment.Grants.DeviceAuthorization (+  DeviceAuthorizationApplication (..),+ )+import Network.OAuth2.Experiment.Grants.JwtBearer (JwtBearerApplication (..))+import Network.OAuth2.Experiment.Grants.ResourceOwnerPassword (ResourceOwnerPasswordApplication (..))
+ src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.OAuth2.Experiment.Grants.AuthorizationCode where++import Control.Monad.IO.Class (MonadIO (..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth2 (ClientAuthenticationMethod (..), ExchangeToken (..))+import Network.OAuth2 qualified as OAuth2+import Network.OAuth2.Experiment.Flows.AuthorizationRequest+import Network.OAuth2.Experiment.Flows.RefreshTokenRequest+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Flows.UserInfoRequest+import Network.OAuth2.Experiment.Pkce+import Network.OAuth2.Experiment.Types+import Network.OAuth2.Experiment.Utils+import URI.ByteString hiding (UserInfo)++-- | An Application that supports "Authorization code" flow+--+-- https://www.rfc-editor.org/rfc/rfc6749#section-4.1+data AuthorizationCodeApplication = AuthorizationCodeApplication+  { acName :: Text+  , acClientId :: ClientId+  , acClientSecret :: ClientSecret+  , acScope :: Set Scope+  , acRedirectUri :: URI+  , acAuthorizeState :: AuthorizeState+  , acAuthorizeRequestExtraParams :: Map Text Text+  , acClientAuthenticationMethod :: ClientAuthenticationMethod+  }++instance HasClientAuthenticationMethod AuthorizationCodeApplication where+  getClientAuthenticationMethod :: AuthorizationCodeApplication -> ClientAuthenticationMethod+  getClientAuthenticationMethod AuthorizationCodeApplication {..} = acClientAuthenticationMethod+  addClientAuthToHeader AuthorizationCodeApplication {..} = addSecretToHeader acClientId acClientSecret++mkAuthorizationRequestParam :: AuthorizationCodeApplication -> AuthorizationRequestParam+mkAuthorizationRequestParam AuthorizationCodeApplication {..} =+  AuthorizationRequestParam+    { arScope = acScope+    , arState = acAuthorizeState+    , arClientId = acClientId+    , arRedirectUri = Just (RedirectUri acRedirectUri)+    , arResponseType = Code+    , arExtraParams = acAuthorizeRequestExtraParams+    }++mkPkceAuthorizeRequestParam :: MonadIO m => AuthorizationCodeApplication -> m (AuthorizationRequestParam, CodeVerifier)+mkPkceAuthorizeRequestParam app = do+  PkceRequestParam {..} <- mkPkceParam+  let authReqParam = mkAuthorizationRequestParam app+      combinatedExtraParams =+        Map.unions+          [ arExtraParams authReqParam+          , toQueryParam codeChallenge+          , toQueryParam codeChallengeMethod+          ]+  pure (authReqParam {arExtraParams = combinatedExtraParams}, codeVerifier)++-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3+instance HasTokenRequest AuthorizationCodeApplication where+  type ExchangeTokenInfo AuthorizationCodeApplication = ExchangeToken+  data TokenRequest AuthorizationCodeApplication = AuthorizationCodeTokenRequest+    { trCode :: ExchangeToken+    , trGrantType :: GrantTypeValue+    , trRedirectUri :: RedirectUri+    , trClientId :: ClientId+    , trClientSecret :: ClientSecret+    , trClientAuthenticationMethod :: ClientAuthenticationMethod+    }++  mkTokenRequestParam :: AuthorizationCodeApplication -> ExchangeToken -> TokenRequest AuthorizationCodeApplication+  mkTokenRequestParam AuthorizationCodeApplication {..} authCode =+    AuthorizationCodeTokenRequest+      { trCode = authCode+      , trGrantType = GTAuthorizationCode+      , trRedirectUri = RedirectUri acRedirectUri+      , trClientId = acClientId+      , trClientSecret = acClientSecret+      , trClientAuthenticationMethod = acClientAuthenticationMethod+      }++instance ToQueryParam (TokenRequest AuthorizationCodeApplication) where+  toQueryParam :: TokenRequest AuthorizationCodeApplication -> Map Text Text+  toQueryParam AuthorizationCodeTokenRequest {..} =+    let extraBodyBasedOnClientAuthMethod =+          case trClientAuthenticationMethod of+            ClientAssertionJwt ->+              [ Map.fromList+                  [ ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer")+                  , ("client_assertion", bs8ToLazyText $ tlToBS $ unClientSecret trClientSecret)+                  ]+              ]+            ClientSecretPost -> [toQueryParam trClientId, toQueryParam trClientSecret]+            ClientSecretBasic -> []+     in Map.unions $+          [ toQueryParam trCode+          , toQueryParam trGrantType+          , toQueryParam trRedirectUri+          ]+            ++ extraBodyBasedOnClientAuthMethod++instance HasUserInfoRequest AuthorizationCodeApplication++instance HasRefreshTokenRequest AuthorizationCodeApplication where+  mkRefreshTokenRequestParam :: AuthorizationCodeApplication -> OAuth2.RefreshToken -> RefreshTokenRequest+  mkRefreshTokenRequestParam AuthorizationCodeApplication {..} rt =+    RefreshTokenRequest+      { rrScope = acScope+      , rrGrantType = GTRefreshToken+      , rrRefreshToken = rt+      , rrClientId = if acClientAuthenticationMethod == ClientSecretPost then Just acClientId else Nothing+      , rrClientSecret = if acClientAuthenticationMethod == ClientSecretPost then Just acClientSecret else Nothing+      }
+ src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.OAuth2.Experiment.Grants.ClientCredentials where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth2 (ClientAuthenticationMethod (..))+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Types+import Network.OAuth2.Experiment.Utils++-- | An Application that supports "Client Credentials" flow+--+-- https://www.rfc-editor.org/rfc/rfc6749#section-4.4+data ClientCredentialsApplication = ClientCredentialsApplication+  { ccClientId :: ClientId+  , ccClientSecret :: ClientSecret+  , ccName :: Text+  , ccScope :: Set Scope+  , ccTokenRequestExtraParams :: Map Text Text+  , ccClientAuthenticationMethod :: ClientAuthenticationMethod+  }++instance HasClientAuthenticationMethod ClientCredentialsApplication where+  getClientAuthenticationMethod :: ClientCredentialsApplication -> ClientAuthenticationMethod+  getClientAuthenticationMethod ClientCredentialsApplication {..} = ccClientAuthenticationMethod++  addClientAuthToHeader ClientCredentialsApplication {..} = addSecretToHeader ccClientId ccClientSecret++-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2+instance HasTokenRequest ClientCredentialsApplication where+  type ExchangeTokenInfo ClientCredentialsApplication = NoNeedExchangeToken+  data TokenRequest ClientCredentialsApplication = ClientCredentialsTokenRequest+    { trScope :: Set Scope+    , trGrantType :: GrantTypeValue+    , trClientSecret :: ClientSecret+    , trClientId :: ClientId+    , trExtraParams :: Map Text Text+    , trClientAuthenticationMethod :: ClientAuthenticationMethod+    }++  mkTokenRequestParam :: ClientCredentialsApplication -> NoNeedExchangeToken -> TokenRequest ClientCredentialsApplication+  mkTokenRequestParam ClientCredentialsApplication {..} _ =+    ClientCredentialsTokenRequest+      { trScope = ccScope+      , trGrantType = GTClientCredentials+      , trClientSecret = ccClientSecret+      , trClientAuthenticationMethod = ccClientAuthenticationMethod+      , trExtraParams = ccTokenRequestExtraParams+      , trClientId = ccClientId+      }++instance ToQueryParam (TokenRequest ClientCredentialsApplication) where+  toQueryParam :: TokenRequest ClientCredentialsApplication -> Map Text Text+  toQueryParam ClientCredentialsTokenRequest {..} =+    let extraBodyBasedOnClientAuthMethod =+          case trClientAuthenticationMethod of+            ClientAssertionJwt ->+              [ Map.fromList+                  [ ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer")+                  , ("client_assertion", bs8ToLazyText $ tlToBS $ unClientSecret trClientSecret)+                  ]+              ]+            ClientSecretPost -> [toQueryParam trClientId, toQueryParam trClientSecret]+            ClientSecretBasic -> []+     in Map.unions $+          [ toQueryParam trGrantType+          , toQueryParam trScope+          , trExtraParams+          ]+            ++ extraBodyBasedOnClientAuthMethod
+ src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.OAuth2.Experiment.Grants.DeviceAuthorization where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth2+import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Flows.UserInfoRequest+import Network.OAuth2.Experiment.Types+import Prelude hiding (error)++-- | An Application that supports "Device Authorization Grant"+--+-- https://www.rfc-editor.org/rfc/rfc8628#section-3.1+data DeviceAuthorizationApplication = DeviceAuthorizationApplication+  { daName :: Text+  , daClientId :: ClientId+  , daClientSecret :: ClientSecret+  , daScope :: Set Scope+  , daAuthorizationRequestExtraParam :: Map Text Text+  -- ^ Additional parameters to the device authorization request.+  -- Most of identity providers follow the spec strictly but+  -- AzureAD requires "tenant" parameter.+  , daAuthorizationRequestAuthenticationMethod :: ClientAuthenticationMethod+  -- ^ The spec requires similar authentication method as /token request.+  -- Most of identity providers doesn't required it but some does like Okta.+  }++instance HasClientAuthenticationMethod DeviceAuthorizationApplication where+  getClientAuthenticationMethod :: DeviceAuthorizationApplication -> ClientAuthenticationMethod+  getClientAuthenticationMethod = daAuthorizationRequestAuthenticationMethod+  addClientAuthToHeader DeviceAuthorizationApplication {..} = addSecretToHeader daClientId daClientSecret++mkDeviceAuthorizationRequestParam :: DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam+mkDeviceAuthorizationRequestParam DeviceAuthorizationApplication {..} =+  DeviceAuthorizationRequestParam+    { darScope = daScope+    , darClientId =+        if daAuthorizationRequestAuthenticationMethod == ClientSecretPost+          then Just daClientId+          else Nothing+    , darExtraParams = daAuthorizationRequestExtraParam+    }++-- | https://www.rfc-editor.org/rfc/rfc8628#section-3.4+instance HasTokenRequest DeviceAuthorizationApplication where+  type ExchangeTokenInfo DeviceAuthorizationApplication = DeviceCode+  data TokenRequest DeviceAuthorizationApplication = AuthorizationCodeTokenRequest+    { trCode :: DeviceCode+    , trGrantType :: GrantTypeValue+    , trClientId :: Maybe ClientId+    }++  mkTokenRequestParam ::+    DeviceAuthorizationApplication ->+    DeviceCode ->+    TokenRequest DeviceAuthorizationApplication+  mkTokenRequestParam DeviceAuthorizationApplication {..} deviceCode =+    --+    -- This is a bit hacky!+    -- The token request use `ClientSecretBasic` by default. (has to pick up one Client Authn Method)+    -- ClientId shall be also be in request body per spec.+    -- However, for some IdPs, e.g. Okta, when using `ClientSecretBasic` to authn Client,+    -- it doesn't allow @client_id@ in the request body+    -- 'daAuthorizationRequestAuthenticationMethod' set the tone for Authorization Request,+    -- hence just follow it in the token request+    AuthorizationCodeTokenRequest+      { trCode = deviceCode+      , trGrantType = GTDeviceCode+      , trClientId =+          if daAuthorizationRequestAuthenticationMethod == ClientSecretPost+            then Just daClientId+            else Nothing+      }++instance ToQueryParam (TokenRequest DeviceAuthorizationApplication) where+  toQueryParam :: TokenRequest DeviceAuthorizationApplication -> Map Text Text+  toQueryParam AuthorizationCodeTokenRequest {..} =+    Map.unions+      [ toQueryParam trCode+      , toQueryParam trGrantType+      , toQueryParam trClientId+      ]++instance HasUserInfoRequest DeviceAuthorizationApplication
+ src/Network/OAuth2/Experiment/Grants/JwtBearer.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.OAuth2.Experiment.Grants.JwtBearer where++import Data.ByteString qualified as BS+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text.Lazy (Text)+import Network.OAuth2 (ClientAuthenticationMethod (..))+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Flows.UserInfoRequest+import Network.OAuth2.Experiment.Types+import Network.OAuth2.Experiment.Utils++-- | An Application that supports "JWT Bearer" flow+--+-- https://datatracker.ietf.org/doc/html/rfc7523+data JwtBearerApplication = JwtBearerApplication+  { jbName :: Text+  , jbJwtAssertion :: BS.ByteString+  }++instance HasClientAuthenticationMethod JwtBearerApplication where+  getClientAuthenticationMethod :: JwtBearerApplication -> ClientAuthenticationMethod+  getClientAuthenticationMethod _ = ClientAssertionJwt++instance HasTokenRequest JwtBearerApplication where+  type ExchangeTokenInfo JwtBearerApplication = NoNeedExchangeToken++  data TokenRequest JwtBearerApplication = JwtBearerTokenRequest+    { trGrantType :: GrantTypeValue -- \| 'GTJwtBearer'+    , trAssertion :: BS.ByteString -- \| The the signed JWT token+    }++  mkTokenRequestParam :: JwtBearerApplication -> NoNeedExchangeToken -> TokenRequest JwtBearerApplication+  mkTokenRequestParam JwtBearerApplication {..} _ =+    JwtBearerTokenRequest+      { trGrantType = GTJwtBearer+      , trAssertion = jbJwtAssertion+      }++instance ToQueryParam (TokenRequest JwtBearerApplication) where+  toQueryParam :: TokenRequest JwtBearerApplication -> Map Text Text+  toQueryParam JwtBearerTokenRequest {..} =+    Map.unions+      [ toQueryParam trGrantType+      , Map.singleton "assertion" (bs8ToLazyText trAssertion)+      ]++instance HasUserInfoRequest JwtBearerApplication
+ src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances #-}++module Network.OAuth2.Experiment.Grants.ResourceOwnerPassword where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Text.Lazy (Text)+import Network.OAuth2 (ClientAuthenticationMethod (..))+import Network.OAuth2 qualified as OAuth2+import Network.OAuth2.Experiment.Flows.RefreshTokenRequest+import Network.OAuth2.Experiment.Flows.TokenRequest+import Network.OAuth2.Experiment.Flows.UserInfoRequest+import Network.OAuth2.Experiment.Types++-- | An Application that supports "Resource Owner Password" flow+--+-- https://www.rfc-editor.org/rfc/rfc6749#section-4.3+data ResourceOwnerPasswordApplication = ResourceOwnerPasswordApplication+  { ropClientId :: ClientId+  , ropClientSecret :: ClientSecret+  , ropName :: Text+  , ropScope :: Set Scope+  , ropUserName :: Username+  , ropPassword :: Password+  , ropTokenRequestExtraParams :: Map Text Text+  , ropClientAuthenticationMethod :: ClientAuthenticationMethod+  }++instance HasClientAuthenticationMethod ResourceOwnerPasswordApplication where+  getClientAuthenticationMethod :: ResourceOwnerPasswordApplication -> ClientAuthenticationMethod+  getClientAuthenticationMethod = ropClientAuthenticationMethod+  addClientAuthToHeader ResourceOwnerPasswordApplication {..} = addSecretToHeader ropClientId ropClientSecret++-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2+instance HasTokenRequest ResourceOwnerPasswordApplication where+  type ExchangeTokenInfo ResourceOwnerPasswordApplication = NoNeedExchangeToken++  data TokenRequest ResourceOwnerPasswordApplication = PasswordTokenRequest+    { trScope :: Set Scope+    , trUsername :: Username+    , trPassword :: Password+    , trGrantType :: GrantTypeValue+    , trExtraParams :: Map Text Text+    }+  mkTokenRequestParam :: ResourceOwnerPasswordApplication -> NoNeedExchangeToken -> TokenRequest ResourceOwnerPasswordApplication+  mkTokenRequestParam ResourceOwnerPasswordApplication {..} _ =+    PasswordTokenRequest+      { trUsername = ropUserName+      , trPassword = ropPassword+      , trGrantType = GTPassword+      , trScope = ropScope+      , trExtraParams = ropTokenRequestExtraParams+      }++instance ToQueryParam (TokenRequest ResourceOwnerPasswordApplication) where+  toQueryParam :: TokenRequest ResourceOwnerPasswordApplication -> Map Text Text+  toQueryParam PasswordTokenRequest {..} =+    Map.unions+      [ toQueryParam trGrantType+      , toQueryParam trScope+      , toQueryParam trUsername+      , toQueryParam trPassword+      , trExtraParams+      ]++instance HasUserInfoRequest ResourceOwnerPasswordApplication++instance HasRefreshTokenRequest ResourceOwnerPasswordApplication where+  mkRefreshTokenRequestParam :: ResourceOwnerPasswordApplication -> OAuth2.RefreshToken -> RefreshTokenRequest+  mkRefreshTokenRequestParam ResourceOwnerPasswordApplication {..} rt =+    RefreshTokenRequest+      { rrScope = ropScope+      , rrGrantType = GTRefreshToken+      , rrRefreshToken = rt+      , rrClientId = if ropClientAuthenticationMethod == ClientSecretPost then Just ropClientId else Nothing+      , rrClientSecret = if ropClientAuthenticationMethod == ClientSecretPost then Just ropClientSecret else Nothing+      }
src/Network/OAuth2/Experiment/Pkce.hs view
@@ -1,15 +1,15 @@-module Network.OAuth2.Experiment.Pkce-  ( mkPkceParam,-    CodeChallenge (..),-    CodeVerifier (..),-    CodeChallengeMethod (..),-    PkceRequestParam (..),-  )-where+module Network.OAuth2.Experiment.Pkce (+  mkPkceParam,+  CodeChallenge (..),+  CodeVerifier (..),+  CodeChallengeMethod (..),+  PkceRequestParam (..),+) where  import Control.Monad.IO.Class import Crypto.Hash qualified as H import Crypto.Random qualified as Crypto+import Data.Base64.Types qualified as B64 import Data.ByteArray qualified as ByteArray import Data.ByteString qualified as BS import Data.ByteString.Base64.URL qualified as B64@@ -19,17 +19,17 @@  newtype CodeChallenge = CodeChallenge {unCodeChallenge :: Text} -newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text} deriving (Show)+newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text}  data CodeChallengeMethod = S256   deriving (Show)  data PkceRequestParam = PkceRequestParam-  { codeVerifier :: CodeVerifier,-    codeChallenge :: CodeChallenge,-    -- | spec says optional but really it shall be s256 or can be omitted?-    -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3-    codeChallengeMethod :: CodeChallengeMethod+  { codeVerifier :: CodeVerifier+  , codeChallenge :: CodeChallenge+  , codeChallengeMethod :: CodeChallengeMethod+  -- ^ spec says optional but in practice it is S256+  -- https://datatracker.ietf.org/doc/html/rfc7636#section-4.3   }  mkPkceParam :: MonadIO m => m PkceRequestParam@@ -37,13 +37,13 @@   codeV <- genCodeVerifier   pure     PkceRequestParam-      { codeVerifier = CodeVerifier (T.decodeUtf8 codeV),-        codeChallenge = CodeChallenge (encodeCodeVerifier codeV),-        codeChallengeMethod = S256+      { codeVerifier = CodeVerifier (T.decodeUtf8 codeV)+      , codeChallenge = CodeChallenge (encodeCodeVerifier codeV)+      , codeChallengeMethod = S256       }  encodeCodeVerifier :: BS.ByteString -> Text-encodeCodeVerifier = B64.encodeBase64Unpadded . BS.pack . ByteArray.unpack . hashSHA256+encodeCodeVerifier = B64.extractBase64 . B64.encodeBase64Unpadded . BS.pack . ByteArray.unpack . hashSHA256  genCodeVerifier :: MonadIO m => m BS.ByteString genCodeVerifier = liftIO $ getBytesInternal BS.empty
src/Network/OAuth2/Experiment/Types.hs view
@@ -1,83 +1,58 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ImportQualifiedPost #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}  module Network.OAuth2.Experiment.Types where -import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Except (ExceptT)-import Data.Aeson (FromJSON)-import Data.Bifunctor-import Data.ByteString.Lazy.Char8 qualified as BSL-import Data.Default (Default (def))-import Data.Kind import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set import Data.String-import Data.Text.Encoding qualified as T import Data.Text.Lazy (Text) import Data.Text.Lazy qualified as TL-import Network.HTTP.Conduit (Manager)-import Network.OAuth.OAuth2 hiding (RefreshToken)-import Network.OAuth.OAuth2 qualified as OAuth2-import Network.OAuth.OAuth2.TokenRequest qualified as TR+import Network.OAuth2 hiding (RefreshToken)+import Network.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment.Pkce import Network.OAuth2.Experiment.Utils-import URI.ByteString hiding (UserInfo)--{- NOTE-  1. shall I lift the constrain of all 'a :: GrantTypeFlow' so that user has max customization/flexibility?--}------------------------------------------------------------------------------------- * Grant Type-----------------------------------------------------------------------------------data GrantTypeFlow = AuthorizationCode | ResourceOwnerPassword | ClientCredentials------------------------------------------------------------------------------------- * Response Type value+import URI.ByteString (URI, serializeURIRef')  ------------------------------------------------------------------------------- -class ToResponseTypeValue (a :: GrantTypeFlow) where-  toResponseTypeValue :: IsString b => b--instance ToResponseTypeValue 'AuthorizationCode where-  -- https://www.rfc-editor.org/rfc/rfc6749#section-3.1.1-  -- Only support "authorization code" flow-  toResponseTypeValue :: IsString b => b-  toResponseTypeValue = "code"--toResponseTypeParam :: forall a b req. (ToResponseTypeValue a, IsString b) => req a -> Map b b-toResponseTypeParam _ = Map.singleton "response_type" (toResponseTypeValue @a)+-- * Idp App  ------------------------------------------------------------------------------- --- * Grant Type value---------------------------------------------------------------------------------+-- | @Idp i@ consists various endpoints endpoints.+--+-- The @i@ is actually phantom type for information only (Idp name) at this moment.+-- And it is PolyKinds.+--+-- Hence whenever @Idp i@ or @IdpApplication i a@ is used as function parameter,+-- PolyKinds need to be enabled.+data Idp (i :: k) = Idp+  { idpUserInfoEndpoint :: URI+  -- ^ Userinfo Endpoint+  , idpAuthorizeEndpoint :: URI+  -- ^ Authorization Endpoint+  , idpTokenEndpoint :: URI+  -- ^ Token Endpoint+  , idpDeviceAuthorizationEndpoint :: Maybe URI+  -- ^ Apparently not all IdP support device code flow+  } --- | Grant type query parameter has association with 'GrantTypeFlow' but not completely strict.+-- | An OAuth2 Application "a" of IdP "i".+-- "a" can be one of following type: ----- e.g. Both 'AuthorizationCode' and 'ResourceOwnerPassword' flow could support refresh token flow.-data GrantTypeValue = GTAuthorizationCode | GTPassword | GTClientCredentials | GTRefreshToken-  deriving (Eq, Show)+-- * `Network.OAuth2.Experiment.AuthorizationCodeApplication`+-- * `Network.OAuth2.Experiment.DeviceAuthorizationApplication`+-- * `Network.OAuth2.Experiment.ClientCredentialsApplication`+-- * `Network.OAuth2.Experiment.ResourceOwnerPasswordApplication`+-- * `Network.OAuth2.Experiment.JwtBearerApplication`+data IdpApplication (i :: k) a = IdpApplication+  { idp :: Idp i+  , application :: a+  }  ------------------------------------------------------------------------------- @@ -85,7 +60,9 @@  ------------------------------------------------------------------------------- --- TODO: following data type is not ideal as Idp would have lots of 'Custom Text'+-- TODO: What's best type for Scope?+-- Use 'Text' isn't super type safe. All cannot specify some standard scopes like openid, email etc.+-- But Following data type is not ideal as Idp would have lots of 'Custom Text' -- -- @ -- data Scope = OPENID | PROFILE | EMAIL | OFFLINE_ACCESS | Custom Text@@ -93,7 +70,7 @@ -- -- Would be nice to define Enum for standard Scope, plus allow user to define their own define (per Idp) and plugin somehow. newtype Scope = Scope {unScope :: Text}-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show)  instance IsString Scope where   fromString :: String -> Scope@@ -101,24 +78,39 @@  ------------------------------------------------------------------------------- +-- * Grant Type value++-------------------------------------------------------------------------------++-- | Grant type query parameter has association with different GrantType flows but not completely strict.+--+-- e.g. Both AuthorizationCode and ResourceOwnerPassword flow could support refresh token flow.+data GrantTypeValue+  = GTAuthorizationCode+  | GTPassword+  | GTClientCredentials+  | GTRefreshToken+  | GTJwtBearer+  | GTDeviceCode+  deriving (Eq, Show)++-------------------------------------------------------------------------------+--                               Response Type                               --+-------------------------------------------------------------------------------+data ResponseType = Code++-------------------------------------------------------------------------------+ -- * Credentials  ------------------------------------------------------------------------------- newtype ClientId = ClientId {unClientId :: Text}   deriving (Show, Eq, IsString) +-- | Can be either "Client Secret" or JWT based on the client authentication method newtype ClientSecret = ClientSecret {unClientSecret :: Text}   deriving (Eq, IsString) --- | In order to reuse some methods from legacy "Network.OAuth.OAuth2".--- Will be removed when Experiment module becomes default.-toOAuth2Key :: ClientId -> ClientSecret -> OAuth2-toOAuth2Key cid csecret =-  def-    { oauth2ClientId = TL.toStrict $ unClientId cid,-      oauth2ClientSecret = TL.toStrict $ unClientSecret csecret-    }- newtype RedirectUri = RedirectUri {unRedirectUri :: URI}   deriving (Eq) @@ -165,6 +157,8 @@       val GTPassword = "password"       val GTClientCredentials = "client_credentials"       val GTRefreshToken = "refresh_token"+      val GTJwtBearer = "urn:ietf:params:oauth:grant-type:jwt-bearer"+      val GTDeviceCode = "urn:ietf:params:oauth:grant-type:device_code"  instance ToQueryParam ClientId where   toQueryParam :: ClientId -> Map Text Text@@ -193,8 +187,11 @@   toQueryParam :: Set Scope -> Map Text Text   toQueryParam = toScopeParam . Set.map unScope     where-      toScopeParam :: (IsString a) => Set Text -> Map a Text-      toScopeParam scope = Map.singleton "scope" (TL.intercalate " " $ Set.toList scope)+      toScopeParam :: IsString a => Set Text -> Map a Text+      toScopeParam scope =+        if Set.null scope+          then Map.empty+          else Map.singleton "scope" (TL.intercalate " " $ Set.toList scope)  instance ToQueryParam CodeVerifier where   toQueryParam :: CodeVerifier -> Map Text Text@@ -216,478 +213,6 @@   toQueryParam :: OAuth2.RefreshToken -> Map Text Text   toQueryParam (OAuth2.RefreshToken x) = Map.singleton "refresh_token" (TL.fromStrict x) ------------------------------------------------------------------------------------ * Authorization and Token Requests types-----------------------------------------------------------------------------------class HasIdpAppName (a :: GrantTypeFlow) where-  getIdpAppName :: IdpApplication a i -> Text--class HasAuthorizeRequest (a :: GrantTypeFlow) where-  data AuthorizationRequest a-  type MkAuthorizationRequestResponse a-  mkAuthorizeRequestParameter :: IdpApplication a i -> AuthorizationRequest a-  mkAuthorizeRequest :: IdpApplication a i -> MkAuthorizationRequestResponse a--class HasTokenRequest (a :: GrantTypeFlow) where-  -- | Each GrantTypeFlow has slightly different request parameter to /token endpoint.-  data TokenRequest a--  -- | Only 'AuthorizationCode flow (but not resource owner password nor client credentials) will use 'ExchangeToken' in the token request-  -- create type family to be explicit on it.-  -- with 'type instance WithExchangeToken a b = b' implies no exchange token-  -- v.s. 'type instance WithExchangeToken a b = ExchangeToken -> b' implies needing an exchange token-  type WithExchangeToken a b--  mkTokenRequest ::-    IdpApplication a i ->-    WithExchangeToken a (TokenRequest a)--  conduitTokenRequest ::-    (MonadIO m) =>-    IdpApplication a i ->-    Manager ->-    WithExchangeToken a (ExceptT (OAuth2Error TR.Errors) m OAuth2Token)--class HasPkceAuthorizeRequest (a :: GrantTypeFlow) where-  mkPkceAuthorizeRequest :: MonadIO m => IdpApplication a i -> m (TL.Text, CodeVerifier)--class HasPkceTokenRequest (b :: GrantTypeFlow) where-  conduitPkceTokenRequest ::-    (MonadIO m) =>-    IdpApplication b i ->-    Manager ->-    (ExchangeToken, CodeVerifier) ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token--class HasRefreshTokenRequest (a :: GrantTypeFlow) where-  -- | https://www.rfc-editor.org/rfc/rfc6749#page-47-  data RefreshTokenRequest a--  mkRefreshTokenRequest :: IdpApplication a i -> OAuth2.RefreshToken -> RefreshTokenRequest a-  conduitRefreshTokenRequest ::-    (MonadIO m) =>-    IdpApplication a i ->-    Manager ->-    OAuth2.RefreshToken ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token------------------------------------------------------------------------------------- * User Info types-----------------------------------------------------------------------------------type family IdpUserInfo a--class HasUserInfoRequest (a :: GrantTypeFlow) where-  conduitUserInfoRequest ::-    FromJSON (IdpUserInfo i) =>-    IdpApplication a i ->-    Manager ->-    AccessToken ->-    ExceptT BSL.ByteString IO (IdpUserInfo i)------------------------------------------------------------------------------------- * Idp App------------------------------------------------------------------------------------- | Shall IdpApplication has a field of 'Idp a'??-data Idp a = Idp-  { idpUserInfoEndpoint :: URI,-    -- NOTE: maybe worth data type to distinguish authorize and token endpoint-    -- as I made mistake at passing to Authorize and Token Request-    idpAuthorizeEndpoint :: URI,-    idpTokenEndpoint :: URI,-    idpFetchUserInfo ::-      forall m.-      (FromJSON (IdpUserInfo a), MonadIO m) =>-      Manager ->-      AccessToken ->-      URI ->-      ExceptT BSL.ByteString m (IdpUserInfo a)-  }------------------------------------------------------------------------------------- * Idp App Config-----------------------------------------------------------------------------------data family IdpApplication (a :: GrantTypeFlow) (i :: Type)------------------------------------------------------------------------------------- * Authorization Code flow------------------------------------------------------------------------------------- | An Application that supports "Authorization code" flow-data instance IdpApplication 'AuthorizationCode i = AuthorizationCodeIdpApplication-  { idpAppName :: Text,-    idpAppClientId :: ClientId,-    idpAppClientSecret :: ClientSecret,-    idpAppScope :: Set Scope,-    idpAppRedirectUri :: URI,-    idpAppAuthorizeState :: AuthorizeState,-    -- | Though technically one key can have multiple value in query, but who actually does it?!-    idpAppAuthorizeExtraParams :: Map Text Text,-    idpAppTokenRequestAuthenticationMethod :: ClientAuthenticationMethod,-    idp :: Idp i-  }---- NOTE: maybe add function for parase authorization response--- though seems overkill. https://github.com/freizl/hoauth2/issues/149--- parseAuthorizationResponse :: String -> AuthorizationResponse--- parseAuthorizationResponse :: ( String, String ) -> AuthorizationResponse--instance HasIdpAppName 'AuthorizationCode where-  getIdpAppName :: IdpApplication 'AuthorizationCode i -> Text-  getIdpAppName AuthorizationCodeIdpApplication {..} = idpAppName--instance HasAuthorizeRequest 'AuthorizationCode where-  -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.1-  data AuthorizationRequest 'AuthorizationCode = AuthorizationCodeAuthorizationRequest-    { scope :: Set Scope,-      state :: AuthorizeState,-      clientId :: ClientId,-      redirectUri :: Maybe RedirectUri-    }-  type MkAuthorizationRequestResponse 'AuthorizationCode = Text--  mkAuthorizeRequestParameter :: IdpApplication 'AuthorizationCode i -> AuthorizationRequest 'AuthorizationCode-  mkAuthorizeRequestParameter AuthorizationCodeIdpApplication {..} =-    AuthorizationCodeAuthorizationRequest-      { scope = if null idpAppScope then Set.empty else idpAppScope,-        state = idpAppAuthorizeState,-        clientId = idpAppClientId,-        redirectUri = Just (RedirectUri idpAppRedirectUri)-      }--  mkAuthorizeRequest :: IdpApplication 'AuthorizationCode i -> Text-  mkAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} =-    let req = mkAuthorizeRequestParameter idpAppConfig-        allParams =-          map (bimap tlToBS tlToBS) $-            Map.toList $-              Map.unions [idpAppAuthorizeExtraParams, toQueryParam req]-     in TL.fromStrict $-          T.decodeUtf8 $-            serializeURIRef' $-              appendQueryParams allParams $-                idpAuthorizeEndpoint idp--instance HasTokenRequest 'AuthorizationCode where-  -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.1.3-  data TokenRequest 'AuthorizationCode = AuthorizationCodeTokenRequest-    { code :: ExchangeToken,-      clientId :: ClientId,-      grantType :: GrantTypeValue,-      redirectUri :: RedirectUri-    }-  type WithExchangeToken 'AuthorizationCode a = ExchangeToken -> a--  mkTokenRequest ::-    IdpApplication 'AuthorizationCode i ->-    ExchangeToken ->-    TokenRequest 'AuthorizationCode-  mkTokenRequest AuthorizationCodeIdpApplication {..} authCode =-    AuthorizationCodeTokenRequest-      { code = authCode,-        clientId = idpAppClientId,-        grantType = GTAuthorizationCode,-        redirectUri = RedirectUri idpAppRedirectUri-      }-  conduitTokenRequest ::-    forall m i.-    (MonadIO m) =>-    IdpApplication 'AuthorizationCode i ->-    Manager ->-    ExchangeToken ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token-  conduitTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr exchangeToken =-    let req = mkTokenRequest idpAppConfig exchangeToken-        key = toOAuth2Key idpAppClientId idpAppClientSecret-        body =-          mapsToParams-            [ toQueryParam req,-              toQueryParam-                ( if idpAppTokenRequestAuthenticationMethod == ClientSecretPost-                    then Just idpAppClientSecret-                    else Nothing-                )-            ]-     in doJSONPostRequest mgr key (idpTokenEndpoint idp) body--instance HasPkceAuthorizeRequest 'AuthorizationCode where-  mkPkceAuthorizeRequest :: MonadIO m => IdpApplication 'AuthorizationCode i -> m (Text, CodeVerifier)-  mkPkceAuthorizeRequest idpAppConfig@AuthorizationCodeIdpApplication {..} = do-    PkceRequestParam {..} <- mkPkceParam-    let req = mkAuthorizeRequestParameter idpAppConfig-    let allParams =-          mapsToParams-            [ idpAppAuthorizeExtraParams,-              toQueryParam req,-              toQueryParam codeChallenge,-              toQueryParam codeChallengeMethod-            ]--    let url =-          TL.fromStrict $-            T.decodeUtf8 $-              serializeURIRef' $-                appendQueryParams allParams $-                  idpAuthorizeEndpoint idp-    pure (url, codeVerifier)--instance HasPkceTokenRequest 'AuthorizationCode where-  conduitPkceTokenRequest ::-    MonadIO m =>-    IdpApplication 'AuthorizationCode i ->-    Manager ->-    (ExchangeToken, CodeVerifier) ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token-  conduitPkceTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr (exchangeToken, codeVerifier) =-    let req = mkTokenRequest idpAppConfig exchangeToken-        key = toOAuth2Key idpAppClientId idpAppClientSecret-        body =-          mapsToParams-            [ toQueryParam req,-              toQueryParam codeVerifier,-              toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing)-            ]-     in doJSONPostRequest mgr key (idpTokenEndpoint idp) body--instance HasRefreshTokenRequest 'AuthorizationCode where-  data RefreshTokenRequest 'AuthorizationCode = AuthorizationCodeTokenRefreshRequest-    { refreshToken :: OAuth2.RefreshToken,-      grantType :: GrantTypeValue,-      scope :: Set Scope-    }--  mkRefreshTokenRequest :: IdpApplication 'AuthorizationCode i -> OAuth2.RefreshToken -> RefreshTokenRequest 'AuthorizationCode-  mkRefreshTokenRequest AuthorizationCodeIdpApplication {..} rt =-    AuthorizationCodeTokenRefreshRequest-      { scope = idpAppScope,-        grantType = GTRefreshToken,-        refreshToken = rt-      }-  conduitRefreshTokenRequest ::-    (MonadIO m) =>-    IdpApplication 'AuthorizationCode i ->-    Manager ->-    OAuth2.RefreshToken ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token-  conduitRefreshTokenRequest idpAppConfig@AuthorizationCodeIdpApplication {..} mgr rt =-    let req = mkRefreshTokenRequest idpAppConfig rt-        key = toOAuth2Key idpAppClientId idpAppClientSecret-        body =-          mapsToParams-            [ toQueryParam req,-              toQueryParam (if idpAppTokenRequestAuthenticationMethod == ClientSecretPost then Just idpAppClientSecret else Nothing)-            ]-     in doJSONPostRequest mgr key (idpTokenEndpoint idp) body--instance HasUserInfoRequest 'AuthorizationCode where-  conduitUserInfoRequest ::-    FromJSON (IdpUserInfo i) =>-    IdpApplication 'AuthorizationCode i ->-    Manager ->-    AccessToken ->-    ExceptT BSL.ByteString IO (IdpUserInfo i)-  conduitUserInfoRequest AuthorizationCodeIdpApplication {..} mgr at = do-    idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp)--instance ToQueryParam (AuthorizationRequest 'AuthorizationCode) where-  toQueryParam :: AuthorizationRequest 'AuthorizationCode -> Map Text Text-  toQueryParam req@AuthorizationCodeAuthorizationRequest {..} =-    Map.unions-      [ toResponseTypeParam req,-        toQueryParam scope,-        toQueryParam clientId,-        toQueryParam state,-        toQueryParam redirectUri-      ]--instance ToQueryParam (TokenRequest 'AuthorizationCode) where-  toQueryParam :: TokenRequest 'AuthorizationCode -> Map Text Text-  toQueryParam AuthorizationCodeTokenRequest {..} =-    Map.unions-      [ toQueryParam grantType,-        toQueryParam code,-        toQueryParam redirectUri-      ]--instance ToQueryParam (RefreshTokenRequest 'AuthorizationCode) where-  toQueryParam :: RefreshTokenRequest 'AuthorizationCode -> Map Text Text-  toQueryParam AuthorizationCodeTokenRefreshRequest {..} =-    Map.unions-      [ toQueryParam grantType,-        toQueryParam scope,-        toQueryParam refreshToken-      ]------------------------------------------------------------------------------------- * Password flow------------------------------------------------------------------------------------- https://www.rfc-editor.org/rfc/rfc6749#section-4.3.1--- 4.3.1.  Authorization Request and Response (Password grant type)--- The method through which the client obtains the resource owner--- credentials is beyond the scope of this specification.  The client--- MUST discard the credentials once an access token has been obtained.------ Hence no AuhorizationRequest instance--data instance IdpApplication 'ResourceOwnerPassword i = ResourceOwnerPasswordIDPAppConfig-  { idpAppClientId :: ClientId,-    idpAppClientSecret :: ClientSecret,-    idpAppName :: Text,-    idpAppScope :: Set Scope,-    idpAppUserName :: Username,-    idpAppPassword :: Password,-    -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec-    idpAppTokenRequestExtraParams :: Map Text Text,-    idp :: Idp i-  }--instance HasIdpAppName 'ResourceOwnerPassword where-  getIdpAppName :: IdpApplication 'ResourceOwnerPassword i -> Text-  getIdpAppName ResourceOwnerPasswordIDPAppConfig {..} = idpAppName--instance HasUserInfoRequest 'ResourceOwnerPassword where-  conduitUserInfoRequest ResourceOwnerPasswordIDPAppConfig {..} mgr at = do-    idpFetchUserInfo idp mgr at (idpUserInfoEndpoint idp)--instance HasTokenRequest 'ResourceOwnerPassword where-  -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.3.2-  data TokenRequest 'ResourceOwnerPassword = PasswordTokenRequest-    { scope :: Set Scope,-      username :: Username,-      password :: Password,-      grantType :: GrantTypeValue-    }-  type WithExchangeToken 'ResourceOwnerPassword a = a--  mkTokenRequest :: IdpApplication 'ResourceOwnerPassword i -> TokenRequest 'ResourceOwnerPassword-  mkTokenRequest ResourceOwnerPasswordIDPAppConfig {..} =-    PasswordTokenRequest-      { username = idpAppUserName,-        password = idpAppPassword,-        grantType = GTPassword,-        scope = idpAppScope-      }--  conduitTokenRequest ::-    (MonadIO m) =>-    IdpApplication 'ResourceOwnerPassword i ->-    Manager ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token-  conduitTokenRequest idpAppConfig@ResourceOwnerPasswordIDPAppConfig {..} mgr =-    let req = mkTokenRequest idpAppConfig-        key = toOAuth2Key idpAppClientId idpAppClientSecret-        body = mapsToParams [idpAppTokenRequestExtraParams, toQueryParam req]-     in doJSONPostRequest mgr key (idpTokenEndpoint idp) body---- | TODO: TBD-instance HasRefreshTokenRequest 'ResourceOwnerPassword where-  data RefreshTokenRequest 'ResourceOwnerPassword = PasswordRefreshTokenRequest--  mkRefreshTokenRequest ::-    IdpApplication 'ResourceOwnerPassword i ->-    OAuth2.RefreshToken ->-    RefreshTokenRequest 'ResourceOwnerPassword-  mkRefreshTokenRequest = undefined--  conduitRefreshTokenRequest ::-    MonadIO m =>-    IdpApplication 'ResourceOwnerPassword i ->-    Manager ->-    OAuth2.RefreshToken ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token-  conduitRefreshTokenRequest = undefined--instance ToQueryParam (TokenRequest 'ResourceOwnerPassword) where-  toQueryParam :: TokenRequest 'ResourceOwnerPassword -> Map Text Text-  toQueryParam PasswordTokenRequest {..} =-    Map.unions-      [ toQueryParam grantType,-        toQueryParam scope,-        toQueryParam username,-        toQueryParam password-      ]------------------------------------------------------------------------------------- * Client Credentials flow------------------------------------------------------------------------------------- https://www.rfc-editor.org/rfc/rfc6749#section-4.4.1--- 4.4.1.  Authorization Request and Response (Client Credentials grant type)--- Since the client authentication is used as the authorization grant,--- no additional authorization request is needed.------ Hence no AuhorizationRequest instance--data instance IdpApplication 'ClientCredentials i = ClientCredentialsIDPAppConfig-  { idpAppClientId :: ClientId,-    idpAppClientSecret :: ClientSecret,-    idpAppName :: Text,-    idpAppScope :: Set Scope,-    -- | Any parameter that required by your Idp and not mentioned in the OAuth2 spec-    idpAppTokenRequestExtraParams :: Map Text Text,-    idp :: Idp i-  }--instance HasIdpAppName 'ClientCredentials where-  getIdpAppName :: IdpApplication 'ClientCredentials i -> Text-  getIdpAppName ClientCredentialsIDPAppConfig {..} = idpAppName--instance HasTokenRequest 'ClientCredentials where-  -- \| https://www.rfc-editor.org/rfc/rfc6749#section-4.4.2-  data TokenRequest 'ClientCredentials = ClientCredentialsTokenRequest-    { scope :: Set Scope,-      grantType :: GrantTypeValue-    }--  type WithExchangeToken 'ClientCredentials a = a--  mkTokenRequest :: IdpApplication 'ClientCredentials i -> TokenRequest 'ClientCredentials-  mkTokenRequest ClientCredentialsIDPAppConfig {..} =-    ClientCredentialsTokenRequest-      { scope = idpAppScope,-        grantType = GTClientCredentials-      }--  conduitTokenRequest ::-    (MonadIO m) =>-    IdpApplication 'ClientCredentials i ->-    Manager ->-    ExceptT (OAuth2Error TR.Errors) m OAuth2Token-  conduitTokenRequest idpAppConfig@ClientCredentialsIDPAppConfig {..} mgr =-    let req = mkTokenRequest idpAppConfig-        key =-          toOAuth2Key-            idpAppClientId-            idpAppClientSecret-        body =-          mapsToParams-            [ idpAppTokenRequestExtraParams,-              toQueryParam req-            ]-     in doJSONPostRequest mgr key (idpTokenEndpoint idp) body--instance ToQueryParam (TokenRequest 'ClientCredentials) where-  toQueryParam :: TokenRequest 'ClientCredentials -> Map Text Text-  toQueryParam ClientCredentialsTokenRequest {..} =-    Map.unions-      [ toQueryParam grantType,-        toQueryParam scope-      ]+instance ToQueryParam ResponseType where+  toQueryParam :: ResponseType -> Map Text Text+  toQueryParam Code = Map.singleton "response_type" "code"
src/Network/OAuth2/Experiment/Utils.hs view
@@ -5,8 +5,11 @@ import Data.ByteString.Char8 qualified as BS8 import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Data.Text.Encoding qualified as T import Data.Text.Encoding qualified as TE import Data.Text.Lazy qualified as TL+import URI.ByteString (URI, serializeURIRef')  tlToBS :: TL.Text -> ByteString tlToBS = TE.encodeUtf8 . TL.toStrict@@ -14,8 +17,11 @@ bs8ToLazyText :: BS8.ByteString -> TL.Text bs8ToLazyText = TL.pack . BS8.unpack -mapsToParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)]-mapsToParams =+unionMapsToQueryParams :: [Map TL.Text TL.Text] -> [(ByteString, ByteString)]+unionMapsToQueryParams =   map (bimap tlToBS tlToBS)     . Map.toList     . Map.unions++uriToText :: URI -> T.Text+uriToText = T.decodeUtf8 . serializeURIRef'
+ src/Network/OAuth2/HttpClient.hs view
@@ -0,0 +1,245 @@+-- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage+-- RFC6750 <https://www.rfc-editor.org/rfc/rfc6750>+module Network.OAuth2.HttpClient (+  -- * AUTH requests+  authGetJSON,+  authGetBS,+  authGetJSONWithAuthMethod,+  authGetBSWithAuthMethod,+  authPostJSON,+  authPostBS,+  authPostJSONWithAuthMethod,+  authPostBSWithAuthMethod,++  -- * Types+  APIAuthenticationMethod (..),+) where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Except (ExceptT (..), throwE)+import Data.Aeson (FromJSON)+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Aeson+import Data.Aeson.KeyMap qualified as Aeson+import Data.ByteString.Char8 qualified as BS+import Data.ByteString.Lazy.Char8 qualified as BSL+import Data.Text.Encoding qualified as T+import Lens.Micro (over)+import Network.HTTP.Client.Conduit (applyBearerAuth)+import Network.HTTP.Client.Contrib (handleResponse)+import Network.HTTP.Conduit+import Network.HTTP.Types qualified as HT+import Network.OAuth2.Internal+import URI.ByteString (URI, URIRef, queryL, queryPairsL)++--------------------------------------------------++-- * AUTH requests++-- Making request with Access Token appended to Header, Request body or query string.+--+--------------------------------------------------++-- | Conduct an authorized GET request and return response as JSON.+--   Inject Access Token to Authorization Header.+authGetJSON ::+  (MonadIO m, FromJSON a) =>+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  -- | Response as JSON+  ExceptT BSL.ByteString m a+authGetJSON = authGetJSONWithAuthMethod AuthInRequestHeader++-- | Conduct an authorized GET request and return response as JSON.+--   Allow to specify how to append AccessToken.+--+-- @since 2.6.0+authGetJSONWithAuthMethod ::+  (MonadIO m, FromJSON a) =>+  APIAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  -- | Response as JSON+  ExceptT BSL.ByteString m a+authGetJSONWithAuthMethod authTypes manager t uri = do+  resp <- authGetBSWithAuthMethod authTypes manager t uri+  either (throwE . BSL.pack) return (Aeson.eitherDecode resp)++-- | Conduct an authorized GET request.+--   Inject Access Token to Authorization Header.+authGetBS ::+  MonadIO m =>+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  -- | Response as ByteString+  ExceptT BSL.ByteString m BSL.ByteString+authGetBS = authGetBSWithAuthMethod AuthInRequestHeader++-- | Conduct an authorized GET request and return response as ByteString.+--   Allow to specify how to append AccessToken.+--+-- @since 2.6.0+authGetBSWithAuthMethod ::+  MonadIO m =>+  -- | Specify the way that how to append the 'AccessToken' in the request+  APIAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  -- | Response as ByteString+  ExceptT BSL.ByteString m BSL.ByteString+authGetBSWithAuthMethod authTypes manager token url = do+  let appendToUrl = AuthInRequestQuery == authTypes+  let appendToHeader = AuthInRequestHeader == authTypes+  let uri = if appendToUrl then url `appendAccessToken` token else url+  let upReq = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.GET+  req <- liftIO $ uriToRequest uri+  authRequest req upReq manager++-- | Conduct POST request and return response as JSON.+--   Inject Access Token to Authorization Header.+authPostJSON ::+  (MonadIO m, FromJSON a) =>+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  PostBody ->+  -- | Response as JSON+  ExceptT BSL.ByteString m a+authPostJSON = authPostJSONWithAuthMethod AuthInRequestHeader++-- | Conduct POST request and return response as JSON.+--   Allow to specify how to append AccessToken.+--+-- @since 2.6.0+authPostJSONWithAuthMethod ::+  (MonadIO m, FromJSON a) =>+  APIAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  PostBody ->+  -- | Response as ByteString+  ExceptT BSL.ByteString m a+authPostJSONWithAuthMethod authTypes manager token url body = do+  resp <- authPostBSWithAuthMethod authTypes manager token url body+  either (throwE . BSL.pack) return (Aeson.eitherDecode resp)++-- | Conduct POST request.+--   Inject Access Token to http header (Authorization)+authPostBS ::+  MonadIO m =>+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  PostBody ->+  -- | Response as ByteString+  ExceptT BSL.ByteString m BSL.ByteString+authPostBS = authPostBSWithAuthMethod AuthInRequestHeader++-- | Conduct POST request and return response as ByteString.+--   Allow to specify how to append AccessToken.+--+-- @since 2.6.0+authPostBSWithAuthMethod ::+  MonadIO m =>+  APIAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  AccessToken ->+  URI ->+  PostBody ->+  -- | Response as ByteString+  ExceptT BSL.ByteString m BSL.ByteString+authPostBSWithAuthMethod authTypes manager token url body = do+  let appendToBody = AuthInRequestBody == authTypes+  let appendToHeader = AuthInRequestHeader == authTypes+  let reqBody = if appendToBody then body ++ accessTokenToParam token else body+  let upBody = if null reqBody then id else jsonBody reqBody+  let upHeaders = updateRequestHeaders (if appendToHeader then Just token else Nothing) . setMethod HT.POST+  let upReq = upHeaders . upBody++  req <- liftIO $ uriToRequest url+  authRequest req upReq manager++jsonBody :: PostBody -> Request -> Request+jsonBody body req =+  req+    { requestBody =+        RequestBodyLBS $+          Aeson.encode $+            Aeson.fromList $+              fmap (\(a, b) -> (Aeson.fromText (T.decodeUtf8 a), T.decodeUtf8 b)) body+    , requestHeaders =+        (HT.hContentType, "application/json")+          : filter (\(x, _) -> x /= HT.hContentType) (requestHeaders req)+    }++--------------------------------------------------++-- * Types++--------------------------------------------------++-- | https://www.rfc-editor.org/rfc/rfc6750#section-2+data APIAuthenticationMethod+  = -- | Provides in Authorization header+    AuthInRequestHeader+  | -- | Provides in request body+    AuthInRequestBody+  | -- | Provides in request query parameter+    AuthInRequestQuery+  deriving (Eq, Ord)++--------------------------------------------------++-- * Utilities++--------------------------------------------------++-- | Send an HTTP request.+authRequest ::+  MonadIO m =>+  -- | Request to perform+  Request ->+  -- | Modify request before sending+  (Request -> Request) ->+  -- | HTTP connection manager.+  Manager ->+  ExceptT BSL.ByteString m BSL.ByteString+authRequest req upReq manage = ExceptT $ do+  resp <- httpLbs (upReq req) manage+  pure (handleResponse resp)++updateRequestHeaders :: Maybe AccessToken -> Request -> Request+updateRequestHeaders mt =+  maybe id (applyBearerAuth . T.encodeUtf8 . atoken) mt+    . addDefaultRequestHeaders++-- | Set the HTTP method to use.+setMethod :: HT.StdMethod -> Request -> Request+setMethod m req = req {method = HT.renderStdMethod m}++-- | For @GET@ method API.+appendAccessToken ::+  -- | Base URI+  URIRef a ->+  -- | Authorized Access Token+  AccessToken ->+  -- | Combined Result+  URIRef a+appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri++-- | Create `QueryParams` with given access token value.+accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)]+accessTokenToParam t = [("access_token", T.encodeUtf8 $ atoken t)]
+ src/Network/OAuth2/Internal.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE QuasiQuotes #-}++module Network.OAuth2.Internal where++import Control.Monad.Catch+import Data.Aeson+import Data.Binary.Instances.Aeson ()+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8+import Data.Default+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Version (showVersion)+import Lens.Micro (over)+import Network.HTTP.Conduit as C+import Network.HTTP.Types qualified as HT+import Paths_hoauth2 (version)+import URI.ByteString+import URI.ByteString.Aeson ()+import URI.ByteString.QQ++-------------------------------------------------------------------------------++-- * OAuth2 Configuration++-------------------------------------------------------------------------------++-- | Query Parameter Representation+data OAuth2 = OAuth2+  { oauth2ClientId :: Text+  , oauth2ClientSecret :: Text+  , oauth2AuthorizeEndpoint :: URIRef Absolute+  , oauth2TokenEndpoint :: URIRef Absolute+  , oauth2RedirectUri :: URIRef Absolute+  }+  deriving (Show, Eq)++instance Default OAuth2 where+  def =+    OAuth2+      { oauth2ClientId = ""+      , oauth2ClientSecret = ""+      , oauth2AuthorizeEndpoint = [uri|https://www.example.com/|]+      , oauth2TokenEndpoint = [uri|https://www.example.com/|]+      , oauth2RedirectUri = [uri|https://www.example.com/|]+      }++-------------------------------------------------------------------------------++-- * Tokens++-------------------------------------------------------------------------------++newtype AccessToken = AccessToken {atoken :: Text} deriving (Eq, Show, FromJSON, ToJSON)++newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Eq, Show, FromJSON, ToJSON)++newtype IdToken = IdToken {idtoken :: Text} deriving (Eq, Show, FromJSON, ToJSON)++-- | Authorization Code+newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON)++-------------------------------------------------------------------------------++-- * Client Authentication methods++-------------------------------------------------------------------------------++-- | How would the Client (RP) authenticate itself?+--+-- The client MUST NOT use more than one authentication method in each request.+-- Means use Authorization header or Post body.+--+-- See more details+--+-- https://www.rfc-editor.org/rfc/rfc6749#section-2.3+-- https://oauth.net/private-key-jwt/+-- https://www.rfc-editor.org/rfc/rfc7523.html+data ClientAuthenticationMethod+  = ClientSecretBasic+  | ClientSecretPost+  | ClientAssertionJwt+  deriving (Eq, Show)++-------------------------------------------------------------------------------++-- * Utilies for Request and URI++-------------------------------------------------------------------------------++-- | Type synonym of post body content+type PostBody = [(BS.ByteString, BS.ByteString)]++-- | Type sysnonym of request query params+type QueryParams = [(BS.ByteString, BS.ByteString)]++defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)]+defaultRequestHeaders =+  [ (HT.hUserAgent, "hoauth2-" <> (T.encodeUtf8 . T.pack $ showVersion version))+  , (HT.hAccept, "application/json")+  ]++-- | Set several header values:+--   + userAgennt    : "hoauth2"+--   + accept        : "application/json"+addDefaultRequestHeaders :: Request -> Request+addDefaultRequestHeaders req =+  let headers = defaultRequestHeaders ++ requestHeaders req+   in req {requestHeaders = headers}++appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a+appendQueryParams params = over (queryL . queryPairsL) (params ++)++uriToRequest :: MonadThrow m => URI -> m Request+uriToRequest = parseRequest . BS8.unpack . serializeURIRef'
+ src/Network/OAuth2/TokenRequest.hs view
@@ -0,0 +1,362 @@+-- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework+-- RFC6749 <https://www.rfc-editor.org/rfc/rfc6749>+module Network.OAuth2.TokenRequest where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Except (ExceptT (..), throwE)+import Data.Aeson+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (Parser, explicitParseFieldMaybe)+import Data.Binary (Binary (..))+import Data.Binary.Instances.Aeson ()+import Data.ByteString.Lazy.Char8 qualified as BSL+import Data.Text (Text, unpack)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Network.HTTP.Conduit+import Network.HTTP.Types qualified as HT+import Network.HTTP.Types.URI (parseQuery)+import Network.OAuth2.Internal+import URI.ByteString+import Prelude hiding (error)++--------------------------------------------------++-- * Token Request Errors++--------------------------------------------------++data TokenResponseError = TokenResponseError+  { tokenResponseError :: TokenResponseErrorCode+  , tokenResponseErrorDescription :: Maybe Text+  , tokenResponseErrorUri :: Maybe (URIRef Absolute)+  }+  deriving (Show, Eq)++-- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2+data TokenResponseErrorCode+  = InvalidRequest+  | InvalidClient+  | InvalidGrant+  | UnauthorizedClient+  | UnsupportedGrantType+  | InvalidScope+  | UnknownErrorCode Text+  deriving (Show, Eq)++instance FromJSON TokenResponseErrorCode where+  parseJSON = withText "parseJSON TokenResponseErrorCode" $ \t ->+    pure $ case t of+      "invalid_request" -> InvalidRequest+      "invalid_client" -> InvalidClient+      "invalid_grant" -> InvalidGrant+      "unauthorized_client" -> UnauthorizedClient+      "unsupported_grant_type" -> UnsupportedGrantType+      "invalid_scope" -> InvalidScope+      _ -> UnknownErrorCode t++instance FromJSON TokenResponseError where+  parseJSON = withObject "parseJSON TokenResponseError" $ \t -> do+    tokenResponseError <- t .: "error"+    tokenResponseErrorDescription <- t .:? "error_description"+    tokenResponseErrorUri <- t .:? "error_uri"+    pure TokenResponseError {..}++parseTokeResponseError :: BSL.ByteString -> TokenResponseError+parseTokeResponseError string =+  either (mkDecodeOAuth2Error string) id (eitherDecode string)+  where+    mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenResponseError+    mkDecodeOAuth2Error response err =+      TokenResponseError+        (UnknownErrorCode "")+        (Just $ T.pack $ "Decode TokenResponseError failed: " <> err <> "\n Original Response:\n" <> show (T.decodeUtf8 $ BSL.toStrict response))+        Nothing++-------------------------------------------------------------------------------++-- * Tokens++-------------------------------------------------------------------------------++-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4+data TokenResponse = TokenResponse+  { accessToken :: AccessToken+  , refreshToken :: Maybe RefreshToken+  -- ^ Exists when @offline_access@ scope is in the Authorization Request and the provider supports Refresh Access Token.+  , expiresIn :: Maybe Int+  , tokenType :: Maybe Text+  -- ^ See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required by spec, but OAuth2 provider implementations vary. We may remove 'Maybe' in a future release.+  , idToken :: Maybe IdToken+  -- ^ Exists when @openid@ scope is in the Authorization Request and the provider supports OpenID protocol.+  , scope :: Maybe Text+  , rawResponse :: Object+  }+  deriving (Eq)++instance Show TokenResponse where+  show TokenResponse {..} =+    "TokenResponse {"+      <> "access_token = ***"+      <> ", id_token = "+      <> showM idToken+      <> ", refresh_token = "+      <> showM refreshToken+      <> ", expires_in = "+      <> show expiresIn+      <> ", token_type = "+      <> show tokenType+      <> ", scope = "+      <> show scope+      <> ", raw_response = ***"+      <> "}"+    where+      showM (Just _) = "***"+      showM Nothing = "Nothing"++instance Binary TokenResponse where+  put TokenResponse {..} = put rawResponse+  get = do+    rawt <- get+    case fromJSON (Aeson.Object rawt) of+      Success a -> pure a+      Error err -> fail err++-- | Parse JSON data into 'TokenResponse'+instance FromJSON TokenResponse where+  parseJSON :: Value -> Parser TokenResponse+  parseJSON = withObject "TokenResponse" $ \v ->+    TokenResponse+      <$> v .: "access_token"+      <*> v .:? "refresh_token"+      <*> explicitParseFieldMaybe parseIntFlexible v "expires_in"+      <*> v .:? "token_type"+      <*> v .:? "id_token"+      <*> v .:? "scope"+      <*> pure v+    where+      parseIntFlexible :: Value -> Parser Int+      parseIntFlexible (String s) = pure . read $ unpack s+      parseIntFlexible v = parseJSON v++instance ToJSON TokenResponse where+  toJSON :: TokenResponse -> Value+  toJSON = toJSON . Object . rawResponse+  toEncoding :: TokenResponse -> Encoding+  toEncoding = toEncoding . Object . rawResponse++--------------------------------------------------++-- * URL++--------------------------------------------------++-- | Prepare the URL and the request body query for fetching an access token.+accessTokenUrl ::+  OAuth2 ->+  -- | access code gained via authorization URL+  ExchangeToken ->+  -- | access token request URL plus the request body.+  (URI, PostBody)+accessTokenUrl oa code =+  let uri = oauth2TokenEndpoint oa+      body =+        [ ("code", T.encodeUtf8 $ extoken code)+        , ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)+        , ("grant_type", "authorization_code")+        ]+   in (uri, body)++-- | Obtain a new access token by sending a Refresh Token to the Authorization server.+refreshAccessTokenUrl ::+  OAuth2 ->+  -- | Refresh Token gained via authorization URL+  RefreshToken ->+  -- | Refresh Token request URL plus the request body.+  (URI, PostBody)+refreshAccessTokenUrl oa token = (uri, body)+  where+    uri = oauth2TokenEndpoint oa+    body =+      [ ("grant_type", "refresh_token")+      , ("refresh_token", T.encodeUtf8 $ rtoken token)+      ]++--------------------------------------------------++-- * Token management++--------------------------------------------------++-- | Exchange @code@ for an Access Token with authenticate in request header.+fetchAccessToken ::+  MonadIO m =>+  -- | HTTP connection manager+  Manager ->+  -- | OAuth Data+  OAuth2 ->+  -- | OAuth2 Code+  ExchangeToken ->+  -- | Access Token+  ExceptT TokenResponseError m TokenResponse+fetchAccessToken = fetchAccessTokenWithAuthMethod ClientSecretBasic++-- | Exchange @code@ for an Access Token+--+-- OAuth2 spec allows credential (@client_id@, @client_secret@) to be sent+-- either in the header (a.k.a `ClientSecretBasic`).+-- or as form/url params (a.k.a `ClientSecretPost`).+--+-- The OAuth provider can choose to implement only one, or both.+-- Look for API document from the OAuth provider you're dealing with.+-- If you`re uncertain, try `fetchAccessToken` which sends credential+-- in authorization http header, which is common case.+--+-- @since 2.6.0+fetchAccessTokenWithAuthMethod ::+  MonadIO m =>+  ClientAuthenticationMethod ->+  -- | HTTP connection manager+  Manager ->+  -- | OAuth Data+  OAuth2 ->+  -- | Authorization Code+  ExchangeToken ->+  -- | Access Token+  ExceptT TokenResponseError m TokenResponse+fetchAccessTokenWithAuthMethod authMethod manager oa code = do+  let (uri, body) = accessTokenUrl oa code+  let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []+  doJSONPostRequest manager oa uri (body ++ extraBody)++-- | Fetch a new AccessToken using the Refresh Token with authentication in request header.+refreshAccessToken ::+  MonadIO m =>+  -- | HTTP connection manager.+  Manager ->+  -- | OAuth context+  OAuth2 ->+  -- | Refresh Token gained after authorization+  RefreshToken ->+  ExceptT TokenResponseError m TokenResponse+refreshAccessToken = refreshAccessTokenWithAuthMethod ClientSecretBasic++-- | Fetch a new AccessToken using the Refresh Token.+--+-- OAuth2 spec allows credential ("client_id", "client_secret") to be sent+-- either in the header (a.k.a 'ClientSecretBasic').+-- or as form/url params (a.k.a 'ClientSecretPost').+--+-- The OAuth provider can choose to implement only one, or both.+-- Look for API document from the OAuth provider you're dealing with.+-- If you're uncertain, try 'refreshAccessToken' which sends credential+-- in authorization http header, which is common case.+--+-- @since 2.6.0+refreshAccessTokenWithAuthMethod ::+  MonadIO m =>+  ClientAuthenticationMethod ->+  -- | HTTP connection manager.+  Manager ->+  -- | OAuth context+  OAuth2 ->+  -- | Refresh Token gained after authorization+  RefreshToken ->+  ExceptT TokenResponseError m TokenResponse+refreshAccessTokenWithAuthMethod authMethod manager oa token = do+  let (uri, body) = refreshAccessTokenUrl oa token+  let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []+  doJSONPostRequest manager oa uri (body ++ extraBody)++--------------------------------------------------++-- * Utilies++--------------------------------------------------++-- | Conduct post request and return response as JSON.+doJSONPostRequest ::+  (MonadIO m, FromJSON a) =>+  -- | HTTP connection manager.+  Manager ->+  -- | OAuth options+  OAuth2 ->+  -- | The URL+  URI ->+  -- | request body+  PostBody ->+  -- | Response as JSON+  ExceptT TokenResponseError m a+doJSONPostRequest manager oa uri body = do+  resp <- doSimplePostRequest manager oa uri body+  case parseResponseFlexible resp of+    Right obj -> return obj+    Left e -> throwE e++-- | Conduct post request.+doSimplePostRequest ::+  MonadIO m =>+  -- | HTTP connection manager.+  Manager ->+  -- | OAuth options+  OAuth2 ->+  -- | URL+  URI ->+  -- | Request body.+  PostBody ->+  -- | Response as ByteString+  ExceptT TokenResponseError m BSL.ByteString+doSimplePostRequest manager oa url body =+  ExceptT . liftIO $ fmap handleOAuth2TokenResponse go+  where+    go = do+      req <- uriToRequest url+      let req' = (addBasicAuth oa . addDefaultRequestHeaders) req+      httpLbs (urlEncodedBody body req') manager++-- | Gets response body from a @Response@ if 200 otherwise assume 'Network.OAuth2.TokenRequest.TokenResponseError'+handleOAuth2TokenResponse :: Response BSL.ByteString -> Either TokenResponseError BSL.ByteString+handleOAuth2TokenResponse rsp =+  if HT.statusIsSuccessful (responseStatus rsp)+    then Right $ responseBody rsp+    else Left $ parseTokeResponseError (responseBody rsp)++-- | Try to parses response as JSON, if failed, try to parse as like query string.+parseResponseFlexible ::+  FromJSON a =>+  BSL.ByteString ->+  Either TokenResponseError a+parseResponseFlexible r = case eitherDecode r of+  Left _ -> parseResponseString r+  Right x -> Right x++-- | Parses the response that contains not JSON but a Query String+parseResponseString ::+  FromJSON a =>+  BSL.ByteString ->+  Either TokenResponseError a+parseResponseString b = case parseQuery $ BSL.toStrict b of+  [] -> Left errorMessage+  a -> case fromJSON $ queryToValue a of+    Error _ -> Left errorMessage+    Success x -> Right x+  where+    queryToValue = Object . KeyMap.fromList . map paramToPair+    paramToPair (k, mv) = (Key.fromText $ T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)+    errorMessage = parseTokeResponseError b++-- | Add Basic Authentication header using client_id and client_secret.+addBasicAuth :: OAuth2 -> Request -> Request+addBasicAuth oa =+  applyBasicAuth+    (T.encodeUtf8 $ oauth2ClientId oa)+    (T.encodeUtf8 $ oauth2ClientSecret oa)++-- | Add Credential (client_id, client_secret) to the request post body.+clientSecretPost :: OAuth2 -> PostBody+clientSecretPost oa =+  [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa)+  , ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)+  ]
+ test/Network/OAuth2/InternalSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE QuasiQuotes #-}++module Network.OAuth2.InternalSpec where++import Control.Monad.IO.Class (MonadIO (..))+import Network.HTTP.Conduit+import Network.OAuth2+import Test.Hspec+import URI.ByteString.QQ++spec :: Spec+spec = do+  describe "uriToRequest" $ do+    it "parse http://localhost:3001/abc/foo?scope=openid&redirect_uri=http://localhost:3001/callback" $ do+      req <- liftIO $ uriToRequest [uri|http://localhost:3001/abc/foo?scope=openid&&redirect_uri=http://localhost:3001/callback|]+      secure req `shouldBe` False+      path req `shouldBe` "/abc/foo"+      port req `shouldBe` 3001+      host req `shouldBe` "localhost"+      queryString req `shouldBe` "?scope=openid&redirect_uri=http%3A%2F%2Flocalhost%3A3001%2Fcallback"+    it "parse http://localhost:3001/abc/foo" $ do+      req <- liftIO $ uriToRequest [uri|http://localhost:3001/abc/foo|]+      secure req `shouldBe` False+      path req `shouldBe` "/abc/foo"+      port req `shouldBe` 3001+      host req `shouldBe` "localhost"+      queryString req `shouldBe` ""+    it "parse http://localhost:3001/" $ do+      req <- liftIO $ uriToRequest [uri|http://localhost:3001/|]+      secure req `shouldBe` False+      path req `shouldBe` "/"+      port req `shouldBe` 3001+      host req `shouldBe` "localhost"+      queryString req `shouldBe` ""+    it "parse https://test.auth0.com/authorize" $ do+      req <- liftIO $ uriToRequest [uri|https://test.auth0.com/authorize|]+      secure req `shouldBe` True+      path req `shouldBe` "/authorize"+      port req `shouldBe` 443+      host req `shouldBe` "test.auth0.com"+      queryString req `shouldBe` ""+    it "parse URL with multiple query parameters" $ do+      req <- liftIO $ uriToRequest [uri|https://api.example.com/oauth2/auth?client_id=123&scope=read,write&state=xyz|]+      secure req `shouldBe` True+      path req `shouldBe` "/oauth2/auth"+      port req `shouldBe` 443+      host req `shouldBe` "api.example.com"+      queryString req `shouldBe` "?client_id=123&scope=read%2Cwrite&state=xyz"+    it "parse URL with special characters in path" $ do+      req <- liftIO $ uriToRequest [uri|https://api.example.com/oauth2/user+info/profile%20data|]+      secure req `shouldBe` True+      path req `shouldBe` "/oauth2/user+info/profile%20data"+      port req `shouldBe` 443+      host req `shouldBe` "api.example.com"+      queryString req `shouldBe` ""+    it "parse URL with fragments (which should be ignored)" $ do+      req <- liftIO $ uriToRequest [uri|https://api.example.com/callback#access_token=xyz|]+      secure req `shouldBe` True+      path req `shouldBe` "/callback"+      port req `shouldBe` 443+      host req `shouldBe` "api.example.com"+      queryString req `shouldBe` ""+    it "parse URL with non-standard HTTPS port" $ do+      req <- liftIO $ uriToRequest [uri|https://api.example.com:8443/oauth/token|]+      secure req `shouldBe` True+      path req `shouldBe` "/oauth/token"+      port req `shouldBe` 8443+      host req `shouldBe` "api.example.com"+      queryString req `shouldBe` ""
+ test/Network/OAuth2/TokenRequestSpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE QuasiQuotes #-}++module Network.OAuth2.TokenRequestSpec where++import Data.Aeson qualified as Aeson+import Network.OAuth2.TokenRequest+import Test.Hspec+import URI.ByteString.QQ+import Prelude hiding (error)++spec :: Spec+spec = do+  describe "parseJSON TokenResponseErrorCode" $ do+    it "invalid_request" $ do+      Aeson.eitherDecode "\"invalid_request\"" `shouldBe` Right InvalidRequest+    it "invalid_client" $ do+      Aeson.eitherDecode "\"invalid_client\"" `shouldBe` Right InvalidClient+    it "invalid_grant" $ do+      Aeson.eitherDecode "\"invalid_grant\"" `shouldBe` Right InvalidGrant+    it "unauthorized_client" $ do+      Aeson.eitherDecode "\"unauthorized_client\"" `shouldBe` Right UnauthorizedClient+    it "unsupported_grant_type" $ do+      Aeson.eitherDecode "\"unsupported_grant_type\"" `shouldBe` Right UnsupportedGrantType+    it "invalid_scope" $ do+      Aeson.eitherDecode "\"invalid_scope\"" `shouldBe` Right InvalidScope+    it "foo_code" $ do+      Aeson.eitherDecode "\"foo_code\"" `shouldBe` Right (UnknownErrorCode "foo_code")++  describe "parseJSON TokenResponseError" $ do+    it "parse error" $ do+      Aeson.eitherDecode "{\"error\": \"invalid_request\"}"+        `shouldBe` Right+          ( TokenResponseError+              { tokenResponseError = InvalidRequest+              , tokenResponseErrorDescription = Nothing+              , tokenResponseErrorUri = Nothing+              }+          )+    it "parse error_description" $ do+      Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_description\": \"token request error foo1\"}"+        `shouldBe` Right+          ( TokenResponseError+              { tokenResponseError = InvalidRequest+              , tokenResponseErrorDescription = Just "token request error foo1"+              , tokenResponseErrorUri = Nothing+              }+          )+    it "parse error_uri" $ do+      Aeson.eitherDecode "{\"error\": \"invalid_request\", \"error_uri\": \"https://example.com\"}"+        `shouldBe` Right+          ( TokenResponseError+              { tokenResponseError = InvalidRequest+              , tokenResponseErrorDescription = Nothing+              , tokenResponseErrorUri = Just [uri|https://example.com|]+              }+          )
+ test/Network/OAuth2/TokenResponseSpec.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Network.OAuth2.TokenResponseSpec where++import Data.Aeson qualified as Aeson+import Data.Binary qualified as Binary+import Data.Maybe (fromJust)+import Network.OAuth2 (AccessToken (..), RefreshToken (..), TokenResponse (..))+import Test.Hspec++spec :: Spec+spec = do+  describe "decode as JSON" $ do+    it "parse access token" $ do+      let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\"}"+      Aeson.eitherDecode resp+        `shouldBe` Right+          ( TokenResponse+              { accessToken = AccessToken "ya29"+              , refreshToken = Just (RefreshToken "0gk")+              , expiresIn = Just 3600+              , tokenType = Just "Bearer"+              , idToken = Nothing+              , scope = Nothing+              , rawResponse = fromJust (Aeson.decode resp)+              }+          )+    it "parse access token with scope" $ do+      let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\",\"scope\": \"openid profile\"}"+      Aeson.eitherDecode resp+        `shouldBe` Right+          ( TokenResponse+              { accessToken = AccessToken "ya29"+              , refreshToken = Just (RefreshToken "0gk")+              , expiresIn = Just 3600+              , tokenType = Just "Bearer"+              , idToken = Nothing+              , scope = Just "openid profile"+              , rawResponse = fromJust (Aeson.decode resp)+              }+          )+  describe "encode/decode binary" $ do+    it "support binary encoding" $ do+      let resp = "{\"access_token\":\"ya29\",\"token_type\":\"Bearer\",\"expires_in\":3600,\"refresh_token\":\"0gk\"}"+          oauth2Token = fromJust (Aeson.decode @TokenResponse resp)+      Binary.decode @TokenResponse (Binary.encode oauth2Token)+        `shouldBe` oauth2Token
+ test/Spec.hs view
@@ -0,0 +1,2 @@+-- file test/Spec.hs+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}