diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,55 @@ +# Changelog + +# 0.3.0.0 +## Added +- Configurable login form: `initOAuthState` now accepts a `LoginFormParams -> Html` renderer, allowing library users to fully replace the built-in login page. Pass `defaultLoginFormRenderer` for the previous behaviour. + +## Changed +- **Breaking:** `initOAuthState` takes an additional `(LoginFormParams -> Html)` argument. + +# 0.2.1.0 +## Added +- Dynamic client management endpoint at `/register/{client_id}` supporting GET/PUT/DELETE for registrations authenticated via the issued `registration_access_token`. + +## Security +- Token endpoint responses now include `Cache-Control: no-store` and `Pragma: no-cache`, preventing intermediaries from caching bearer tokens. +- Authorization login form no longer fabricates an empty `state` value; parameters are only echoed when provided by the client, preserving CSRF protection for state-less callers. +- Dynamic client registration now enforces absolute redirect URIs (https-only except localhost loopback) and rejects fragment-bearing or empty lists, preventing misconfigurations that lead to insecure redirects. +- Replaced predictable `StdGen` token generator with Base64URL-encoded output sourced from `cryptonite`'s `getRandomBytes`, ensuring authorization codes, refresh tokens, and client secrets draw from strong entropy. +- Registration endpoint now returns `client_secret` (and expiry metadata) for confidential clients so freshly issued credentials can be retrieved immediately. +- Authorization callback revalidates registered clients, redirect URIs, scopes, and PKCE parameters before minting authorization codes, closing the tampering vector that allowed arbitrary redirect destinations and scope escalation. +- Authorization code redemption inside the token endpoint now executes under a single state lock, preventing concurrent exchanges from reusing the same code. +- Refresh token rotation is now atomic, stopping concurrent refresh requests from returning multiple valid tokens for the same handle. +## Fixed +- Authorization login and retry flows now generate relative callback URLs, so mounting the server under a sub-path (e.g. `/oauth`) no longer breaks form submissions or error redirects. +- Token endpoint error responses also emit `Cache-Control: no-store` and `Pragma: no-cache`, keeping sensitive failures out of intermediary caches. +- Dynamic client registration accepts any `127.0.0.0/8` loopback redirect host, restoring compatibility with tooling that binds to alternate loopback addresses. +- Dynamic client registration omits `client_secret` and `client_secret_expires_at` when no secret is issued, matching RFC 7591 expectations. +- Registration now rejects unsupported `token_endpoint_auth_method` values instead of provisioning unusable clients. +- Token endpoint `invalid_client` responses include a `WWW-Authenticate` challenge so OAuth clients can discover the required authentication scheme. +- Authorization endpoint now emits OAuth error responses via 303 redirects to the validated `redirect_uri`, including the original `state` when present, so clients receive spec-compliant failure notifications. +- Authorization callback now returns a relative `Location: ../authorize` on credential failures, guaranteeing the retry redirect lands on the authorize endpoint even when the server is mounted under a sub-path. +- Authorization callback now performs RFC-compliant 303 redirects with correctly constructed `Location` headers instead of relying on HTML meta refresh, preserving existing redirect URI queries and fragments. +- Discovery metadata now preserves the configured base URL, appending the OAuth server port only when absent and constructing endpoint paths without producing malformed `host:port:port` strings. +- Token issuance no longer crashes the server on JWT signing failures; such errors now surface as OAuth `server_error` responses (HTTP 500). +- Discovery metadata advertises all supported token endpoint authentication methods, including `client_secret_post`, preventing metadata-driven clients from failing their confidential flows. +- Dynamic client registration accepts the RFC 7591 `scope` field and persists it, rather than silently defaulting every client to `"read write"`. +- OAuth error responses now set the `application/json` content type, allowing clients to parse structured failures reliably. +- The authorize endpoint now returns RFC-compliant `invalid_request` or `unsupported_response_type` errors when callers omit or mis-state required parameters. +- Authorization code exchanges no longer mint refresh tokens for clients that omit the `refresh_token` grant, aligning runtime behaviour with registered capabilities. +- Confidential client registrations now leave `client_secret_expires_at` unset for non-expiring secrets instead of reporting an immediately expired timestamp. +- Dynamic client registration replies with HTTP 201 Created, returning `registration_access_token` and `registration_client_uri` alongside the client metadata so RFC 7591 clients can manage their registrations. +- Authorization server metadata now reports the union of scopes registered by clients, ensuring discovery reflects dynamically configured scope values. + +## Changed +- Source module headers now declare the MPL-2.0 license to match the package manifest. +- Added `Web.OAuth2.Internal` to expose a stable-for-tests surface so the test suite can target internals without compiling the entire source tree. +- Restored the full suite of OAuth endpoint tests, including end-to-end flow coverage, after they were accidentally dropped during the namespace migration. + +# 0.2.0.0 +## Changed +- Renamed the exposed module hierarchy from `OAuth` to `Web.OAuth`. +- Updated package metadata and documentation to reflect the new namespace. + +# 0.1.0.0 +- Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,200 @@ +# oauth2-server — OAuth 2.1 Authorization Server for Servant + +`oauth2-server` is a small, composable OAuth 2.1 authorization server for Haskell/Servant. It implements the core endpoints for authorization code with PKCE, dynamic client registration, token issuance and refresh, and discovery metadata. It integrates with `servant-auth-server` to mint JWT access tokens and lets you plug in your own username/password authentication via a simple typeclass. + +This library is designed to be embedded inside your existing Servant application, mounting the OAuth routes alongside your APIs. + +## Features + +- OAuth 2.1 authorization code flow with PKCE (RFC 6749 + RFC 7636) +- Token endpoint with refresh token rotation +- Dynamic client registration (RFC 7591) +- Authorization server metadata discovery (RFC 8414) +- JWT access tokens via `servant-auth-server` +- Pluggable user authentication through a `FormAuth` typeclass +- In‑memory refresh token persistence by default, with an interface to plug your own store + +## Endpoints + +- `GET /.well-known/oauth-authorization-server` — discovery metadata +- `GET /authorize` — start authorization (renders a login form) +- `POST /authorize/callback` — handles login form submission and issues authorization codes +- `POST /token` — exchanges codes for tokens and refreshes tokens +- `POST /register` — dynamic client registration + +PKCE is enforced for all clients using the authorization code grant. Use either `S256` or `plain` as the challenge method. + +## Install + +Add the package to your library or executable stanza: + +```cabal +build-depends: + base + , servant + , servant-server + , servant-auth-server + , blaze-html + , text + , aeson + , containers + , oauth2-server -- this package +``` + +This project targets GHC 9.12 (see `cabal.project`). + +## Quick Start + +Below is a minimal Servant application that mounts the OAuth server. It defines a user type, a simple `FormAuth` instance, configures JWT settings, initializes the OAuth state, and serves the combined OAuth API. + +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Main where + +import Control.Concurrent.MVar (newMVar) +import Data.Text (Text) +import GHC.Generics (Generic) +import Network.Wai (Application) +import Network.Wai.Handler.Warp (run) +import Servant +import Servant.Auth.Server +import Web.OAuth2 (OAuthAPI, oAuthAPI, defaultLoginFormRenderer) +import Web.OAuth2.Types + +-- Your application user type and JWT instances +data User = User { userId :: Text } deriving (Show, Generic) +instance ToJWT User +instance FromJWT User + +-- Plug in your authentication (username/password) logic +data MyAuthSettings = MyAuthSettings +instance FormAuth User where + type FormAuthSettings User = MyAuthSettings + runFormAuth _ "alice" "wonderland" = pure (Authenticated (User "alice")) + runFormAuth _ _ _ = pure NoSuchUser + +type Ctx = '[JWTSettings, MyAuthSettings] + +mkApp :: IO Application +mkApp = do + jwk <- generateKey + let jwt = defaultJWTSettings jwk + ctx = jwt :. MyAuthSettings :. EmptyContext + + -- In-memory refresh-token persistence (swap for your DB if needed) + rtp <- mkDefaultRefreshTokenPersistence + st <- newMVar (initOAuthState @User "http://localhost" 8080 rtp defaultLoginFormRenderer) + + pure $ serveWithContext (Proxy :: Proxy OAuthAPI) ctx (oAuthAPI st ctx) + +main :: IO () +main = mkApp >>= run 8080 +``` + +Notes: + +- `initOAuthState` sets the base URL and port used in discovery metadata. +- Pass `defaultLoginFormRenderer` for the built-in login page, or supply your own `LoginFormParams -> Html` function to customise the look-and-feel. +- For production, provide a durable `RefreshTokenPersistence` (e.g. database) by implementing `persistRefreshToken`, `deleteRefreshToken`, and `lookupRefreshToken`. +- The default login page references `/static/logo.png` if present; it's optional. + +## Short Tutorial + +This walkthrough registers a client, runs a PKCE authorization code flow, exchanges the code for tokens, and refreshes the token. Replace placeholders as needed. + +1) Register a client + +```bash +curl -s http://localhost:8080/register \ + -H 'Content-Type: application/json' \ + -d '{ + "client_name": "My App", + "redirect_uris": ["http://localhost:3000/callback"], + "grant_types": ["authorization_code", "refresh_token"], + "response_types": ["code"], + "scope": "read write", + "token_endpoint_auth_method": "none" + }' +# => { "client_id": "client_...", ... } +``` + +2) Start authorization (PKCE) + +For a simple demo, use `code_challenge_method=plain` and set both challenge and verifier to the same value, e.g. `testverifier`. + +Open in your browser: + +``` +http://localhost:8080/authorize?response_type=code&client_id=CLIENT_ID\ +&redirect_uri=http://localhost:3000/callback&scope=read&state=xyz\ +&code_challenge=testverifier&code_challenge_method=plain +``` + +Log in with the credentials handled by your `FormAuth` instance (from the example above: username `alice`, password `wonderland`). You will be redirected to the `redirect_uri` with `?code=...&state=xyz`. + +3) Exchange the code for tokens + +```bash +curl -s http://localhost:8080/token \ + -H 'Content-Type: application/x-www-form-urlencoded' \ + -d "grant_type=authorization_code&code=AUTH_CODE&redirect_uri=http://localhost:3000/callback&client_id=CLIENT_ID&code_verifier=testverifier" +# => { "access_token": "...", "token_type": "Bearer", "expires_in": 3600, "refresh_token": "...", "scope": "read" } +``` + +4) Refresh the access token (rotation) + +```bash +curl -s http://localhost:8080/token \ + -H 'Content-Type: application/x-www-form-urlencoded' \ + -d "grant_type=refresh_token&refresh_token=REFRESH_TOKEN&client_id=CLIENT_ID" +# => { "access_token": "...", "refresh_token": "..." } +``` + +5) Discover server metadata (optional) + +```bash +curl -s http://localhost:8080/.well-known/oauth-authorization-server | jq +``` + +## Key Types and APIs + +- `OAuthAPI` — combined Servant API for all OAuth endpoints +- `oAuthAPI :: MVar (OAuthState usr) -> Context ctxt -> Server OAuthAPI` — server implementation +- `FormAuth usr` — plug‑in credential verification for your user type: + - associated type `FormAuthSettings usr` + - `runFormAuth :: Context ctxt -> Text -> Text -> IO (AuthResult usr)` +- `OAuthState usr` — holds authorization codes, client registry, refresh‑token persistence, and login form renderer +- `mkDefaultRefreshTokenPersistence` — in‑memory `RefreshToken` storage (replace in production) +- `initOAuthState` — construct initial state with base URL, port, and login form renderer +- `defaultLoginFormRenderer` — built-in login page; pass to `initOAuthState` or replace with your own +- `LoginFormParams` — parameters available to a custom login form renderer + +See also: + +- `tests/OAuth/FlowSpec.hs` — end‑to‑end flow covering registration, authorization, token exchange, and refresh +- `tests/OAuth/TestUtils.hs` — example `FormAuth` instance and JWT configuration + +## Development + +Run tests: + +```bash +cabal build +cabal test +``` + +## Security Notes + +- Always serve over HTTPS in production. Set `oauth_url` accordingly. +- Use a strong JWT signing key and appropriate token lifetimes. +- PKCE is required for authorization code exchanges. Prefer `S256` in real clients. +- The default refresh‑token store is in‑memory and not durable; implement your own for production. + +## License + +See `LICENSE` in this repository. diff --git a/oauth2-server.cabal b/oauth2-server.cabal new file mode 100644 --- /dev/null +++ b/oauth2-server.cabal @@ -0,0 +1,132 @@ +cabal-version: 2.2 +name: oauth2-server +version: 0.3.0.0 +license: MPL-2.0 +license-file: LICENSE +author: DPella AB +extra-doc-files: CHANGELOG.md, README.md +maintainer: matti@dpella.io, + lobo@dpella.io +synopsis: OAuth 2.1 authorization server implementation +description: + Provides a cohesive Servant implementation of the OAuth 2.1 surface, covering + discovery metadata, authorization and callback flows, token issuance, and dynamic + client registration. The package models authorization codes, refresh tokens, and + registered clients with PKCE enforcement, configurable persistence backends, and + secure token generation helpers. Combined servers share state through `MVar`s, + integrate with `servant-auth-server` to mint JWT access tokens, and expose ergonomic + helpers for embedding standards-compliant OAuth flows into Haskell applications. +homepage: https://github.com/DPella/oauth2-server +bug-reports: https://github.com/DPella/oauth2-server/issues +category: Web, Security + +source-repository head + type: git + location: https://github.com/DPella/oauth2-server.git + +library + default-language: + Haskell2010 + default-extensions: + DataKinds + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , OverloadedStrings + , PolyKinds + , RankNTypes + , TypeApplications + , TypeFamilies + hs-source-dirs: + src + exposed-modules: + Web.OAuth2 + Web.OAuth2.Types + Web.OAuth2.Internal + other-modules: + Web.OAuth2.TokenAPI + Web.OAuth2.AuthorizeAPI + Web.OAuth2.AuthorizeCallbackAPI + Web.OAuth2.RegisterAPI + Web.OAuth2.MetadataAPI + build-depends: + base >=4.18 && <4.22 + , servant >=0.20 && <0.21 + , servant-server >=0.20 && <0.21 + , servant-auth-server >=0.4.9 && <0.5 + , servant-blaze >=0.9 && <0.10 + , text >=2.0 && <2.2 + , bytestring >=0.11 && <0.13 + , aeson >=2.1 && <2.3 + , containers >=0.6 && <0.8 + , time >=1.12 && <1.15 + , random >=1.2 && <1.4 + , blaze-html >=0.9 && <0.10 + , network-uri >=2.6 && <2.7 + , http-api-data >=0.5 && <0.7 + , http-types >=0.12 && <0.13 + , cryptonite >=0.29 && <0.31 + , memory >=0.17 && <0.19 + , base64-bytestring >=1.2 && <1.3 + , transformers >=0.5 && <0.7 + +test-suite test-oauth2-server + type: exitcode-stdio-1.0 + default-language: + Haskell2010 + default-extensions: + DataKinds + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , OverloadedStrings + , PolyKinds + , RankNTypes + , TypeApplications + hs-source-dirs: + test + main-is: + Main.hs + other-modules: + Web.OAuth2.AuthorizeCallbackSpec + Web.OAuth2.AuthorizeSpec + Web.OAuth2.FlowSpec + Web.OAuth2.MetadataSpec + Web.OAuth2.RegisterSpec + Web.OAuth2.TestUtils + Web.OAuth2.TokenSpec + build-depends: + base >=4.18 && <4.22 + , oauth2-server + , aeson + , text + , bytestring + , containers + , time + , async + , tasty + , tasty-hunit + , tasty-quickcheck + , QuickCheck + , servant + , servant-server + , servant-auth-server + , servant-blaze + , network-uri + , http-api-data + , wai + , wai-extra + , http-types + , http-client + , warp + , cryptonite + , memory + , scientific + , base64-bytestring + , blaze-html + , blaze-markup + , transformers diff --git a/src/Web/OAuth2.hs b/src/Web/OAuth2.hs new file mode 100644 --- /dev/null +++ b/src/Web/OAuth2.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module: Web.OAuth2 +-- Copyright: (c) DPella AB 2025 +-- License: MPL-2.0 +-- Maintainer: , +-- +-- OAuth 2.1 server implementation module. +-- +-- This module combines all OAuth endpoints into a single API type +-- and provides the server implementation that routes requests to +-- the appropriate handlers. +module Web.OAuth2 (OAuthAPI, oAuthAPI, mkDefaultRefreshTokenPersistence, defaultLoginFormRenderer) where + +import Control.Concurrent.MVar (MVar) +import Web.OAuth2.AuthorizeAPI +import Web.OAuth2.AuthorizeCallbackAPI +import Web.OAuth2.MetadataAPI +import Web.OAuth2.RegisterAPI +import Web.OAuth2.TokenAPI +import Web.OAuth2.Types +import Servant +import Servant.Auth.Server + +-- | Combined OAuth 2.1 API type. +-- +-- Includes all OAuth endpoints: +-- * Metadata discovery endpoint +-- * Authorization endpoint +-- * Authorization callback endpoint +-- * Token exchange endpoint +-- * Dynamic client registration endpoint +type OAuthAPI = MetadataAPI :<|> AuthorizeAPI :<|> AuthorizeCallbackAPI :<|> TokenAPI :<|> RegisterAPI + +-- | OAuth server implementation. +-- +-- Takes an MVar containing the OAuth server state and returns +-- a Servant server that handles all OAuth endpoints. The state +-- is shared across all handlers to maintain authorization codes, +-- refresh tokens, and client registrations. +oAuthAPI + :: ( FormAuth usr + , ToJWT usr + , HasContextEntry ctxt JWTSettings + , HasContextEntry ctxt (FormAuthSettings usr) + ) + => MVar (OAuthState usr) + -> Context ctxt + -> Server OAuthAPI +oAuthAPI state_var ctxt = + handleMetadata state_var + :<|> handleAuthorize state_var + :<|> handleAuthorizeCallback state_var ctxt + :<|> handleTokenRequest state_var ctxt + :<|> registerServer state_var diff --git a/src/Web/OAuth2/AuthorizeAPI.hs b/src/Web/OAuth2/AuthorizeAPI.hs new file mode 100644 --- /dev/null +++ b/src/Web/OAuth2/AuthorizeAPI.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module: Web.OAuth2.AuthorizeAPI +-- Copyright: (c) DPella AB 2025 +-- License: MPL-2.0 +-- Maintainer: , +-- +-- OAuth 2.1 Authorization Endpoint. +-- +-- This module implements the OAuth 2.1 authorization endpoint that handles +-- the initial step of the authorization code flow. It presents a login form +-- to users and validates their credentials against the configured authentication +-- backend. +-- +-- The authorization flow follows RFC 6749 with PKCE (RFC 7636) support for +-- enhanced security in public clients. +module Web.OAuth2.AuthorizeAPI where + +import Control.Concurrent.MVar +import Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Network.URI (escapeURIString, isUnescapedInURIComponent) +import Web.OAuth2.Types +import Servant +import Servant.HTML.Blaze +import Text.Blaze.Html5 qualified as H +import Text.Blaze.Html5.Attributes qualified as A +import Prelude hiding (error) + +-- | Servant API type for the OAuth 2.1 authorization endpoint. +-- +-- Query parameters: +-- * @response_type@ - Must be "code" for authorization code flow +-- * @client_id@ - The client identifier issued during registration +-- * @redirect_uri@ - Where to redirect after authorization +-- * @scope@ - Space-delimited list of requested scopes +-- * @state@ - Opaque value to maintain state between request and callback +-- * @code_challenge@ - PKCE challenge for public clients (RFC 7636) +-- * @code_challenge_method@ - Either "S256" or "plain" for PKCE +-- * @error@ - Error message to display (used for login retry) +type AuthorizeAPI = + "authorize" + :> QueryParam "response_type" Text + :> QueryParam "client_id" Text + :> QueryParam "redirect_uri" Text + :> QueryParam "scope" Text + :> QueryParam "state" Text + :> QueryParam "code_challenge" Text + :> QueryParam "code_challenge_method" Text + :> QueryParam "error" Text + :> Get '[HTML] H.Html + +-- | Handle OAuth 2.1 authorization requests. +-- +-- This function validates the authorization request parameters and displays +-- a login form to the user. It performs the following validations: +-- +-- 1. Ensures @response_type@ is "code" (only authorization code flow is supported) +-- 2. Validates that the client is registered +-- 3. Checks that the redirect URI matches one registered for the client +-- 4. Validates that requested scopes are allowed for the client +-- +-- If all validations pass, it returns an HTML login form. The form will POST +-- credentials to the callback endpoint for authentication. +handleAuthorize + :: forall usr + . MVar (OAuthState usr) + -> Maybe Text + -- ^ response_type parameter + -> Maybe Text + -- ^ client_id parameter + -> Maybe Text + -- ^ redirect_uri parameter + -> Maybe Text + -- ^ scope parameter + -> Maybe Text + -- ^ state parameter + -> Maybe Text + -- ^ code_challenge parameter (PKCE) + -> Maybe Text + -- ^ code_challenge_method parameter (PKCE) + -> Maybe Text + -- ^ error parameter (for retry display) + -> Handler H.Html +handleAuthorize + state_var + responseType + clientIdParam + redirectParam + mb_scope + mb_state + code_challenge + code_challenge_method + error_msg = do + case responseType of + Nothing -> invalidRequest "Missing response_type parameter" + Just "code" -> pure () + Just _ -> unsupportedResponseType "Only response_type=code is supported" + cid <- maybe (invalidRequest "Missing client_id parameter") pure clientIdParam + redirect_uri <- maybe (invalidRequest "Missing redirect_uri parameter") pure redirectParam + oauth_state <- liftIO $ readMVar state_var + case Map.lookup cid (registered_clients oauth_state) of + Just RegisteredClient{..} -> + if redirect_uri `elem` registered_client_redirect_uris + then + if validateScope scope registered_client_scope + then do + let params = LoginFormParams + { lfp_client_id = cid + , lfp_redirect_uri = redirect_uri + , lfp_scope = scope + , lfp_state = mb_state + , lfp_code_challenge = code_challenge + , lfp_code_challenge_method = code_challenge_method + , lfp_error = error_msg + } + return (login_form_renderer oauth_state params) + else redirectWithError redirect_uri "invalid_scope" (Just "Requested scope is not allowed for this client") + else badRequest "unauthorized_client" "Invalid redirect URI for client" + Nothing -> authError "unauthorized_client" "Client not registered or invalid client_id" + where + invalidRequest :: Text -> Handler a + invalidRequest desc = + throwError $ oauthErrorResponse err400 "invalid_request" (Just desc) + + unsupportedResponseType :: Text -> Handler a + unsupportedResponseType desc = + throwError $ oauthErrorResponse err400 "unsupported_response_type" (Just desc) + + badRequest :: Text -> Text -> Handler H.Html + badRequest error_code desc = + throwError $ oauthErrorResponse err400 error_code (Just desc) + + authError :: Text -> Text -> Handler H.Html + authError error_code desc = + throwError $ oauthErrorResponse err401 error_code (Just desc) + + scope = fromMaybe "" mb_scope + + redirectWithError :: Text -> Text -> Maybe Text -> Handler a + redirectWithError redirectUri errorCode errorDescription = + let params = + [("error", errorCode)] + <> maybeParam "error_description" errorDescription + <> maybeParam "state" mb_state + location = buildRedirectUrl redirectUri params + in throwError err303{errHeaders = [("Location", TE.encodeUtf8 location)]} + + maybeParam :: Text -> Maybe Text -> [(Text, Text)] + maybeParam key = maybe [] (\value -> [(key, value)]) + + buildRedirectUrl :: Text -> [(Text, Text)] -> Text + buildRedirectUrl baseUri params = + let (baseWithoutFragment, fragmentPart) = T.breakOn "#" baseUri + fragmentSuffix = + if T.null fragmentPart + then "" + else T.cons '#' (T.drop 1 fragmentPart) + encodedParams = + T.intercalate "&" $ fmap encodeParam params + baseWithQuery + | T.null encodedParams = baseWithoutFragment + | "?" `T.isInfixOf` baseWithoutFragment = baseWithoutFragment <> "&" <> encodedParams + | otherwise = baseWithoutFragment <> "?" <> encodedParams + in baseWithQuery <> fragmentSuffix + + encodeParam :: (Text, Text) -> Text + encodeParam (key, value) = + let pctEncode = T.pack . escapeURIString isUnescapedInURIComponent . T.unpack + in pctEncode key <> "=" <> pctEncode value + +-- | Validate that the requested scope is a subset of the client's allowed scopes. +-- +-- Scopes are space-delimited strings. This function checks that every scope +-- requested by the client is present in the list of allowed scopes. +-- +-- >>> validateScope "read" "read write admin" +-- True +-- +-- >>> validateScope "read write" "read" +-- False +validateScope :: Text -> Text -> Bool +validateScope requested allowed = + let requested_scopes = T.words requested + allowed_scopes = T.words allowed + in not (null requested_scopes) && all (`elem` allowed_scopes) requested_scopes + +-- | Default login form renderer. +-- +-- Produces a self-contained HTML page with inline CSS that displays a +-- centred login box, optional error banner, and username\/password fields. +-- The form POSTs to @authorize\/callback@. +-- +-- Pass this to 'initOAuthState' when you do not need a custom login page. +defaultLoginFormRenderer :: LoginFormParams -> H.Html +defaultLoginFormRenderer LoginFormParams{..} = H.docTypeHtml $ do + H.head $ do + H.title "OAuth Login" + H.style $ + H.toHtml $ + T.unlines + [ "body { font-family: Arial, sans-serif; display: flex; justify-content: center; align-items: center; height: 100vh; margin: 0; background-color: #f0f0f0; }" + , ".login-box { background: white; padding: 2rem; border-radius: 8px; box-shadow: 0 2px 4px rgba(0,0,0,0.1); width: 300px; text-align: center; }" + , ".logo { width: 80px; height: 80px; margin: 0 auto 1.5rem; display: block; }" + , "h2 { margin-top: 0; margin-bottom: 1.5rem; color: #333; }" + , "input { width: 100%; padding: 0.5rem; margin: 0.5rem 0; border: 1px solid #ddd; border-radius: 4px; box-sizing: border-box; }" + , "button { width: 100%; padding: 0.75rem; background-color: #007bff; color: white; border: none; border-radius: 4px; cursor: pointer; font-size: 1rem; margin-top: 1rem; }" + , "button:hover { background-color: #0056b3; }" + , ".form-group { text-align: left; }" + , ".error-message { background-color: #f8d7da; border: 1px solid #f5c6cb; color: #721c24; padding: 0.75rem; border-radius: 4px; margin-bottom: 1rem; font-size: 0.9rem; }" + ] + H.body $ do + H.div H.! A.class_ "login-box" $ do + H.img H.! A.src "/static/logo.png" H.! A.alt "Logo" H.! A.class_ "logo" + H.h2 "Sign In" + case lfp_error of + Just "invalid_password" -> H.div H.! A.class_ "error-message" $ "Invalid username or password" + Just err -> H.div H.! A.class_ "error-message" $ H.toHtml err + Nothing -> mempty + H.form H.! A.method "post" H.! A.action "authorize/callback" $ do + H.input H.! A.type_ "hidden" H.! A.name "client_id" H.! A.value (H.toValue lfp_client_id) + H.input H.! A.type_ "hidden" H.! A.name "redirect_uri" H.! A.value (H.toValue lfp_redirect_uri) + H.input H.! A.type_ "hidden" H.! A.name "scope" H.! A.value (H.toValue lfp_scope) + forM_ lfp_state $ \st -> + H.input H.! A.type_ "hidden" H.! A.name "state" H.! A.value (H.toValue st) + forM_ lfp_code_challenge $ \cc -> + H.input H.! A.type_ "hidden" H.! A.name "code_challenge" H.! A.value (H.toValue cc) + forM_ lfp_code_challenge_method $ \ccm -> + H.input H.! A.type_ "hidden" H.! A.name "code_challenge_method" H.! A.value (H.toValue ccm) + + H.div H.! A.class_ "form-group" $ do + H.input H.! A.type_ "text" H.! A.name "username" H.! A.placeholder "Username" H.! A.required "" + H.input H.! A.type_ "password" H.! A.name "password" H.! A.placeholder "Password" H.! A.required "" + + H.button H.! A.type_ "submit" $ "Sign In" diff --git a/src/Web/OAuth2/AuthorizeCallbackAPI.hs b/src/Web/OAuth2/AuthorizeCallbackAPI.hs new file mode 100644 --- /dev/null +++ b/src/Web/OAuth2/AuthorizeCallbackAPI.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module: Web.OAuth2.AuthorizeCallbackAPI +-- Copyright: (c) DPella AB 2025 +-- License: MPL-2.0 +-- Maintainer: , +-- +-- OAuth 2.1 Authorization Callback Handler. +-- +-- This module handles the POST callback from the authorization login form. +-- It validates user credentials, generates authorization codes, and redirects +-- the user back to the client application with the authorization code. +-- +-- The module implements PKCE (Proof Key for Code Exchange) support as defined +-- in RFC 7636 to protect against authorization code interception attacks. +module Web.OAuth2.AuthorizeCallbackAPI where + +import Control.Concurrent.MVar +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Time.Clock +import GHC.Generics +import Network.URI (escapeURIString, isUnescapedInURIComponent) +import Web.OAuth2.Types +import Servant +import Servant.Auth.Server (AuthResult (..)) +import Servant.HTML.Blaze +import Text.Blaze.Html5 (Html) +import Web.FormUrlEncoded (FromForm (..), parseMaybe, parseUnique) +import Web.OAuth2.AuthorizeAPI (validateScope) + +-- | Form data submitted from the OAuth login page. +-- +-- This data structure captures all the form fields from the login form, +-- including the original OAuth parameters that need to be preserved +-- throughout the authentication flow. +data LoginForm = LoginForm + { username :: Text + -- ^ User's login username + , password :: Text + -- ^ User's login password + , login_client_id :: Text + -- ^ OAuth client identifier + , login_redirect_uri :: Text + -- ^ Client's redirect URI + , login_scope :: Text + -- ^ Requested OAuth scopes + , login_state :: Maybe Text + -- ^ Client's state parameter (optional) + , login_code_challenge :: Maybe Text + -- ^ PKCE code challenge + , login_code_challenge_method :: Maybe Text + -- ^ PKCE challenge method (S256 or plain) + } + deriving (Eq, Show, Generic) + +instance FromForm LoginForm where + fromForm f = + LoginForm + <$> parseUnique "username" f + <*> parseUnique "password" f + <*> parseUnique "client_id" f + <*> parseUnique "redirect_uri" f + <*> parseUnique "scope" f + <*> parseMaybe "state" f + <*> parseMaybe "code_challenge" f + <*> parseMaybe "code_challenge_method" f + +-- | Servant API type for the authorization callback endpoint. +-- +-- This endpoint receives the login form submission and processes +-- the authentication. It returns HTML that redirects the user +-- back to the client application. +type AuthorizeCallbackAPI = + "authorize" + :> "callback" + :> ReqBody '[FormUrlEncoded] LoginForm + :> Post '[HTML] Html + +-- | Handle the authorization callback after user submits login credentials. +-- +-- This function: +-- +-- 1. Validates the user's credentials against the configured authentication backend +-- 2. If successful, generates a new authorization code with 10-minute expiry +-- 3. Stores the authorization code with associated PKCE parameters +-- 4. Redirects the user back to the client with the authorization code +-- 5. If authentication fails, redirects back to the login form with an error +-- +-- Responses use HTTP redirects (303 See Other) with appropriate Location headers. +handleAuthorizeCallback + :: (FormAuth usr, HasContextEntry ctxt (FormAuthSettings usr)) + => MVar (OAuthState usr) + -> Context ctxt + -> LoginForm + -> Handler Html +handleAuthorizeCallback state_var ctxt LoginForm{..} = do + auth_user <- liftIO $ runFormAuth ctxt username password + case auth_user of + Authenticated user -> do + oauth_state <- liftIO $ readMVar state_var + registeredClient <- + case Map.lookup login_client_id (registered_clients oauth_state) of + Nothing -> unauthorizedClient + Just rc -> pure rc + unless (login_redirect_uri `elem` registered_client_redirect_uris registeredClient) $ + invalidRequest "unauthorized_client" "Invalid redirect URI for client" + unless (validateScope login_scope (registered_client_scope registeredClient)) $ + invalidRequest "invalid_scope" "Requested scope is not allowed for this client" + case login_code_challenge of + Nothing -> invalidRequest "invalid_request" "PKCE code_challenge required" + Just _ -> pure () + let methodValid = + maybe True (`elem` ["plain", "S256"]) login_code_challenge_method + unless methodValid $ + invalidRequest "invalid_request" "Unsupported code_challenge_method" + auth_code <- liftIO generateToken + current_time <- liftIO getCurrentTime + let expiry = addUTCTime 600 current_time + new_auth_code = + AuthCode + auth_code + login_client_id + user + login_redirect_uri + login_scope + expiry + login_code_challenge + login_code_challenge_method + + liftIO $ modifyMVar_ state_var $ \s -> + return s{auth_codes = Map.insert auth_code new_auth_code (auth_codes s)} + + let redirect_url = + buildRedirectUrl + login_redirect_uri + (("code", auth_code) : maybeParam "state" login_state) + redirect303 redirect_url + _ -> do + let base = "../authorize" + params = + [ ("response_type", "code") + , ("client_id", login_client_id) + , ("redirect_uri", login_redirect_uri) + , ("scope", login_scope) + ] + <> maybeParam "code_challenge" login_code_challenge + <> maybeParam "code_challenge_method" login_code_challenge_method + <> maybeParam "state" login_state + <> [("error", "invalid_password")] + redirect303 (buildRedirectUrl base params) + where + redirect303 :: Text -> Handler Html + redirect303 location = + throwError err303{errHeaders = [("Location", TE.encodeUtf8 location)]} + + maybeParam :: Text -> Maybe Text -> [(Text, Text)] + maybeParam key = maybe [] (\value -> [(key, value)]) + + buildRedirectUrl :: Text -> [(Text, Text)] -> Text + buildRedirectUrl baseUri params = + let (baseWithoutFragment, fragmentPart) = T.breakOn "#" baseUri + fragmentSuffix = + if T.null fragmentPart + then "" + else T.cons '#' (T.drop 1 fragmentPart) + encodedParams = + T.intercalate "&" $ fmap encodeParam params + baseWithQuery + | T.null encodedParams = baseWithoutFragment + | "?" `T.isInfixOf` baseWithoutFragment = baseWithoutFragment <> "&" <> encodedParams + | otherwise = baseWithoutFragment <> "?" <> encodedParams + in baseWithQuery <> fragmentSuffix + + encodeParam :: (Text, Text) -> Text + encodeParam (key, value) = + let pctEncode = T.pack . escapeURIString isUnescapedInURIComponent . T.unpack + in pctEncode key <> "=" <> pctEncode value + + invalidRequest :: Text -> Text -> Handler a + invalidRequest errorCode errorDescription = + throwError $ oauthErrorResponse err400 errorCode (Just errorDescription) + + unauthorizedClient :: Handler a + unauthorizedClient = + throwError $ oauthErrorResponse err401 "unauthorized_client" (Just "Client not registered or invalid client_id") diff --git a/src/Web/OAuth2/Internal.hs b/src/Web/OAuth2/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Web/OAuth2/Internal.hs @@ -0,0 +1,45 @@ +-- | +-- Module: Web.OAuth2.Internal +-- Description: Project-internal surface area for testing. +-- +-- This module exposes a minimal collection of internal functions +-- and data constructors that the test suite exercises. External +-- callers should treat this interface as unstable. +module Web.OAuth2.Internal + ( validateScope + , defaultLoginFormRenderer + , LoginForm (..) + , handleAuthorizeCallback + , handleTokenRequest + , TokenRequest (..) + , TokenResponse (TokenResponse, access_token, token_type, expires_in, refresh_token_resp) + , TokenResponseHeaders + , handleRegister + , registerServer + , handleRegistrationGet + , handleRegistrationUpdate + , handleRegistrationDelete + , ClientRegistrationRequest (..) + , ClientRegistrationResponse (..) + , handleMetadata + , OAuthMetadata (..) + ) where + +import Web.OAuth2.AuthorizeAPI (defaultLoginFormRenderer, validateScope) +import Web.OAuth2.AuthorizeCallbackAPI (LoginForm (..), handleAuthorizeCallback) +import Web.OAuth2.MetadataAPI (OAuthMetadata (..), handleMetadata) +import Web.OAuth2.RegisterAPI + ( ClientRegistrationRequest (..) + , ClientRegistrationResponse (..) + , handleRegister + , handleRegistrationDelete + , handleRegistrationGet + , handleRegistrationUpdate + , registerServer + ) +import Web.OAuth2.TokenAPI + ( TokenRequest (..) + , TokenResponse (TokenResponse, access_token, token_type, expires_in, refresh_token_resp) + , TokenResponseHeaders + , handleTokenRequest + ) diff --git a/src/Web/OAuth2/MetadataAPI.hs b/src/Web/OAuth2/MetadataAPI.hs new file mode 100644 --- /dev/null +++ b/src/Web/OAuth2/MetadataAPI.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module: Web.OAuth2.MetadataAPI +-- Copyright: (c) DPella AB 2025 +-- License: MPL-2.0 +-- Maintainer: , +-- +-- OAuth 2.1 Authorization Server Metadata Endpoint. +-- +-- This module implements the OAuth 2.1 Authorization Server Metadata +-- endpoint as defined in RFC 8414. It provides clients with information +-- about the authorization server's capabilities and endpoints. +-- +-- The metadata helps clients discover: +-- * Authorization and token endpoints +-- * Supported grant types and response types +-- * Authentication methods +-- * PKCE support +-- * Available scopes +module Web.OAuth2.MetadataAPI where + +import Control.Concurrent.MVar +import Control.Monad.IO.Class (liftIO) +import Data.Aeson +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics +import Servant +import Web.OAuth2.Types + +-- | OAuth 2.1 Authorization Server Metadata structure. +-- +-- This structure contains all the metadata fields defined in RFC 8414 +-- that are relevant for this OAuth implementation. +data OAuthMetadata = OAuthMetadata + { issuer :: Text + -- ^ The authorization server's issuer identifier + , authorization_endpoint :: Text + -- ^ URL of the authorization endpoint + , token_endpoint :: Text + -- ^ URL of the token endpoint + , registration_endpoint :: Text + -- ^ URL of the dynamic client registration endpoint + , grant_types_supported :: [Text] + -- ^ List of supported OAuth 2.1 grant types + , response_types_supported :: [Text] + -- ^ List of supported response types + , token_endpoint_auth_methods_supported :: [Text] + -- ^ List of client authentication methods supported at token endpoint + , code_challenge_methods_supported :: [Text] + -- ^ List of PKCE code challenge methods supported + , scopes_supported :: [Text] + -- ^ List of supported scope values + } + deriving (Generic, Show) + +instance ToJSON OAuthMetadata + +-- | Servant API type for the OAuth metadata endpoint. +-- +-- The endpoint is available at @/.well-known/oauth-authorization-server@ +-- as specified in RFC 8414. +type MetadataAPI = ".well-known" :> "oauth-authorization-server" :> Get '[JSON] OAuthMetadata + +-- | Handle requests for OAuth server metadata. +-- +-- Returns a JSON object describing the capabilities and endpoints +-- of the OAuth authorization server. The metadata includes: +-- +-- * Server issuer URL constructed from base URL and port +-- * All OAuth endpoints (authorize, token, register) +-- * Supported grant types: "authorization_code" and "refresh_token" +-- * PKCE support with "S256" and "plain" methods +-- * Available scopes: "read" and "write" +handleMetadata :: forall usr. MVar (OAuthState usr) -> Handler OAuthMetadata +handleMetadata state_var = do + OAuthState{..} <- liftIO $ readMVar state_var + let baseUrl = normalizeBaseUrl oauth_url oauth_port + baseForPaths = stripTrailingSlash baseUrl + scopeTokens = + Set.toList $ + Set.fromList $ + concatMap (T.words . registered_client_scope) (Map.elems registered_clients) + scopesSupported = + if null scopeTokens + then ["read", "write"] + else scopeTokens + return $ + OAuthMetadata + { issuer = baseUrl + , authorization_endpoint = appendPathSegment baseForPaths "/authorize" + , token_endpoint = appendPathSegment baseForPaths "/token" + , registration_endpoint = appendPathSegment baseForPaths "/register" + , grant_types_supported = ["authorization_code", "refresh_token"] + , response_types_supported = ["code"] + , token_endpoint_auth_methods_supported = ["none", "client_secret_post"] + , code_challenge_methods_supported = ["S256", "plain"] + , scopes_supported = scopesSupported + } diff --git a/src/Web/OAuth2/RegisterAPI.hs b/src/Web/OAuth2/RegisterAPI.hs new file mode 100644 --- /dev/null +++ b/src/Web/OAuth2/RegisterAPI.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module: Web.OAuth2.RegisterAPI +-- Copyright: (c) DPella AB 2025 +-- License: MPL-2.0 +-- Maintainer: , +-- +-- OAuth 2.1 Dynamic Client Registration (RFC 7591). +-- +-- This module implements dynamic client registration as defined in RFC 7591. +-- It allows OAuth clients to register themselves programmatically with the +-- authorization server. +-- +-- Registered clients receive a unique client_id that must be used in all +-- subsequent OAuth flows. The registration process collects client metadata +-- including redirect URIs, grant types, and requested scopes. +module Web.OAuth2.RegisterAPI where + +import Control.Concurrent.MVar +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Data.Aeson +import Data.ByteString.Char8 qualified as BS8 +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics +import Network.URI qualified as URI +import Web.OAuth2.Types +import Servant +import Text.Read (readMaybe) + +-- | Servant API type for the OAuth dynamic client registration endpoint. +-- +-- Accepts a JSON request body with client metadata and returns +-- the registered client information including the assigned client_id. +type RegisterAPI = + "register" + :> ReqBody '[JSON] ClientRegistrationRequest + :> PostCreated '[JSON] ClientRegistrationResponse + :<|> + "register" + :> Capture "client_id" Text + :> Header "Authorization" Text + :> Get '[JSON] ClientRegistrationResponse + :<|> + "register" + :> Capture "client_id" Text + :> Header "Authorization" Text + :> ReqBody '[JSON] ClientRegistrationRequest + :> Put '[JSON] ClientRegistrationResponse + :<|> + "register" + :> Capture "client_id" Text + :> Header "Authorization" Text + :> Verb 'DELETE 204 '[JSON] NoContent + +-- | Request payload for dynamic client registration. +-- +-- Contains the client metadata that should be registered with +-- the authorization server. Most fields are optional and will +-- use sensible defaults if not provided. +data ClientRegistrationRequest = ClientRegistrationRequest + { client_name :: Text + -- ^ Human-readable name of the client + , redirect_uris :: [Text] + -- ^ List of allowed redirect URIs for this client + , grant_types :: Maybe [Text] + -- ^ OAuth grant types the client will use (default: ["authorization_code", "refresh_token"]) + , response_types :: Maybe [Text] + -- ^ OAuth response types the client will use (default: ["code"]) + , scope :: Maybe Text + -- ^ Space-delimited list of scopes the client may request (default: "read write") + , token_endpoint_auth_method :: Maybe Text + -- ^ Client authentication method at token endpoint (default: "none") + } + deriving (Eq, Show, Generic) + +instance FromJSON ClientRegistrationRequest + +instance ToJSON ClientRegistrationRequest + +-- | Response returned after successful client registration. +-- +-- Contains all the registered client metadata including the +-- newly assigned client_id that must be used in OAuth flows. +data ClientRegistrationResponse = ClientRegistrationResponse + { reg_client_id :: Text + -- ^ Unique identifier assigned to the client + , reg_client_name :: Text + -- ^ Registered human-readable name + , reg_client_secret :: Maybe Text + -- ^ Secret issued to confidential clients (Nothing for public clients) + , reg_client_secret_expires_at :: Maybe Int + -- ^ Epoch seconds when the secret expires (Nothing means unspecified) + , reg_redirect_uris :: [Text] + -- ^ Registered redirect URIs + , reg_grant_types :: [Text] + -- ^ Allowed grant types for this client + , reg_response_types :: [Text] + -- ^ Allowed response types for this client + , reg_scope :: Text + -- ^ Maximum scope this client can request + , reg_token_endpoint_auth_method :: Text + -- ^ Required authentication method at token endpoint + , reg_registration_access_token :: Text + -- ^ Registration access token for subsequent client management + , reg_registration_client_uri :: Text + -- ^ URI where the client configuration can be managed + } + deriving (Eq, Show, Generic) + +instance ToJSON ClientRegistrationResponse where + toJSON ClientRegistrationResponse{..} = + object $ + [ "client_id" .= reg_client_id + , "client_name" .= reg_client_name + , "redirect_uris" .= reg_redirect_uris + , "grant_types" .= reg_grant_types + , "response_types" .= reg_response_types + , "scope" .= reg_scope + , "token_endpoint_auth_method" .= reg_token_endpoint_auth_method + , "registration_access_token" .= reg_registration_access_token + , "registration_client_uri" .= reg_registration_client_uri + ] + <> maybe [] (\secret -> ["client_secret" .= secret]) reg_client_secret + <> maybe [] (\expiry -> ["client_secret_expires_at" .= expiry]) reg_client_secret_expires_at + +-- | Handle dynamic client registration requests. +-- +-- This function: +-- +-- 1. Generates a unique client_id with "client_" prefix +-- 2. Applies defaults for any optional parameters: +-- - grant_types: ["authorization_code", "refresh_token"] +-- - response_types: ["code"] +-- - scope: "read write" +-- - auth_method: "none" +-- 3. Stores the client registration in the OAuth state +-- 4. Returns the complete client registration details +-- +registerServer :: forall usr. MVar (OAuthState usr) -> Server RegisterAPI +registerServer state_var = + handleRegister state_var + :<|> handleRegistrationGet state_var + :<|> handleRegistrationUpdate state_var + :<|> handleRegistrationDelete state_var + +data NormalizedRegistration = NormalizedRegistration + { normGrantTypes :: [Text] + , normResponseTypes :: [Text] + , normScope :: Text + , normAuthMethod :: Text + , normSecret :: Maybe Text + } + +-- | Handle dynamic client registration requests. +-- +-- The client_id is generated using a secure random token generator. +handleRegister :: forall usr. MVar (OAuthState usr) -> ClientRegistrationRequest -> Handler ClientRegistrationResponse +handleRegister state_var request@ClientRegistrationRequest{..} = do + normalized <- liftEitherIO =<< liftIO (normalizeRegistration Nothing request) + client_id <- ("client_" <>) <$> liftIO generateToken + registration_access_token <- liftIO generateToken + response <- + liftIO $ + modifyMVar state_var $ \s -> do + let baseUrl = normalizeBaseUrl (oauth_url s) (oauth_port s) + baseForPaths = stripTrailingSlash baseUrl + registration_client_uri = appendPathSegment baseForPaths ("/register/" <> client_id) + newClient = + RegisteredClient + { registered_client_id = client_id + , registered_client_name = client_name + , registered_client_secret = normSecret normalized + , registered_client_redirect_uris = redirect_uris + , registered_client_grant_types = normGrantTypes normalized + , registered_client_response_types = normResponseTypes normalized + , registered_client_scope = normScope normalized + , registered_client_token_endpoint_auth_method = normAuthMethod normalized + , registered_client_registration_access_token = Just registration_access_token + } + updatedState = + s + { registered_clients = Map.insert client_id newClient (registered_clients s) + } + responseValue = + buildRegistrationResponse registration_client_uri registration_access_token newClient + pure (updatedState, responseValue) + pure response + +-- | Retrieve metadata for an existing client registration (RFC 7592). +handleRegistrationGet + :: forall usr + . MVar (OAuthState usr) + -> Text + -> Maybe Text + -> Handler ClientRegistrationResponse +handleRegistrationGet state_var clientId mAuth = do + state <- liftIO $ readMVar state_var + (baseUrl, managementToken, client) <- resolveManagedClient state clientId mAuth + let registrationUri = appendPathSegment (stripTrailingSlash baseUrl) ("/register/" <> clientId) + pure $ buildRegistrationResponse registrationUri managementToken client + +-- | Update metadata for an existing client registration (RFC 7592). +handleRegistrationUpdate + :: forall usr + . MVar (OAuthState usr) + -> Text + -> Maybe Text + -> ClientRegistrationRequest + -> Handler ClientRegistrationResponse +handleRegistrationUpdate state_var clientId mAuth request@ClientRegistrationRequest{client_name = newName, redirect_uris = newRedirects} = do + result <- + liftIO $ + modifyMVar state_var $ \s -> do + let baseUrl = normalizeBaseUrl (oauth_url s) (oauth_port s) + baseForPaths = stripTrailingSlash baseUrl + case Map.lookup clientId (registered_clients s) of + Nothing -> + pure (s, Left $ registrationNotFound clientId) + Just existing -> do + let authCheck = authorizeManagement existing mAuth + case authCheck of + Left err -> pure (s, Left err) + Right token -> do + normalizedResult <- normalizeRegistration (Just existing) request + case normalizedResult of + Left err -> pure (s, Left err) + Right normalized -> do + let registration_client_uri = appendPathSegment baseForPaths ("/register/" <> clientId) + updatedClient = + existing + { registered_client_name = newName + , registered_client_secret = normSecret normalized + , registered_client_redirect_uris = newRedirects + , registered_client_grant_types = normGrantTypes normalized + , registered_client_response_types = normResponseTypes normalized + , registered_client_scope = normScope normalized + , registered_client_token_endpoint_auth_method = normAuthMethod normalized + } + newState = + s + { registered_clients = Map.insert clientId updatedClient (registered_clients s) + } + responseValue = + buildRegistrationResponse registration_client_uri token updatedClient + pure (newState, Right responseValue) + either throwError pure result + +-- | Remove an existing client registration (RFC 7592). +handleRegistrationDelete + :: forall usr + . MVar (OAuthState usr) + -> Text + -> Maybe Text + -> Handler NoContent +handleRegistrationDelete state_var clientId mAuth = do + result <- + liftIO $ + modifyMVar state_var $ \s -> do + case Map.lookup clientId (registered_clients s) of + Nothing -> + pure (s, Left $ registrationNotFound clientId) + Just existing -> + case authorizeManagement existing mAuth of + Left err -> pure (s, Left err) + Right _ -> + let newState = + s + { registered_clients = Map.delete clientId (registered_clients s) + } + in pure (newState, Right NoContent) + either throwError pure result + +buildRegistrationResponse + :: Text + -> Text + -> RegisteredClient + -> ClientRegistrationResponse +buildRegistrationResponse registrationUri registrationToken RegisteredClient{..} = + ClientRegistrationResponse + { reg_client_id = registered_client_id + , reg_client_name = registered_client_name + , reg_client_secret = registered_client_secret + , reg_client_secret_expires_at = Nothing + , reg_redirect_uris = registered_client_redirect_uris + , reg_grant_types = registered_client_grant_types + , reg_response_types = registered_client_response_types + , reg_scope = registered_client_scope + , reg_token_endpoint_auth_method = registered_client_token_endpoint_auth_method + , reg_registration_access_token = registrationToken + , reg_registration_client_uri = registrationUri + } + +authorizeManagement :: RegisteredClient -> Maybe Text -> Either ServerError Text +authorizeManagement RegisteredClient{registered_client_registration_access_token = Nothing} _ = + Left $ oauthErrorResponse err500 "server_error" (Just "Client missing management access token") +authorizeManagement RegisteredClient{registered_client_registration_access_token = Just expectedToken} mHeader = + case extractBearerToken mHeader of + Left err -> Left err + Right provided -> + if constTimeEq provided expectedToken + then Right expectedToken + else Left $ addBearerChallenge $ oauthErrorResponse err401 "invalid_token" (Just "Invalid management access token") + +resolveManagedClient + :: OAuthState usr + -> Text + -> Maybe Text + -> Handler (Text, Text, RegisteredClient) +resolveManagedClient state clientId mAuth = + case Map.lookup clientId (registered_clients state) of + Nothing -> throwError $ registrationNotFound clientId + Just rc -> + case authorizeManagement rc mAuth of + Left err -> throwError err + Right token -> do + let baseUrl = normalizeBaseUrl (oauth_url state) (oauth_port state) + pure (baseUrl, token, rc) + +normalizeRegistration + :: Maybe RegisteredClient + -> ClientRegistrationRequest + -> IO (Either ServerError NormalizedRegistration) +normalizeRegistration existing ClientRegistrationRequest{..} = runExceptT $ do + exceptEither $ validateRedirectUris redirect_uris + let baseGrant = maybe ["authorization_code", "refresh_token"] registered_client_grant_types existing + baseResponse = maybe ["code"] registered_client_response_types existing + baseScope = maybe "read write" registered_client_scope existing + baseAuth = maybe "none" registered_client_token_endpoint_auth_method existing + grantTypes = fromMaybe baseGrant grant_types + responseTypes = fromMaybe baseResponse response_types + resolvedScope = fromMaybe baseScope scope + resolvedAuthMethod = fromMaybe baseAuth token_endpoint_auth_method + exceptEither $ validateAuthMethod resolvedAuthMethod + secret <- + case resolvedAuthMethod of + "none" -> pure Nothing + "client_secret_post" -> + case existing of + Just RegisteredClient{registered_client_secret = Just existingSecret, registered_client_token_endpoint_auth_method = "client_secret_post"} -> + pure (Just existingSecret) + _ -> Just <$> liftIO generateToken + _ -> pure Nothing + pure + NormalizedRegistration + { normGrantTypes = grantTypes + , normResponseTypes = responseTypes + , normScope = resolvedScope + , normAuthMethod = resolvedAuthMethod + , normSecret = secret + } + +validateAuthMethod :: Text -> Either ServerError () +validateAuthMethod method + | method `elem` ["none", "client_secret_post"] = Right () + | otherwise = + Left $ invalidMetadataError "Unsupported token_endpoint_auth_method; expected \"none\" or \"client_secret_post\"" + +validateRedirectUris :: [Text] -> Either ServerError () +validateRedirectUris uris + | null uris = Left $ invalidMetadataError "redirect_uris must include at least one absolute URI" + | otherwise = foldl' step (Right ()) uris + where + step acc uriText = acc >> checkUri uriText + + checkUri uriText = + case URI.parseURI (T.unpack uriText) of + Just parsed + | not (null (URI.uriScheme parsed)) -> + ensureNoFragment parsed >> ensureScheme parsed + _ -> Left $ invalidMetadataError "redirect_uri is not an absolute URI" + + ensureNoFragment parsed = + if null (URI.uriFragment parsed) + then Right () + else Left $ invalidMetadataError "redirect_uris must not contain URI fragments" + + ensureScheme parsed = + case URI.uriScheme parsed of + "https:" -> ensureAuthority parsed + "http:" -> + case URI.uriAuthority parsed of + Just auth + | isLoopbackHost (T.pack (URI.uriRegName auth)) -> Right () + | otherwise -> Left $ invalidMetadataError "http redirect_uris are only allowed for loopback clients" + Nothing -> Left $ invalidMetadataError "redirect_uris must include a network host component" + _ -> Left $ invalidMetadataError "redirect_uris must use https scheme" + + ensureAuthority parsed = + case URI.uriAuthority parsed of + Just _ -> Right () + Nothing -> Left $ invalidMetadataError "redirect_uri must include authority (host)" + + isLoopbackHost hostName = + hostName == "localhost" + || hostName == "[::1]" + || hostName == "::1" + || isIPv4Loopback hostName + + isIPv4Loopback host = + case traverse (readMaybe . T.unpack) (T.splitOn "." host) of + Just [a, b, c, d] + | a == (127 :: Int) + , all (\o -> o >= 0 && o <= 255) [b, c, d] -> True + _ -> False + +extractBearerToken :: Maybe Text -> Either ServerError Text +extractBearerToken Nothing = + Left $ addBearerChallenge $ oauthErrorResponse err401 "invalid_token" (Just "Missing Authorization header") +extractBearerToken (Just headerValue) = + case T.words headerValue of + ["Bearer", token] -> tokenOrError token + ["bearer", token] -> tokenOrError token + _ -> Left $ addBearerChallenge $ oauthErrorResponse err401 "invalid_token" (Just "Malformed Authorization header") + where + tokenOrError tok + | T.null tok = Left $ addBearerChallenge $ oauthErrorResponse err401 "invalid_token" (Just "Missing bearer token") + | otherwise = Right tok + +registrationNotFound :: Text -> ServerError +registrationNotFound clientId = + oauthErrorResponse err404 "invalid_client" (Just ("Unknown client_id: " <> clientId)) + +invalidMetadataError :: Text -> ServerError +invalidMetadataError msg = + oauthErrorResponse err400 "invalid_client_metadata" (Just msg) + +addBearerChallenge :: ServerError -> ServerError +addBearerChallenge err = + let headerName = "WWW-Authenticate" + challengeHeader = (headerName, BS8.pack "Bearer realm=\"oauth\"") + filteredHeaders = filter ((/= headerName) . fst) (errHeaders err) + in err{errHeaders = challengeHeader : filteredHeaders} + +exceptEither :: Either ServerError a -> ExceptT ServerError IO a +exceptEither = either throwE pure + +liftEitherIO :: Either ServerError a -> Handler a +liftEitherIO = either throwError pure diff --git a/src/Web/OAuth2/TokenAPI.hs b/src/Web/OAuth2/TokenAPI.hs new file mode 100644 --- /dev/null +++ b/src/Web/OAuth2/TokenAPI.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module: Web.OAuth2.TokenAPI +-- Copyright: (c) DPella AB 2025 +-- License: MPL-2.0 +-- Maintainer: , +-- +-- OAuth 2.1 Token Endpoint. +-- +-- This module implements the OAuth 2.1 token endpoint that exchanges +-- authorization codes for access tokens and handles refresh token requests. +-- +-- The implementation supports: +-- * Authorization code grant with PKCE verification +-- * Refresh token grant for obtaining new access tokens +-- * JWT-based access tokens signed by the server +-- +-- All tokens are validated against the registered client information +-- and PKCE challenges when applicable. +module Web.OAuth2.TokenAPI where + +import Control.Concurrent.MVar +import Control.Monad.IO.Class (liftIO) +import Crypto.Hash (Digest, SHA256 (..), hashWith) +import Data.Aeson +import Data.ByteArray qualified as BA +import Data.ByteString qualified as BS +import Data.ByteString.Base64.URL qualified as B64URL +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Time.Clock +import GHC.Generics +import Web.OAuth2.Types +import Servant +import Servant.Auth.Server +import Web.FormUrlEncoded (FromForm (..)) +import Prelude hiding (error) +import Data.ByteString.Char8 qualified as BS8 + +-- | Servant API type for the OAuth token endpoint. +-- +-- Accepts form-encoded token requests and returns JSON responses +-- containing access tokens and optional refresh tokens. +type TokenAPI = + "token" + :> ReqBody '[FormUrlEncoded] TokenRequest + :> Post + '[JSON] + (Headers '[Header "Cache-Control" Text, Header "Pragma" Text] TokenResponse) + +-- | Token request parameters as defined in RFC 6749. +-- +-- Supports both authorization code and refresh token grants. +-- The required fields depend on the grant type being used. +data TokenRequest = TokenRequest + { grant_type :: Text + -- ^ The type of grant being requested ("authorization_code" or "refresh_token") + , code :: Maybe Text + -- ^ Authorization code (required for authorization_code grant) + , refresh_token :: Maybe Text + -- ^ Refresh token (required for refresh_token grant) + , redirect_uri :: Maybe Text + -- ^ Must match the redirect_uri used in authorization request + , client_id :: Text + -- ^ Client identifier + , client_secret :: Maybe Text + -- ^ Client secret (for confidential clients, client_secret_post) + , code_verifier :: Maybe Text + -- ^ PKCE code verifier (required if code_challenge was used) + } + deriving (Eq, Show, Generic) + +instance FromForm TokenRequest + +-- | Token response structure as defined in RFC 6749. +-- +-- Contains the access token and associated metadata. +-- Refresh tokens are only included for authorization_code grants. +data TokenResponse = TokenResponse + { access_token :: Text + -- ^ The access token (JWT) that can be used to authenticate requests + , token_type :: Text + -- ^ Type of token (always "Bearer") + , expires_in :: Int + -- ^ Token lifetime in seconds (3600 = 1 hour) + , refresh_token_resp :: Maybe Text + -- ^ Refresh token for obtaining new access tokens + , scope :: Maybe Text + -- ^ Granted scope (may be less than requested) + } + deriving (Eq, Show, Generic) + +instance ToJSON TokenResponse where + toJSON TokenResponse{..} = + object $ + [ "access_token" .= access_token + , "token_type" .= token_type + , "expires_in" .= expires_in + ] + <> ["refresh_token" .= rt | Just rt <- [refresh_token_resp]] + <> ["scope" .= s | Just s <- [scope]] + +type TokenResponseHeaders = Headers '[Header "Cache-Control" Text, Header "Pragma" Text] TokenResponse + +-- | Handle OAuth token requests for both authorization code and refresh token grants. +-- +-- For authorization code grant: +-- +-- 1. Validates the authorization code exists and hasn't expired +-- 2. Verifies client_id and redirect_uri match the authorization request +-- 3. Validates PKCE code_verifier if code_challenge was used +-- 4. Issues a JWT access token and refresh token +-- 5. Deletes the used authorization code +-- +-- For refresh token grant: +-- +-- 1. Validates the refresh token exists +-- 2. Verifies client_id matches +-- 3. Issues a new JWT access token +-- +-- Access tokens are JWTs signed by the server with 1-hour expiry. +-- Authorization codes expire after 10 minutes. +handleTokenRequest + :: forall usr ctxt + . (ToJWT usr, HasContextEntry ctxt JWTSettings) + => MVar (OAuthState usr) + -> Context ctxt + -> TokenRequest + -> Handler TokenResponseHeaders +handleTokenRequest state_var ctxt TokenRequest{..} = do + let jwtCfg = getContextEntry ctxt + result <- + liftIO $ + modifyMVar state_var $ \state -> + processRequest jwtCfg state + case result of + Left err -> throwError (attachNoStoreError err) + Right resp -> pure (attachNoStoreHeaders resp) + where + attachNoStoreHeaders :: TokenResponse -> TokenResponseHeaders + attachNoStoreHeaders resp = + let withPragma :: Headers '[Header "Pragma" Text] TokenResponse + withPragma = addHeader ("no-cache" :: Text) resp + in addHeader ("no-store" :: Text) withPragma + + attachNoStoreError :: ServerError -> ServerError + attachNoStoreError err = + let filtered = + filter + ( \ (name, _) -> + name /= "Cache-Control" && name /= "Pragma" + ) + (errHeaders err) + in err{errHeaders = ("Cache-Control", "no-store") : ("Pragma", "no-cache") : filtered} + + processRequest + :: JWTSettings + -> OAuthState usr + -> IO (OAuthState usr, Either ServerError TokenResponse) + processRequest jwtCfg state = + case Map.lookup client_id (registered_clients state) of + Nothing -> + pure (state, Left $ tokenAuthFailure "unauthorized_client" "Client not registered") + Just client@RegisteredClient{} -> do + authCheck <- authenticateClient client + case authCheck of + Left err -> pure (state, Left err) + Right () -> processGrant jwtCfg state client + + authenticateClient :: RegisteredClient -> IO (Either ServerError ()) + authenticateClient RegisteredClient{..} + | registered_client_token_endpoint_auth_method == "client_secret_post" = + case (client_secret, registered_client_secret) of + (Just provided, Just expected) + | constTimeEq provided expected -> pure (Right ()) + | otherwise -> pure (Left $ tokenAuthFailure "invalid_client" "Invalid client secret") + _ -> pure (Left $ tokenAuthFailure "invalid_client" "Missing client secret") + | registered_client_token_endpoint_auth_method == "none" = + pure (Right ()) + | otherwise = + pure (Left $ tokenAuthFailure "invalid_client" "Unsupported client authentication method") + + processGrant + :: JWTSettings + -> OAuthState usr + -> RegisteredClient + -> IO (OAuthState usr, Either ServerError TokenResponse) + processGrant jwtCfg state client@RegisteredClient{..} + | grant_type `elem` registered_client_grant_types = + case grant_type of + "authorization_code" -> processAuthorizationCode jwtCfg state client + "refresh_token" -> processRefreshTokenGrant jwtCfg state client + _ -> pure (state, Left $ badTokenRequest "unsupported_grant_type" "Grant type not supported") + | otherwise = + pure (state, Left $ badTokenRequest "unauthorized_client" "Grant type not allowed for this client") + + processAuthorizationCode + :: JWTSettings + -> OAuthState usr + -> RegisteredClient + -> IO (OAuthState usr, Either ServerError TokenResponse) + processAuthorizationCode jwtCfg state RegisteredClient{..} = do + currentTime <- getCurrentTime + case code of + Nothing -> + pure (state, Left $ badTokenRequest "invalid_request" "Missing authorization code") + Just authCodeValue -> + case Map.lookup authCodeValue (auth_codes state) of + Nothing -> + pure (state, Left $ badTokenRequest "invalid_grant" "Invalid authorization code") + Just AuthCode{..} + | currentTime > auth_code_expiry -> + pure (state, Left $ badTokenRequest "invalid_grant" "Authorization code expired") + | auth_code_client_id /= client_id -> + pure (state, Left $ badTokenRequest "invalid_grant" "Client ID mismatch") + | otherwise -> + case redirect_uri of + Nothing -> + pure (state, Left $ badTokenRequest "invalid_request" "Missing redirect_uri") + Just ru + | ru `notElem` registered_client_redirect_uris -> + pure (state, Left $ badTokenRequest "invalid_grant" "redirect_uri not registered for client") + | auth_code_redirect_uri /= ru -> + pure (state, Left $ badTokenRequest "invalid_grant" "Redirect URI mismatch") + | otherwise -> + let allowed_scopes = T.words registered_client_scope + granted_scopes = T.words auth_code_scope + in if not (all (`elem` allowed_scopes) granted_scopes) + then pure (state, Left $ badTokenRequest "invalid_scope" "Invalid or excessive scope requested") + else + case (auth_code_challenge, auth_code_challenge_method, code_verifier) of + (Just challenge, method, Just verifier) + | verifyCodeChallenge challenge method verifier -> do + accessTokenResult <- issueAccessToken jwtCfg auth_code_user + case accessTokenResult of + Left err -> pure (state, Left err) + Right accessToken -> do + let refreshAllowed = "refresh_token" `elem` registered_client_grant_types + persistence = refresh_token_persistence state + cleanedState = + state + { auth_codes = Map.delete authCodeValue (auth_codes state) + } + if refreshAllowed + then do + newRefreshToken <- generateToken + let refreshRecord = + RefreshToken + { refresh_token_value = newRefreshToken + , refresh_token_client_id = client_id + , refresh_token_user = auth_code_user + , refresh_token_scope = auth_code_scope + } + persistRefreshToken persistence refreshRecord + pure + ( cleanedState + , Right + TokenResponse + { access_token = accessToken + , token_type = "Bearer" + , expires_in = 3600 + , refresh_token_resp = Just newRefreshToken + , scope = Just auth_code_scope + } + ) + else + pure + ( cleanedState + , Right + TokenResponse + { access_token = accessToken + , token_type = "Bearer" + , expires_in = 3600 + , refresh_token_resp = Nothing + , scope = Just auth_code_scope + } + ) + | otherwise -> + pure (state, Left $ badTokenRequest "invalid_grant" "Invalid code verifier") + _ -> + pure (state, Left $ badTokenRequest "invalid_request" "PKCE required: missing code_challenge or code_verifier") + + processRefreshTokenGrant + :: JWTSettings + -> OAuthState usr + -> RegisteredClient + -> IO (OAuthState usr, Either ServerError TokenResponse) + processRefreshTokenGrant jwtCfg state RegisteredClient{..} = + case refresh_token of + Nothing -> + pure (state, Left $ badTokenRequest "invalid_request" "Missing refresh token") + Just rtValue -> do + let persistence = refresh_token_persistence state + stored <- lookupRefreshToken persistence rtValue + case stored of + Nothing -> + pure (state, Left $ badTokenRequest "invalid_grant" "Invalid refresh token") + Just RefreshToken{..} + | refresh_token_client_id /= client_id -> + pure (state, Left $ badTokenRequest "invalid_grant" "Client ID mismatch") + | otherwise -> + let allowed_scopes = T.words registered_client_scope + granted_scopes = T.words refresh_token_scope + in if not (all (`elem` allowed_scopes) granted_scopes) + then pure (state, Left $ badTokenRequest "invalid_scope" "Invalid or excessive scope requested") + else do + accessTokenResult <- issueAccessToken jwtCfg refresh_token_user + case accessTokenResult of + Left err -> pure (state, Left err) + Right accessToken -> do + newRefreshToken <- generateToken + let newToken = + RefreshToken + { refresh_token_value = newRefreshToken + , refresh_token_client_id = client_id + , refresh_token_user = refresh_token_user + , refresh_token_scope = refresh_token_scope + } + deleteRefreshToken persistence rtValue + persistRefreshToken persistence newToken + pure + ( state + , Right + TokenResponse + { access_token = accessToken + , token_type = "Bearer" + , expires_in = 3600 + , refresh_token_resp = Just newRefreshToken + , scope = Just refresh_token_scope + } + ) + + issueAccessToken :: JWTSettings -> usr -> IO (Either ServerError Text) + issueAccessToken jwtCfg user = do + now <- getCurrentTime + jwtRes <- makeJWT user jwtCfg $ Just (addUTCTime 3600 now) + pure $ + case jwtRes of + Left _ -> Left $ internalServerError "Failed to sign access token" + Right token -> Right $ T.pack $ BSL.unpack token + + verifyCodeChallenge :: Text -> Maybe Text -> Text -> Bool + verifyCodeChallenge challenge method verifier = + case method of + Just "S256" -> + let verifier_bs = T.encodeUtf8 verifier + hash = hashWith SHA256 verifier_bs :: Digest SHA256 + hash_bs = BS.pack $ BA.unpack hash + encoded = T.decodeUtf8 $ B64URL.encodeUnpadded hash_bs + in encoded == challenge + Just "plain" -> challenge == verifier + Nothing -> challenge == verifier + _ -> False + + badTokenRequest :: Text -> Text -> ServerError + badTokenRequest error_code error_description = + oauthErrorResponse err400 error_code (Just error_description) + + tokenAuthFailure :: Text -> Text -> ServerError + tokenAuthFailure error_code error_description = + addAuthChallenge $ + oauthErrorResponse err401 error_code (Just error_description) + + internalServerError :: Text -> ServerError + internalServerError message = + oauthErrorResponse err500 "server_error" (Just message) + + addAuthChallenge :: ServerError -> ServerError + addAuthChallenge err = + let headerName = "WWW-Authenticate" + challengeHeader = (headerName, BS8.pack "Basic realm=\"oauth\"") + filteredHeaders = filter ((/= headerName) . fst) (errHeaders err) + in err{errHeaders = challengeHeader : filteredHeaders} diff --git a/src/Web/OAuth2/Types.hs b/src/Web/OAuth2/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/OAuth2/Types.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module: Web.OAuth2.Types +-- Copyright: (c) DPella AB 2025 +-- License: MPL-2.0 +-- Maintainer: , +-- +-- Core types and data structures for the OAuth 2.1 implementation. +-- +-- This module defines the fundamental types used throughout the OAuth system: +-- * Authorization codes with expiry and PKCE parameters +-- * Refresh tokens for long-lived access +-- * Client registrations with allowed grants and scopes +-- * Server state management +-- +-- The types support the OAuth 2.1 authorization code flow with PKCE +-- as defined in RFC 6749 and RFC 7636. +module Web.OAuth2.Types where + +import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar) +import Data.Aeson (defaultOptions, encode, omitNothingFields) +import Data.Aeson.TH (deriveJSON) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Time.Clock +import GHC.Generics +import Network.HTTP.Types (hContentType) +import Network.URI +import Servant (Context, HasContextEntry) +import Servant.Auth.Server (AuthResult (..)) +import Text.Blaze.Html5 (Html) +import Servant.Server (ServerError (..)) +import Crypto.Random (getRandomBytes) +import Data.ByteArray qualified as BA +import Data.ByteString.Base64.URL qualified as B64URL + +-- | Authorization code issued after successful authentication. +-- +-- Authorization codes are short-lived (10 minutes) and single-use. +-- They must be exchanged for access tokens at the token endpoint. +data AuthCode usr = AuthCode + { auth_code_value :: Text + -- ^ The authorization code value + , auth_code_client_id :: Text + -- ^ Client that requested this code + , auth_code_user :: usr + -- ^ Authenticated user + , auth_code_redirect_uri :: Text + -- ^ Redirect URI that must match token request + , auth_code_scope :: Text + -- ^ Granted scope + , auth_code_expiry :: UTCTime + -- ^ When this code expires + , auth_code_challenge :: Maybe Text + -- ^ PKCE code challenge + , auth_code_challenge_method :: Maybe Text + -- ^ PKCE challenge method (S256 or plain) + } + +-- | Refresh token for obtaining new access tokens. +-- +-- Refresh tokens are long-lived and can be used multiple times +-- to obtain new access tokens when the current one expires. +data RefreshToken usr = RefreshToken + { refresh_token_value :: Text + -- ^ The refresh token value + , refresh_token_client_id :: Text + -- ^ Client that owns this token + , refresh_token_user :: usr + -- ^ User associated with this token + , refresh_token_scope :: Text + -- ^ Maximum scope for new access tokens + } + +-- | Persistence callbacks for refresh tokens. +data RefreshTokenPersistence usr = RefreshTokenPersistence + { persistRefreshToken :: RefreshToken usr -> IO () + -- ^ Persist a refresh token + , deleteRefreshToken :: Text -> IO () + -- ^ Delete a persisted refresh token by its value + , lookupRefreshToken :: Text -> IO (Maybe (RefreshToken usr)) + -- ^ Lookup a refresh token + } + +-- | Default Map-backed refresh token persistence implementation. +mkDefaultRefreshTokenPersistence :: IO (RefreshTokenPersistence usr) +mkDefaultRefreshTokenPersistence = do + rt_st <- newMVar Map.empty + pure + RefreshTokenPersistence + { persistRefreshToken = \rt -> modifyMVar_ rt_st $ \mp -> + pure (Map.insert (refresh_token_value rt) rt mp) + , deleteRefreshToken = \tok -> modifyMVar_ rt_st $ \mp -> + pure (Map.delete tok mp) + , lookupRefreshToken = \tok -> + readMVar rt_st >>= \mp -> + pure (Map.lookup tok mp) + } + +-- | OAuth client registration information. +-- +-- Contains all metadata about a registered OAuth client including +-- allowed redirect URIs, grant types, and maximum requestable scope. +data RegisteredClient = RegisteredClient + { registered_client_id :: Text + -- ^ Unique registered_client identifier + , registered_client_name :: Text + -- ^ Human-readable registered_client name + , registered_client_secret :: Maybe Text + -- ^ Secret for confidential registered_clients (Nothing for public registered_clients) + , registered_client_redirect_uris :: [Text] + -- ^ Allowed redirect URIs + , registered_client_grant_types :: [Text] + -- ^ Allowed OAuth grant types + , registered_client_response_types :: [Text] + -- ^ Allowed OAuth response types + , registered_client_scope :: Text + -- ^ Maximum scope this registered_client can request + , registered_client_token_endpoint_auth_method :: Text + -- ^ Required auth method at token endpoint + , registered_client_registration_access_token :: Maybe Text + -- ^ Registration access token issued for dynamic client management + } + deriving (Eq, Show) + +-- | Parameters passed to the login form renderer. +-- +-- Custom renderers must produce an HTML form that POSTs to +-- @authorize\/callback@ with at least the following fields: +-- +-- * @username@ — the user's login name +-- * @password@ — the user's password +-- * @client_id@ — copied from 'lfp_client_id' +-- * @redirect_uri@ — copied from 'lfp_redirect_uri' +-- * @scope@ — copied from 'lfp_scope' +-- * @state@ — copied from 'lfp_state' when present +-- * @code_challenge@ — copied from 'lfp_code_challenge' when present +-- * @code_challenge_method@ — copied from 'lfp_code_challenge_method' when present +data LoginFormParams = LoginFormParams + { lfp_client_id :: Text + -- ^ OAuth client identifier + , lfp_redirect_uri :: Text + -- ^ Client's registered redirect URI + , lfp_scope :: Text + -- ^ Space-delimited requested scopes + , lfp_state :: Maybe Text + -- ^ Client's opaque state parameter + , lfp_code_challenge :: Maybe Text + -- ^ PKCE code challenge + , lfp_code_challenge_method :: Maybe Text + -- ^ PKCE challenge method (@S256@ or @plain@) + , lfp_error :: Maybe Text + -- ^ Error from a previous login attempt (e.g. @invalid_password@) + } + +-- | Global state for the OAuth authorization server. +-- +-- Maintains all active authorization codes, refresh tokens, +-- and registered clients. This state is shared across all +-- OAuth endpoints via an MVar. +data OAuthState usr = OAuthState + { auth_codes :: Map.Map Text (AuthCode usr) + -- ^ Active authorization codes indexed by code value + , refresh_token_persistence :: RefreshTokenPersistence usr + -- ^ Persistence layer for refresh tokens + , registered_clients :: Map.Map Text RegisteredClient + -- ^ Registered clients indexed by client_idQ + , oauth_url :: Text + -- ^ Base URL for the OAuth server + , oauth_port :: Int + -- ^ Port for the OAuth server + , login_form_renderer :: LoginFormParams -> Html + -- ^ Render the authorization login form. Use 'defaultLoginFormRenderer' + -- from "Web.OAuth2.AuthorizeAPI" for the built-in page, or supply your + -- own function. + } + +-- | Represents errors that can occur during the OAuth authentication process. +-- +-- The 'OAuthError' type is used to capture and describe various error conditions +-- that may arise when handling OAuth flows, such as invalid credentials, expired tokens, +-- missing parameters, or network issues. Each constructor of this type provides +-- information about a specific kind of OAuth-related failure, which can be used +-- for error handling, logging, or user feedback. +data OAuthError = OAuthError + { error :: Text + , error_description :: Maybe Text + , error_uri :: Maybe Text + } + deriving (Generic) + +$( deriveJSON + defaultOptions{omitNothingFields = True} + ''OAuthError + ) + +-- | Constructs an 'OAuthError' value with the given error message. +-- The resulting 'OAuthError' will have the provided error text, +-- and 'Nothing' for the optional description and URI fields. +oAuthError :: Text -> OAuthError +oAuthError err = OAuthError err Nothing Nothing + +-- | Attach an OAuthError JSON payload to a Servant ServerError. +jsonErrorResponse :: ServerError -> OAuthError -> ServerError +jsonErrorResponse base oauthErr = + let contentHeader = (hContentType, "application/json; charset=utf-8") + filteredHeaders = filter ((/= hContentType) . fst) (errHeaders base) + in base + { errBody = encode oauthErr + , errHeaders = contentHeader : filteredHeaders + } + +-- | Convenience helper to build a JSON OAuth error response. +oauthErrorResponse :: ServerError -> Text -> Maybe Text -> ServerError +oauthErrorResponse base code description = + jsonErrorResponse base (oAuthError code){error_description = description} + +-- | Initialize an empty OAuth server state. +-- +-- Creates a new OAuth state with no registered clients, +-- authorization codes, or refresh tokens. +initOAuthState + :: forall usr + . Text + -> Int + -> RefreshTokenPersistence usr + -> (LoginFormParams -> Html) + -> OAuthState usr +initOAuthState url port rtp renderer = + OAuthState + { auth_codes = Map.empty + , refresh_token_persistence = rtp + , registered_clients = Map.empty + , oauth_url = url + , oauth_port = port + , login_form_renderer = renderer + } + +-- | Type alias for token values (authorization codes, refresh tokens, client IDs). +type Token = Text + +-- | Generate a cryptographically secure random token. +-- +-- Produces a Base64URL-encoded token derived from 32 bytes of +-- cryptographic entropy. The output is URL-safe and suitable for +-- use as authorization codes, refresh tokens, or client identifiers. +generateToken :: IO Token +generateToken = do + bytes <- getRandomBytes 32 + pure $ TE.decodeUtf8 (B64URL.encodeUnpadded bytes) + +-- | Normalize the configured base URL ensuring the desired port is present. +normalizeBaseUrl :: Text -> Int -> Text +normalizeBaseUrl rawUrl port = + case parseURI (T.unpack rawUrl) of + Just uri -> + case uriAuthority uri of + Just auth -> + let hasPort = not (null (uriPort auth)) + desiredPort = if port > 0 then ":" <> show port else "" + authWithPort = + if hasPort || null desiredPort + then auth + else auth{uriPort = desiredPort} + normalizedUri = uri{uriAuthority = Just authWithPort} + in T.pack (uriToString id normalizedUri "") + Nothing -> appendPortFallback rawUrl port + Nothing -> appendPortFallback rawUrl port + where + appendPortFallback :: Text -> Int -> Text + appendPortFallback url port' = + let portTxt = ":" <> T.pack (show port') + in if port' <= 0 || portTxt `T.isInfixOf` url + then url + else + let (prefix, suffix) = T.breakOn "/" url + in if T.null suffix + then url <> portTxt + else prefix <> portTxt <> suffix + +-- | Remove any trailing '/' from a URL. +stripTrailingSlash :: Text -> Text +stripTrailingSlash = T.dropWhileEnd (== '/') + +-- | Append a path segment to a base URL, preserving fragments. +appendPathSegment :: Text -> Text -> Text +appendPathSegment base segment = + let (baseWithoutFragment, fragmentPart) = T.breakOn "#" base + baseStripped = + if T.null baseWithoutFragment + then baseWithoutFragment + else T.dropWhileEnd (== '/') baseWithoutFragment + combined = baseStripped <> segment + in combined <> fragmentPart + +-- | Constant-time equality comparison for Text values. +-- +-- Prevents timing side-channel attacks when comparing secrets, +-- tokens, or other security-sensitive strings. +constTimeEq :: Text -> Text -> Bool +constTimeEq a b = BA.constEq (TE.encodeUtf8 a) (TE.encodeUtf8 b) + +-- | Class for verifying user credentials from username and password +class FormAuth usr where + type FormAuthSettings usr + runFormAuth + :: (HasContextEntry ctxt (FormAuthSettings usr)) + => Context ctxt + -> Text + -> Text + -> IO (AuthResult usr) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,24 @@ +module Main where + +import Test.Tasty +import qualified Web.OAuth2.AuthorizeCallbackSpec +import qualified Web.OAuth2.AuthorizeSpec +import qualified Web.OAuth2.FlowSpec +import qualified Web.OAuth2.MetadataSpec +import qualified Web.OAuth2.RegisterSpec +import qualified Web.OAuth2.TokenSpec + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "OAuth Tests" + [ Web.OAuth2.MetadataSpec.tests + , Web.OAuth2.RegisterSpec.tests + , Web.OAuth2.AuthorizeSpec.tests + , Web.OAuth2.AuthorizeCallbackSpec.tests + , Web.OAuth2.TokenSpec.tests + , Web.OAuth2.FlowSpec.tests + ] diff --git a/test/Web/OAuth2/AuthorizeCallbackSpec.hs b/test/Web/OAuth2/AuthorizeCallbackSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/OAuth2/AuthorizeCallbackSpec.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +module Web.OAuth2.AuthorizeCallbackSpec (tests) where + +import Control.Concurrent.MVar (MVar, readMVar) +import Data.Aeson (eitherDecode) +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Time.Clock (addUTCTime, getCurrentTime) +import Network.HTTP.Types (hContentType, hLocation, methodPost, status303, status400) +import Network.Wai (Application, requestHeaders, requestMethod) +import Network.Wai.Test +import Test.Tasty +import Test.Tasty.HUnit +import Web.OAuth2.TestUtils +import Web.OAuth2.Types + +tests :: TestTree +tests = + testGroup + "Authorize callback endpoint" + [ successfulLoginIssuesAuthCode + , invalidCredentialsRedirectBack + , rejectsTamperedRedirectUri + , rejectsInvalidScope + , rejectsMissingPkce + , successfulLoginWithoutStateSkipsEcho + ] + +withApp :: (MVar (OAuthState TestUser) -> Application -> IO a) -> IO a +withApp action = do + (stateVar, _ctx, app) <- createTestApplication + addRegisteredClientToState stateVar (mkPublicClient "client-1" ["http://localhost:4000/cb"] "read write") + action stateVar app + +successfulLoginIssuesAuthCode :: TestTree +successfulLoginIssuesAuthCode = testCase "stores auth code and redirects with state" $ + withApp $ \stateVar app -> do + now <- getCurrentTime + let challenge = "verifier123" + formBody = + encodeForm + [ ("username", "testuser") + , ("password", "testpass") + , ("client_id", "client-1") + , ("redirect_uri", "http://localhost:4000/cb") + , ("scope", "read") + , ("state", "my-state") + , ("code_challenge", challenge) + , ("code_challenge_method", "plain") + ] + req = + SRequest + ( setPath defaultRequest "/authorize/callback" + ){ requestMethod = methodPost + , requestHeaders = [(hContentType, "application/x-www-form-urlencoded")] + } + formBody + res <- runSession (srequest req) app + simpleStatus res @?= status303 + let location = lookup hLocation (simpleHeaders res) + case location of + Nothing -> assertFailure "Location header missing" + Just loc -> do + let locText = TE.decodeUtf8 loc + assertBool "state propagated" ("state=my-state" `T.isInfixOf` locText) + assertBool "authorization code parameter present" ("code=" `T.isInfixOf` locText) + + st <- readMVar stateVar + let codes = Map.elems (auth_codes st) + assertBool "auth code stored" (not (null codes)) + stored <- case codes of + (x:_) -> pure x + [] -> assertFailure "no auth codes stored" + auth_code_client_id stored @?= "client-1" + auth_code_scope stored @?= "read" + auth_code_challenge stored @?= Just challenge + auth_code_challenge_method stored @?= Just "plain" + assertBool "expiry in future" (auth_code_expiry stored > addUTCTime (-1) now) + +invalidCredentialsRedirectBack :: TestTree +invalidCredentialsRedirectBack = testCase "redirects back to authorize with error=invalid_password" $ + withApp $ \stateVar app -> do + let formBody = + encodeForm + [ ("username", "testuser") + , ("password", "wrong") + , ("client_id", "client-1") + , ("redirect_uri", "http://localhost:4000/cb") + , ("scope", "read write") + , ("state", "orig-state") + , ("code_challenge", "abc") + , ("code_challenge_method", "S256") + ] + req = + SRequest + ( setPath defaultRequest "/authorize/callback" + ){ requestMethod = methodPost + , requestHeaders = [(hContentType, "application/x-www-form-urlencoded")] + } + formBody + res <- runSession (srequest req) app + simpleStatus res @?= status303 + let location = lookup hLocation (simpleHeaders res) + case location of + Nothing -> assertFailure "Location header missing" + Just loc -> do + let locText = TE.decodeUtf8 loc + assertBool "redirected to authorize" ("../authorize" `T.isPrefixOf` locText) + assertBool "state preserved" ("state=orig-state" `T.isInfixOf` locText) + assertBool "error flag propagated" ("error=invalid_password" `T.isInfixOf` locText) + + st <- readMVar stateVar + Map.size (auth_codes st) @?= 0 + +rejectsTamperedRedirectUri :: TestTree +rejectsTamperedRedirectUri = testCase "rejects redirect_uri not registered for client" $ + withApp $ \stateVar app -> do + let formBody = + encodeForm + [ ("username", "testuser") + , ("password", "testpass") + , ("client_id", "client-1") + , ("redirect_uri", "https://attacker.invalid/cb") + , ("scope", "read") + , ("state", "state-1") + , ("code_challenge", "challenge") + , ("code_challenge_method", "plain") + ] + req = + SRequest + ( setPath defaultRequest "/authorize/callback" + ){ requestMethod = methodPost + , requestHeaders = [(hContentType, "application/x-www-form-urlencoded")] + } + formBody + res <- runSession (srequest req) app + simpleStatus res @?= status400 + lookup hContentType (simpleHeaders res) @?= Just "application/json; charset=utf-8" + err <- decodeError (simpleBody res) + Web.OAuth2.Types.error err @?= "unauthorized_client" + st <- readMVar stateVar + Map.size (auth_codes st) @?= 0 + +rejectsInvalidScope :: TestTree +rejectsInvalidScope = testCase "rejects scope escalation attempts" $ + withApp $ \stateVar app -> do + let formBody = + encodeForm + [ ("username", "testuser") + , ("password", "testpass") + , ("client_id", "client-1") + , ("redirect_uri", "http://localhost:4000/cb") + , ("scope", "admin") + , ("state", "state-2") + , ("code_challenge", "challenge") + , ("code_challenge_method", "plain") + ] + req = + SRequest + ( setPath defaultRequest "/authorize/callback" + ){ requestMethod = methodPost + , requestHeaders = [(hContentType, "application/x-www-form-urlencoded")] + } + formBody + res <- runSession (srequest req) app + simpleStatus res @?= status400 + lookup hContentType (simpleHeaders res) @?= Just "application/json; charset=utf-8" + err <- decodeError (simpleBody res) + Web.OAuth2.Types.error err @?= "invalid_scope" + st <- readMVar stateVar + Map.size (auth_codes st) @?= 0 + +rejectsMissingPkce :: TestTree +rejectsMissingPkce = testCase "rejects requests missing PKCE code_challenge" $ + withApp $ \stateVar app -> do + let formBody = + encodeForm + [ ("username", "testuser") + , ("password", "testpass") + , ("client_id", "client-1") + , ("redirect_uri", "http://localhost:4000/cb") + , ("scope", "read") + , ("state", "state-3") + ] + req = + SRequest + ( setPath defaultRequest "/authorize/callback" + ){ requestMethod = methodPost + , requestHeaders = [(hContentType, "application/x-www-form-urlencoded")] + } + formBody + res <- runSession (srequest req) app + simpleStatus res @?= status400 + lookup hContentType (simpleHeaders res) @?= Just "application/json; charset=utf-8" + err <- decodeError (simpleBody res) + Web.OAuth2.Types.error err @?= "invalid_request" + st <- readMVar stateVar + Map.size (auth_codes st) @?= 0 + +successfulLoginWithoutStateSkipsEcho :: TestTree +successfulLoginWithoutStateSkipsEcho = testCase "does not add state parameter when none provided" $ + withApp $ \stateVar app -> do + let challenge = "verifier456" + formBody = + encodeForm + [ ("username", "testuser") + , ("password", "testpass") + , ("client_id", "client-1") + , ("redirect_uri", "http://localhost:4000/cb") + , ("scope", "read") + , ("code_challenge", challenge) + , ("code_challenge_method", "plain") + ] + req = + SRequest + ( setPath defaultRequest "/authorize/callback" + ){ requestMethod = methodPost + , requestHeaders = [(hContentType, "application/x-www-form-urlencoded")] + } + formBody + res <- runSession (srequest req) app + simpleStatus res @?= status303 + let location = lookup hLocation (simpleHeaders res) + case location of + Nothing -> assertFailure "Location header missing" + Just loc -> do + let locText = TE.decodeUtf8 loc + assertBool "redirected to provided redirect_uri" ("http://localhost:4000/cb" `T.isPrefixOf` locText) + assertBool "state parameter absent" (not ("state=" `T.isInfixOf` locText)) + st <- readMVar stateVar + Map.size (auth_codes st) @?= 1 + +decodeError :: LBS.ByteString -> IO OAuthError +decodeError body = + case eitherDecode body of + Left msg -> assertFailure ("Failed to decode OAuth error: " <> msg) + Right v -> pure v diff --git a/test/Web/OAuth2/AuthorizeSpec.hs b/test/Web/OAuth2/AuthorizeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/OAuth2/AuthorizeSpec.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Web.OAuth2.AuthorizeSpec (tests) where + +import Control.Concurrent.MVar (MVar, newMVar) +import Data.Aeson (eitherDecode) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Network.HTTP.Types (hContentType, status200, status303, status400, status401) +import Network.HTTP.Types.URI (renderQuery) +import Network.Wai (Application) +import Network.Wai.Test +import Servant (Proxy (..), serveWithContext) +import Test.Tasty +import Test.Tasty.HUnit +import Text.Blaze.Html5 qualified as H +import Web.OAuth2 (OAuthAPI, oAuthAPI) +import Web.OAuth2.Internal (validateScope) +import Web.OAuth2.TestUtils +import Web.OAuth2.Types hiding (error) +import Web.OAuth2.Types qualified as OAuthTypes + +tests :: TestTree +tests = + testGroup + "Authorize endpoint" + [ rejectsUnknownClient + , rejectsMismatchedRedirect + , rejectsInvalidScope + , rendersLoginFormWithPkce + , echoesErrorMessage + , omitsStateHiddenFieldWhenAbsent + , missingParametersReturnInvalidRequest + , rejectsUnsupportedResponseType + , usesCustomLoginFormRenderer + , validateScopeTests + ] + +withApp :: (MVar (OAuthState TestUser) -> Application -> IO a) -> IO a +withApp action = do + (stateVar, _ctx, app) <- createTestApplication + action stateVar app + +reconstructError :: LBS.ByteString -> IO OAuthError +reconstructError body = + case eitherDecode body of + Left err -> assertFailure ("Failed to decode OAuthError: " <> err) + Right val -> pure val + +rejectsUnknownClient :: TestTree +rejectsUnknownClient = testCase "returns 401 for unknown client_id" $ + withApp $ \_ app -> do + let query = + [ ("response_type", Just "code") + , ("client_id", Just "missing-client") + , ("redirect_uri", Just "http://localhost:4000/cb") + , ("scope", Just "read") + , ("state", Just "state-1") + ] + path = BS.concat ["/authorize", renderQuery True query] + res <- + runSession + (srequest (SRequest (setPath defaultRequest path) LBS.empty)) + app + simpleStatus res @?= status401 + errResp <- reconstructError (simpleBody res) + OAuthTypes.error errResp @?= "unauthorized_client" + +rejectsMismatchedRedirect :: TestTree +rejectsMismatchedRedirect = testCase "400 when redirect_uri not registered" $ + withApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "cid-1" ["http://localhost:4000/callback"] "read write") + let query = + [ ("response_type", Just "code") + , ("client_id", Just "cid-1") + , ("redirect_uri", Just "http://localhost:4000/evil") + , ("scope", Just "read") + , ("state", Just "s") + ] + path = BS.concat ["/authorize", renderQuery True query] + res <- + runSession + (srequest (SRequest (setPath defaultRequest path) LBS.empty)) + app + simpleStatus res @?= status400 + errResp <- reconstructError (simpleBody res) + OAuthTypes.error errResp @?= "unauthorized_client" + +rejectsInvalidScope :: TestTree +rejectsInvalidScope = testCase "redirects with invalid_scope when request exceeds client allow list" $ + withApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "cid-2" ["http://localhost:4000/callback"] "read write") + let query = + [ ("response_type", Just "code") + , ("client_id", Just "cid-2") + , ("redirect_uri", Just "http://localhost:4000/callback") + , ("scope", Just "admin") + , ("state", Just "s") + ] + path = BS.concat ["/authorize", renderQuery True query] + res <- + runSession + (srequest (SRequest (setPath defaultRequest path) LBS.empty)) + app + simpleStatus res @?= status303 + case lookup "Location" (simpleHeaders res) of + Nothing -> assertFailure "Location header missing on invalid scope redirect" + Just loc -> do + let locText = TE.decodeUtf8 loc + assertBool "redirect URI preserved" ("http://localhost:4000/callback" `T.isPrefixOf` locText) + assertBool "invalid_scope error included" ("error=invalid_scope" `T.isInfixOf` locText) + assertBool "state propagated" ("state=s" `T.isInfixOf` locText) + +omitsStateHiddenFieldWhenAbsent :: TestTree +omitsStateHiddenFieldWhenAbsent = testCase "does not propagate state when request omitted it" $ + withApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "cid-5" ["http://localhost:4000/cb"] "read") + let query = + [ ("response_type", Just "code") + , ("client_id", Just "cid-5") + , ("redirect_uri", Just "http://localhost:4000/cb") + , ("scope", Just "read") + ] + path = BS.concat ["/authorize", renderQuery True query] + res <- + runSession + (srequest (SRequest (setPath defaultRequest path) LBS.empty)) + app + simpleStatus res @?= status200 + let bodyTxt = LBS.toStrict (simpleBody res) + assertBool "state input absent" (not ("name=\"state\"" `BS.isInfixOf` bodyTxt)) + +missingParametersReturnInvalidRequest :: TestTree +missingParametersReturnInvalidRequest = testCase "returns JSON invalid_request when required params absent" $ + withApp $ \_ app -> do + res <- + runSession + (srequest (SRequest (setPath defaultRequest "/authorize") LBS.empty)) + app + simpleStatus res @?= status400 + lookup hContentType (simpleHeaders res) @?= Just "application/json; charset=utf-8" + errResp <- reconstructError (simpleBody res) + OAuthTypes.error errResp @?= "invalid_request" + +rendersLoginFormWithPkce :: TestTree +rendersLoginFormWithPkce = testCase "renders login form for valid request including PKCE fields" $ + withApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "cid-3" ["http://localhost:4000/cb"] "read write") + let query = + [ ("response_type", Just "code") + , ("client_id", Just "cid-3") + , ("redirect_uri", Just "http://localhost:4000/cb") + , ("scope", Just "read write") + , ("state", Just "xyz") + , ("code_challenge", Just "pkce-challenge") + , ("code_challenge_method", Just "S256") + ] + path = BS.concat ["/authorize", renderQuery True query] + res <- + runSession + (srequest (SRequest (setPath defaultRequest path) LBS.empty)) + app + simpleStatus res @?= status200 + let bodyTxt = LBS.toStrict (simpleBody res) + assertBool "code_challenge field present" ("name=\"code_challenge\"" `BS.isInfixOf` bodyTxt) + assertBool "code_challenge_method field present" ("name=\"code_challenge_method\"" `BS.isInfixOf` bodyTxt) + assertBool "state preserved" ("value=\"xyz\"" `BS.isInfixOf` bodyTxt) + +echoesErrorMessage :: TestTree +echoesErrorMessage = testCase "renders login form with error message when provided" $ + withApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "cid-4" ["http://localhost:4000/cb"] "read") + let query = + [ ("response_type", Just "code") + , ("client_id", Just "cid-4") + , ("redirect_uri", Just "http://localhost:4000/cb") + , ("scope", Just "read") + , ("state", Just "s") + , ("error", Just "invalid_password") + ] + path = BS.concat ["/authorize", renderQuery True query] + res <- + runSession + (srequest (SRequest (setPath defaultRequest path) LBS.empty)) + app + simpleStatus res @?= status200 + let bodyTxt = LBS.toStrict (simpleBody res) + assertBool "error message rendered" ("Invalid username or password" `BS.isInfixOf` bodyTxt) + +rejectsUnsupportedResponseType :: TestTree +rejectsUnsupportedResponseType = testCase "rejects response_type=token with unsupported_response_type" $ + withApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "cid-6" ["http://localhost:4000/cb"] "read") + let query = + [ ("response_type", Just "token") + , ("client_id", Just "cid-6") + , ("redirect_uri", Just "http://localhost:4000/cb") + , ("scope", Just "read") + ] + path = BS.concat ["/authorize", renderQuery True query] + res <- + runSession + (srequest (SRequest (setPath defaultRequest path) LBS.empty)) + app + simpleStatus res @?= status400 + errResp <- reconstructError (simpleBody res) + OAuthTypes.error errResp @?= "unsupported_response_type" + +usesCustomLoginFormRenderer :: TestTree +usesCustomLoginFormRenderer = testCase "authorize endpoint invokes custom login_form_renderer" $ do + let customRenderer _params = H.unsafeByteString "CUSTOM_FORM" + persistence <- mkDefaultRefreshTokenPersistence + stateVar <- newMVar (initOAuthState @TestUser "http://localhost:8080" 8080 persistence customRenderer) + addRegisteredClientToState stateVar (mkPublicClient "cid-custom" ["http://localhost:4000/cb"] "read") + ctx <- createTestContext + let app = serveWithContext (Proxy :: Proxy OAuthAPI) ctx (oAuthAPI stateVar ctx) + query = + [ ("response_type", Just "code") + , ("client_id", Just "cid-custom") + , ("redirect_uri", Just "http://localhost:4000/cb") + , ("scope", Just "read") + , ("state", Just "xyz") + , ("code_challenge", Just "test-challenge") + , ("code_challenge_method", Just "S256") + ] + path = BS.concat ["/authorize", renderQuery True query] + res <- + runSession + (srequest (SRequest (setPath defaultRequest path) LBS.empty)) + app + simpleStatus res @?= status200 + let bodyTxt = LBS.toStrict (simpleBody res) + assertBool "custom renderer output present" ("CUSTOM_FORM" `BS.isInfixOf` bodyTxt) + assertBool "default form not rendered" (not ("Sign In" `BS.isInfixOf` bodyTxt)) + +validateScopeTests :: TestTree +validateScopeTests = + testGroup + "validateScope" + [ testCase "single scope within allowed" $ + validateScope "read" "read write" @?= True + , testCase "multiple scopes within allowed" $ + validateScope "read write" "read write admin" @?= True + , testCase "exact match" $ + validateScope "read write" "read write" @?= True + , testCase "rejects scope not in allowed list" $ + validateScope "admin" "read write" @?= False + , testCase "rejects partially invalid scope" $ + validateScope "read admin" "read write" @?= False + , testCase "rejects empty requested scope" $ + validateScope "" "read write" @?= False + , testCase "duplicate requested scopes still valid" $ + validateScope "read read" "read write" @?= True + , testCase "extra whitespace handled" $ + validateScope "read write" "read write" @?= True + ] diff --git a/test/Web/OAuth2/FlowSpec.hs b/test/Web/OAuth2/FlowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/OAuth2/FlowSpec.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Web.OAuth2.FlowSpec (tests) where + +import Control.Concurrent.MVar +import Control.Monad.IO.Class (MonadIO, liftIO) +import Crypto.Hash (Digest, SHA256 (..), hashWith) +import Data.Aeson (Value (..), eitherDecode, object, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KM +import Data.ByteArray qualified as BA +import Data.ByteString qualified as BS +import Data.ByteString.Base64.URL qualified as B64URL +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable (toList) +import Data.List (find) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust, isJust) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Time.Clock +import Network.HTTP.Types (hContentType, hLocation, methodPost, status200, status201, status303) +import Network.Wai (requestHeaders, requestMethod) +import Network.Wai.Test +import Servant +import Test.Tasty +import Test.Tasty.HUnit +import Web.OAuth2 (OAuthAPI, oAuthAPI) +import Web.OAuth2.TestUtils +import Web.OAuth2.Types + +tests :: TestTree +tests = testGroup "OAuth End-to-End Flow" [commonFlow] + +commonFlow :: TestTree +commonFlow = testCase "Dynamic registration -> authorize -> token -> refresh" $ do + stateVar <- emptyOAuthState + ctx <- createTestContext + let app :: Application + app = serveWithContext (Proxy :: Proxy OAuthAPI) ctx (oAuthAPI stateVar ctx) + + metadataValue <- + runSession + ( do + let req = setPath defaultRequest "/.well-known/oauth-authorization-server" + res <- srequest (SRequest req LBS.empty) + liftIO $ assertEqual "metadata status" status200 (simpleStatus res) + case eitherDecode (simpleBody res) :: Either String Value of + Left e -> abort e + Right v -> pure v + ) + app + metadataObj <- + case metadataValue of + Object o -> pure o + _ -> abort "unexpected metadata response" + issuerValue <- lookupText "issuer" metadataObj + authorizeEndpointValue <- lookupText "authorization_endpoint" metadataObj + tokenEndpointValue <- lookupText "token_endpoint" metadataObj + registerEndpointValue <- lookupText "registration_endpoint" metadataObj + issuerValue @?= "http://localhost:8080" + authorizeEndpointValue @?= "http://localhost:8080/authorize" + tokenEndpointValue @?= "http://localhost:8080/token" + registerEndpointValue @?= "http://localhost:8080/register" + case KM.lookup "token_endpoint_auth_methods_supported" metadataObj of + Just (Array arr) -> toList arr @?= [String "none", String "client_secret_post"] + _ -> abort "token_endpoint_auth_methods_supported missing" + case KM.lookup "scopes_supported" metadataObj of + Just (Array arr) -> toList arr @?= [String "read", String "write"] + _ -> abort "scopes_supported missing" + + let redirectUri = "http://localhost:4000/cb" + regResponsePublic <- + runSession + ( do + let body = + object + [ "client_name" .= ("Test SPA" :: Text) + , "redirect_uris" .= [redirectUri] + , "grant_types" .= (["authorization_code", "refresh_token"] :: [Text]) + , "response_types" .= (["code"] :: [Text]) + , "scope" .= ("read write" :: Text) + , "token_endpoint_auth_method" .= ("none" :: Text) + ] + req = + SRequest + (setPath defaultRequest "/register") + { requestMethod = methodPost + , requestHeaders = [(hContentType, "application/json")] + } + (Aeson.encode body) + res <- srequest req + liftIO $ assertEqual "register status" status201 (simpleStatus res) + case eitherDecode (simpleBody res) :: Either String Value of + Left e -> abort e + Right v -> pure v + ) + app + publicObj <- valueToObject regResponsePublic + clientId <- lookupTextFromObject "client_id" publicObj + registrationToken <- lookupTextFromObject "registration_access_token" publicObj + registrationUri <- lookupTextFromObject "registration_client_uri" publicObj + assertBool "public client secret omitted" (KM.lookup "client_secret" publicObj == Nothing) + assertBool "public client secret expiry omitted" (KM.lookup "client_secret_expires_at" publicObj == Nothing) + assertBool "registration access token present" (not (T.null registrationToken)) + assertBool "registration client URI includes register path" ("/register/" `T.isInfixOf` registrationUri) + + st1 <- readMVar stateVar + case Map.lookup clientId (registered_clients st1) of + Nothing -> assertFailure "client not inserted in state" + Just c -> do + registered_client_token_endpoint_auth_method c @?= "none" + registered_client_grant_types c @?= ["authorization_code", "refresh_token"] + registered_client_registration_access_token c @?= Just registrationToken + + now <- getCurrentTime + verifier <- pure "verifier-value" + let challenge = base64UrlHash verifier + authorizeQuery = + encodeForm + [ ("response_type", "code") + , ("client_id", clientId) + , ("redirect_uri", redirectUri) + , ("scope", "read") + , ("state", "state-xyz") + , ("code_challenge", challenge) + , ("code_challenge_method", "S256") + ] + _ <- + runSession + ( do + let req = setPath defaultRequest (BS.concat ["/authorize?", LBS.toStrict authorizeQuery]) + res <- srequest (SRequest req LBS.empty) + liftIO $ assertEqual "authorize status" status200 (simpleStatus res) + ) + app + + loginRes <- + runSession + ( do + let formBody = + encodeForm + [ ("username", "testuser") + , ("password", "testpass") + , ("client_id", clientId) + , ("redirect_uri", redirectUri) + , ("scope", "read") + , ("state", "state-xyz") + , ("code_challenge", challenge) + , ("code_challenge_method", "S256") + ] + req = + SRequest + (setPath defaultRequest "/authorize/callback") + { requestMethod = methodPost + , requestHeaders = [(hContentType, "application/x-www-form-urlencoded")] + } + formBody + res <- srequest req + liftIO $ assertEqual "callback redirect" status303 (simpleStatus res) + pure res + ) + app + case lookup hLocation (simpleHeaders loginRes) of + Nothing -> assertFailure "authorize callback missing Location" + Just loc -> do + let locText = TE.decodeUtf8 loc + assertBool "redirect URI echoed" (redirectUri `T.isPrefixOf` locText) + assertBool "state parameter included" ("state=state-xyz" `T.isInfixOf` locText) + + st2 <- readMVar stateVar + let ac = fromJust $ find ((== clientId) . auth_code_client_id) (Map.elems (auth_codes st2)) + auth_code_challenge ac @?= Just challenge + auth_code_challenge_method ac @?= Just "S256" + assertBool "expiry set in future" (auth_code_expiry ac > now) + + (accessTokenValue, refreshTokenValue) <- + runSession + ( do + let formBody = + encodeForm + [ ("grant_type", "authorization_code") + , ("code", auth_code_value ac) + , ("redirect_uri", redirectUri) + , ("client_id", clientId) + , ("code_verifier", verifier) + ] + req = + SRequest + (setPath defaultRequest "/token") + { requestMethod = methodPost + , requestHeaders = [(hContentType, "application/x-www-form-urlencoded")] + } + formBody + res <- srequest req + liftIO $ assertEqual "token exchange status" status200 (simpleStatus res) + value <- + case eitherDecode (simpleBody res) :: Either String Value of + Left e -> abort e + Right v -> pure v + obj <- liftIO $ valueToObject value + accessToken <- liftIO $ lookupTextFromObject "access_token" obj + refreshToken <- liftIO $ lookupTextFromObject "refresh_token" obj + pure (accessToken, refreshToken) + ) + app + assertBool "access token populated" (not (T.null accessTokenValue)) + assertBool "refresh token populated" (not (T.null refreshTokenValue)) + + st3 <- readMVar stateVar + Map.member (auth_code_value ac) (auth_codes st3) @?= False + let persistence = refresh_token_persistence st3 + isJust <$> lookupRefreshToken persistence refreshTokenValue >>= (@?= True) + + (rotatedAccessToken, rotatedRefreshToken) <- + runSession + ( do + let formBody = + encodeForm + [ ("grant_type", "refresh_token") + , ("refresh_token", refreshTokenValue) + , ("client_id", clientId) + ] + req = + SRequest + (setPath defaultRequest "/token") + { requestMethod = methodPost + , requestHeaders = [(hContentType, "application/x-www-form-urlencoded")] + } + formBody + res <- srequest req + liftIO $ assertEqual "refresh status" status200 (simpleStatus res) + value <- + case eitherDecode (simpleBody res) :: Either String Value of + Left e -> abort e + Right v -> pure v + obj <- liftIO $ valueToObject value + accessTok <- liftIO $ lookupTextFromObject "access_token" obj + refreshTok <- liftIO $ lookupTextFromObject "refresh_token" obj + pure (accessTok, refreshTok) + ) + app + assertBool "rotated access token populated" (not (T.null rotatedAccessToken)) + assertBool "refresh token rotated" (rotatedRefreshToken /= refreshTokenValue) + + st4 <- readMVar stateVar + let persistence' = refresh_token_persistence st4 + isJust <$> lookupRefreshToken persistence' refreshTokenValue >>= (@?= False) + isJust <$> lookupRefreshToken persistence' rotatedRefreshToken >>= (@?= True) + +lookupText :: Text -> KM.KeyMap Value -> IO Text +lookupText key obj = lookupTextFromObject key obj + +lookupTextFromObject :: Text -> KM.KeyMap Value -> IO Text +lookupTextFromObject key obj = + case KM.lookup (Key.fromText key) obj of + Just (String t) -> pure t + _ -> abort ("missing text field: " <> T.unpack key) + +valueToObject :: Value -> IO (KM.KeyMap Value) +valueToObject (Object o) = pure o +valueToObject _ = abort "expected JSON object" + +base64UrlHash :: Text -> Text +base64UrlHash verifier = + let bytes = TE.encodeUtf8 verifier + digest = hashWith SHA256 bytes :: Digest SHA256 + in TE.decodeUtf8 (B64URL.encodeUnpadded (BS.pack (BA.unpack digest))) + +abort :: (MonadIO m, MonadFail m) => String -> m a +abort msg = liftIO (assertFailure msg) >> fail msg diff --git a/test/Web/OAuth2/MetadataSpec.hs b/test/Web/OAuth2/MetadataSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/OAuth2/MetadataSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +module Web.OAuth2.MetadataSpec (tests) where + +import Control.Concurrent.MVar (MVar, modifyMVar_) +import Data.Aeson (Value (..), eitherDecode) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable (toList) +import Network.HTTP.Types (status200) +import Network.Wai (Application) +import Network.Wai.Test +import Test.Tasty +import Test.Tasty.HUnit +import Web.OAuth2.TestUtils +import Web.OAuth2.Types + +tests :: TestTree +tests = + testGroup + "Metadata endpoint" + [ returnsExpectedEndpoints + , handlesExplicitPortGracefully + ] + +withApp :: (MVar (OAuthState TestUser) -> Application -> IO a) -> IO a +withApp action = do + (stateVar, _ctx, app) <- createTestApplication + action stateVar app + +fetchMetadata :: Application -> IO Value +fetchMetadata app = do + res <- + runSession + (srequest (SRequest (setPath defaultRequest "/.well-known/oauth-authorization-server") LBS.empty)) + app + simpleStatus res @?= status200 + case eitherDecode (simpleBody res) of + Left err -> assertFailure ("Failed to decode metadata: " <> err) + Right val -> pure val + +returnsExpectedEndpoints :: TestTree +returnsExpectedEndpoints = testCase "returns issuer and endpoints for default configuration" $ + withApp $ \_ app -> do + val <- fetchMetadata app + case val of + Object obj -> do + KM.lookup "issuer" obj @?= Just (String "http://localhost:8080") + KM.lookup "authorization_endpoint" obj @?= Just (String "http://localhost:8080/authorize") + KM.lookup "token_endpoint" obj @?= Just (String "http://localhost:8080/token") + KM.lookup "registration_endpoint" obj @?= Just (String "http://localhost:8080/register") + case KM.lookup "token_endpoint_auth_methods_supported" obj of + Just (Array arr) -> + toList arr @?= [String "none", String "client_secret_post"] + _ -> assertFailure "token_endpoint_auth_methods_supported missing" + _ -> assertFailure "metadata response not an object" + +handlesExplicitPortGracefully :: TestTree +handlesExplicitPortGracefully = testCase "does not duplicate port when oauth_url already includes it" $ + withApp $ \stateVar app -> do + modifyMVar_ stateVar $ \s -> pure s{oauth_url = "https://dpella.example:8443/", oauth_port = 8443} + val <- fetchMetadata app + case val of + Object obj -> do + KM.lookup "issuer" obj @?= Just (String "https://dpella.example:8443/") + KM.lookup "authorization_endpoint" obj @?= Just (String "https://dpella.example:8443/authorize") + KM.lookup "token_endpoint" obj @?= Just (String "https://dpella.example:8443/token") + _ -> assertFailure "metadata response not an object" diff --git a/test/Web/OAuth2/RegisterSpec.hs b/test/Web/OAuth2/RegisterSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/OAuth2/RegisterSpec.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Web.OAuth2.RegisterSpec (tests) where + +import Control.Concurrent.MVar (MVar, readMVar) +import Data.Aeson +import Data.Aeson.Key (toText) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy qualified as LBS +import Data.Foldable (toList) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Network.HTTP.Types (HeaderName, hAuthorization, hContentType, methodDelete, methodPost, methodPut, status200, status201, status204, status400, status401, status404) +import Network.Wai (Application, requestHeaders, requestMethod) +import Network.Wai.Test +import Test.Tasty +import Test.Tasty.HUnit +import Web.OAuth2.TestUtils +import Web.OAuth2.Types + +tests :: TestTree +tests = + testGroup + "Register endpoint" + [ appliesDefaultsForPublicClients + , issuesSecretForConfidentialClients + , exposesManagementCredentials + , managementGetReturnsClientMetadata + , managementRejectsInvalidToken + , managementUpdateAppliesChanges + , managementDeleteRemovesClient + , honorsRequestedScope + , rejectsEmptyRedirectUris + , rejectsRelativeRedirectUris + , rejectsInsecureRedirectUris + , acceptsExtendedLoopbackRedirects + , rejectsUnsupportedAuthMethod + ] + +withApp :: (MVar (OAuthState TestUser) -> Application -> IO a) -> IO a +withApp action = do + (stateVar, _ctx, app) <- createTestApplication + action stateVar app + +registerClient :: Application -> Value -> IO SResponse +registerClient app payload = do + let req = + SRequest + ( setPath defaultRequest "/register" + ){ requestMethod = methodPost + , requestHeaders = [(hContentType, "application/json")] + } + (encode payload) + runSession (srequest req) app + +extractObject :: LBS.ByteString -> IO Object +extractObject body = + case eitherDecode body of + Left err -> assertFailure ("Failed to decode registration response: " <> err) + Right (Object o) -> pure o + Right _ -> assertFailure "Expected JSON object in registration response" + +decodeRegistrationError :: LBS.ByteString -> IO OAuthError +decodeRegistrationError body = + case eitherDecode body of + Left err -> assertFailure ("Failed to decode registration error: " <> err) + Right val -> pure val + +appliesDefaultsForPublicClients :: TestTree +appliesDefaultsForPublicClients = testCase "fills defaults for omitted fields" $ + withApp $ \stateVar app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("Minimal App" :: Text) + , "redirect_uris" .= ["http://localhost:4000/callback" :: Text] + ] + ) + simpleStatus res @?= status201 + obj <- extractObject (simpleBody res) + let getTextField key = + case KM.lookup key obj of + Just (String t) -> pure t + _ -> assertFailure ("Missing text field: " <> T.unpack (toText key)) + getTextArray key = + case KM.lookup key obj of + Just (Array arr) -> + pure [t | String t <- toList arr] + _ -> assertFailure ("Missing array field: " <> T.unpack (toText key)) + clientId <- getTextField "client_id" + assertBool "client_id non-empty" (not (T.null clientId)) + tokenMethod <- getTextField "token_endpoint_auth_method" + tokenMethod @?= "none" + grants <- getTextArray "grant_types" + grants @?= ["authorization_code", "refresh_token"] + responses <- getTextArray "response_types" + responses @?= ["code"] + scopeVal <- getTextField "scope" + scopeVal @?= "read write" + regToken <- getTextField "registration_access_token" + assertBool "registration_access_token non-empty" (not (T.null regToken)) + regUri <- getTextField "registration_client_uri" + assertBool "registration_client_uri includes client id" (clientId `T.isInfixOf` regUri) + assertBool "client_secret absent" (KM.lookup "client_secret" obj == Nothing) + assertBool "client_secret_expires_at absent" (KM.lookup "client_secret_expires_at" obj == Nothing) + + st <- readMVar stateVar + case Map.lookup clientId (registered_clients st) of + Just c -> do + registered_client_grant_types c @?= ["authorization_code", "refresh_token"] + registered_client_secret c @?= Nothing + registered_client_registration_access_token c @?= Just regToken + Nothing -> assertFailure "Client not persisted in state" + +issuesSecretForConfidentialClients :: TestTree +issuesSecretForConfidentialClients = testCase "returns secret for confidential registration and stores it" $ + withApp $ \stateVar app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("Confidential" :: Text) + , "redirect_uris" .= ["https://localhost/callback" :: Text] + , "grant_types" .= ["authorization_code" :: Text] + , "token_endpoint_auth_method" .= ("client_secret_post" :: Text) + ] + ) + simpleStatus res @?= status201 + obj <- extractObject (simpleBody res) + secretField <- + case KM.lookup "client_secret" obj of + Just (String s) -> pure s + _ -> assertFailure "client_secret missing" + let expiryField = KM.lookup "client_secret_expires_at" obj + assertBool "expiry omitted" (expiryField == Nothing) + clientId <- + case KM.lookup "client_id" obj of + Just (String cid) -> pure cid + _ -> assertFailure "client_id missing" + assertBool "secret non-empty" (not (T.null secretField)) + registrationToken <- + case KM.lookup "registration_access_token" obj of + Just (String tok) -> pure tok + _ -> assertFailure "registration_access_token missing" + + st <- readMVar stateVar + case Map.lookup clientId (registered_clients st) of + Nothing -> assertFailure "Client not persisted for confidential registration" + Just client -> do + registered_client_secret client @?= Just secretField + registered_client_token_endpoint_auth_method client @?= "client_secret_post" + registered_client_registration_access_token client @?= Just registrationToken + +exposesManagementCredentials :: TestTree +exposesManagementCredentials = testCase "includes management token and URI in response" $ + withApp $ \stateVar app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("Management App" :: Text) + , "redirect_uris" .= ["http://localhost:4000/callback" :: Text] + ] + ) + simpleStatus res @?= status201 + obj <- extractObject (simpleBody res) + clientId <- + case KM.lookup "client_id" obj of + Just (String cid) -> pure cid + _ -> assertFailure "client_id missing" + managementToken <- + case KM.lookup "registration_access_token" obj of + Just (String tok) -> pure tok + _ -> assertFailure "registration_access_token missing" + managementUri <- + case KM.lookup "registration_client_uri" obj of + Just (String uriTxt) -> pure uriTxt + _ -> assertFailure "registration_client_uri missing" + managementUri @?= "http://localhost:8080/register/" <> clientId + st <- readMVar stateVar + case Map.lookup clientId (registered_clients st) of + Nothing -> assertFailure "Client not persisted" + Just client -> + registered_client_registration_access_token client @?= Just managementToken + +managementGetReturnsClientMetadata :: TestTree +managementGetReturnsClientMetadata = testCase "management GET returns stored metadata" $ + withApp $ \_ app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("Mgmt GET" :: Text) + , "redirect_uris" .= ["http://localhost:4000/callback" :: Text] + ] + ) + simpleStatus res @?= status201 + regObj <- extractObject (simpleBody res) + clientId <- requireTextField "client_id" regObj + managementToken <- requireTextField "registration_access_token" regObj + getRes <- + runSession + ( srequest + ( SRequest + ( setPath defaultRequest (registrationPath clientId) + ){ requestHeaders = [bearerHeader managementToken] + } + LBS.empty + ) + ) + app + simpleStatus getRes @?= status200 + getObj <- extractObject (simpleBody getRes) + KM.lookup "client_id" getObj @?= Just (String clientId) + KM.lookup "registration_access_token" getObj @?= Just (String managementToken) + KM.lookup "registration_client_uri" getObj @?= Just (String ("http://localhost:8080/register/" <> clientId)) + +managementRejectsInvalidToken :: TestTree +managementRejectsInvalidToken = testCase "management endpoints reject missing or invalid tokens" $ + withApp $ \_ app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("Mgmt Invalid" :: Text) + , "redirect_uris" .= ["http://localhost:4000/callback" :: Text] + ] + ) + simpleStatus res @?= status201 + regObj <- extractObject (simpleBody res) + clientId <- requireTextField "client_id" regObj + -- Missing header + resMissing <- + runSession + ( srequest + ( SRequest + ( setPath defaultRequest (registrationPath clientId) + ){ requestHeaders = [] + } + LBS.empty + ) + ) + app + simpleStatus resMissing @?= status401 + -- Wrong token + resWrong <- + runSession + ( srequest + ( SRequest + ( setPath defaultRequest (registrationPath clientId) + ){ requestHeaders = [bearerHeader "not-the-token"] + } + LBS.empty + ) + ) + app + simpleStatus resWrong @?= status401 + +managementUpdateAppliesChanges :: TestTree +managementUpdateAppliesChanges = testCase "PUT replaces client metadata and persists" $ + withApp $ \stateVar app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("Mgmt Update" :: Text) + , "redirect_uris" .= ["https://localhost/callback" :: Text] + , "scope" .= ("read write" :: Text) + ] + ) + simpleStatus res @?= status201 + regObj <- extractObject (simpleBody res) + clientId <- requireTextField "client_id" regObj + managementToken <- requireTextField "registration_access_token" regObj + let updatePayload = + object + [ "client_name" .= ("Mgmt Update v2" :: Text) + , "redirect_uris" .= ["https://localhost/updated" :: Text] + , "scope" .= ("profile email" :: Text) + , "grant_types" .= ["authorization_code", "refresh_token" :: Text] + , "response_types" .= ["code" :: Text] + , "token_endpoint_auth_method" .= ("none" :: Text) + ] + updateRes <- + runSession + ( srequest + ( SRequest + ( setPath defaultRequest (registrationPath clientId) + ){ requestMethod = methodPut + , requestHeaders = + [ bearerHeader managementToken + , (hContentType, "application/json") + ] + } + (encode updatePayload) + ) + ) + app + simpleStatus updateRes @?= status200 + updateObj <- extractObject (simpleBody updateRes) + KM.lookup "scope" updateObj @?= Just (String "profile email") + KM.lookup "client_name" updateObj @?= Just (String "Mgmt Update v2") + st <- readMVar stateVar + case Map.lookup clientId (registered_clients st) of + Nothing -> assertFailure "Client missing after update" + Just client -> do + registered_client_scope client @?= "profile email" + registered_client_redirect_uris client @?= ["https://localhost/updated"] + +managementDeleteRemovesClient :: TestTree +managementDeleteRemovesClient = testCase "DELETE removes client and subsequent GET returns 404" $ + withApp $ \stateVar app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("Mgmt Delete" :: Text) + , "redirect_uris" .= ["http://localhost:4000/callback" :: Text] + ] + ) + simpleStatus res @?= status201 + regObj <- extractObject (simpleBody res) + clientId <- requireTextField "client_id" regObj + managementToken <- requireTextField "registration_access_token" regObj + deleteRes <- + runSession + ( srequest + ( SRequest + ( setPath defaultRequest (registrationPath clientId) + ){ requestMethod = methodDelete + , requestHeaders = [bearerHeader managementToken] + } + LBS.empty + ) + ) + app + simpleStatus deleteRes @?= status204 + st <- readMVar stateVar + Map.lookup clientId (registered_clients st) @?= Nothing + afterDelete <- + runSession + ( srequest + ( SRequest + ( setPath defaultRequest (registrationPath clientId) + ){ requestHeaders = [bearerHeader managementToken] + } + LBS.empty + ) + ) + app + simpleStatus afterDelete @?= status404 + +honorsRequestedScope :: TestTree +honorsRequestedScope = testCase "persists provided scope field" $ + withApp $ \stateVar app -> do + let customScope = "profile email" + res <- + registerClient + app + ( object + [ "client_name" .= ("Scoped App" :: Text) + , "redirect_uris" .= ["https://localhost/callback" :: Text] + , "scope" .= customScope + ] + ) + simpleStatus res @?= status201 + obj <- extractObject (simpleBody res) + case KM.lookup "scope" obj of + Just (String scopeVal) -> scopeVal @?= customScope + _ -> assertFailure "scope field missing in response" + case KM.lookup "client_id" obj of + Just (String cid) -> do + st <- readMVar stateVar + case Map.lookup cid (registered_clients st) of + Nothing -> assertFailure "registered client missing from state" + Just client -> registered_client_scope client @?= customScope + metadataRes <- + runSession + ( srequest + (SRequest (setPath defaultRequest "/.well-known/oauth-authorization-server") LBS.empty) + ) + app + simpleStatus metadataRes @?= status200 + metadataObj <- + case eitherDecode (simpleBody metadataRes) of + Left err -> assertFailure ("Failed to decode metadata: " <> err) + Right (Object o) -> pure o + Right _ -> assertFailure "Metadata response not an object" + case KM.lookup "scopes_supported" metadataObj of + Just (Array arr) -> + let scopes = [t | String t <- toList arr] + in assertBool "metadata scopes include custom scope tokens" (all (`elem` scopes) (T.words customScope)) + _ -> assertFailure "scopes_supported missing from metadata" + _ -> assertFailure "client_id missing in response" + +rejectsEmptyRedirectUris :: TestTree +rejectsEmptyRedirectUris = testCase "rejects registrations without redirect URIs" $ + withApp $ \_ app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("No Redirects" :: Text) + , "redirect_uris" .= ([] :: [Text]) + ] + ) + simpleStatus res @?= status400 + err <- decodeRegistrationError (simpleBody res) + Web.OAuth2.Types.error err @?= "invalid_client_metadata" + +registrationPath :: Text -> BS8.ByteString +registrationPath clientId = BS8.concat ["/register/", TE.encodeUtf8 clientId] + +bearerHeader :: Text -> (HeaderName, BS8.ByteString) +bearerHeader token = (hAuthorization, TE.encodeUtf8 ("Bearer " <> token)) + +requireTextField :: Text -> Object -> IO Text +requireTextField key obj = + case KM.lookup (Key.fromText key) obj of + Just (String val) -> pure val + _ -> assertFailure ("Missing text field: " <> T.unpack key) + +rejectsUnsupportedAuthMethod :: TestTree +rejectsUnsupportedAuthMethod = testCase "rejects token auth methods the server cannot fulfill" $ + withApp $ \_ app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("Bad Auth" :: Text) + , "redirect_uris" .= ["https://localhost/callback" :: Text] + , "token_endpoint_auth_method" .= ("client_secret_basic" :: Text) + ] + ) + simpleStatus res @?= status400 + err <- decodeRegistrationError (simpleBody res) + Web.OAuth2.Types.error err @?= "invalid_client_metadata" + +rejectsRelativeRedirectUris :: TestTree +rejectsRelativeRedirectUris = testCase "rejects non-absolute redirect URIs" $ + withApp $ \_ app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("Relative Redirect" :: Text) + , "redirect_uris" .= ["/callback" :: Text] + ] + ) + simpleStatus res @?= status400 + err <- decodeRegistrationError (simpleBody res) + Web.OAuth2.Types.error err @?= "invalid_client_metadata" + +rejectsInsecureRedirectUris :: TestTree +rejectsInsecureRedirectUris = testCase "rejects non-loopback http redirect URIs" $ + withApp $ \_ app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("Insecure Redirect" :: Text) + , "redirect_uris" .= ["http://example.com/callback" :: Text] + ] + ) + simpleStatus res @?= status400 + err <- decodeRegistrationError (simpleBody res) + Web.OAuth2.Types.error err @?= "invalid_client_metadata" + +acceptsExtendedLoopbackRedirects :: TestTree +acceptsExtendedLoopbackRedirects = testCase "accepts any 127.0.0.0/8 redirect host" $ + withApp $ \_ app -> do + res <- + registerClient + app + ( object + [ "client_name" .= ("Loopback" :: Text) + , "redirect_uris" .= ["http://127.10.20.30/callback" :: Text] + ] + ) + simpleStatus res @?= status201 diff --git a/test/Web/OAuth2/TestUtils.hs b/test/Web/OAuth2/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/Web/OAuth2/TestUtils.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Web.OAuth2.TestUtils + ( -- * Shared fixtures + TestUser (..) + , testUser + , TestAuthSettings (..) + , mkAuthCode + , mkRegisteredClient + , mkPublicClient + , mkConfidentialClient + , mkTrackingPersistence + , mkState + , mkJWTSettings + , jwtContext + , formAuthContext + , runHandler + , encodeForm + -- * Application helpers + , emptyOAuthState + , createTestContext + , createTestApplication + , addRegisteredClientToState + , addAuthCodeToState + , addRefreshTokenToState + ) where + +import Control.Concurrent.MVar +import Control.Monad (void) +import Data.Aeson (FromJSON, ToJSON) +import Data.ByteString.Lazy qualified as LBS +import Data.IORef +import Data.List (find) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Time.Clock +import GHC.Generics (Generic) +import Network.Wai (Application) +import Servant (Context (EmptyContext, (:.)), Handler, Proxy (..), ServerError, serveWithContext) +import Servant.Auth.Server +import Servant.Server.Internal.Handler qualified as Internal +import Web.OAuth2 +import Web.OAuth2.Types + +data TestUser = TestUser + { userId :: Text + , userName :: Text + , userEmail :: Text + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +instance ToJWT TestUser + +instance FromJWT TestUser + +instance FormAuth TestUser where + type FormAuthSettings TestUser = TestAuthSettings + runFormAuth _ username password = + pure $ + case (username, password) of + ("testuser", "testpass") -> Authenticated testUser + ("admin", "admin") -> Authenticated (TestUser "admin" "Admin User" "admin@example.com") + _ -> NoSuchUser + +data TestAuthSettings = TestAuthSettings + +testUser :: TestUser +testUser = TestUser "user1" "Test User" "test@example.com" + +mkAuthCode + :: Text + -> RegisteredClient + -> TestUser + -> UTCTime + -> Text + -> Maybe Text + -> Maybe Text + -> AuthCode TestUser +mkAuthCode codeValue RegisteredClient{registered_client_id, registered_client_scope} usr expiry redirectUri challenge challengeMethod = + AuthCode + { auth_code_value = codeValue + , auth_code_client_id = registered_client_id + , auth_code_user = usr + , auth_code_redirect_uri = redirectUri + , auth_code_scope = registered_client_scope + , auth_code_expiry = expiry + , auth_code_challenge = challenge + , auth_code_challenge_method = challengeMethod + } + +mkRegisteredClient + :: Text + -> [Text] + -> [Text] + -> [Text] + -> Text + -> Text + -> Maybe Text + -> RegisteredClient +mkRegisteredClient clientId redirects grants responses scope tokenMethod secret = + RegisteredClient + { registered_client_id = clientId + , registered_client_name = clientId + , registered_client_secret = secret + , registered_client_redirect_uris = redirects + , registered_client_grant_types = grants + , registered_client_response_types = responses + , registered_client_scope = scope + , registered_client_token_endpoint_auth_method = tokenMethod + , registered_client_registration_access_token = Nothing + } + +mkPublicClient :: Text -> [Text] -> Text -> RegisteredClient +mkPublicClient clientId redirectUris scope = + mkRegisteredClient clientId redirectUris ["authorization_code", "refresh_token"] ["code"] scope "none" Nothing + +mkConfidentialClient :: Text -> Text -> [Text] -> Text -> RegisteredClient +mkConfidentialClient clientId secret redirectUris scope = + mkRegisteredClient clientId redirectUris ["authorization_code", "refresh_token"] ["code"] scope "client_secret_post" (Just secret) + +mkTrackingPersistence + :: IO (RefreshTokenPersistence TestUser, IO [RefreshToken TestUser]) +mkTrackingPersistence = do + ref <- newIORef ([] :: [RefreshToken TestUser]) + let persist token = + atomicModifyIORef' ref $ \tokens -> (token : tokens, ()) + delete tokenValue = + atomicModifyIORef' ref $ \tokens -> + (filter ((/= tokenValue) . refresh_token_value) tokens, ()) + lookupToken tokenValue = do + tokens <- readIORef ref + pure $ find ((== tokenValue) . refresh_token_value) tokens + pure + ( RefreshTokenPersistence + { persistRefreshToken = persist + , deleteRefreshToken = delete + , lookupRefreshToken = lookupToken + } + , reverse <$> readIORef ref + ) + +mkState + :: RefreshTokenPersistence TestUser + -> [RegisteredClient] + -> [(Text, AuthCode TestUser)] + -> IO (MVar (OAuthState TestUser)) +mkState persistence clients codes = + newMVar + OAuthState + { auth_codes = Map.fromList codes + , refresh_token_persistence = persistence + , registered_clients = + Map.fromList $ fmap (\c -> (registered_client_id c, c)) clients + , oauth_url = "https://auth.example.com" + , oauth_port = 443 + , login_form_renderer = defaultLoginFormRenderer + } + +mkJWTSettings :: IO JWTSettings +mkJWTSettings = defaultJWTSettings <$> generateKey + +jwtContext :: JWTSettings -> Context '[JWTSettings] +jwtContext settings = settings :. EmptyContext + +formAuthContext :: Context '[TestAuthSettings] +formAuthContext = TestAuthSettings :. EmptyContext + +runHandler :: Handler a -> IO (Either ServerError a) +runHandler = Internal.runHandler + +encodeForm :: [(Text, Text)] -> LBS.ByteString +encodeForm fields = + let fragment (k, v) = k <> "=" <> v + body = T.intercalate "&" (map fragment fields) + in LBS.fromStrict (TE.encodeUtf8 body) + +emptyOAuthState :: IO (MVar (OAuthState TestUser)) +emptyOAuthState = do + persistence <- mkDefaultRefreshTokenPersistence + newMVar (initOAuthState @TestUser "http://localhost:8080" 8080 persistence defaultLoginFormRenderer) + +createTestContext :: IO (Context '[JWTSettings, TestAuthSettings]) +createTestContext = do + jwt <- mkJWTSettings + pure (jwt :. TestAuthSettings :. EmptyContext) + +createTestApplication :: IO (MVar (OAuthState TestUser), Context '[JWTSettings, TestAuthSettings], Application) +createTestApplication = do + stateVar <- emptyOAuthState + ctx <- createTestContext + let app = serveWithContext (Proxy :: Proxy OAuthAPI) ctx (oAuthAPI stateVar ctx) + pure (stateVar, ctx, app) + +addRegisteredClientToState :: MVar (OAuthState TestUser) -> RegisteredClient -> IO () +addRegisteredClientToState st client = + void $ + modifyMVar st $ \s -> do + let updated = + s + { registered_clients = + Map.insert (registered_client_id client) client (registered_clients s) + } + pure (updated, ()) + +addAuthCodeToState :: MVar (OAuthState TestUser) -> AuthCode TestUser -> IO () +addAuthCodeToState st ac = + void $ + modifyMVar st $ \s -> do + let updated = s{auth_codes = Map.insert (auth_code_value ac) ac (auth_codes s)} + pure (updated, ()) + +addRefreshTokenToState :: MVar (OAuthState TestUser) -> RefreshToken TestUser -> IO () +addRefreshTokenToState st rt = + void $ + modifyMVar st $ \s -> do + persistRefreshToken (refresh_token_persistence s) rt + pure (s, ()) diff --git a/test/Web/OAuth2/TokenSpec.hs b/test/Web/OAuth2/TokenSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/OAuth2/TokenSpec.hs @@ -0,0 +1,540 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + +module Web.OAuth2.TokenSpec (tests) where + +import Control.Concurrent.Async (concurrently) +import Control.Concurrent.MVar (MVar, readMVar) +import Crypto.Hash (SHA256 (..), hashWith) +import Data.Aeson (Value (..), eitherDecode) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteArray qualified as BA +import Data.ByteString qualified as BS +import Data.ByteString.Base64.URL qualified as B64URL +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy qualified as LBS +import Data.List (sort) +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust, isNothing) +import Data.Text (Text) +import Data.Text.Encoding qualified as TE +import Data.Time.Clock +import Network.HTTP.Types (hContentType, methodPost, status200, status400, status401) +import Network.Wai (Application, requestHeaders, requestMethod) +import Network.Wai.Test +import Servant.API.ResponseHeaders (getHeaders, getResponse) +import Test.Tasty +import Test.Tasty.HUnit +import Web.OAuth2.Internal (TokenRequest (..), TokenResponse (..), TokenResponseHeaders, handleTokenRequest) +import Web.OAuth2.TestUtils +import Web.OAuth2.Types hiding (error) +import Web.OAuth2.Types qualified as OAuthTypes + +tests :: TestTree +tests = + testGroup + "Token endpoint" + [ tokenEndpointIntegrationTests + , handlerLevelTests + ] + +tokenEndpointIntegrationTests :: TestTree +tokenEndpointIntegrationTests = + testGroup + "Integration" + [ rejectsMissingVerifier + , rejectsInvalidVerifier + , rejectsExpiredAuthCode + , confidentialClientsRequireSecret + , rejectsUnknownRefreshToken + , rejectsRefreshScopeEscalation + , authorizationCodeSingleUseConcurrent + , refreshTokenSingleUseConcurrent + , rejectsDisallowedGrantType + , rejectsRefreshTokenClientMismatch + , pkceS256AcceptsValidVerifier + , pkceDefaultsToPlainWhenMethodOmitted + , rejectsUnsupportedPkceMethod + ] + +handlerLevelTests :: TestTree +handlerLevelTests = + testGroup + "Handler behaviour" + [ noRefreshTokenIssuedForClientsWithoutGrant + , refreshTokenIssuedWhenAllowed + ] + +withFreshApp :: (MVar (OAuthState TestUser) -> Application -> IO a) -> IO a +withFreshApp action = do + (stateVar, _ctx, app) <- createTestApplication + action stateVar app + +decodeOAuthError :: LBS.ByteString -> IO OAuthError +decodeOAuthError body = + case eitherDecode body of + Left err -> assertFailure ("Failed to decode OAuthError: " <> err) + Right val -> pure val + +postToken :: Application -> LBS.ByteString -> IO SResponse +postToken app body = do + let req = + SRequest + ( setPath defaultRequest "/token" + ){ requestMethod = methodPost + , requestHeaders = [(hContentType, "application/x-www-form-urlencoded")] + } + body + runSession (srequest req) app + +mkAuthCodeEntry + :: Text + -> Text + -> Text + -> Text + -> UTCTime + -> Maybe Text + -> Maybe Text + -> AuthCode TestUser +mkAuthCodeEntry value clientId redirect scope expiry challenge method = + AuthCode + { auth_code_value = value + , auth_code_client_id = clientId + , auth_code_user = testUser + , auth_code_redirect_uri = redirect + , auth_code_scope = scope + , auth_code_expiry = expiry + , auth_code_challenge = challenge + , auth_code_challenge_method = method + } + +rejectsMissingVerifier :: TestTree +rejectsMissingVerifier = testCase "enforces PKCE code_verifier when challenge stored" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "pub-1" ["http://localhost:4000/cb"] "read write") + now <- getCurrentTime + let authCode = mkAuthCodeEntry "code-pkce" "pub-1" "http://localhost:4000/cb" "read" (addUTCTime 600 now) (Just "challenge") (Just "plain") + addAuthCodeToState stateVar authCode + res <- + postToken + app + ( encodeForm + [ ("grant_type", "authorization_code") + , ("code", "code-pkce") + , ("redirect_uri", "http://localhost:4000/cb") + , ("client_id", "pub-1") + ] + ) + simpleStatus res @?= status400 + lookup hContentType (simpleHeaders res) @?= Just "application/json; charset=utf-8" + assertNoStoreHeadersResponse res + errResp <- decodeOAuthError (simpleBody res) + OAuthTypes.error errResp @?= "invalid_request" + +rejectsInvalidVerifier :: TestTree +rejectsInvalidVerifier = testCase "rejects mismatched code_verifier" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "pub-2" ["http://localhost:4000/cb"] "read") + now <- getCurrentTime + let authCode = mkAuthCodeEntry "code-wrong" "pub-2" "http://localhost:4000/cb" "read" (addUTCTime 600 now) (Just "correct") (Just "plain") + addAuthCodeToState stateVar authCode + res <- + postToken + app + ( encodeForm + [ ("grant_type", "authorization_code") + , ("code", "code-wrong") + , ("redirect_uri", "http://localhost:4000/cb") + , ("client_id", "pub-2") + , ("code_verifier", "incorrect") + ] + ) + simpleStatus res @?= status400 + lookup hContentType (simpleHeaders res) @?= Just "application/json; charset=utf-8" + assertNoStoreHeadersResponse res + errResp <- decodeOAuthError (simpleBody res) + OAuthTypes.error errResp @?= "invalid_grant" + OAuthTypes.error_description errResp @?= Just "Invalid code verifier" + +rejectsExpiredAuthCode :: TestTree +rejectsExpiredAuthCode = testCase "rejects expired authorization codes" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "pub-3" ["http://localhost:4000/cb"] "read") + now <- getCurrentTime + let authCode = mkAuthCodeEntry "code-expired" "pub-3" "http://localhost:4000/cb" "read" (addUTCTime (-30) now) (Just "verifier") (Just "plain") + addAuthCodeToState stateVar authCode + res <- + postToken + app + ( encodeForm + [ ("grant_type", "authorization_code") + , ("code", "code-expired") + , ("redirect_uri", "http://localhost:4000/cb") + , ("client_id", "pub-3") + , ("code_verifier", "verifier") + ] + ) + simpleStatus res @?= status400 + lookup hContentType (simpleHeaders res) @?= Just "application/json; charset=utf-8" + assertNoStoreHeadersResponse res + errResp <- decodeOAuthError (simpleBody res) + OAuthTypes.error errResp @?= "invalid_grant" + OAuthTypes.error_description errResp @?= Just "Authorization code expired" + +confidentialClientsRequireSecret :: TestTree +confidentialClientsRequireSecret = testCase "confidential clients must provide client_secret" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkConfidentialClient "conf-1" "top-secret" ["http://localhost:4000/cb"] "read") + now <- getCurrentTime + let authCode = mkAuthCodeEntry "code-conf" "conf-1" "http://localhost:4000/cb" "read" (addUTCTime 600 now) (Just "secret") Nothing + addAuthCodeToState stateVar authCode + res <- + postToken + app + ( encodeForm + [ ("grant_type", "authorization_code") + , ("code", "code-conf") + , ("redirect_uri", "http://localhost:4000/cb") + , ("client_id", "conf-1") + , ("code_verifier", "secret") + ] + ) + simpleStatus res @?= status401 + lookup hContentType (simpleHeaders res) @?= Just "application/json; charset=utf-8" + assertNoStoreHeadersResponse res + errResp <- decodeOAuthError (simpleBody res) + OAuthTypes.error errResp @?= "invalid_client" + st <- readMVar stateVar + Map.member "code-conf" (auth_codes st) @?= True + +rejectsUnknownRefreshToken :: TestTree +rejectsUnknownRefreshToken = testCase "rejects refresh_token grant when token missing" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "pub-4" ["http://localhost:4000/cb"] "read") + res <- + postToken + app + ( encodeForm + [ ("grant_type", "refresh_token") + , ("refresh_token", "does-not-exist") + , ("client_id", "pub-4") + ] + ) + simpleStatus res @?= status400 + lookup hContentType (simpleHeaders res) @?= Just "application/json; charset=utf-8" + assertNoStoreHeadersResponse res + errResp <- decodeOAuthError (simpleBody res) + OAuthTypes.error errResp @?= "invalid_grant" + +rejectsRefreshScopeEscalation :: TestTree +rejectsRefreshScopeEscalation = testCase "rejects refresh token with scope outside client allowance" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "pub-5" ["http://localhost:4000/cb"] "read") + let refreshTok = + RefreshToken + { refresh_token_value = "rt-1" + , refresh_token_client_id = "pub-5" + , refresh_token_user = testUser + , refresh_token_scope = "write" + } + addRefreshTokenToState stateVar refreshTok + res <- + postToken + app + ( encodeForm + [ ("grant_type", "refresh_token") + , ("refresh_token", "rt-1") + , ("client_id", "pub-5") + ] + ) + simpleStatus res @?= status400 + lookup hContentType (simpleHeaders res) @?= Just "application/json; charset=utf-8" + assertNoStoreHeadersResponse res + errResp <- decodeOAuthError (simpleBody res) + OAuthTypes.error errResp @?= "invalid_scope" + +authorizationCodeSingleUseConcurrent :: TestTree +authorizationCodeSingleUseConcurrent = testCase "authorization codes cannot be redeemed concurrently" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "pub-6" ["http://localhost:4000/cb"] "read") + now <- getCurrentTime + let authCode = mkAuthCodeEntry "code-concurrent" "pub-6" "http://localhost:4000/cb" "read" (addUTCTime 600 now) (Just "verifier") (Just "plain") + body = + encodeForm + [ ("grant_type", "authorization_code") + , ("code", "code-concurrent") + , ("redirect_uri", "http://localhost:4000/cb") + , ("client_id", "pub-6") + , ("code_verifier", "verifier") + ] + addAuthCodeToState stateVar authCode + (resA, resB) <- concurrently (postToken app body) (postToken app body) + let statuses = sort [simpleStatus resA, simpleStatus resB] + statuses @?= [status200, status400] + let (failureRes, successRes) = if simpleStatus resA == status400 then (resA, resB) else (resB, resA) + lookup hContentType (simpleHeaders failureRes) @?= Just "application/json; charset=utf-8" + assertNoStoreHeadersResponse failureRes + errResp <- decodeOAuthError (simpleBody failureRes) + OAuthTypes.error errResp @?= "invalid_grant" + simpleStatus successRes @?= status200 + assertNoStoreHeadersResponse successRes + stateAfter <- readMVar stateVar + Map.member "code-concurrent" (auth_codes stateAfter) @?= False + +refreshTokenSingleUseConcurrent :: TestTree +refreshTokenSingleUseConcurrent = testCase "refresh tokens rotate under concurrent use" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "pub-7" ["http://localhost:4000/cb"] "read") + let originalToken = + RefreshToken + { refresh_token_value = "rt-concurrent" + , refresh_token_client_id = "pub-7" + , refresh_token_user = testUser + , refresh_token_scope = "read" + } + body = + encodeForm + [ ("grant_type", "refresh_token") + , ("refresh_token", "rt-concurrent") + , ("client_id", "pub-7") + ] + addRefreshTokenToState stateVar originalToken + (resA, resB) <- concurrently (postToken app body) (postToken app body) + let statuses = sort [simpleStatus resA, simpleStatus resB] + statuses @?= [status200, status400] + let (failureRes, successRes) = if simpleStatus resA == status400 then (resA, resB) else (resB, resA) + lookup hContentType (simpleHeaders failureRes) @?= Just "application/json; charset=utf-8" + assertNoStoreHeadersResponse failureRes + errResp <- decodeOAuthError (simpleBody failureRes) + OAuthTypes.error errResp @?= "invalid_grant" + simpleStatus successRes @?= status200 + assertNoStoreHeadersResponse successRes + successValue <- + case eitherDecode (simpleBody successRes) :: Either String Value of + Left err -> assertFailure ("Failed to decode success token response: " <> err) + Right val -> pure val + newRefresh <- + case successValue of + Object obj -> + case KM.lookup "refresh_token" obj of + Just (String t) -> pure t + _ -> assertFailure "refresh_token missing from successful response" + _ -> assertFailure "Expected object in token response" + assertBool "rotation produced new token" (newRefresh /= refresh_token_value originalToken) + stateAfter <- readMVar stateVar + let persistence = refresh_token_persistence stateAfter + oldToken <- lookupRefreshToken persistence (refresh_token_value originalToken) + assertBool "old refresh token removed" (isNothing oldToken) + newToken <- lookupRefreshToken persistence newRefresh + assertBool "new refresh token persisted" (isJust newToken) + +noRefreshTokenIssuedForClientsWithoutGrant :: TestTree +noRefreshTokenIssuedForClientsWithoutGrant = + testCase "authorization_code clients without refresh grant do not receive refresh tokens" $ do + (persistence, readPersisted) <- mkTrackingPersistence + let client = + mkRegisteredClient + "public-client" + ["https://client.example/callback"] + ["authorization_code"] + ["code"] + "read" + "none" + Nothing + expiry <- addUTCTime 600 <$> getCurrentTime + let user = testUser + authCode = mkAuthCode "auth-code-1" client user expiry "https://client.example/callback" (Just "verifier") Nothing + stateVar <- mkState persistence [client] [("auth-code-1", authCode)] + jwtSettings <- mkJWTSettings + let tokenRequest = + TokenRequest + { grant_type = "authorization_code" + , code = Just "auth-code-1" + , refresh_token = Nothing + , redirect_uri = Just "https://client.example/callback" + , client_id = "public-client" + , client_secret = Nothing + , code_verifier = Just "verifier" + } + result <- runHandler $ handleTokenRequest stateVar (jwtContext jwtSettings) tokenRequest + tokenResponseHeaders <- + either (assertFailure . ("Token handler failed: " <>) . show) pure result + let tokenResponse = getResponse tokenResponseHeaders + assertBool "refresh_token should be omitted" (isNothing (refresh_token_resp tokenResponse)) + persisted <- readPersisted + assertBool "no refresh token should be persisted" (null persisted) + stateAfter <- readMVar stateVar + assertBool "authorization code should be cleared" (null (auth_codes stateAfter)) + assertNoStoreHeadersFromHeaders tokenResponseHeaders + +refreshTokenIssuedWhenAllowed :: TestTree +refreshTokenIssuedWhenAllowed = + testCase "authorization_code clients with refresh grant receive refresh tokens" $ do + (persistence, readPersisted) <- mkTrackingPersistence + let client = + mkRegisteredClient + "confidential-client" + ["https://conf.example/cb"] + ["authorization_code", "refresh_token"] + ["code"] + "read" + "none" + Nothing + expiry <- addUTCTime 600 <$> getCurrentTime + let user = testUser + authCode = mkAuthCode "auth-code-2" client user expiry "https://conf.example/cb" (Just "verifier") Nothing + stateVar <- mkState persistence [client] [("auth-code-2", authCode)] + jwtSettings <- mkJWTSettings + let tokenRequest = + TokenRequest + { grant_type = "authorization_code" + , code = Just "auth-code-2" + , refresh_token = Nothing + , redirect_uri = Just "https://conf.example/cb" + , client_id = "confidential-client" + , client_secret = Nothing + , code_verifier = Just "verifier" + } + result <- runHandler $ handleTokenRequest stateVar (jwtContext jwtSettings) tokenRequest + tokenResponseHeaders <- + either (assertFailure . ("Token handler failed: " <>) . show) pure result + let tokenResponse = getResponse tokenResponseHeaders + assertBool "refresh_token should be present" (isJust (refresh_token_resp tokenResponse)) + persisted <- readPersisted + assertEqual "a refresh token should be persisted" 1 (length persisted) + stateAfter <- readMVar stateVar + assertBool "authorization code should be cleared" (null (auth_codes stateAfter)) + assertNoStoreHeadersFromHeaders tokenResponseHeaders + +assertNoStoreHeadersFromHeaders :: TokenResponseHeaders -> Assertion +assertNoStoreHeadersFromHeaders headers = do + let actualHeaders = fmap (BS8.unpack . snd) (getHeaders headers) + assertBool "Cache-Control no-store" ("no-store" `elem` actualHeaders) + assertBool "Pragma no-cache" ("no-cache" `elem` actualHeaders) + +assertNoStoreHeadersResponse :: SResponse -> Assertion +assertNoStoreHeadersResponse res = do + lookup "Cache-Control" (simpleHeaders res) @?= Just "no-store" + lookup "Pragma" (simpleHeaders res) @?= Just "no-cache" + +rejectsDisallowedGrantType :: TestTree +rejectsDisallowedGrantType = testCase "rejects grant_type not in client's allowed grants" $ + withFreshApp $ \stateVar app -> do + let client = mkRegisteredClient "authonly" ["http://localhost:4000/cb"] ["authorization_code"] ["code"] "read" "none" Nothing + addRegisteredClientToState stateVar client + res <- + postToken + app + ( encodeForm + [ ("grant_type", "refresh_token") + , ("refresh_token", "rt-any") + , ("client_id", "authonly") + ] + ) + simpleStatus res @?= status400 + assertNoStoreHeadersResponse res + errResp <- decodeOAuthError (simpleBody res) + OAuthTypes.error errResp @?= "unauthorized_client" + +rejectsRefreshTokenClientMismatch :: TestTree +rejectsRefreshTokenClientMismatch = testCase "rejects refresh token issued to a different client" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "client-a" ["http://localhost:4000/cb"] "read") + addRegisteredClientToState stateVar (mkPublicClient "client-b" ["http://localhost:4000/cb"] "read") + let refreshTok = + RefreshToken + { refresh_token_value = "rt-stolen" + , refresh_token_client_id = "client-a" + , refresh_token_user = testUser + , refresh_token_scope = "read" + } + addRefreshTokenToState stateVar refreshTok + res <- + postToken + app + ( encodeForm + [ ("grant_type", "refresh_token") + , ("refresh_token", "rt-stolen") + , ("client_id", "client-b") + ] + ) + simpleStatus res @?= status400 + assertNoStoreHeadersResponse res + errResp <- decodeOAuthError (simpleBody res) + OAuthTypes.error errResp @?= "invalid_grant" + OAuthTypes.error_description errResp @?= Just "Client ID mismatch" + +-- | Compute a PKCE S256 challenge from a verifier. +s256Challenge :: Text -> Text +s256Challenge verifier = + let hash = hashWith SHA256 (TE.encodeUtf8 verifier) + hashBytes = BS.pack (BA.unpack hash) + in TE.decodeUtf8 (B64URL.encodeUnpadded hashBytes) + +pkceS256AcceptsValidVerifier :: TestTree +pkceS256AcceptsValidVerifier = testCase "accepts valid S256 PKCE code_verifier" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "pub-s256" ["http://localhost:4000/cb"] "read") + now <- getCurrentTime + let verifier = "dBjftJeZ4CVP-mB92K27uhbUJU1p1r_wW1gFWFOEjXk" + challenge = s256Challenge verifier + authCode = mkAuthCodeEntry "code-s256" "pub-s256" "http://localhost:4000/cb" "read" (addUTCTime 600 now) (Just challenge) (Just "S256") + addAuthCodeToState stateVar authCode + res <- + postToken + app + ( encodeForm + [ ("grant_type", "authorization_code") + , ("code", "code-s256") + , ("redirect_uri", "http://localhost:4000/cb") + , ("client_id", "pub-s256") + , ("code_verifier", verifier) + ] + ) + simpleStatus res @?= status200 + assertNoStoreHeadersResponse res + +pkceDefaultsToPlainWhenMethodOmitted :: TestTree +pkceDefaultsToPlainWhenMethodOmitted = testCase "PKCE defaults to plain verification when method is omitted" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "pub-nomethod" ["http://localhost:4000/cb"] "read") + now <- getCurrentTime + let verifier = "my-plain-verifier" + authCode = mkAuthCodeEntry "code-nomethod" "pub-nomethod" "http://localhost:4000/cb" "read" (addUTCTime 600 now) (Just verifier) Nothing + addAuthCodeToState stateVar authCode + res <- + postToken + app + ( encodeForm + [ ("grant_type", "authorization_code") + , ("code", "code-nomethod") + , ("redirect_uri", "http://localhost:4000/cb") + , ("client_id", "pub-nomethod") + , ("code_verifier", verifier) + ] + ) + simpleStatus res @?= status200 + assertNoStoreHeadersResponse res + +rejectsUnsupportedPkceMethod :: TestTree +rejectsUnsupportedPkceMethod = testCase "rejects unsupported PKCE code_challenge_method" $ + withFreshApp $ \stateVar app -> do + addRegisteredClientToState stateVar (mkPublicClient "pub-badmethod" ["http://localhost:4000/cb"] "read") + now <- getCurrentTime + let authCode = mkAuthCodeEntry "code-badmethod" "pub-badmethod" "http://localhost:4000/cb" "read" (addUTCTime 600 now) (Just "challenge") (Just "RS256") + addAuthCodeToState stateVar authCode + res <- + postToken + app + ( encodeForm + [ ("grant_type", "authorization_code") + , ("code", "code-badmethod") + , ("redirect_uri", "http://localhost:4000/cb") + , ("client_id", "pub-badmethod") + , ("code_verifier", "challenge") + ] + ) + simpleStatus res @?= status400 + assertNoStoreHeadersResponse res + errResp <- decodeOAuthError (simpleBody res) + OAuthTypes.error errResp @?= "invalid_grant"