oauth2-server (empty) → 0.3.0.0

raw patch · 20 files changed

+4680/−0 lines, 20 filesdep +QuickCheckdep +aesondep +async

Dependencies added: QuickCheck, aeson, async, base, base64-bytestring, blaze-html, blaze-markup, bytestring, containers, cryptonite, http-api-data, http-client, http-types, memory, network-uri, oauth2-server, random, scientific, servant, servant-auth-server, servant-blaze, servant-server, tasty, tasty-hunit, tasty-quickcheck, text, time, transformers, wai, wai-extra, warp

Files

• CHANGELOG.md +55/−0
• LICENSE +373/−0
• README.md +200/−0
• oauth2-server.cabal +132/−0
• src/Web/OAuth2.hs +57/−0
• src/Web/OAuth2/AuthorizeAPI.hs +244/−0
• src/Web/OAuth2/AuthorizeCallbackAPI.hs +197/−0
• src/Web/OAuth2/Internal.hs +45/−0
• src/Web/OAuth2/MetadataAPI.hs +105/−0
• src/Web/OAuth2/RegisterAPI.hs +447/−0
• src/Web/OAuth2/TokenAPI.hs +383/−0
• src/Web/OAuth2/Types.hs +318/−0
• test/Main.hs +24/−0
• test/Web/OAuth2/AuthorizeCallbackSpec.hs +241/−0
• test/Web/OAuth2/AuthorizeSpec.hs +260/−0
• test/Web/OAuth2/FlowSpec.hs +275/−0
• test/Web/OAuth2/MetadataSpec.hs +69/−0
• test/Web/OAuth2/RegisterSpec.hs +487/−0
• test/Web/OAuth2/TestUtils.hs +228/−0
• test/Web/OAuth2/TokenSpec.hs +540/−0

@@ -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.

@@ -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.

@@ -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.

@@ -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

@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module:      Web.OAuth2+-- Copyright:   (c) DPella AB 2025+-- License:     MPL-2.0+-- Maintainer:  <matti@dpella.io>, <lobo@dpella.io>+--+-- 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

@@ -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:  <matti@dpella.io>, <lobo@dpella.io>+--+-- 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"

@@ -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:  <matti@dpella.io>, <lobo@dpella.io>+--+-- 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")

@@ -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+  )

@@ -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:  <matti@dpella.io>, <lobo@dpella.io>+--+-- 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+      }

@@ -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:  <matti@dpella.io>, <lobo@dpella.io>+--+-- 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

@@ -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:  <matti@dpella.io>, <lobo@dpella.io>+--+-- 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}

@@ -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:  <matti@dpella.io>, <lobo@dpella.io>+--+-- 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)

@@ -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+    ]

@@ -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

@@ -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+    ]

@@ -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

@@ -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"

@@ -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

@@ -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, ())

@@ -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"