diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,11 @@ -[![Build Status](https://secure.travis-ci.org/freizl/hoauth2.png?branch=master)](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) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/example/Google/test.hs b/example/Google/test.hs deleted file mode 100644 --- a/example/Google/test.hs +++ /dev/null @@ -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)) diff --git a/example/Weibo/test.hs b/example/Weibo/test.hs deleted file mode 100644 --- a/example/Weibo/test.hs +++ /dev/null @@ -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 diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -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: - . - * weibo 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 +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 diff --git a/src/Network/HTTP/Client/Contrib.hs b/src/Network/HTTP/Client/Contrib.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Contrib.hs @@ -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 diff --git a/src/Network/OAuth/OAuth2.hs b/src/Network/OAuth/OAuth2.hs deleted file mode 100644 --- a/src/Network/OAuth/OAuth2.hs +++ /dev/null @@ -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) - diff --git a/src/Network/OAuth/OAuth2/HttpClient.hs b/src/Network/OAuth/OAuth2/HttpClient.hs deleted file mode 100644 --- a/src/Network/OAuth/OAuth2/HttpClient.hs +++ /dev/null @@ -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 diff --git a/src/Network/OAuth2.hs b/src/Network/OAuth2.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2.hs @@ -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 diff --git a/src/Network/OAuth2/AuthorizationRequest.hs b/src/Network/OAuth2/AuthorizationRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/AuthorizationRequest.hs @@ -0,0 +1,88 @@ +-- | Bindings Authorization part of The OAuth 2.0 Authorization Framework +-- 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) + ] diff --git a/src/Network/OAuth2/Experiment.hs b/src/Network/OAuth2/Experiment.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment.hs @@ -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) diff --git a/src/Network/OAuth2/Experiment/Flows.hs b/src/Network/OAuth2/Experiment/Flows.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows.hs @@ -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 +-- . +-- +-- 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 +-- . +-- +-- 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 +-- . +-- 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 +-- . +-- +-- 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 +-- . +-- +-- 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 diff --git a/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs b/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/AuthorizationRequest.hs @@ -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 + ] diff --git a/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs b/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/DeviceAuthorizationRequest.hs @@ -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 + ] diff --git a/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/RefreshTokenRequest.hs @@ -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 diff --git a/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/TokenRequest.hs @@ -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 diff --git a/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs b/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Flows/UserInfoRequest.hs @@ -0,0 +1,7 @@ +module Network.OAuth2.Experiment.Flows.UserInfoRequest where + +------------------------------------------------------------------------------- +-- User Info Request -- +------------------------------------------------------------------------------- + +class HasUserInfoRequest a diff --git a/src/Network/OAuth2/Experiment/Grants.hs b/src/Network/OAuth2/Experiment/Grants.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants.hs @@ -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 (..)) diff --git a/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs b/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/AuthorizationCode.hs @@ -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 + } diff --git a/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs b/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/ClientCredentials.hs @@ -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 diff --git a/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs b/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/DeviceAuthorization.hs @@ -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 diff --git a/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs b/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/JwtBearer.hs @@ -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 diff --git a/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Grants/ResourceOwnerPassword.hs @@ -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 + } diff --git a/src/Network/OAuth2/Experiment/Pkce.hs b/src/Network/OAuth2/Experiment/Pkce.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Pkce.hs @@ -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] diff --git a/src/Network/OAuth2/Experiment/Types.hs b/src/Network/OAuth2/Experiment/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Types.hs @@ -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" diff --git a/src/Network/OAuth2/Experiment/Utils.hs b/src/Network/OAuth2/Experiment/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Experiment/Utils.hs @@ -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' diff --git a/src/Network/OAuth2/HttpClient.hs b/src/Network/OAuth2/HttpClient.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/HttpClient.hs @@ -0,0 +1,245 @@ +-- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage +-- 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)] diff --git a/src/Network/OAuth2/Internal.hs b/src/Network/OAuth2/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/Internal.hs @@ -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' diff --git a/src/Network/OAuth2/TokenRequest.hs b/src/Network/OAuth2/TokenRequest.hs new file mode 100644 --- /dev/null +++ b/src/Network/OAuth2/TokenRequest.hs @@ -0,0 +1,362 @@ +-- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework +-- 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) + ] diff --git a/test/Network/OAuth2/InternalSpec.hs b/test/Network/OAuth2/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/OAuth2/InternalSpec.hs @@ -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` "" diff --git a/test/Network/OAuth2/TokenRequestSpec.hs b/test/Network/OAuth2/TokenRequestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/OAuth2/TokenRequestSpec.hs @@ -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|] + } + ) diff --git a/test/Network/OAuth2/TokenResponseSpec.hs b/test/Network/OAuth2/TokenResponseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/OAuth2/TokenResponseSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +-- file test/Spec.hs +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}