hoauth2 0.2.6 → 2.15.1
raw patch · 35 files changed
Files
- CHANGELOG.md +161/−0
- LICENSE +17/−26
- README.md +10/−12
- Setup.hs +0/−2
- example/Google/test.hs +0/−85
- example/Weibo/test.hs +0/−47
- hoauth2.cabal +112/−57
- src/Network/HTTP/Client/Contrib.hs +25/−0
- src/Network/OAuth/OAuth2.hs +0/−159
- src/Network/OAuth/OAuth2/HttpClient.hs +0/−128
- src/Network/OAuth2.hs +26/−0
- src/Network/OAuth2/AuthorizationRequest.hs +88/−0
- src/Network/OAuth2/Experiment.hs +157/−0
- src/Network/OAuth2/Experiment/Flows.hs +273/−0
- src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs +33/−0
- src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs +59/−0
- src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs +39/−0
- src/Network/OAuth2/Experiment/Flows/TokenRequest.hs +41/−0
- src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs +7/−0
- src/Network/OAuth2/Experiment/Grants.hs +15/−0
- src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs +117/−0
- src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs +73/−0
- src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs +90/−0
- src/Network/OAuth2/Experiment/Grants/JwtBearer.hs +50/−0
- src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs +78/−0
- src/Network/OAuth2/Experiment/Pkce.hs +82/−0
- src/Network/OAuth2/Experiment/Types.hs +218/−0
- src/Network/OAuth2/Experiment/Utils.hs +27/−0
- src/Network/OAuth2/HttpClient.hs +245/−0
- src/Network/OAuth2/Internal.hs +116/−0
- src/Network/OAuth2/TokenRequest.hs +362/−0
- test/Network/OAuth2/InternalSpec.hs +69/−0
- test/Network/OAuth2/TokenRequestSpec.hs +56/−0
- test/Network/OAuth2/TokenResponseSpec.hs +48/−0
- test/Spec.hs +2/−0
+ 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
LICENSE view
@@ -1,30 +1,21 @@-Copyright (c)2012, Haisheng Wu--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+MIT License - * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.+Copyright (c) 2022 Haisheng Wu - * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.+Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions: - * Neither the name of Haisheng Wu nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.+The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
README.md view
@@ -1,13 +1,11 @@-[](http://travis-ci.org/freizl/hoauth2)--## Introduction--A lightweight oauth2 haskell binding. See examples in `example/` folder.--In additions, [snaplet-oauth] use this lib as well.--[snaplet-oauth]: https://github.com/HaskellCNOrg/snaplet-oauth--## Contribute+Haskell bindings for -Feel free send pull request or submit issue ticket.+- [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)
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− example/Google/test.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{---This is basically very manual test. Check following link for details.--google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer--Google OAuth 2.0 playround: https://developers.google.com/oauthplayground/---}--module Main where--import qualified Data.ByteString.Char8 as BS-import Data.Maybe (fromJust)-import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery)-import System.Environment--import Network.OAuth.OAuth2.HttpClient-import Network.OAuth.OAuth2-import Google.Key-------------------------------------------------------main :: IO ()-main = do- (x:_) <- getArgs- case x of- "normal" -> normalCase- "offline" -> offlineCase---offlineCase :: IO ()-offlineCase = do - print $ authorizationUrl googleKeys `BS.append` "&" `BS.append` extraParams- putStrLn "visit the url and paste code here: "- code <- getLine- (Just (AccessToken accessToken refreshToken)) <- requestAccessToken googleKeys (BS.pack code) - print (accessToken, refreshToken)- validateToken accessToken >>= print- -- - -- obtain a new access token with refresh token, which turns out only in response at first time.- -- Revoke Access https://www.google.com/settings/security- --- case refreshToken of- Nothing -> print "Failed to fetch refresh token"- Just tk -> refreshAccessToken googleKeys tk >>= print- where extraParams = renderSimpleQuery False $ ("access_type", "offline"):googleScopeEmail---normalCase :: IO ()-normalCase = do - print $ authorizationUrl googleKeys `BS.append` "&" `BS.append` extraParams- putStrLn "visit the url and paste code here: "- code <- getLine- (Just (AccessToken accessToken Nothing)) <- requestAccessToken googleKeys (BS.pack code) - print accessToken- res <- validateToken accessToken- print res- res2 <- userinfo accessToken- print res2- where extraParams = renderSimpleQuery False googleScopeEmail-------------------------------------------------------- Google API---- | this is special for google Gain read-only access to the user's email address.-googleScopeEmail = [("scope", "https://www.googleapis.com/auth/userinfo.email")]---- | Gain read-only access to basic profile information, including a -googleScopeUserInfo = [("scope", "https://www.googleapis.com/auth/userinfo.profile")]---- Token Validation-validateToken accessToken = doSimplePostRequest ("https://www.googleapis.com/oauth2/v1/tokeninfo", - (accessTokenToParam accessToken))---- | fetch user email.--- for more information, please check the playround site.----userinfo accessToken = doSimpleGetRequest (appendQueryParam- "https://www.googleapis.com/oauth2/v2/userinfo"- (accessTokenToParam accessToken))
− example/Weibo/test.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}--{---weibo oauth2: http://open.weibo.com/wiki/Oauth2--This is very trivial testing of the httpclient api.-1. this case will print out a URL-2. run the URL in browser and will navigate to weibo auth page-3. conform the authentication and browser will navigate back to the callback url,- which obviously will failed cause there is no local server.-4. copy the `code` in the callback url and parse into console-5. this test case will gain access token using the `code` and print it out.--check for integration testing at: -https://github.com/HaskellCNOrg/snaplet-oauth/tree/master/test---}--module Main where--import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Maybe (fromJust)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Network.HTTP.Types as HT-import Network.HTTP.Conduit-import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Conduit (MonadResource)--import Network.OAuth.OAuth2.HttpClient-import Network.OAuth.OAuth2--import Weibo.Key- -main :: IO ()-main = do - print $ authorizationUrl weiboKeys- putStrLn "visit the url and paste code here: "- code <- getLine- token <- requestAccessToken weiboKeys (sToBS code)- print token--sToBS :: String -> BS.ByteString-sToBS = T.encodeUtf8 . T.pack
hoauth2.cabal view
@@ -1,67 +1,122 @@-Name: hoauth2--- (http://www.haskell.org/haskellwiki/Package_versioning_policy)-Version: 0.2.6--Synopsis: hoauth2-Description:- Haskell OAuth2 authentication.- .- Tested following services- .- * google web oauth: <https://developers.google.com/accounts/docs/OAuth2WebServer>- .- * weibo oauth2: <http://open.weibo.com/wiki/Oauth2>+cabal-version: 2.4+name: hoauth2 -Homepage: https://github.com/freizl/hoauth2-License: BSD3-License-file: LICENSE-Author: Haisheng Wu-Maintainer: freizl@gmail.com-Copyright: Haisheng,Wu-Category: Network-Build-type: Simple-stability: alpha-tested-with: GHC <= 7.6.1+-- http://wiki.haskell.org/Package_versioning_policy+version: 2.15.1+synopsis: Haskell OAuth2 authentication client+description:+ This package provides Haskell bindings for the OAuth2 Authorization Framework and Bearer Token Usage. +homepage: https://github.com/freizl/hoauth2+license: MIT+license-file: LICENSE+author: Haisheng Wu+maintainer: Haisheng Wu <freizl@gmail.com>+copyright: Haisheng Wu+category: Network+build-type: Simple+stability: Beta+tested-with:+ GHC ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4 || ==9.6.1 || ==9.8.2 --- Extra files to be distributed with the package, such as examples or--- a README.-Extra-source-files:+extra-source-files:+ CHANGELOG.md README.md- example/Google/test.hs- example/Weibo/test.hs -Cabal-version: >=1.8+source-repository head+ type: git+ location: https://github.com/freizl/hoauth2.git -Source-Repository head- Type: git- Location: git://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.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 -Library- hs-source-dirs: src- Exposed-modules:- Network.OAuth.OAuth2.HttpClient- Network.OAuth.OAuth2+ default-extensions:+ DeriveGeneric+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ InstanceSigs+ OverloadedStrings+ PolyKinds+ RecordWildCards+ TypeFamilies - Build-Depends:- aeson >= 0.6 && < 0.7,- base >= 4 && < 5,- text >= 0.11 && < 0.12,- bytestring >= 0.9 && < 0.11,- bytestring-show >= 0.3.5 && < 0.4,- conduit >= 0.5 && < 0.6,- http-conduit >= 1.8.4 && < 1.8.5,- http-types >= 0.7 && < 0.8,- monad-control >= 0.3 && < 0.4,- mtl >= 1 && < 2.2,- transformers >= 0.2 && < 0.4,- resourcet >= 0.4.0.2 && < 0.4.1,- random+ build-depends:+ , 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 - if impl(ghc >= 6.12.0)- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields- -fno-warn-orphans -fno-warn-unused-do-bind- else- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields- -fno-warn-orphans+ ghc-options:+ -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields+ -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,159 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}---- | A simple OAuth2 Haskell binding.--- (This is supposed to be independent with http client.)--module Network.OAuth.OAuth2 where--import Control.Applicative ((<$>), (<*>))-import Control.Exception-import Control.Monad (mzero)-import Data.Aeson-import qualified Data.ByteString as BS-import Data.Maybe (fromMaybe)-import Data.Typeable (Typeable)-import Network.HTTP.Types (renderSimpleQuery)------------------------------------------------------- Data Types------------------------------------------------------- | Query Parameter Representation----data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString- , oauthClientSecret :: BS.ByteString- , oauthOAuthorizeEndpoint :: BS.ByteString- , oauthAccessTokenEndpoint :: BS.ByteString- , oauthCallback :: Maybe BS.ByteString- , oauthAccessToken :: Maybe BS.ByteString- -- ^ TODO: why not Maybe AccessToken???- } deriving (Show, Eq)---- | Simple Exception representation.-data OAuthException = OAuthException String- deriving (Show, Eq, Typeable)---- | OAuthException is kind of Exception.----instance Exception OAuthException---- | The gained Access Token. Use @Data.Aeson.decode@ to decode string to @AccessToken@.--- The @refresheToken@ is special at some case.--- e.g. https://developers.google.com/accounts/docs/OAuth2----data AccessToken = AccessToken { accessToken :: BS.ByteString- , refreshToken :: Maybe BS.ByteString }- deriving (Show)---- | Parse JSON data into {AccessToken}----instance FromJSON AccessToken where- parseJSON (Object o) = AccessToken- <$> o .: "access_token"- <*> o .:? "refresh_token"- parseJSON _ = mzero------------------------------------------------------- Types Synonym------------------------------------------------------- | type synonym of query parameters-type QueryParams = [(BS.ByteString, BS.ByteString)]---- | type synonym of post body content-type PostBody = [(BS.ByteString, BS.ByteString)]---- | type synonym of a URI-type URI = BS.ByteString---- | Access Code that is required for fetching Access Token-type AccessCode = BS.ByteString-------------------------------------------------------- URLs------------------------------------------------------- | Prepare the authorization URL.--- Redirect to this URL asking for user interactive authentication.----authorizationUrl :: OAuth2 -> URI-authorizationUrl oa = oauthOAuthorizeEndpoint oa `appendQueryParam` queryStr- where queryStr = transform' [ ("client_id", Just $ oauthClientId oa)- , ("response_type", Just "code")- , ("redirect_uri", oauthCallback oa)]----- | Prepare URL and the request body query for fetching access token.----accessTokenUrl :: OAuth2- -> AccessCode -- ^ access code gained via authorization URL- -> (URI, PostBody) -- ^ access token request URL plus the request body.-accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code")---accessTokenUrl' :: OAuth2- -> AccessCode -- ^ access code gained via authorization URL- -> Maybe BS.ByteString -- ^ Grant Type- -> (URI, PostBody) -- ^ access token request URL plus the request body.-accessTokenUrl' oa code gt = (uri, body)- where uri = oauthAccessTokenEndpoint oa- body = transform' [ ("client_id", Just $ oauthClientId oa)- , ("client_secret", Just $ oauthClientSecret oa)- , ("code", Just code)- , ("redirect_uri", oauthCallback oa)- , ("grant_type", gt) ]---- | Using a Refresh Token.--- obtain a new access token by sending a refresh token to the Authorization server.----refreshAccessTokenUrl :: OAuth2- -> BS.ByteString -- ^ refresh token gained via authorization URL- -> (URI, PostBody) -- ^ refresh token request URL plus the request body.-refreshAccessTokenUrl oa rtoken = (uri, body)- where uri = oauthAccessTokenEndpoint oa- body = transform' [ ("client_id", Just $ oauthClientId oa)- , ("client_secret", Just $ oauthClientSecret oa)- , ("grant_type", Just "refresh_token")- , ("refresh_token", Just rtoken) ]------------------------------------------------------- UTILs------------------------------------------------------- | Append query parameters with '?'-appendQueryParam :: URI -> QueryParams -> URI-appendQueryParam uri q = uri `BS.append` renderSimpleQuery True q---- | Append query parameters with '&'.-appendQueryParam' :: URI -> QueryParams -> URI-appendQueryParam' uri q = uri `BS.append` "&" `BS.append` renderSimpleQuery False q---- | For GET method API.-appendAccessToken :: URI -- ^ Base URI- -> OAuth2 -- ^ OAuth has Authorized Access Token- -> URI -- ^ Combined Result-appendAccessToken uri oauth = appendQueryParam uri- (token $ oauthAccessToken oauth)- where token :: Maybe BS.ByteString -> QueryParams- token = accessTokenToParam . fromMaybe ""---- | Create QueryParams with given access token value.----accessTokenToParam :: BS.ByteString -> QueryParams-accessTokenToParam token = [("access_token", token)]----- | lift value in the Maybe and abonda Nothing-transform' :: [(a, Maybe b)] -> [(a, b)]-transform' = foldr step' []- where step' :: (a, Maybe b) -> [(a, b)] -> [(a, b)]- step' (a, Just b) xs = (a, b):xs- step' _ xs = xs--- -- Expect Access Token exists- -- FIXME: append empty when Nothing- --uri `BS.append` renderSimpleQuery True (accessTokenToParam $ token oauth)-
− src/Network/OAuth/OAuth2/HttpClient.hs
@@ -1,128 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}---- | A simple http client for request OAuth2 tokens and several utils.--module Network.OAuth.OAuth2.HttpClient where--import Control.Exception-import Control.Monad (liftM)-import Control.Monad.Trans.Resource (ResourceT)-import Data.Aeson-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Network.HTTP.Conduit-import Network.HTTP.Types (renderSimpleQuery)-import qualified Network.HTTP.Types as HT--import Network.OAuth.OAuth2------------------------------------------------------- Fetch AccessToken; RefreshAccessToken------------------------------------------------------- | Request (via POST method) "Access Token".------ FIXME: what if @requestAccessToken'@ return error?----requestAccessToken :: OAuth2 -- ^ OAuth Data- -> BS.ByteString -- ^ Authentication code gained after authorization- -> IO (Maybe AccessToken) -- ^ Access Token-requestAccessToken oa code = doJSONPostRequest (accessTokenUrl oa code)----- | Request the "Refresh Token".----refreshAccessToken :: OAuth2- -> BS.ByteString -- ^ refresh token gained after authorization- -> IO (Maybe AccessToken)-refreshAccessToken oa rtoken = doJSONPostRequest (refreshAccessTokenUrl oa rtoken)-------------------------------------------------------- conduit http request------------------------------------------------------- | Conduct post request.----doSimplePostRequest :: (URI, PostBody) -- ^ The URI and request body for fetching token.- -> IO BSL.ByteString -- ^ Response as ByteString-doSimplePostRequest (uri, body) = doPostRequst (bsToS uri) body >>= handleResponse---- | Conduct post request and return response as JSON.----doJSONPostRequest :: FromJSON a- => (URI, PostBody) -- ^ The URI and request body for fetching token.- -> IO (Maybe a) -- ^ Response as ByteString-doJSONPostRequest (uri, body) = doPostRequst (bsToS uri) body- >>= liftM decode . handleResponse---- | Conduct GET request.----doSimpleGetRequest :: URI -- ^ URL- -> IO BSL.ByteString -- ^ Response as ByteString-doSimpleGetRequest url = doGetRequest (bsToS url) [] >>= handleResponse---- | Conduct GET request and return response as JSON.----doJSONGetRequest :: FromJSON a- => URI -- ^ Full URL- -> IO (Maybe a) -- ^ Response as ByteString-doJSONGetRequest url = doGetRequest (bsToS url) []- >>= liftM decode . handleResponse----- | Conduct GET request with given URL by append extra parameters provided.----doGetRequest :: String -- ^ URL- -> [(BS.ByteString, BS.ByteString)] -- ^ Extra Parameters- -> IO (Response BSL.ByteString) -- ^ Response-doGetRequest url pm = doGetRequestWithReq url pm id---- | TODO: can not be `Request m -> Request m`, why??----doGetRequestWithReq :: String -- ^ URL- -> [(BS.ByteString, BS.ByteString)] -- ^ Extra Parameters- -> (Request (ResourceT IO) -> Request (ResourceT IO)) -- ^ update Request- -> IO (Response BSL.ByteString) -- ^ Response-doGetRequestWithReq url pm f = do- req <- parseUrl $ url ++ bsToS (renderSimpleQuery True pm)- let req' = (updateRequestHeaders .f) req- withManager $ httpLbs req'----- | Conduct POST request with given URL with post body data.----doPostRequst :: String -- ^ URL- -> [(BS.ByteString, BS.ByteString)] -- ^ Data to Post Body- -> IO (Response BSL.ByteString) -- ^ Response-doPostRequst url body = doPostRequstWithReq url body id--doPostRequstWithReq :: String -- ^ URL- -> [(BS.ByteString, BS.ByteString)] -- ^ Data to Post Body- -> (Request (ResourceT IO) -> Request (ResourceT IO))- -> IO (Response BSL.ByteString) -- ^ Response-doPostRequstWithReq url body f = do- req <- parseUrl url- let req' = (updateRequestHeaders . f) req- withManager $ httpLbs (urlEncodedBody body req')-------------------------------------------------------- Utils-----------------------------------------------------handleResponse :: Response BSL.ByteString -> IO BSL.ByteString-handleResponse rsp = if (HT.statusCode . responseStatus) rsp == 200- then return (responseBody rsp)- else throwIO . OAuthException $- "Gaining token failed: " ++ BSL.unpack (responseBody rsp)--updateRequestHeaders :: Request m -> Request m-updateRequestHeaders req = req { requestHeaders = [ (HT.hAccept, "application/json") ] }--bsToS :: BS.ByteString -> String-bsToS = T.unpack . T.decodeUtf8
+ 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
@@ -0,0 +1,157 @@+-- | This module contains a new way of doing OAuth2 authorization and authentication+-- in order to obtain an access token and maybe a refresh token based on RFC 6749.+--+-- This module will become the default in a future release.+--+-- 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 the supported flows:+--+-- 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 hitting the token endpoint with, of course,+-- username and password, to obtain tokens.+--+-- 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.+--+-- 4. PKCE (RFC 7636). This is an enhancement on top of the authorization code flow.+--+-- 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 a quick sample showing how to use the vocabulary from this module.+--+-- 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+-- { 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 :: AuthorizationCodeApplication+-- fooApp =+-- AuthorizationCodeApplication+-- { acClientId = "xxxxx",+-- acClientSecret = "xxxxx",+-- acScope =+-- Set.fromList+-- [ \"https:\/\/www.googleapis.com\/auth\/userinfo.email\",+-- \"https:\/\/www.googleapis.com\/auth\/userinfo.profile\"+-- ],+-- 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+-- @+--+-- Second, construct the authorize URL.+--+-- @+-- authorizeUrl = mkAuthorizationRequest fooIdpApplication+-- @+--+-- Third, after a successful redirect with an authorization code,+-- you can exchange it for an access token.+--+-- @+-- mgr <- liftIO $ newManager tlsManagerSettings+-- tokenResp <- conduitTokenRequest fooIdpApplication mgr authorizeCode+-- @+--+-- If you'd like to fetch user info, use this method:+--+-- @+-- conduitUserInfoRequest fooIdpApplication mgr (accessToken tokenResp)+-- @+--+-- 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,++ -- * 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
@@ -0,0 +1,82 @@+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+import Data.Text (Text)+import Data.Text.Encoding qualified as T+import Data.Word++newtype CodeChallenge = CodeChallenge {unCodeChallenge :: Text}++newtype CodeVerifier = CodeVerifier {unCodeVerifier :: Text}++data CodeChallengeMethod = S256+ deriving (Show)++data PkceRequestParam = PkceRequestParam+ { 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+mkPkceParam = do+ codeV <- genCodeVerifier+ pure+ PkceRequestParam+ { codeVerifier = CodeVerifier (T.decodeUtf8 codeV)+ , codeChallenge = CodeChallenge (encodeCodeVerifier codeV)+ , codeChallengeMethod = S256+ }++encodeCodeVerifier :: BS.ByteString -> Text+encodeCodeVerifier = B64.extractBase64 . B64.encodeBase64Unpadded . BS.pack . ByteArray.unpack . hashSHA256++genCodeVerifier :: MonadIO m => m BS.ByteString+genCodeVerifier = liftIO $ getBytesInternal BS.empty++cvMaxLen :: Int+cvMaxLen = 128++-- The default 'getRandomBytes' generates bytes out of unreverved characters scope.+-- code-verifier = 43*128unreserved+-- unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"+-- ALPHA = %x41-5A / %x61-7A+-- DIGIT = %x30-39+getBytesInternal :: BS.ByteString -> IO BS.ByteString+getBytesInternal ba+ | BS.length ba >= cvMaxLen = pure (BS.take cvMaxLen ba)+ | otherwise = do+ bs <- Crypto.getRandomBytes cvMaxLen+ let bsUnreserved = ba `BS.append` BS.filter isUnreversed bs+ getBytesInternal bsUnreserved++hashSHA256 :: BS.ByteString -> H.Digest H.SHA256+hashSHA256 = H.hash++isUnreversed :: Word8 -> Bool+isUnreversed w = w `BS.elem` unreverseBS++{-+a-z: 97-122+A-Z: 65-90+-: 45+.: 46+_: 95+~: 126+-}+unreverseBS :: BS.ByteString+unreverseBS = BS.pack $ [97 .. 122] ++ [65 .. 90] ++ [45, 46, 95, 126]
+ src/Network/OAuth2/Experiment/Types.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}++module Network.OAuth2.Experiment.Types where++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.Lazy (Text)+import Data.Text.Lazy qualified as TL+import Network.OAuth2 hiding (RefreshToken)+import Network.OAuth2 qualified as OAuth2+import Network.OAuth2.Experiment.Pkce+import Network.OAuth2.Experiment.Utils+import URI.ByteString (URI, serializeURIRef')++-------------------------------------------------------------------------------++-- * Idp App++-------------------------------------------------------------------------------++-- | @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+ }++-- | An OAuth2 Application "a" of IdP "i".+-- "a" can be one of following type:+--+-- * `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+ }++-------------------------------------------------------------------------------++-- * Scope++-------------------------------------------------------------------------------++-- 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+-- @+--+-- 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 (Eq, Ord, Show)++instance IsString Scope where+ fromString :: String -> Scope+ fromString = Scope . TL.pack++-------------------------------------------------------------------------------++-- * 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)++newtype RedirectUri = RedirectUri {unRedirectUri :: URI}+ deriving (Eq)++newtype AuthorizeState = AuthorizeState {unAuthorizeState :: Text}+ deriving (Eq)++instance IsString AuthorizeState where+ fromString :: String -> AuthorizeState+ fromString = AuthorizeState . TL.pack++newtype Username = Username {unUsername :: Text}+ deriving (Eq)++instance IsString Username where+ fromString :: String -> Username+ fromString = Username . TL.pack++newtype Password = Password {unPassword :: Text}+ deriving (Eq)++instance IsString Password where+ fromString :: String -> Password+ fromString = Password . TL.pack++-------------------------------------------------------------------------------++-- * Query parameters++-------------------------------------------------------------------------------+class ToQueryParam a where+ toQueryParam :: a -> Map Text Text++instance ToQueryParam a => ToQueryParam (Maybe a) where+ toQueryParam :: ToQueryParam a => Maybe a -> Map Text Text+ toQueryParam Nothing = Map.empty+ toQueryParam (Just a) = toQueryParam a++instance ToQueryParam GrantTypeValue where+ toQueryParam :: GrantTypeValue -> Map Text Text+ toQueryParam x = Map.singleton "grant_type" (val x)+ where+ val :: GrantTypeValue -> Text+ val GTAuthorizationCode = "authorization_code"+ 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+ toQueryParam (ClientId i) = Map.singleton "client_id" i++instance ToQueryParam ClientSecret where+ toQueryParam :: ClientSecret -> Map Text Text+ toQueryParam (ClientSecret x) = Map.singleton "client_secret" x++instance ToQueryParam Username where+ toQueryParam :: Username -> Map Text Text+ toQueryParam (Username x) = Map.singleton "username" x++instance ToQueryParam Password where+ toQueryParam :: Password -> Map Text Text+ toQueryParam (Password x) = Map.singleton "password" x++instance ToQueryParam AuthorizeState where+ toQueryParam :: AuthorizeState -> Map Text Text+ toQueryParam (AuthorizeState x) = Map.singleton "state" x++instance ToQueryParam RedirectUri where+ toQueryParam (RedirectUri uri) = Map.singleton "redirect_uri" (bs8ToLazyText $ serializeURIRef' uri)++instance ToQueryParam (Set Scope) where+ toQueryParam :: Set Scope -> Map Text Text+ toQueryParam = toScopeParam . Set.map unScope+ where+ 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+ toQueryParam (CodeVerifier x) = Map.singleton "code_verifier" (TL.fromStrict x)++instance ToQueryParam CodeChallenge where+ toQueryParam :: CodeChallenge -> Map Text Text+ toQueryParam (CodeChallenge x) = Map.singleton "code_challenge" (TL.fromStrict x)++instance ToQueryParam CodeChallengeMethod where+ toQueryParam :: CodeChallengeMethod -> Map Text Text+ toQueryParam x = Map.singleton "code_challenge_method" (TL.pack $ show x)++instance ToQueryParam ExchangeToken where+ toQueryParam :: ExchangeToken -> Map Text Text+ toQueryParam (ExchangeToken x) = Map.singleton "code" (TL.fromStrict x)++instance ToQueryParam OAuth2.RefreshToken where+ toQueryParam :: OAuth2.RefreshToken -> Map Text Text+ toQueryParam (OAuth2.RefreshToken x) = Map.singleton "refresh_token" (TL.fromStrict x)++instance ToQueryParam ResponseType where+ toQueryParam :: ResponseType -> Map Text Text+ toQueryParam Code = Map.singleton "response_type" "code"
+ src/Network/OAuth2/Experiment/Utils.hs view
@@ -0,0 +1,27 @@+module Network.OAuth2.Experiment.Utils where++import Data.Bifunctor+import Data.ByteString (ByteString)+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++bs8ToLazyText :: BS8.ByteString -> TL.Text+bs8ToLazyText = TL.pack . BS8.unpack++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 #-}