packages feed

shomei-servant (empty) → 0.2.0.0

raw patch · 55 files changed

+10644/−0 lines, 55 filesdep +QuickCheckdep +aesondep +aeson-pretty

Dependencies added: QuickCheck, aeson, aeson-pretty, base, base64, bytestring, case-insensitive, containers, cookie, directory, effectful, effectful-core, generic-lens, hspec, http-api-data, http-client, http-media, http-types, jose, lens, mtl, network, openapi-hs, quickcheck-instances, servant, servant-health, servant-openapi-hs, servant-server, shomei-core, shomei-jwt, shomei-servant, sop-core, tasty, tasty-hunit, text, time, transformers, uuid, wai, warp

Files

+ CHANGELOG.md view
@@ -0,0 +1,53 @@+# Changelog for shomei-servant++All notable changes to `shomei-servant` are documented here. This package adheres to the+[PVP](https://pvp.haskell.org/) and is versioned independently of the other+Shōmei packages.++## 0.2.0.0 — 2026-08-27++- **Breaking:** requires `shomei-core ^>=0.2.0.0`.+- **Breaking:** secure cookie transport now emits and accepts `__Host-shomei_session` and+  `__Secure-shomei_refresh`, enforcing browser prefix invariants. Existing browser sessions are+  logged out once; deployments with `cookieSecure = false` retain the bare names.+- OIDC discovery handles invalid hand-built signing configuration without a partial fallback; the+  standalone server rejects that configuration before serving discovery.+- Duplicate signup login ids and email addresses consistently return their existing `409`+  problem codes, including PostgreSQL uniqueness races.+- `GET /oauth/authorize` now requires a live interactive session. Machine, delegated, and+  explicit-actor credentials receive `401 login_required` in the OAuth error shape with no+  redirect; dead sessions follow the unauthenticated login branch.+- The bespoke refresh endpoint refuses OAuth-client sessions; OAuth refresh retains and echoes the+  original granted scopes.+- Revocation enforces OAuth-client and service-account ownership (`shomei:admin` remains global),+  and UserInfo exposes email only under `email` and roles only under `profile`.+- `client_secret_basic` credentials are form-decoded, discovery advertises token exchange,+  introspection recognizes refresh tokens without a hint, and a missing UserInfo bearer challenge+  omits `error` as required by RFC 6750.++## 0.1.0.0 — 2026-08-24++*Editorial note, 2026-08-27: module names corrected to the ones shipped in 0.1.0.0; the entry+originally used pre-plan-48 names that never existed at release.*++Initial release. The HTTP layer of the Shōmei authentication toolkit.++- `ShomeiAPI` as a `NamedRoutes` record with typed `MultiVerb` results,+  organized by concept, covering signup, login, refresh, logout, email+  verification, password reset/change, MFA, passkeys, OAuth 2.0 and OpenID+  Connect, audit, and admin routes.+- Application routes live under `/v1`; the root keeps the health and+  readiness probes and the `.well-known` documents.+- Every error path returns an RFC 7807 `problem+json` envelope, backed by a+  documented error catalog.+- Enforcing auth combinators for guarding your own routes: `Authenticated`,+  `RequireRole`, `RequireScope`, and `RequirePermission`. Verification runs+  through `Shomei.Session.Authentication.Workflow.verifyToken`, so `sessionCheckMode =+  VerifyTokenAndSession` genuinely re-reads the session on every request.+- Cookie token transport with CSRF defenses, alongside bearer tokens.+- OAuth/OIDC endpoints: discovery, `authorize`, `token` (authorization code,+  refresh, `client_credentials`, and RFC 8693 token exchange), `userinfo`,+  `introspect`, and `revoke`.+- An OpenAPI 3.1 document generated from the same types, served at+  `/openapi.json` and emitted by the `shomei-openapi` executable, with a+  conformance test suite.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Nadeem Bitar++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ app/openapi/Main.hs view
@@ -0,0 +1,14 @@+-- | Emit the Shōmei OpenAPI 3.1 document as pretty JSON to stdout (EP-27).+--+-- > cabal run shomei-openapi > docs/api/openapi.json+--+-- The output is deterministic, so regenerating and diffing the committed+-- @docs/api/openapi.json@ surfaces any drift from the Servant types.+module Main (main) where++import Data.Aeson.Encode.Pretty (encodePretty)+import Data.ByteString.Lazy.Char8 qualified as BL+import Shomei.Servant.OpenApi (shomeiOpenApi)++main :: IO ()+main = BL.putStrLn (encodePretty shomeiOpenApi)
+ shomei-servant.cabal view
@@ -0,0 +1,207 @@+cabal-version:   3.0+name:            shomei-servant+version:         0.2.0.0+synopsis:        Servant API, handlers, and auth combinators for Shōmei+description:+  The HTTP layer of the Shōmei authentication toolkit. Exposes ShomeiAPI as a+  NamedRoutes record covering signup, login, refresh, logout, email+  verification, password reset, MFA, passkeys, OAuth 2.0 and OpenID Connect,+  audit, and admin routes, together with the request/response DTOs, the+  handlers, and the Authenticated, RequireRole, RequireScope, and+  RequirePermission combinators for guarding your own routes. Mount it inside+  an existing Servant application, or serve it standalone with shomei-server.+  An OpenAPI 3.1 document can be generated from the same types.++homepage:        https://github.com/shinzui/shomei+bug-reports:     https://github.com/shinzui/shomei/issues+license:         MIT+license-file:    LICENSE+author:          Nadeem Bitar+maintainer:      nadeem@gmail.com+copyright:       2026 Nadeem Bitar+category:        Web, Security+tested-with:     GHC ==9.12.4+extra-doc-files: CHANGELOG.md++source-repository head+  type:     git+  location: https://github.com/shinzui/shomei.git++common warnings+  ghc-options:+    -Wall -Wcompat -Widentities -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++common shared+  default-language:   GHC2024+  default-extensions:+    BlockArguments+    DataKinds+    DeriveAnyClass+    DuplicateRecordFields+    LambdaCase+    MultilineStrings+    OverloadedLabels+    OverloadedRecordDot+    OverloadedStrings+    QualifiedDo+    TemplateHaskell+    TypeFamilies+    TypeOperators++library+  import:          warnings, shared+  hs-source-dirs:  src+  exposed-modules:+    Shomei.Account.Admin.Api+    Shomei.Account.Api+    Shomei.Account.Dto+    Shomei.Account.Handler+    Shomei.Account.Result+    Shomei.Account.User.Dto+    Shomei.Audit.Api+    Shomei.Audit.Dto+    Shomei.Audit.Handler+    Shomei.Audit.Result+    Shomei.Authorization.Api+    Shomei.Authorization.Handler+    Shomei.Authorization.Result+    Shomei.Delegation.Handler+    Shomei.Mfa.Api+    Shomei.Mfa.Dto+    Shomei.Mfa.Handler+    Shomei.Mfa.Result+    Shomei.OAuth.Api+    Shomei.OAuth.Handler+    Shomei.OAuth.Result+    Shomei.Passkey.Api+    Shomei.Passkey.Dto+    Shomei.Passkey.Handler+    Shomei.Passkey.Result+    Shomei.Servant.Api+    Shomei.Servant.Application+    Shomei.Servant.Auth+    Shomei.Servant.Authz+    Shomei.Servant.ClientIp+    Shomei.Servant.Cookie+    Shomei.Servant.Error+    Shomei.Servant.Middleware+    Shomei.Servant.OAuth+    Shomei.Servant.Oidc+    Shomei.Servant.OpenApi+    Shomei.Servant.PreHandler+    Shomei.Servant.RemoteHost+    Shomei.Servant.Result+    Shomei.Servant.Seam+    Shomei.Servant.Server+    Shomei.Servant.Throttle+    Shomei.Session.Admin.Api+    Shomei.Session.Api+    Shomei.Session.Dto+    Shomei.Session.Handler+    Shomei.Session.Result+    Shomei.SigningKey.Api+    Shomei.SigningKey.Handler++  build-depends:+    , aeson               >=2.1      && <2.3+    , base                >=4.18     && <5+    , base64              >=1.0      && <1.1+    , bytestring          >=0.11     && <0.13+    , containers          >=0.6      && <0.9+    , cookie              >=0.4      && <0.6+    , effectful           >=2.5      && <2.8+    , effectful-core      >=2.5      && <2.8+    , http-api-data       >=0.6      && <0.8+    , http-media          >=0.8      && <0.9+    , http-types          >=0.12     && <0.13+    , lens                >=5.2      && <5.4+    , mtl                 >=2.3      && <2.4+    , network             >=3.1      && <3.3+    , openapi-hs          >=5.0      && <5.1+    , servant             >=0.20.3   && <0.21+    , servant-health      >=0.1      && <0.2+    , servant-openapi-hs  >=5.1      && <5.2+    , servant-server      >=0.20.3   && <0.21+    , shomei-core         ^>=0.2.0.0+    , sop-core            >=0.5      && <0.6+    , text                >=2.0      && <2.2+    , time                >=1.12     && <1.15+    , transformers        >=0.6      && <0.7+    , uuid                >=1.3      && <1.4+    , wai                 >=3.2      && <3.3++executable shomei-openapi+  import:         warnings, shared+  hs-source-dirs: app/openapi+  main-is:        Main.hs+  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  build-depends:+    , aeson-pretty    >=0.8      && <0.9+    , base            >=4.18     && <5+    , bytestring      >=0.11     && <0.13+    , shomei-servant  ^>=0.2.0.0++-- | OpenAPI 3.1 conformance (EP-27 M4): property-checks that every JSON body+-- type's actual 'ToJSON' encoding validates against its generated 'ToSchema',+-- plus smoke assertions on the assembled document. Kept separate from the+-- end-to-end HTTP suite because it is hspec/QuickCheck-based.+test-suite shomei-servant-openapi-test+  import:             warnings, shared+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test-openapi+  main-is:            Main.hs+  default-extensions:+    DerivingStrategies+    FlexibleInstances+    ScopedTypeVariables+    StandaloneDeriving+    TypeApplications+    UndecidableInstances++  ghc-options:        -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0+  build-depends:+    , aeson                 >=2.1      && <2.3+    , base                  >=4.18     && <5+    , directory             >=1.3      && <1.4+    , hspec                 >=2.11     && <2.12+    , openapi-hs            >=5.0      && <6+    , QuickCheck            >=2.14     && <2.17+    , quickcheck-instances  >=0.3      && <0.4+    , servant               >=0.20.3   && <0.21+    , servant-health        >=0.1      && <0.2+    , servant-openapi-hs    >=5.0      && <6+    , servant-server        >=0.20.3   && <0.21+    , shomei-servant        ^>=0.2.0.0+    , text                  >=2.0      && <2.2++test-suite shomei-servant-test+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Main.hs+  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  build-depends:+    , aeson             >=2.1      && <2.3+    , base              >=4.18     && <5+    , bytestring        >=0.11     && <0.13+    , case-insensitive  >=1.2      && <1.3+    , containers        >=0.6      && <0.9+    , effectful         >=2.5      && <2.8+    , generic-lens      >=2.2      && <2.4+    , http-client       >=0.7      && <0.8+    , http-types        >=0.12     && <0.13+    , jose              >=0.13     && <0.14+    , servant           >=0.20.3   && <0.21+    , servant-health    >=0.1      && <0.2+    , servant-server    >=0.20.3   && <0.21+    , shomei-core       ^>=0.2.0.0+    , shomei-jwt        ^>=0.2.0.0+    , shomei-servant    ^>=0.2.0.0+    , tasty             >=1.4      && <1.6+    , tasty-hunit       >=0.10     && <0.11+    , text              >=2.0      && <2.2+    , time              >=1.12     && <1.15+    , uuid              >=1.3      && <1.4+    , wai               >=3.2      && <3.3+    , warp              >=3.3      && <3.5
+ src/Shomei/Account/Admin/Api.hs view
@@ -0,0 +1,43 @@+-- | Administrative account lifecycle routes.+module Shomei.Account.Admin.Api+  ( AdminAccountApi (..),+    ListUsersRoute,+    GetUserRoute,+    SuspendUserRoute,+    ReinstateUserRoute,+    DeleteUserRoute,+    AdminPasswordResetRoute,+  )+where++import Servant.API+import Servant.API.MultiVerb (MultiVerb)+import Shomei.Account.Result+import Shomei.Account.User.Dto (AdminStatusFilter, UserPageCursor)+import Shomei.Id (UserId)+import Shomei.Prelude+import Shomei.Servant.Authz (RequireAdmin)+import Shomei.Servant.PreHandler (CsrfProtected, PreHandlerResponses)+import Shomei.Servant.Result (ApplicationContentTypes, BadRequestPreHandlerResponses)++type ListUsersRoute = "users" :> RequireAdmin :> PreHandlerResponses BadRequestPreHandlerResponses :> QueryParam "status" AdminStatusFilter :> QueryParam "limit" Int :> QueryParam "before" UserPageCursor :> MultiVerb 'GET ApplicationContentTypes ListUsersResponses ListUsersResult++type GetUserRoute = "users" :> RequireAdmin :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> MultiVerb 'GET ApplicationContentTypes GetUserResponses GetUserResult++type SuspendUserRoute = "users" :> RequireAdmin :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> "suspend" :> MultiVerb 'POST ApplicationContentTypes SuspendUserResponses SuspendUserResult++type ReinstateUserRoute = "users" :> RequireAdmin :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> "reinstate" :> MultiVerb 'POST ApplicationContentTypes ReinstateUserResponses ReinstateUserResult++type DeleteUserRoute = "users" :> RequireAdmin :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> MultiVerb 'DELETE ApplicationContentTypes DeleteUserResponses DeleteUserResult++type AdminPasswordResetRoute = "users" :> RequireAdmin :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> "password-reset" :> MultiVerb 'POST ApplicationContentTypes AdminPasswordResetResponses AdminPasswordResetResult++data AdminAccountApi mode = AdminAccountApi+  { listUsers :: mode :- ListUsersRoute,+    getUser :: mode :- GetUserRoute,+    suspendUser :: mode :- SuspendUserRoute,+    reinstateUser :: mode :- ReinstateUserRoute,+    deleteUser :: mode :- DeleteUserRoute,+    passwordReset :: mode :- AdminPasswordResetRoute+  }+  deriving stock (Generic)
+ src/Shomei/Account/Api.hs view
@@ -0,0 +1,53 @@+-- | Account-owned HTTP routes.+module Shomei.Account.Api+  ( AccountApi (..),+    SignupRoute,+    VerifyEmailRequestRoute,+    VerifyEmailConfirmRoute,+    PasswordResetRequestRoute,+    PasswordResetConfirmRoute,+    PasswordChangeRoute,+    MeRoute,+  )+where++import Servant.API+import Servant.API.MultiVerb (MultiVerb)+import Shomei.Account.Dto+  ( ChangePasswordRequest,+    ConfirmEmailVerificationRequest,+    ConfirmPasswordResetRequest,+    PasswordResetRequest,+    SignupRequest,+    VerifyEmailRequest,+  )+import Shomei.Account.Result+import Shomei.Prelude+import Shomei.Servant.Auth (Authenticated)+import Shomei.Servant.PreHandler (CsrfProtected, PreHandlerResponses, RateLimited)+import Shomei.Servant.Result (ApplicationContentTypes, BadRequestPreHandlerResponses)++type SignupRoute = "signup" :> RateLimited :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] SignupRequest :> MultiVerb 'POST ApplicationContentTypes SignupResponses SignupResult++type VerifyEmailRequestRoute = "verify-email" :> "request" :> RateLimited :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] VerifyEmailRequest :> MultiVerb 'POST ApplicationContentTypes VerifyEmailRequestResponses VerifyEmailRequestResult++type VerifyEmailConfirmRoute = "verify-email" :> "confirm" :> RateLimited :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] ConfirmEmailVerificationRequest :> MultiVerb 'POST ApplicationContentTypes VerifyEmailConfirmResponses VerifyEmailConfirmResult++type PasswordResetRequestRoute = "password-reset" :> "request" :> RateLimited :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] PasswordResetRequest :> MultiVerb 'POST ApplicationContentTypes PasswordResetRequestResponses PasswordResetRequestResult++type PasswordResetConfirmRoute = "password-reset" :> "confirm" :> RateLimited :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] ConfirmPasswordResetRequest :> MultiVerb 'POST ApplicationContentTypes PasswordResetConfirmResponses PasswordResetConfirmResult++type PasswordChangeRoute = "password" :> "change" :> RateLimited :> Authenticated :> CsrfProtected :> RemoteHost :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] ChangePasswordRequest :> MultiVerb 'POST ApplicationContentTypes PasswordChangeResponses PasswordChangeResult++type MeRoute = Authenticated :> "me" :> MultiVerb 'GET ApplicationContentTypes MeResponses MeResult++data AccountApi mode = AccountApi+  { signup :: mode :- SignupRoute,+    verifyEmailRequest :: mode :- VerifyEmailRequestRoute,+    verifyEmailConfirm :: mode :- VerifyEmailConfirmRoute,+    passwordResetRequest :: mode :- PasswordResetRequestRoute,+    passwordResetConfirm :: mode :- PasswordResetConfirmRoute,+    passwordChange :: mode :- PasswordChangeRoute,+    me :: mode :- MeRoute+  }+  deriving stock (Generic)
+ src/Shomei/Account/Dto.hs view
@@ -0,0 +1,57 @@+-- | Account lifecycle request and response wire types.+module Shomei.Account.Dto+  ( SignupRequest (..),+    SignupResponse (..),+    VerifyEmailRequest (..),+    ConfirmEmailVerificationRequest (..),+    PasswordResetRequest (..),+    ConfirmPasswordResetRequest (..),+    ChangePasswordRequest (..),+  )+where++import Shomei.Account.User.Dto (UserResponse)+import Shomei.Prelude+import Shomei.Session.Dto (TokenPairResponse)++data SignupRequest = SignupRequest+  { loginId :: !Text,+    email :: !(Maybe Text),+    password :: !Text,+    displayName :: !Text+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data SignupResponse = SignupResponse+  { user :: !UserResponse,+    token :: !TokenPairResponse+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype VerifyEmailRequest = VerifyEmailRequest {email :: Text}+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype ConfirmEmailVerificationRequest = ConfirmEmailVerificationRequest {token :: Text}+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype PasswordResetRequest = PasswordResetRequest {email :: Text}+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data ConfirmPasswordResetRequest = ConfirmPasswordResetRequest+  { token :: !Text,+    newPassword :: !Text+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data ChangePasswordRequest = ChangePasswordRequest+  { currentPassword :: !Text,+    newPassword :: !Text+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)
+ src/Shomei/Account/Handler.hs view
@@ -0,0 +1,194 @@+-- | Account and administrative-account HTTP adapters.+module Shomei.Account.Handler+  ( accountServer,+    adminAccountServer,+    loadUser,+    requireExistingUser,+  )+where++import Data.Text qualified as Text+import Network.Socket (SockAddr)+import Servant (Handler)+import Servant.Server.Generic (AsServerT)+import Shomei.Account.Admin.Api (AdminAccountApi (..))+import Shomei.Account.Admin.Workflow qualified as Admin+import Shomei.Account.Api (AccountApi (..))+import Shomei.Account.Dto+import Shomei.Account.Email.Domain (mkEmail)+import Shomei.Account.Lifecycle.Workflow qualified as Account+import Shomei.Account.LoginId.Domain (mkLoginId)+import Shomei.Account.OneTimeToken.Domain (OneTimeToken (..))+import Shomei.Account.Password.Domain (PlainPassword (..))+import Shomei.Account.Result+import Shomei.Account.User.Domain (User (..))+import Shomei.Account.User.Dto+import Shomei.Account.User.Store+  ( UserCursor (..),+    UserListQuery (..),+    clampUserLimit,+    emptyUserListQuery,+    findUserById,+  )+import Shomei.Account.User.Store qualified as UserStore+import Shomei.Authorization.Role.Workflow qualified as Roles+import Shomei.Delegation.Handler (denyUnderDelegation)+import Shomei.Error (AuthError (UserHasNoEmail, UserNotFound))+import Shomei.Id (UserId)+import Shomei.Prelude+import Shomei.Servant.Application (ApplicationHandler, port, rejectAuth, rejectProblem, runApplicationHandler, workflow)+import Shomei.Servant.Auth (AuthUser (..))+import Shomei.Servant.ClientIp (clientIpText)+import Shomei.Servant.Cookie (tokenCookies)+import Shomei.Servant.Error (noProblemOccurrence, pcSelfTargetForbidden)+import Shomei.Servant.Result (cookieResponse)+import Shomei.Servant.Seam (Env (..))+import Shomei.Session.Authentication.Workflow qualified as Authentication+import Shomei.Session.Command (ProofContext (..), SignupCommand (..))+import Shomei.Session.Dto (tokenPairToResponse)+import Shomei.Session.LoginAttempt.Domain (ClientIp (..))++accountServer :: Env -> AccountApi (AsServerT Handler)+accountServer env =+  AccountApi+    { signup = signupH env,+      verifyEmailRequest = verifyEmailRequestH env,+      verifyEmailConfirm = verifyEmailConfirmH env,+      passwordResetRequest = passwordResetRequestH env,+      passwordResetConfirm = passwordResetConfirmH env,+      passwordChange = passwordChangeH env,+      me = meH env+    }++adminAccountServer :: Env -> AdminAccountApi (AsServerT Handler)+adminAccountServer env =+  AdminAccountApi+    { listUsers = adminListUsersH env,+      getUser = adminGetUserH env,+      suspendUser = adminSuspendUserH env,+      reinstateUser = adminReinstateUserH env,+      deleteUser = adminDeleteUserH env,+      passwordReset = adminPasswordResetH env+    }++signupH :: Env -> SignupRequest -> Handler SignupResult+signupH env request = runApplicationHandler do+  loginId <- either rejectAuth pure (mkLoginId request.loginId)+  email <- traverse (either rejectAuth pure . mkEmail) request.email+  let command =+        SignupCommand+          { loginId,+            email,+            password = PlainPassword request.password,+            displayName = nonEmpty request.displayName+          }+  (user, tokens) <- workflow env (Authentication.signup env.config command)+  pure $+    cookieResponse env.config (tokenCookies env.config tokens) $+      SignupResponse+        { user = userToResponse user,+          token = tokenPairToResponse env.config tokens+        }++verifyEmailRequestH :: Env -> VerifyEmailRequest -> Handler VerifyEmailRequestResult+verifyEmailRequestH env request = runApplicationHandler do+  email <- either rejectAuth pure (mkEmail request.email)+  workflow env (Account.requestEmailVerification env.config (Account.RequestEmailVerification email))++verifyEmailConfirmH :: Env -> ConfirmEmailVerificationRequest -> Handler VerifyEmailConfirmResult+verifyEmailConfirmH env request = runApplicationHandler do+  workflow env (Account.confirmEmailVerification env.config (Account.ConfirmEmailVerification (OneTimeToken request.token)))++passwordResetRequestH :: Env -> PasswordResetRequest -> Handler PasswordResetRequestResult+passwordResetRequestH env request = runApplicationHandler do+  email <- either rejectAuth pure (mkEmail request.email)+  workflow env (Account.requestPasswordReset env.config (Account.RequestPasswordReset email))++passwordResetConfirmH :: Env -> ConfirmPasswordResetRequest -> Handler PasswordResetConfirmResult+passwordResetConfirmH env request = runApplicationHandler do+  workflow env $+    Account.confirmPasswordReset+      env.config+      (Account.ConfirmPasswordReset (OneTimeToken request.token) (PlainPassword request.newPassword))++passwordChangeH :: Env -> AuthUser -> SockAddr -> ChangePasswordRequest -> Handler PasswordChangeResult+passwordChangeH env user peer request = runApplicationHandler do+  denyUnderDelegation env "password_change" user+  workflow env $+    Account.changePassword+      env.config+      ProofContext {clientIp = ClientIp (clientIpText peer), accountKeyOf = env.accountKeyOf}+      (Account.ChangePassword user.authUserId (PlainPassword request.currentPassword) (PlainPassword request.newPassword))++meH :: Env -> AuthUser -> Handler MeResult+meH env user = runApplicationHandler (userToResponse <$> loadUser env user)++loadUser :: Env -> AuthUser -> ApplicationHandler User+loadUser env user = do+  found <- port env (findUserById user.authUserId)+  maybe (rejectAuth UserNotFound) pure found++adminListUsersH :: Env -> AuthUser -> Maybe AdminStatusFilter -> Maybe Int -> Maybe UserPageCursor -> Handler ListUsersResult+adminListUsersH env _ status limit cursor = runApplicationHandler do+  let query =+        emptyUserListQuery+          { queryStatus = (.userStatus) <$> status,+            queryLimit = fromMaybe 50 limit,+            queryBefore = (.userCursor) <$> cursor+          }+  users <- port env (UserStore.listUsers query)+  let full = length users == clampUserLimit query.queryLimit+      nextCursor = if full then encodeUserCursor . cursorOf <$> lastMay users else Nothing+  pure AdminUsersPage {users = map userToResponse users, nextCursor}+  where+    cursorOf user = UserCursor {cursorCreatedAt = user.createdAt, cursorUserId = user.userId}++adminGetUserH :: Env -> AuthUser -> UserId -> Handler GetUserResult+adminGetUserH env _ target = runApplicationHandler do+  user <- requireExistingUser env target+  roles <- workflow env (Roles.rolesOf target)+  pure (adminUserToResponse user roles)++adminSuspendUserH :: Env -> AuthUser -> UserId -> Handler SuspendUserResult+adminSuspendUserH env actor target = runApplicationHandler do+  denyUnderDelegation env "admin_suspend" actor+  denySelfTarget actor target+  workflow env (Admin.suspendUser actor.authUserId target)++adminReinstateUserH :: Env -> AuthUser -> UserId -> Handler ReinstateUserResult+adminReinstateUserH env actor target = runApplicationHandler do+  denyUnderDelegation env "admin_reinstate" actor+  workflow env (Admin.reinstateUser actor.authUserId target)++adminDeleteUserH :: Env -> AuthUser -> UserId -> Handler DeleteUserResult+adminDeleteUserH env actor target = runApplicationHandler do+  denyUnderDelegation env "admin_delete" actor+  denySelfTarget actor target+  workflow env (Admin.deleteUser actor.authUserId target)++adminPasswordResetH :: Env -> AuthUser -> UserId -> Handler AdminPasswordResetResult+adminPasswordResetH env actor target = runApplicationHandler do+  denyUnderDelegation env "admin_password_reset" actor+  user <- requireExistingUser env target+  email <- maybe (rejectAuth UserHasNoEmail) pure user.email+  workflow env (Account.requestPasswordReset env.config (Account.RequestPasswordReset email))++requireExistingUser :: Env -> UserId -> ApplicationHandler User+requireExistingUser env target = do+  found <- port env (findUserById target)+  maybe (rejectAuth UserNotFound) pure found++denySelfTarget :: AuthUser -> UserId -> ApplicationHandler ()+denySelfTarget actor target =+  when (target == actor.authUserId) $+    rejectProblem pcSelfTargetForbidden noProblemOccurrence++lastMay :: [a] -> Maybe a+lastMay = \case+  [] -> Nothing+  values -> Just (last values)++nonEmpty :: Text -> Maybe Text+nonEmpty value+  | Text.null value = Nothing+  | otherwise = Just value
+ src/Shomei/Account/Result.hs view
@@ -0,0 +1,86 @@+-- | Named account response lists and handler result types.+module Shomei.Account.Result+  ( SignupResponses,+    SignupResult,+    VerifyEmailRequestResponses,+    VerifyEmailRequestResult,+    VerifyEmailConfirmResponses,+    VerifyEmailConfirmResult,+    PasswordResetRequestResponses,+    PasswordResetRequestResult,+    PasswordResetConfirmResponses,+    PasswordResetConfirmResult,+    PasswordChangeResponses,+    PasswordChangeResult,+    MeResponses,+    MeResult,+    ListUsersResponses,+    ListUsersResult,+    GetUserResponses,+    GetUserResult,+    SuspendUserResponses,+    SuspendUserResult,+    ReinstateUserResponses,+    ReinstateUserResult,+    DeleteUserResponses,+    DeleteUserResult,+    AdminPasswordResetResponses,+    AdminPasswordResetResult,+  )+where++import Shomei.Account.Dto (SignupResponse)+import Shomei.Account.User.Dto (AdminUserResponse, AdminUsersPage, UserResponse)+import Shomei.Servant.Result++type SignupResponses = ApplicationCookieResponses 201 "Account created" SignupResponse++type SignupResult = ApplicationResult (CookieResponse SignupResponse)++type VerifyEmailRequestResponses = ApplicationEmptyResponses 202 "Verification request accepted"++type VerifyEmailRequestResult = ApplicationResult ()++type VerifyEmailConfirmResponses = ApplicationEmptyResponses 200 "Email verified"++type VerifyEmailConfirmResult = ApplicationResult ()++type PasswordResetRequestResponses = ApplicationEmptyResponses 202 "Password reset request accepted"++type PasswordResetRequestResult = ApplicationResult ()++type PasswordResetConfirmResponses = ApplicationEmptyResponses 200 "Password reset"++type PasswordResetConfirmResult = ApplicationResult ()++type PasswordChangeResponses = ApplicationEmptyResponses 204 "Password changed"++type PasswordChangeResult = ApplicationResult ()++type MeResponses = ApplicationResponses 200 "Current account" UserResponse++type MeResult = ApplicationResult UserResponse++type ListUsersResponses = ApplicationResponses 200 "Users" AdminUsersPage++type ListUsersResult = ApplicationResult AdminUsersPage++type GetUserResponses = ApplicationResponses 200 "User" AdminUserResponse++type GetUserResult = ApplicationResult AdminUserResponse++type SuspendUserResponses = ApplicationEmptyResponses 204 "User suspended"++type SuspendUserResult = ApplicationResult ()++type ReinstateUserResponses = ApplicationEmptyResponses 204 "User reinstated"++type ReinstateUserResult = ApplicationResult ()++type DeleteUserResponses = ApplicationEmptyResponses 204 "User deleted"++type DeleteUserResult = ApplicationResult ()++type AdminPasswordResetResponses = ApplicationEmptyResponses 202 "Password reset requested"++type AdminPasswordResetResult = ApplicationResult ()
+ src/Shomei/Account/User/Dto.hs view
@@ -0,0 +1,112 @@+-- | User and administrative-account wire types.+module Shomei.Account.User.Dto+  ( UserResponse (..),+    AdminUserResponse (..),+    AdminUsersPage (..),+    AdminStatusFilter (..),+    UserPageCursor (..),+    userToResponse,+    adminUserToResponse,+    encodeUserCursor,+    decodeUserCursor,+  )+where++import Data.List (sort)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show)+import Data.UUID qualified as UUID+import Shomei.Account.Email.Domain (emailText)+import Shomei.Account.LoginId.Domain (loginIdText)+import Shomei.Account.User.Domain (User (..), UserStatus (..))+import Shomei.Account.User.Store (UserCursor (..))+import Shomei.Authorization.Claims.Domain (Role (..))+import Shomei.Id (idText, userIdFromUUID, userIdToUUID)+import Shomei.Prelude+import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))++data UserResponse = UserResponse+  { userId :: !Text,+    loginId :: !Text,+    email :: !(Maybe Text),+    displayName :: !Text,+    status :: !Text+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data AdminUserResponse = AdminUserResponse+  { user :: !UserResponse,+    roles :: ![Text]+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data AdminUsersPage = AdminUsersPage+  { users :: ![UserResponse],+    nextCursor :: !(Maybe Text)+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype AdminStatusFilter = AdminStatusFilter {userStatus :: UserStatus}+  deriving stock (Eq, Show)++instance FromHttpApiData AdminStatusFilter where+  parseUrlPiece = \case+    "active" -> Right (AdminStatusFilter UserActive)+    "suspended" -> Right (AdminStatusFilter UserSuspended)+    "deleted" -> Right (AdminStatusFilter UserDeleted)+    other -> Left ("invalid status parameter: " <> other <> " (expected active, suspended, or deleted)")++instance ToHttpApiData AdminStatusFilter where+  toUrlPiece (AdminStatusFilter status) = renderUserStatus status++newtype UserPageCursor = UserPageCursor {userCursor :: UserCursor}+  deriving stock (Eq, Show)++instance FromHttpApiData UserPageCursor where+  parseUrlPiece value = maybe (Left "invalid before cursor") (Right . UserPageCursor) (decodeUserCursor value)++instance ToHttpApiData UserPageCursor where+  toUrlPiece = encodeUserCursor . (.userCursor)++userToResponse :: User -> UserResponse+userToResponse user =+  UserResponse+    { userId = idText user.userId,+      loginId = loginIdText user.loginId,+      email = emailText <$> user.email,+      displayName = fromMaybe "" user.displayName,+      status = renderUserStatus user.status+    }++adminUserToResponse :: User -> Set Role -> AdminUserResponse+adminUserToResponse user roles =+  AdminUserResponse+    { user = userToResponse user,+      roles = sort [name | Role name <- Set.toList roles]+    }++renderUserStatus :: UserStatus -> Text+renderUserStatus = \case+  UserActive -> "active"+  UserSuspended -> "suspended"+  UserDeleted -> "deleted"++encodeUserCursor :: UserCursor -> Text+encodeUserCursor cursor =+  Text.pack (iso8601Show cursor.cursorCreatedAt)+    <> ";"+    <> UUID.toText (userIdToUUID cursor.cursorUserId)++decodeUserCursor :: Text -> Maybe UserCursor+decodeUserCursor value = case Text.breakOn ";" value of+  (timestamp, rest)+    | Just identifier <- Text.stripPrefix ";" rest -> do+        createdAt <- iso8601ParseM (Text.unpack timestamp)+        userId <- userIdFromUUID <$> UUID.fromText identifier+        pure UserCursor {cursorCreatedAt = createdAt, cursorUserId = userId}+  _ -> Nothing
+ src/Shomei/Audit/Api.hs view
@@ -0,0 +1,18 @@+-- | Administrative audit-query routes.+module Shomei.Audit.Api (AuditApi (..), AuditEventsRoute) where++import Servant.API+import Servant.API.MultiVerb (MultiVerb)+import Shomei.Audit.Dto (AuditPageCursor, AuditSessionId, AuditTimestamp, AuditUserId)+import Shomei.Audit.Result+import Shomei.Prelude+import Shomei.Servant.Authz (RequireAdmin)+import Shomei.Servant.PreHandler (PreHandlerResponses)+import Shomei.Servant.Result (ApplicationContentTypes, BadRequestPreHandlerResponses)++type AuditEventsRoute = "audit" :> "events" :> RequireAdmin :> PreHandlerResponses BadRequestPreHandlerResponses :> QueryParam "user" AuditUserId :> QueryParam "session" AuditSessionId :> QueryParams "type" Text :> QueryParam "since" AuditTimestamp :> QueryParam "until" AuditTimestamp :> QueryParam "limit" Int :> QueryParam "before" AuditPageCursor :> MultiVerb 'GET ApplicationContentTypes AuditEventsResponses AuditEventsResult++data AuditApi mode = AuditApi+  { events :: mode :- AuditEventsRoute+  }+  deriving stock (Generic)
+ src/Shomei/Audit/Dto.hs view
@@ -0,0 +1,100 @@+-- | Audit-query parameters and response wire types.+module Shomei.Audit.Dto+  ( AuditEventResponse (..),+    AuditEventsPage (..),+    AuditUserId (..),+    AuditSessionId (..),+    AuditTimestamp (..),+    AuditPageCursor (..),+    storedToResponse,+    encodeCursor,+    decodeCursor,+  )+where++import Data.Aeson (Value)+import Data.Text qualified as Text+import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show)+import Data.UUID qualified as UUID+import Shomei.Audit.Reader.Store (AuditCursor (..), StoredAuthEvent (..))+import Shomei.Id (SessionId, UserId, idText, parseId)+import Shomei.Prelude+import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))++data AuditEventResponse = AuditEventResponse+  { eventId :: !Text,+    eventType :: !Text,+    userId :: !(Maybe Text),+    sessionId :: !(Maybe Text),+    createdAt :: !Text,+    payload :: !Value+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data AuditEventsPage = AuditEventsPage+  { events :: ![AuditEventResponse],+    nextCursor :: !(Maybe Text)+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype AuditUserId = AuditUserId {auditUserId :: UserId}+  deriving stock (Eq, Show)++instance FromHttpApiData AuditUserId where+  parseUrlPiece value = either (Left . Text.pack . show) (Right . AuditUserId) (parseId value)++instance ToHttpApiData AuditUserId where+  toUrlPiece = idText . (.auditUserId)++newtype AuditSessionId = AuditSessionId {auditSessionId :: SessionId}+  deriving stock (Eq, Show)++instance FromHttpApiData AuditSessionId where+  parseUrlPiece value = either (Left . Text.pack . show) (Right . AuditSessionId) (parseId value)++instance ToHttpApiData AuditSessionId where+  toUrlPiece = idText . (.auditSessionId)++newtype AuditTimestamp = AuditTimestamp {auditTimestamp :: UTCTime}+  deriving stock (Eq, Show)++instance FromHttpApiData AuditTimestamp where+  parseUrlPiece value = maybe (Left "invalid ISO-8601 timestamp") (Right . AuditTimestamp) (iso8601ParseM (Text.unpack value))++instance ToHttpApiData AuditTimestamp where+  toUrlPiece = Text.pack . iso8601Show . (.auditTimestamp)++newtype AuditPageCursor = AuditPageCursor {auditCursor :: AuditCursor}+  deriving stock (Eq, Show)++instance FromHttpApiData AuditPageCursor where+  parseUrlPiece value = maybe (Left "invalid before cursor") (Right . AuditPageCursor) (decodeCursor value)++instance ToHttpApiData AuditPageCursor where+  toUrlPiece = encodeCursor . (.auditCursor)++storedToResponse :: StoredAuthEvent -> AuditEventResponse+storedToResponse stored =+  AuditEventResponse+    { eventId = UUID.toText stored.storedEventId,+      eventType = stored.storedEventType,+      userId = UUID.toText <$> stored.storedUserId,+      sessionId = UUID.toText <$> stored.storedSessionId,+      createdAt = Text.pack (iso8601Show stored.storedCreatedAt),+      payload = stored.storedPayload+    }++encodeCursor :: AuditCursor -> Text+encodeCursor cursor =+  Text.pack (iso8601Show cursor.cursorCreatedAt) <> ";" <> UUID.toText cursor.cursorEventId++decodeCursor :: Text -> Maybe AuditCursor+decodeCursor value = case Text.breakOn ";" value of+  (timestamp, rest)+    | Just identifier <- Text.stripPrefix ";" rest -> do+        createdAt <- iso8601ParseM (Text.unpack timestamp)+        eventId <- UUID.fromText identifier+        pure AuditCursor {cursorCreatedAt = createdAt, cursorEventId = eventId}+  _ -> Nothing
+ src/Shomei/Audit/Handler.hs view
@@ -0,0 +1,58 @@+-- | Administrative audit-reader HTTP adapter.+module Shomei.Audit.Handler (auditServer) where++import Servant (Handler)+import Servant.Server.Generic (AsServerT)+import Shomei.Audit.Api (AuditApi (..))+import Shomei.Audit.Dto+import Shomei.Audit.Reader.Store+  ( AuditCursor (..),+    AuditEventQuery (..),+    StoredAuthEvent (..),+    clampLimit,+    emptyAuditQuery,+    queryAuthEvents,+  )+import Shomei.Audit.Result+import Shomei.Id (sessionIdToUUID, userIdToUUID)+import Shomei.Prelude+import Shomei.Servant.Application (port, runApplicationHandler)+import Shomei.Servant.Auth (AuthUser)+import Shomei.Servant.Seam (Env)++auditServer :: Env -> AuditApi (AsServerT Handler)+auditServer env = AuditApi {events = auditEventsH env}++auditEventsH ::+  Env ->+  AuthUser ->+  Maybe AuditUserId ->+  Maybe AuditSessionId ->+  [Text] ->+  Maybe AuditTimestamp ->+  Maybe AuditTimestamp ->+  Maybe Int ->+  Maybe AuditPageCursor ->+  Handler AuditEventsResult+auditEventsH env _ user session eventTypes since untilTime limit before = runApplicationHandler do+  let query =+        emptyAuditQuery+          { queryUserId = userIdToUUID . (.auditUserId) <$> user,+            querySessionId = sessionIdToUUID . (.auditSessionId) <$> session,+            queryEventTypes = eventTypes,+            querySince = (.auditTimestamp) <$> since,+            queryUntil = (.auditTimestamp) <$> untilTime,+            queryLimit = fromMaybe 50 limit,+            queryBefore = (.auditCursor) <$> before+          }+  events <- port env (queryAuthEvents query)+  let full = length events == clampLimit query.queryLimit+      nextCursor = if full then encodeCursor . cursorOf <$> lastMay events else Nothing+  pure AuditEventsPage {events = map storedToResponse events, nextCursor}+  where+    cursorOf event = AuditCursor {cursorCreatedAt = event.storedCreatedAt, cursorEventId = event.storedEventId}++lastMay :: [a] -> Maybe a+lastMay = \case+  [] -> Nothing+  values -> Just (last values)
+ src/Shomei/Audit/Result.hs view
@@ -0,0 +1,8 @@+module Shomei.Audit.Result (AuditEventsResponses, AuditEventsResult) where++import Shomei.Audit.Dto (AuditEventsPage)+import Shomei.Servant.Result++type AuditEventsResponses = ApplicationResponses 200 "Audit events" AuditEventsPage++type AuditEventsResult = ApplicationResult AuditEventsPage
+ src/Shomei/Authorization/Api.hs view
@@ -0,0 +1,21 @@+-- | Administrative authorization-grant routes.+module Shomei.Authorization.Api (AuthorizationApi (..), GrantRoleRoute, RevokeRoleRoute) where++import Servant.API+import Servant.API.MultiVerb (MultiVerb)+import Shomei.Authorization.Result+import Shomei.Id (UserId)+import Shomei.Prelude+import Shomei.Servant.Authz (RequireAdmin)+import Shomei.Servant.PreHandler (CsrfProtected, PreHandlerResponses)+import Shomei.Servant.Result (ApplicationContentTypes, BadRequestPreHandlerResponses)++type GrantRoleRoute = "users" :> RequireAdmin :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> "roles" :> Capture "role" Text :> MultiVerb 'PUT ApplicationContentTypes GrantRoleResponses GrantRoleResult++type RevokeRoleRoute = "users" :> RequireAdmin :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> "roles" :> Capture "role" Text :> MultiVerb 'DELETE ApplicationContentTypes RevokeRoleResponses RevokeRoleResult++data AuthorizationApi mode = AuthorizationApi+  { grantRole :: mode :- GrantRoleRoute,+    revokeRole :: mode :- RevokeRoleRoute+  }+  deriving stock (Generic)
+ src/Shomei/Authorization/Handler.hs view
@@ -0,0 +1,44 @@+-- | Administrative authorization HTTP adapters.+module Shomei.Authorization.Handler (authorizationServer) where++import Data.Text qualified as Text+import Servant (Handler)+import Servant.Server.Generic (AsServerT)+import Shomei.Authorization.Api (AuthorizationApi (..))+import Shomei.Authorization.Claims.Domain (Role (..))+import Shomei.Authorization.Result+import Shomei.Authorization.Role.Workflow qualified as Roles+import Shomei.Delegation.Handler (denyUnderDelegation)+import Shomei.Id (UserId)+import Shomei.Prelude+import Shomei.Servant.Application (ApplicationHandler, rejectProblem, runApplicationHandler, workflow)+import Shomei.Servant.Auth (AuthUser (..))+import Shomei.Servant.Error (detailOccurrence, noProblemOccurrence, pcBadRequest, pcRoleNotGranted)+import Shomei.Servant.Seam (Env)++authorizationServer :: Env -> AuthorizationApi (AsServerT Handler)+authorizationServer env =+  AuthorizationApi+    { grantRole = grantRoleH env,+      revokeRole = revokeRoleH env+    }++grantRoleH :: Env -> AuthUser -> UserId -> Text -> Handler GrantRoleResult+grantRoleH env actor target roleText = runApplicationHandler do+  denyUnderDelegation env "admin_grant_role" actor+  role <- parseRole roleText+  void $ workflow env (Roles.grantRoleTo (Just actor.authUserId) Nothing target role)++revokeRoleH :: Env -> AuthUser -> UserId -> Text -> Handler RevokeRoleResult+revokeRoleH env actor target roleText = runApplicationHandler do+  denyUnderDelegation env "admin_revoke_role" actor+  role <- parseRole roleText+  changed <- workflow env (Roles.revokeRoleFrom (Just actor.authUserId) target role)+  unless changed (rejectProblem pcRoleNotGranted noProblemOccurrence)++parseRole :: Text -> ApplicationHandler Role+parseRole value+  | Text.null trimmed = rejectProblem pcBadRequest (detailOccurrence "role must not be blank")+  | otherwise = pure (Role trimmed)+  where+    trimmed = Text.strip value
+ src/Shomei/Authorization/Result.hs view
@@ -0,0 +1,17 @@+module Shomei.Authorization.Result+  ( GrantRoleResponses,+    GrantRoleResult,+    RevokeRoleResponses,+    RevokeRoleResult,+  )+where++import Shomei.Servant.Result++type GrantRoleResponses = ApplicationEmptyResponses 204 "Role granted"++type GrantRoleResult = ApplicationResult ()++type RevokeRoleResponses = ApplicationEmptyResponses 204 "Role revoked"++type RevokeRoleResult = ApplicationResult ()
+ src/Shomei/Delegation/Handler.hs view
@@ -0,0 +1,31 @@+-- | Shared HTTP policy for credential-changing operations performed with a delegated token.+module Shomei.Delegation.Handler (denyUnderDelegation) where++import Shomei.Audit.Event.Domain qualified as Event+import Shomei.Audit.Publisher.Store (publishAuthEvent)+import Shomei.Authorization.Claims.Domain (AuthClaims (..))+import Shomei.Error (AuthError (ImpersonationActionBlocked))+import Shomei.Prelude+import Shomei.Servant.Application (ApplicationHandler, port, rejectAuth)+import Shomei.Servant.Auth (AuthUser (..))+import Shomei.Servant.Seam (Env)+import Shomei.Time.Store (now)++-- | Reject credential and administrative mutations when the token has an RFC 8693 actor.+denyUnderDelegation :: Env -> Text -> AuthUser -> ApplicationHandler ()+denyUnderDelegation env action user =+  case user.authClaims.actor of+    Nothing -> pure ()+    Just actorId -> do+      timestamp <- port env now+      port env $+        publishAuthEvent $+          Event.ImpersonationActionBlocked+            Event.ImpersonationActionBlockedData+              { actorUserId = actorId,+                subjectUserId = user.authUserId,+                sessionId = user.authSessionId,+                action = action,+                occurredAt = timestamp+              }+      rejectAuth ImpersonationActionBlocked
+ src/Shomei/Mfa/Api.hs view
@@ -0,0 +1,46 @@+-- | Multi-factor authentication HTTP routes.+module Shomei.Mfa.Api+  ( MfaApi (..),+    MfaCompleteRoute,+    TotpEnrollRoute,+    TotpVerifyRoute,+    TotpDeleteRoute,+    RecoveryCodesGenerateRoute,+    RecoveryCodesCountRoute,+  )+where++import Servant.API+import Servant.API.MultiVerb (MultiVerb)+import Shomei.Mfa.Dto+  ( MfaCompleteRequest,+    TotpRemoveRequest,+    TotpVerifyRequest,+  )+import Shomei.Mfa.Result+import Shomei.Prelude+import Shomei.Servant.Auth (Authenticated)+import Shomei.Servant.PreHandler (CsrfProtected, PreHandlerResponses, RateLimited)+import Shomei.Servant.Result (ApplicationContentTypes, BadRequestPreHandlerResponses)++type MfaCompleteRoute = "mfa" :> "complete" :> RateLimited :> RemoteHost :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] MfaCompleteRequest :> MultiVerb 'POST ApplicationContentTypes MfaCompleteResponses MfaCompleteResult++type TotpEnrollRoute = "totp" :> "enroll" :> Authenticated :> CsrfProtected :> MultiVerb 'POST ApplicationContentTypes TotpEnrollResponses TotpEnrollResult++type TotpVerifyRoute = "totp" :> "verify" :> Authenticated :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] TotpVerifyRequest :> MultiVerb 'POST ApplicationContentTypes TotpVerifyResponses TotpVerifyResult++type TotpDeleteRoute = "totp" :> RateLimited :> Authenticated :> CsrfProtected :> RemoteHost :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] TotpRemoveRequest :> MultiVerb 'DELETE ApplicationContentTypes TotpDeleteResponses TotpDeleteResult++type RecoveryCodesGenerateRoute = "recovery-codes" :> Authenticated :> CsrfProtected :> MultiVerb 'POST ApplicationContentTypes RecoveryCodesGenerateResponses RecoveryCodesGenerateResult++type RecoveryCodesCountRoute = "recovery-codes" :> Authenticated :> MultiVerb 'GET ApplicationContentTypes RecoveryCodesCountResponses RecoveryCodesCountResult++data MfaApi mode = MfaApi+  { complete :: mode :- MfaCompleteRoute,+    totpEnroll :: mode :- TotpEnrollRoute,+    totpVerify :: mode :- TotpVerifyRoute,+    totpDelete :: mode :- TotpDeleteRoute,+    recoveryCodesGenerate :: mode :- RecoveryCodesGenerateRoute,+    recoveryCodesCount :: mode :- RecoveryCodesCountRoute+  }+  deriving stock (Generic)
+ src/Shomei/Mfa/Dto.hs view
@@ -0,0 +1,107 @@+-- | MFA, TOTP, and recovery-code wire types.+module Shomei.Mfa.Dto+  ( MfaProof (..),+    MfaCompleteRequest (..),+    mfaCompletionOf,+    TotpEnrollResponse (..),+    TotpVerifyRequest (..),+    TotpRemoveRequest (..),+    totpRemovalProofOf,+    RecoveryCodesResponse (..),+    RecoveryCodesCountResponse (..),+  )+where++import Data.Aeson (Value, object, withObject, (.:), (.:?))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (Parser)+import Data.List (sort)+import Data.Maybe (catMaybes, isJust)+import Data.Text qualified as Text+import Shomei.Mfa.Totp.Workflow (TotpRemovalProof (..))+import Shomei.Mfa.Workflow (MfaCompletion (..))+import Shomei.Prelude++data MfaProof+  = PasskeyProof {assertion :: !Value}+  | TotpProof {code :: !Text}+  | RecoveryCodeProof {code :: !Text}+  deriving stock (Generic)++instance FromJSON MfaProof where+  parseJSON = withObject "MfaProof" \objectValue -> do+    proofType <- objectValue .: "type" :: Parser Text+    case proofType of+      "passkey" -> requireKeys ["assertion", "type"] objectValue >> PasskeyProof <$> objectValue .: "assertion"+      "totp" -> requireKeys ["code", "type"] objectValue >> TotpProof <$> objectValue .: "code"+      "recovery_code" -> requireKeys ["code", "type"] objectValue >> RecoveryCodeProof <$> objectValue .: "code"+      other -> fail ("unknown MFA proof type: " <> Text.unpack other)+    where+      requireKeys expected objectValue =+        unless (sort (map Key.toText (KeyMap.keys objectValue)) == expected) $+          fail "MFA proof contains missing or unexpected fields"++instance ToJSON MfaProof where+  toJSON = \case+    PasskeyProof assertion -> object ["type" Aeson..= ("passkey" :: Text), "assertion" Aeson..= assertion]+    TotpProof code -> object ["type" Aeson..= ("totp" :: Text), "code" Aeson..= code]+    RecoveryCodeProof code -> object ["type" Aeson..= ("recovery_code" :: Text), "code" Aeson..= code]++data MfaCompleteRequest = MfaCompleteRequest+  { ceremonyId :: !Text,+    proof :: !MfaProof+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++mfaCompletionOf :: MfaCompleteRequest -> MfaCompletion+mfaCompletionOf MfaCompleteRequest {proof} = case proof of+  PasskeyProof assertion -> MfaPasskey assertion+  TotpProof code -> MfaTotp code+  RecoveryCodeProof code -> MfaRecoveryCode code++data TotpEnrollResponse = TotpEnrollResponse+  { secret :: !Text,+    otpauthUri :: !Text+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype TotpVerifyRequest = TotpVerifyRequest {code :: Text}+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data TotpRemoveRequest = TotpRemoveRequest+  { code :: !(Maybe Text),+    recoveryCode :: !(Maybe Text)+  }+  deriving stock (Generic)++instance FromJSON TotpRemoveRequest where+  parseJSON = withObject "TotpRemoveRequest" \objectValue -> do+    code <- objectValue .:? "code"+    recoveryCode <- objectValue .:? "recoveryCode"+    case (isJust code, isJust recoveryCode) of+      (True, False) -> pure (TotpRemoveRequest code recoveryCode)+      (False, True) -> pure (TotpRemoveRequest code recoveryCode)+      _ -> fail "exactly one of code, recoveryCode must be present"++instance ToJSON TotpRemoveRequest where+  toJSON (TotpRemoveRequest code recoveryCode) =+    object (catMaybes [("code" Aeson..=) <$> code, ("recoveryCode" Aeson..=) <$> recoveryCode])++totpRemovalProofOf :: TotpRemoveRequest -> TotpRemovalProof+totpRemovalProofOf (TotpRemoveRequest code recoveryCode) = case (code, recoveryCode) of+  (Just value, _) -> RemoveWithCode value+  (_, Just value) -> RemoveWithRecoveryCode value+  _ -> RemoveWithCode ""++newtype RecoveryCodesResponse = RecoveryCodesResponse {codes :: [Text]}+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype RecoveryCodesCountResponse = RecoveryCodesCountResponse {remaining :: Int}+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)
+ src/Shomei/Mfa/Handler.hs view
@@ -0,0 +1,97 @@+-- | MFA, TOTP, and recovery-code HTTP adapters.+module Shomei.Mfa.Handler (mfaServer) where++import Data.Time (addUTCTime)+import Network.Socket (SockAddr)+import Servant (Handler)+import Servant.Server.Generic (AsServerT)+import Shomei.Account.Handler (loadUser)+import Shomei.Authorization.Claims.Domain (AuthClaims (..))+import Shomei.Config (ImpersonationConfig (..), ShomeiConfig (..))+import Shomei.Delegation.Handler (denyUnderDelegation)+import Shomei.Id (parseId)+import Shomei.Mfa.Api (MfaApi (..))+import Shomei.Mfa.Dto+import Shomei.Mfa.RecoveryCode.Store (countUnusedRecoveryCodes)+import Shomei.Mfa.Result+import Shomei.Mfa.Totp.Workflow qualified as Totp+import Shomei.Mfa.Workflow qualified as Mfa+import Shomei.Prelude+import Shomei.Servant.Application (ApplicationHandler, port, rejectProblem, runApplicationHandler, workflow)+import Shomei.Servant.Auth (AuthUser (..))+import Shomei.Servant.ClientIp (clientIpText)+import Shomei.Servant.Cookie (tokenCookies)+import Shomei.Servant.Error (detailOccurrence, noProblemOccurrence, pcBadRequest, pcReauthenticationRequired)+import Shomei.Servant.Result (cookieResponse)+import Shomei.Servant.Seam (Env (..))+import Shomei.Session.Command (ProofContext (..))+import Shomei.Session.Dto (tokenPairToResponse)+import Shomei.Session.LoginAttempt.Domain (ClientIp (..))+import Shomei.Time.Store (now)++mfaServer :: Env -> MfaApi (AsServerT Handler)+mfaServer env =+  MfaApi+    { complete = completeH env,+      totpEnroll = totpEnrollH env,+      totpVerify = totpVerifyH env,+      totpDelete = totpDeleteH env,+      recoveryCodesGenerate = recoveryCodesGenerateH env,+      recoveryCodesCount = recoveryCodesCountH env+    }++completeH :: Env -> SockAddr -> MfaCompleteRequest -> Handler MfaCompleteResult+completeH env peer request = runApplicationHandler do+  ceremonyId <-+    either+      (const (rejectProblem pcBadRequest (detailOccurrence "invalid ceremonyId")))+      pure+      (parseId request.ceremonyId)+  (_, tokens) <- workflow env (Mfa.completeMfa env.config (proofContext env peer) ceremonyId (mfaCompletionOf request))+  pure (cookieResponse env.config (tokenCookies env.config tokens) (tokenPairToResponse env.config tokens))++totpEnrollH :: Env -> AuthUser -> Handler TotpEnrollResult+totpEnrollH env authUser = runApplicationHandler do+  denyUnderDelegation env "totp_enroll" authUser+  user <- loadUser env authUser+  Totp.TotpEnrollment {secretBase32, otpauthUri} <- workflow env (Totp.enrollTotp env.config user)+  pure TotpEnrollResponse {secret = secretBase32, otpauthUri}++totpVerifyH :: Env -> AuthUser -> TotpVerifyRequest -> Handler TotpVerifyResult+totpVerifyH env authUser request = runApplicationHandler do+  user <- loadUser env authUser+  workflow env (Totp.verifyTotpEnrollment env.config user request.code)++totpDeleteH :: Env -> AuthUser -> SockAddr -> TotpRemoveRequest -> Handler TotpDeleteResult+totpDeleteH env authUser peer request = runApplicationHandler do+  denyUnderDelegation env "totp_remove" authUser+  requireFreshAuth env authUser+  user <- loadUser env authUser+  workflow env (Totp.removeTotp env.config (proofContext env peer) user (totpRemovalProofOf request))++recoveryCodesGenerateH :: Env -> AuthUser -> Handler RecoveryCodesGenerateResult+recoveryCodesGenerateH env authUser = runApplicationHandler do+  denyUnderDelegation env "recovery_codes_generate" authUser+  requireFreshAuth env authUser+  user <- loadUser env authUser+  codes <- workflow env (Totp.regenerateRecoveryCodes env.config user)+  pure RecoveryCodesResponse {codes}++recoveryCodesCountH :: Env -> AuthUser -> Handler RecoveryCodesCountResult+recoveryCodesCountH env authUser = runApplicationHandler do+  remaining <- port env (countUnusedRecoveryCodes authUser.authUserId)+  pure RecoveryCodesCountResponse {remaining}++requireFreshAuth :: Env -> AuthUser -> ApplicationHandler ()+requireFreshAuth env user = do+  timestamp <- port env now+  let window = env.config.impersonationConfig.actorFreshnessWindow+  when (timestamp > addUTCTime window user.authClaims.authTime) $+    rejectProblem pcReauthenticationRequired noProblemOccurrence++proofContext :: Env -> SockAddr -> ProofContext+proofContext env peer =+  ProofContext+    { clientIp = ClientIp (clientIpText peer),+      accountKeyOf = env.accountKeyOf+    }
+ src/Shomei/Mfa/Result.hs view
@@ -0,0 +1,43 @@+module Shomei.Mfa.Result+  ( MfaCompleteResponses,+    MfaCompleteResult,+    TotpEnrollResponses,+    TotpEnrollResult,+    TotpVerifyResponses,+    TotpVerifyResult,+    TotpDeleteResponses,+    TotpDeleteResult,+    RecoveryCodesGenerateResponses,+    RecoveryCodesGenerateResult,+    RecoveryCodesCountResponses,+    RecoveryCodesCountResult,+  )+where++import Shomei.Mfa.Dto+import Shomei.Servant.Result+import Shomei.Session.Dto (TokenPairResponse)++type MfaCompleteResponses = ApplicationCookieResponses 200 "Authenticated" TokenPairResponse++type MfaCompleteResult = ApplicationResult (CookieResponse TokenPairResponse)++type TotpEnrollResponses = ApplicationResponses 200 "TOTP enrollment" TotpEnrollResponse++type TotpEnrollResult = ApplicationResult TotpEnrollResponse++type TotpVerifyResponses = ApplicationEmptyResponses 200 "TOTP enrollment verified"++type TotpVerifyResult = ApplicationResult ()++type TotpDeleteResponses = ApplicationEmptyResponses 204 "TOTP removed"++type TotpDeleteResult = ApplicationResult ()++type RecoveryCodesGenerateResponses = ApplicationResponses 200 "Recovery codes" RecoveryCodesResponse++type RecoveryCodesGenerateResult = ApplicationResult RecoveryCodesResponse++type RecoveryCodesCountResponses = ApplicationResponses 200 "Recovery code count" RecoveryCodesCountResponse++type RecoveryCodesCountResult = ApplicationResult RecoveryCodesCountResponse
+ src/Shomei/OAuth/Api.hs view
@@ -0,0 +1,37 @@+-- | OAuth 2.0 protocol routes. These use protocol result types rather than application problems.+module Shomei.OAuth.Api+  ( OAuthApi (..),+    AuthorizeRoute,+    TokenRoute,+    UserinfoRoute,+    IntrospectRoute,+    RevokeRoute,+  )+where++import Servant.API+import Servant.API.MultiVerb (MultiVerb)+import Shomei.OAuth.Result+import Shomei.Prelude+import Shomei.Servant.Auth (OAuthAuthenticated)+import Shomei.Servant.PreHandler (RateLimited)+import Web.FormUrlEncoded (Form)++type AuthorizeRoute = "authorize" :> Header "Authorization" Text :> Header "Cookie" Text :> QueryParam "response_type" Text :> QueryParam "client_id" Text :> QueryParam "redirect_uri" Text :> QueryParam "scope" Text :> QueryParam "state" Text :> QueryParam "nonce" Text :> QueryParam "code_challenge" Text :> QueryParam "code_challenge_method" Text :> MultiVerb 'GET '[JSON] AuthorizeResponses AuthorizeResult++type TokenRoute = "token" :> RateLimited :> Header "Authorization" Text :> RemoteHost :> ReqBody '[FormUrlEncoded] Form :> MultiVerb 'POST '[JSON] TokenResponses TokenResult++type UserinfoRoute = "userinfo" :> OAuthAuthenticated :> MultiVerb 'GET '[JSON] UserinfoResponses UserinfoResult++type IntrospectRoute = "introspect" :> Header "Authorization" Text :> ReqBody '[FormUrlEncoded] Form :> MultiVerb 'POST '[JSON] IntrospectResponses IntrospectResult++type RevokeRoute = "revoke" :> Header "Authorization" Text :> ReqBody '[FormUrlEncoded] Form :> MultiVerb 'POST '[JSON] RevokeResponses RevokeResult++data OAuthApi mode = OAuthApi+  { authorize :: mode :- AuthorizeRoute,+    token :: mode :- TokenRoute,+    userinfo :: mode :- UserinfoRoute,+    introspect :: mode :- IntrospectRoute,+    revoke :: mode :- RevokeRoute+  }+  deriving stock (Generic)
+ src/Shomei/OAuth/Handler.hs view
@@ -0,0 +1,689 @@+-- | OAuth and OIDC protocol handlers. These endpoints deliberately retain+-- their protocol-defined error envelope instead of application Problem Details.+module Shomei.OAuth.Handler+  ( oauthServer,+    oidcDiscoveryH,+  )+where++import Control.Monad.Except (catchError)+import Data.Aeson (Value)+import Data.Aeson qualified as Aeson+import Data.ByteString (ByteString)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Data.Time (NominalDiffTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Effectful (Eff)+import Network.HTTP.Types.Status (status400, status401, status404, status500, status503)+import Network.HTTP.Types.URI (renderSimpleQuery)+import Network.Socket (SockAddr)+import Servant (Handler, ServerError (..), throwError)+import Servant.Server.Generic (AsServerT)+import Shomei.Account.Email.Domain (emailText)+import Shomei.Account.User.Domain (User (..))+import Shomei.Account.User.Store (findUserById)+import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Role (..), Scope (..))+import Shomei.Config (OAuthConfig (..), ShomeiConfig (..))+import Shomei.Error (AuthError (..))+import Shomei.Id (idText)+import Shomei.OAuth.Api (OAuthApi (..))+import Shomei.OAuth.Authorize.Workflow qualified as OAuthAuthorize+import Shomei.OAuth.Client.Domain (OAuthClientStatus (..), isRegisteredRedirectUri)+import Shomei.OAuth.Client.Domain qualified as OAuthClient+import Shomei.OAuth.Client.Store (findOAuthClientByClientId)+import Shomei.OAuth.IdToken.Domain (IdToken (..))+import Shomei.OAuth.Result+import Shomei.OAuth.Revocation.Domain (RevocationCaller (..), mayRevokeSession)+import Shomei.OAuth.TokenExchange.Workflow qualified as TokenExchange+import Shomei.OAuth.TokenGrant.Workflow qualified as OAuthTokenGrant+import Shomei.Prelude+import Shomei.Servant.Auth (AuthUser (..), resolveAuthUser)+import Shomei.Servant.ClientIp (clientIpText)+import Shomei.Servant.OAuth qualified as OAuth+import Shomei.Servant.Oidc qualified as Oidc+import Shomei.Servant.Seam (AppEffects, Env (..), runPortResult)+import Shomei.ServiceAccount.ClientCredentials.Workflow qualified as ClientCredentials+import Shomei.ServiceAccount.Domain qualified as ServiceAccount+import Shomei.ServiceAccount.Secret qualified as ServiceAccountSecret+import Shomei.ServiceAccount.Store (findServiceAccountByClientId)+import Shomei.Session.Domain qualified as Session+import Shomei.Session.RefreshToken.Domain (RefreshToken (..), RefreshTokenStatus (RefreshTokenActive))+import Shomei.Session.RefreshToken.Store (findRefreshTokenByHash, revokeRefreshTokenFamily, revokeSessionRefreshTokens)+import Shomei.Session.Store (findSessionById)+import Shomei.Session.Store qualified as SessionStore+import Shomei.Session.Token.Domain (AccessToken (..))+import Shomei.Session.Token.Generator (hashRefreshToken)+import Shomei.SigningKey.Verifier (verifyAccessToken)+import Shomei.Time.Store (now)+import Web.FormUrlEncoded (Form)++oauthServer :: Env -> OAuthApi (AsServerT Handler)+oauthServer env =+  OAuthApi+    { authorize = \a b c d e f g h i j -> typedOAuth (oauthAuthorizeH env a b c d e f g h i j),+      token = \authorization peer form -> typedOAuth (oauthTokenH env authorization peer form),+      userinfo = \user -> typedOAuth (oauthUserinfoH env user),+      introspect = \authorization form -> typedOAuth (oauthIntrospectH env authorization form),+      revoke = \authorization form -> typedOAuth (oauthRevokeH env authorization form)+    }++typedOAuth :: Handler a -> Handler (OAuthResult a)+typedOAuth action = (OAuthSuccess <$> action) `catchError` (pure . oauthServerErrorResult)++runOAuthPort :: Env -> Eff AppEffects a -> Handler a+runOAuthPort env action = runPortResult env action >>= either (throwError . oauthInfrastructureError) pure++oauthInfrastructureError :: AuthError -> ServerError+oauthInfrastructureError = \case+  DependencyUnavailable _ -> OAuth.oauthError status503 "temporarily_unavailable" "a required dependency is unavailable"+  _ -> OAuth.oauthError status500 "server_error" "the authorization server encountered an unexpected condition"++-- | @GET \/.well-known\/openid-configuration@ (EP-5).+--+-- With the provider disabled the answer is @404@ carrying an RFC 6749-shaped body, not a problem+-- document: a client that reaches this URL is OIDC tooling, and it must fail on a shape it can+-- parse. This is the same envelope boundary the @\/oauth\/*@ endpoints observe.+oidcDiscoveryH :: Env -> Handler OidcDiscoveryResult+oidcDiscoveryH env = typedOAuth (oidcDiscoveryValueH env)++oidcDiscoveryValueH :: Env -> Handler Value+oidcDiscoveryValueH env+  | env.config.oauthConfig.oidcEnabled = pure (Oidc.discoveryDocument env.config)+  | otherwise =+      throwError+        ( OAuth.oauthError+            status404+            "not_found"+            "the OIDC provider is not enabled on this deployment"+        )++-- | @GET \/oauth\/authorize@ (EP-5): the authorization-code flow's browser leg (RFC 6749 §4.1).+--+-- __The order of the five steps below is the security property__, not a style choice.+--+--   1. Resolve @client_id@ to an /active/ client and require @redirect_uri@ to be one of its+--      registered URIs, compared byte for byte. Either failing is @400@ with __no redirect__: a+--      server that redirects to an unvalidated URI is an open redirector, and an attacker uses it+--      to have this endpoint deliver authorization codes to a host of their choosing. This is why+--      a test that wants an error for an unknown client must expect @400@ and never @302@.+--+--   2. Any other parameter violation redirects to the /now validated/ @redirect_uri@ carrying+--      @error@, @error_description@, and the echoed @state@ (RFC 6749 §4.1.2.1). The client, not+--      the user, is the one who can fix these.+--+--   3. No authenticated user: redirect to the operator's @loginUrl@ with the /reconstructed/+--      authorize URL in @return_to@. It is rebuilt from the parameters this handler validated,+--      never from anything the caller supplied, so the host cannot be talked into sending the+--      user back to somewhere else. With no @loginUrl@ configured, @401@ with an OAuth error body.+--      Shōmei persists no pending-authorize state: it all round-trips in that URL.+--+--   4. An authenticated but non-interactive credential (machine, delegated, or carrying @act@)+--      is refused with @401 login_required@ and no redirect.+--+--   5. A live interactive session runs the workflow and redirects with @code@, @state@, and @iss@.+oauthAuthorizeH ::+  Env ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Handler AuthorizeRedirect+oauthAuthorizeH env mAuthHeader mCookie mResponseType mClientId mRedirectUri mScope mState mNonce mChallenge mChallengeMethod = do+  unless env.config.oauthConfig.oidcEnabled (throwError providerDisabled)++  -- (1) The no-redirect regime.+  clientId <- maybe (throwError (oauthBadRequest "client_id is required")) pure mClientId+  redirectUri <- maybe (throwError (oauthBadRequest "redirect_uri is required")) pure mRedirectUri+  client <-+    runOAuthPort env (findOAuthClientByClientId clientId)+      >>= maybe (throwError (oauthBadRequest "unknown client_id")) pure+  -- A revoked client is refused exactly as an unknown one is, and neither may redirect.+  unless (client ^. #status == OAuthClientActive) (throwError (oauthBadRequest "unknown client_id"))+  unless (isRegisteredRedirectUri client redirectUri) (throwError (oauthBadRequest "redirect_uri is not registered for this client"))++  let params =+        OAuthAuthorize.AuthorizeParams+          { responseType = mResponseType,+            redirectUri,+            scope = mScope,+            state = mState,+            nonce = mNonce,+            codeChallenge = mChallenge,+            codeChallengeMethod = mChallengeMethod+          }++  -- (3) Authenticate before running the workflow, so a request that is going to bounce to the+  -- login page never mints a code. The parameter errors in (2) are still reported first when they+  -- apply to an authenticated caller, because the workflow raises them.+  let loginRequired = case env.config.oauthConfig.loginUrl of+        Just loginUrl -> redirectTo (loginUrl `withQuery` [("return_to", TE.encodeUtf8 (reconstructedAuthorizeUrl params clientId))])+        Nothing -> throwError (OAuth.oauthError status401 "login_required" "no authenticated user and no login URL is configured")+  mUser <- liftIO (resolveAuthUser env mAuthHeader mCookie)+  case mUser of+    Nothing -> loginRequired+    -- Defense in depth: the workflow repeats this rule for library callers, while the handler+    -- refuses an explicit actor without spending a session-store read.+    Just user | isJust user.authClaims.actor -> throwError notInteractive+    Just user -> do+      outcome <- runOAuthPort env (OAuthAuthorize.authorize env.config client user.authClaims params)+      case outcome of+        Left (OAuthAuthorize.AuthorizeLoginRequired OAuthAuthorize.NonInteractiveCredential) ->+          throwError notInteractive+        Left (OAuthAuthorize.AuthorizeLoginRequired OAuthAuthorize.SessionNotLive) -> loginRequired+        -- (2) The redirect regime: the client learns what it did wrong, at a URI we validated.+        Left e ->+          redirectTo+            ( redirectUri+                `withQuery` ( [ ("error", TE.encodeUtf8 (OAuthAuthorize.authorizeErrorCode e)),+                                ("error_description", TE.encodeUtf8 (OAuthAuthorize.authorizeErrorDescription e))+                              ]+                                <> stateParam mState+                            )+            )+        -- (4) RFC 9207: `iss` lets a client that talks to several providers detect a mix-up attack.+        Right issued ->+          redirectTo+            ( redirectUri+                `withQuery` ( [("code", TE.encodeUtf8 (issued ^. #code))]+                                <> stateParam (issued ^. #state)+                                <> [("iss", TE.encodeUtf8 (issuerText env.config.issuer))]+                            )+            )+  where+    notInteractive =+      OAuth.oauthError status401 "login_required" "an interactive login session is required to authorize a client"++    providerDisabled =+      OAuth.oauthError status404 "not_found" "the OIDC provider is not enabled on this deployment"++    oauthBadRequest = OAuth.oauthError status400 "invalid_request"++    stateParam = foldMap (\s -> [("state", TE.encodeUtf8 s)])++    issuerText (Issuer t) = t++    -- `no-store` on every answer: a cached 302 would replay a one-time code out of the browser's+    -- history, and a cached error redirect would confuse a retry.+    redirectTo loc = pure (AuthorizeRedirect loc "no-store")++    -- Rebuilt from what this handler validated, never from a caller-supplied copy. The base is the+    -- issuer, which for an OIDC-enabled deployment IS the public base URL (boot enforces it).+    reconstructedAuthorizeUrl params clientId =+      (Oidc.oidcEndpointBase env.config <> "/oauth/authorize")+        `withQuery` ( [ ("client_id", TE.encodeUtf8 clientId),+                        ("redirect_uri", TE.encodeUtf8 params.redirectUri)+                      ]+                        <> optional "response_type" params.responseType+                        <> optional "scope" params.scope+                        <> optional "state" params.state+                        <> optional "nonce" params.nonce+                        <> optional "code_challenge" params.codeChallenge+                        <> optional "code_challenge_method" params.codeChallengeMethod+                    )++    optional k = foldMap (\v -> [(k, TE.encodeUtf8 v)])++-- | Append query parameters to a URL that may already carry some.+--+-- 'renderSimpleQuery' percent-encodes every key and value, which is what keeps a @state@ or+-- @return_to@ containing @&@ or @#@ from splicing extra parameters into the URL.+withQuery :: Text -> [(ByteString, ByteString)] -> Text+withQuery url params+  | null params = url+  | otherwise = url <> separator <> TE.decodeUtf8 (renderSimpleQuery False params)+  where+    separator = if Text.any (== '?') url then "&" else "?"++-- | @POST \/oauth\/token@ (EP-4): the OAuth2 token endpoint and its @grant_type@ dispatcher.+--+-- __Every failure here is rendered by 'OAuth.oauthError' in the RFC 6749 §5.2 shape__, never by+-- 'authErrorToServerError'. A stock OAuth2 client parses @error@\/@error_description@ by field+-- name; handing it a problem document would break it. This is the one endpoint exempt from the+-- application-wide envelope (see "Shomei.Servant.OAuth" and "Shomei.Servant.Error").+--+-- __This @case@ is the extension point for the sibling plans in this MasterPlan.__ Plan 42+-- (@docs\/plans\/42-oidc-provider-subset-…@) registers @authorization_code@ (with PKCE+-- verification) and @refresh_token@ here; plan 43+-- (@docs\/plans\/43-rfc-8693-token-exchange-endpoint.md@) registers+-- @urn:ietf:params:oauth:grant-type:token-exchange@. Both reuse 'OAuth.extractClientAuth' and+-- 'OAuth.oauthError' unchanged; only this dispatcher grows an arm.+oauthTokenH ::+  Env ->+  Maybe Text ->+  SockAddr ->+  Form ->+  Handler TokenSuccess+oauthTokenH env mAuthHeader peer form =+  case OAuth.lookupParam "grant_type" form of+    Nothing -> throwError (OAuth.invalidRequest "grant_type is required")+    Just "client_credentials" -> clientCredentialsGrant env mAuthHeader form+    Just "authorization_code" -> authorizationCodeGrant env mAuthHeader form+    Just "refresh_token" -> refreshTokenGrant env mAuthHeader form+    Just "urn:ietf:params:oauth:grant-type:token-exchange" -> tokenExchangeGrant env mAuthHeader peer form+    Just other -> throwError (OAuth.unsupportedGrantType other)++-- | RFC 6749 §4.4. Authenticate the client, read the optional @scope@, mint the token.+clientCredentialsGrant ::+  Env ->+  Maybe Text ->+  Form ->+  Handler TokenSuccess+clientCredentialsGrant env mAuthHeader form = do+  auth <- either throwError pure (OAuth.extractClientAuth mAuthHeader form)+  let grant =+        ClientCredentials.ClientCredentialsGrant+          { clientId = auth ^. #clientId,+            clientSecret = auth ^. #clientSecret,+            requestedScopes = OAuth.parseScopeParam form+          }+  outcome <- runOAuthPort env (ClientCredentials.grantClientCredentials env.config grant)+  granted <- either (throwError . oauthErrorFor) pure outcome+  -- Read through lens labels: 'GrantedToken' shares @accessToken@/@expiresIn@/@sessionId@ with+  -- Several grant result records share @accessToken@, so select the field through its label.+  let AccessToken token = granted ^. #accessToken+      body =+        OAuth.TokenResponse+          { accessToken = token,+            tokenType = "Bearer",+            expiresIn = round (granted ^. #expiresIn),+            scope = Text.unwords [s | Scope s <- Set.toList (granted ^. #grantedScopes)],+            -- Deliberately refresh-less: the credential dies at its TTL and the client asks again.+            refreshToken = Nothing,+            idToken = Nothing,+            issuedTokenType = Nothing+          }+  pure (TokenSuccess body "no-store" "no-cache")++-- | RFC 6749 §4.1.3 with PKCE (RFC 7636). Redeem the code, mint access + refresh + (for @openid@)+-- an ID token.+authorizationCodeGrant ::+  Env ->+  Maybe Text ->+  Form ->+  Handler TokenSuccess+authorizationCodeGrant env mAuthHeader form = do+  (clientId, mSecret) <- oauthClientCredentials mAuthHeader form+  code <- requireParam "code" form+  redirectUri <- requireParam "redirect_uri" form+  let grant =+        OAuthTokenGrant.ExchangeAuthorizationCode+          { clientId,+            clientSecret = mSecret,+            code,+            redirectUri,+            codeVerifier = OAuth.lookupParam "code_verifier" form+          }+  outcome <- runOAuthPort env (OAuthTokenGrant.exchangeAuthorizationCode env.config grant)+  exchanged <- either (throwError . grantError) pure outcome+  let AccessToken access = exchanged ^. #tokens . #accessToken+      RefreshToken refresh = exchanged ^. #tokens . #refreshToken+      body =+        OAuth.TokenResponse+          { accessToken = access,+            tokenType = "Bearer",+            expiresIn = round env.config.accessTokenTTL,+            scope = Text.unwords [sc | Scope sc <- Set.toList (exchanged ^. #grantedScopes)],+            refreshToken = Just refresh,+            idToken = (\(IdToken t) -> t) <$> exchanged ^. #idToken,+            issuedTokenType = Nothing+          }+  pure (TokenSuccess body "no-store" "no-cache")++-- | RFC 6749 §6, bound to the client that minted the session. Rotation and reuse detection are the+-- existing workflow's; this arm adds only the client check.+refreshTokenGrant ::+  Env ->+  Maybe Text ->+  Form ->+  Handler TokenSuccess+refreshTokenGrant env mAuthHeader form = do+  (clientId, mSecret) <- oauthClientCredentials mAuthHeader form+  presented <- requireParam "refresh_token" form+  let grant =+        OAuthTokenGrant.RefreshViaOAuth+          { clientId,+            clientSecret = mSecret,+            refreshToken = RefreshToken presented+          }+  outcome <- runOAuthPort env (OAuthTokenGrant.refreshViaOAuth env.config grant)+  refreshed <- either (throwError . grantError) pure outcome+  -- Read through lens labels: 'TokenPair' shares @accessToken@/@refreshToken@/@expiresIn@ with+  -- 'OAuth.TokenResponse' and 'ExchangedTokens', so dot access is ambiguous here.+  let AccessToken access = refreshed ^. #tokens . #accessToken+      RefreshToken rotated = refreshed ^. #tokens . #refreshToken+      body =+        OAuth.TokenResponse+          { accessToken = access,+            tokenType = "Bearer",+            expiresIn = round (refreshed ^. #tokens . #expiresIn :: NominalDiffTime),+            scope = Text.unwords [scope | Scope scope <- Set.toList (refreshed ^. #grantedScopes)],+            refreshToken = Just rotated,+            -- No ID token on refresh: the nonce and auth_time an ID token must carry belong to the+            -- authorize request, and Shōmei does not persist them past the code. A client that+            -- needs a fresh ID token runs the authorize flow again.+            idToken = Nothing,+            issuedTokenType = Nothing+          }+  pure (TokenSuccess body "no-store" "no-cache")++-- | RFC 8693 token exchange (EP-6): the third grant on @POST \/oauth\/token@. Two modes selected by+-- the parameters (see "Shomei.OAuth.TokenExchange.Workflow"):+--+--   * __impersonation__ — no client authentication; the operator's credential is the @actor_token@.+--   * __service on-behalf-of__ — the service authenticates as an EP-4 service account (client_secret_+--     basic\/post) and presents a user's access token as the @subject_token@.+--+-- Client authentication is /optional/ here, which is why this arm cannot reuse+-- 'oauthClientCredentials' (which demands it): absent credentials mean impersonation mode, present+-- credentials must resolve to an active service account or fail @401 invalid_client@. The @resource@+-- parameter is rejected; @audience@ is ignored (both documented in the plan).+tokenExchangeGrant ::+  Env ->+  Maybe Text ->+  SockAddr ->+  Form ->+  Handler TokenSuccess+tokenExchangeGrant env mAuthHeader peer form = do+  when (isJust (OAuth.lookupParam "resource" form)) $+    throwError (OAuth.invalidRequest "resource parameter not supported")+  mSvc <- resolveExchangeClient env mAuthHeader form+  subjectToken <- requireParam "subject_token" form+  subjectTokenType <- requireParam "subject_token_type" form+  let req =+        TokenExchange.ExchangeRequest+          { subjectToken,+            subjectTokenType,+            actorToken = OAuth.lookupParam "actor_token" form,+            actorTokenType = OAuth.lookupParam "actor_token_type" form,+            requestedScopes = OAuth.parseScopeParam form,+            requestedTokenType = OAuth.lookupParam "requested_token_type" form,+            reason = OAuth.lookupParam "reason" form,+            ticketId = OAuth.lookupParam "ticket_id" form,+            clientIp = Just (clientIpText peer),+            authenticatedService = mSvc+          }+  outcome <- runOAuthPort env (TokenExchange.exchangeToken env.config req)+  exchanged <- either (throwError . exchangeErrorFor) pure outcome+  let AccessToken access = exchanged ^. #accessToken+      body =+        OAuth.TokenResponse+          { accessToken = access,+            tokenType = "Bearer",+            expiresIn = round (exchanged ^. #expiresIn :: NominalDiffTime),+            scope = Text.unwords [s | Scope s <- Set.toList (exchanged ^. #grantedScopes)],+            -- Refresh-less by design: a delegated token cannot be silently renewed (both modes).+            refreshToken = Nothing,+            idToken = Nothing,+            -- RFC 8693 §2.2.1 requires this member; Shōmei's exchange only ever issues access tokens.+            issuedTokenType = Just TokenExchange.accessTokenType+          }+  pure (TokenSuccess body "no-store" "no-cache")++-- | Resolve the /optional/ client authentication of a token-exchange request. Absent credentials →+-- 'Nothing' (impersonation mode). Present credentials must resolve to an active service account and+-- match its secret, else @401 invalid_client@ — a bad or unknown credential must never be mistaken+-- for "no credential" and silently downgraded to impersonation mode.+resolveExchangeClient :: Env -> Maybe Text -> Form -> Handler (Maybe ServiceAccount.ServiceAccount)+resolveExchangeClient env mAuthHeader form =+  case OAuth.extractClientAuth mAuthHeader form of+    Right auth -> do+      mAccount <- runOAuthPort env (findServiceAccountByClientId (auth ^. #clientId))+      case mAccount of+        Just acc | serviceAccountAuthenticates (auth ^. #clientSecret) acc -> pure (Just acc)+        _ -> throwError OAuth.invalidClient+    -- 'extractClientAuth' fails both when credentials are absent and when they are malformed. Only a+    -- fully absent credential (no Authorization header, no client_id/client_secret) is impersonation+    -- mode; anything partial is a malformed client attempt.+    Left _+      | isJust mAuthHeader+          || isJust (OAuth.lookupParam "client_id" form)+          || isJust (OAuth.lookupParam "client_secret" form) ->+          throwError OAuth.invalidClient+      | otherwise -> pure Nothing++-- | Render a token-exchange failure as its RFC 6749 §5.2 object. The impersonation guards+-- ('ImpersonationForbidden'\/'ImpersonationTargetInvalid') collapse to a generic @invalid_grant@ so+-- a stock caller learns nothing of Shōmei's impersonation policy internals.+exchangeErrorFor :: AuthError -> ServerError+exchangeErrorFor = \case+  OAuthClientInvalid -> OAuth.invalidClient+  OAuthScopeInvalid -> OAuth.oauthError status400 "invalid_scope" "the requested scope is empty, or exceeds what the account or subject may grant"+  OAuthRequestMalformed -> OAuth.oauthError status400 "invalid_request" "the token-exchange request is malformed"+  OAuthGrantInvalid -> OAuth.oauthError status400 "invalid_grant" "the subject or actor token is invalid"+  ImpersonationForbidden -> OAuth.oauthError status400 "invalid_grant" "the subject or actor token is invalid"+  ImpersonationTargetInvalid -> OAuth.oauthError status400 "invalid_grant" "the subject or actor token is invalid"+  -- Any other AuthError is an infrastructure failure (e.g. InternalAuthError): a 500 in the OAuth+  -- shape so the caller's error parser does not itself fail while handling the failure.+  _ -> OAuth.oauthError status500 "server_error" "the authorization server encountered an unexpected condition"++-- | Client credentials for the EP-5 grants, which admit __public__ clients (no secret at all)+-- alongside the @client_secret_basic@\/@client_secret_post@ methods 'OAuth.extractClientAuth'+-- covers.+--+-- A public client identifies itself with a bare @client_id@ body parameter. That is not+-- authentication and is not treated as such: what actually binds its authorize request to this+-- exchange is PKCE, which the workflow requires of it.+oauthClientCredentials :: Maybe Text -> Form -> Handler (Text, Maybe Text)+oauthClientCredentials mAuthHeader form =+  case OAuth.extractClientAuth mAuthHeader form of+    Right auth -> pure (auth ^. #clientId, Just (auth ^. #clientSecret))+    Left _ -> case (mAuthHeader, OAuth.lookupParam "client_id" form) of+      -- No Authorization header and a bare client_id: a public client.+      (Nothing, Just clientId) -> pure (clientId, Nothing)+      _ -> throwError OAuth.invalidClient++requireParam :: Text -> Form -> Handler Text+requireParam k form =+  maybe (throwError (OAuth.invalidRequest (k <> " is required"))) pure (OAuth.lookupParam k form)++-- | Render an EP-5 grant failure as its RFC 6749 §5.2 object.+grantError :: OAuthTokenGrant.TokenGrantError -> ServerError+grantError e = case OAuthTokenGrant.grantErrorCode e of+  "invalid_client" -> OAuth.invalidClient+  code -> OAuth.oauthError status400 code (OAuthTokenGrant.grantErrorDescription e)++-- | @GET \/oauth\/userinfo@ (OIDC Core §5.3). The protocol-specific authentication combinator+-- turns a missing or invalid credential into OAuth @invalid_token@ rather than crossing into the+-- application Problem Details envelope.+--+-- Returns @sub@ and @scopes@ always, @roles@ under the OIDC @profile@ scope, and+-- @email@\/@email_verified@ under @email@. Roles\/scopes come from the verified claims, not a fresh+-- role-store read: userinfo reports what /this token/ carries, which is what a relying party+-- correlating it with the ID token expects.+oauthUserinfoH :: Env -> AuthUser -> Handler Value+oauthUserinfoH env user = do+  mUser <- runOAuthPort env (findUserById user.authUserId)+  let base =+        [ "sub" Aeson..= idText user.authUserId,+          "scopes" Aeson..= [s | Scope s <- Set.toList user.authScopes]+        ]+      roleFields+        | Scope "profile" `Set.member` user.authScopes = ["roles" Aeson..= [r | Role r <- Set.toList user.authRoles]]+        | otherwise = []+      emailFields u =+        foldMap (\e -> ["email" Aeson..= emailText e, "email_verified" Aeson..= isJust u.emailVerifiedAt]) u.email+      scopedEmailFields+        | Scope "email" `Set.member` user.authScopes = maybe [] emailFields mUser+        | otherwise = []+  pure (Aeson.object (base <> roleFields <> scopedEmailFields))++-- | @POST \/oauth\/introspect@ (RFC 7662): session-aware token status for resource servers.+--+-- Client-authenticated (an OAuth client or an EP-4 service account). The response is @200@ in+-- every case: @{"active": false}@ for anything invalid, expired, or revoked — never an error,+-- because an introspection endpoint that distinguished failures would let a caller probe for valid+-- tokens. On success the fields the RFC defines are filled from the claims.+--+-- __It always consults the session store__, regardless of @sessionCheckMode@ (Decision Log): a+-- token is @active@ only if it verifies /and/ its @sid@ resolves to a live session. That is the+-- whole point of RFC 7662 — a resource server can see a revocation that stateless JWT verification+-- cannot — and it is what makes the revoke→introspect flip observable.+oauthIntrospectH :: Env -> Maybe Text -> Form -> Handler Value+oauthIntrospectH env mAuthHeader form = do+  _ <- authenticateOAuthCaller env mAuthHeader form+  case OAuth.lookupParam "token" form of+    Nothing -> pure inactive+    Just presented -> case OAuth.lookupParam "token_type_hint" form of+      -- The hint is advisory. Try an opaque refresh token directly when named; otherwise try the+      -- JWT path first and fall back to refresh lookup when signature verification fails.+      Just "refresh_token" -> introspectRefresh env presented+      _ -> do+        verified <- runOAuthPort env (verifyAccessToken (AccessToken presented))+        case verified of+          Left _ -> introspectRefresh env presented+          Right claims -> do+            mSession <- runOAuthPort env (findSessionById claims.sessionId)+            now' <- runOAuthPort env now+            case mSession of+              Just s | sessionIsLive now' s -> pure (activeAccess claims s)+              -- The signature is fine but the session is gone or dead: to a resource server the+              -- token is not active, which is exactly what revocation must make observable.+              _ -> pure inactive++-- | Introspect a presented refresh token: hash it, look it up, and report from its status and its+-- session's liveness.+introspectRefresh :: Env -> Text -> Handler Value+introspectRefresh env presented = do+  tokHash <- runOAuthPort env (hashRefreshToken (RefreshToken presented))+  mTok <- runOAuthPort env (findRefreshTokenByHash tokHash)+  case mTok of+    Nothing -> pure inactive+    Just tok+      | (tok ^. #status) /= RefreshTokenActive -> pure inactive+      | otherwise -> do+          mSession <- runOAuthPort env (findSessionById (tok ^. #sessionId))+          now' <- runOAuthPort env now+          case mSession of+            Just s | sessionIsLive now' s -> pure (Aeson.object ["active" Aeson..= True, "token_type" Aeson..= ("refresh_token" :: Text)])+            _ -> pure inactive++-- | @POST \/oauth\/revoke@ (RFC 7009): revoke what we recognize, and always answer @200@.+--+-- A refresh token revokes its whole family and its session; an access token revokes its session+-- and that session's refresh tokens. Under the default @VerifyTokenOnly@ the stateless auth path+-- keeps accepting that JWT until @exp@; under @VerifyTokenAndSession@ its next use is refused with+-- @401 session_revoked@. An unknown token is not an error — RFC 7009 §2.2 forbids that, to stop+-- probing — so this only ever raises on a failed client authentication.+oauthRevokeH :: Env -> Maybe Text -> Form -> Handler ()+oauthRevokeH env mAuthHeader form = do+  caller <- authenticateOAuthCaller env mAuthHeader form+  case OAuth.lookupParam "token" form of+    Nothing -> pure ()+    Just presented -> do+      now' <- runOAuthPort env now+      tokHash <- runOAuthPort env (hashRefreshToken (RefreshToken presented))+      mTok <- runOAuthPort env (findRefreshTokenByHash tokHash)+      case mTok of+        -- A refresh token: revoke the family and the session it belongs to.+        Just tok -> do+          mSession <- runOAuthPort env (findSessionById (tok ^. #sessionId))+          when (maybe False (mayRevokeSession caller) mSession) $+            runOAuthPort env do+              revokeRefreshTokenFamily (tok ^. #refreshTokenId) now'+              SessionStore.revokeSession (tok ^. #sessionId) now'+          pure ()+        -- Otherwise try to read it as an access JWT and revoke its session.+        Nothing -> do+          verified <- runOAuthPort env (verifyAccessToken (AccessToken presented))+          case verified of+            Right claims -> do+              mSession <- runOAuthPort env (findSessionById claims.sessionId)+              when (maybe False (mayRevokeSession caller) mSession) $+                runOAuthPort env do+                  SessionStore.revokeSession claims.sessionId now'+                  revokeSessionRefreshTokens claims.sessionId now'+              pure ()+            -- Neither a known refresh token nor a valid access token: nothing to do, still 200.+            Left _ -> pure ()++-- | Client-authenticate a caller of @\/oauth\/introspect@ or @\/oauth\/revoke@ against __either__ a+-- confidential OAuth client or an EP-4 service account, both of which legitimately introspect.+--+-- A failure is @401 invalid_client@, the same shape the token endpoint uses. Public OAuth clients+-- cannot introspect: they hold no secret, and an unauthenticated introspection endpoint is a+-- probing oracle.+authenticateOAuthCaller :: Env -> Maybe Text -> Form -> Handler RevocationCaller+authenticateOAuthCaller env mAuthHeader form = do+  auth <- either throwError pure (OAuth.extractClientAuth mAuthHeader form)+  let clientId = auth ^. #clientId+      secret = auth ^. #clientSecret+  caller <-+    runOAuthPort env do+      mClient <- findOAuthClientByClientId clientId+      case mClient of+        Just client+          | Just h <- oauthClientSecretHash client,+            client ^. #status == OAuthClientActive,+            ServiceAccountSecret.verifyServiceSecret h secret ->+              pure (Just (RevokingOAuthClient clientId))+        _ -> do+          mAccount <- findServiceAccountByClientId clientId+          pure case mAccount of+            Just account | serviceAccountAuthenticates secret account -> Just (RevokingServiceAccount account)+            _ -> Nothing+  maybe (throwError OAuth.invalidClient) pure caller++-- | A service account authenticates iff it is active and its secret matches. Read through record+-- patterns because 'ServiceAccount' shares field names with 'User'.+serviceAccountAuthenticates :: Text -> ServiceAccount.ServiceAccount -> Bool+serviceAccountAuthenticates secret account =+  ServiceAccountSecret.verifyServiceSecret (saSecretHash account) secret+    && saStatus account == ServiceAccount.ServiceAccountActive+  where+    saSecretHash ServiceAccount.ServiceAccount {secretHash} = secretHash+    saStatus ServiceAccount.ServiceAccount {status} = status++-- | An OAuth client's secret hash, read through a record pattern.+oauthClientSecretHash :: OAuthClient.OAuthClient -> Maybe Text+oauthClientSecretHash OAuthClient.OAuthClient {secretHash} = secretHash++-- | @{"active": false}@, the one answer to every introspection failure.+inactive :: Value+inactive = Aeson.object ["active" Aeson..= False]++-- | Is this session usable right now — active and unexpired?+sessionIsLive :: UTCTime -> Session.Session -> Bool+sessionIsLive now' s = s.status == Session.SessionActive && s.expiresAt > now'++-- | The RFC 7662 active-response object for a verified access token whose session is live.+activeAccess :: AuthClaims -> Session.Session -> Value+activeAccess claims _s =+  Aeson.object+    ( [ "active" Aeson..= True,+        "token_type" Aeson..= ("Bearer" :: Text),+        "scope" Aeson..= Text.unwords [s | Scope s <- Set.toList claims.scopes],+        "sub" Aeson..= idText claims.subject,+        "sid" Aeson..= idText claims.sessionId,+        "iss" Aeson..= issuerClaimText claims.issuer,+        "aud" Aeson..= audienceClaimText claims.audience,+        "exp" Aeson..= (floor (utcTimeToPOSIXSeconds claims.expiresAt) :: Integer),+        "iat" Aeson..= (floor (utcTimeToPOSIXSeconds claims.issuedAt) :: Integer)+      ]+        -- `act` per the RFC 8693 convention when the token was delegated (impersonation).+        <> foldMap (\a -> ["act" Aeson..= Aeson.object ["sub" Aeson..= idText a]]) claims.actor+    )+  where+    issuerClaimText (Issuer t) = t+    audienceClaimText (Audience t) = t++-- | The OAuth-local error mapping. Deliberately not 'authErrorToServerError': that renders the+-- problem-details envelope, which this endpoint must not emit.+oauthErrorFor :: AuthError -> ServerError+oauthErrorFor = \case+  OAuthClientInvalid -> OAuth.invalidClient+  -- One description for both refusals the workflow can raise: an explicitly empty `scope=`, and a+  -- scope outside the account's allow-list. Saying only "exceeds the allowed scopes" would be a+  -- lie for the empty case, which a live transcript caught.+  OAuthScopeInvalid -> OAuth.oauthError status400 "invalid_scope" "the requested scope is empty, or exceeds the client's allowed scopes"+  -- No other AuthError is reachable from 'grantClientCredentials'. An infrastructure failure+  -- (a database outage surfacing as InternalAuthError) is a 500, still in the OAuth shape so a+  -- client's error parser does not itself fail while handling the failure.+  _ -> OAuth.oauthError status500 "server_error" "the authorization server encountered an unexpected condition"
+ src/Shomei/OAuth/Result.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | RFC 6749/OIDC response sums. These deliberately do not mention 'ProblemDetails'.+module Shomei.OAuth.Result+  ( OAuthErrorHeaders,+    OAuthErrorWithHeaders (..),+    OAuthErrorResponses,+    OAuthResponses,+    OAuthEmptyResponses,+    OAuthResult (..),+    AuthorizeHeaders,+    AuthorizeRedirect (..),+    TokenHeaders,+    TokenSuccess (..),+    AuthorizeResponses,+    AuthorizeResult,+    TokenResponses,+    TokenResult,+    UserinfoResponses,+    UserinfoResult,+    IntrospectResponses,+    IntrospectResult,+    RevokeResponses,+    RevokeResult,+    OidcDiscoveryResponses,+    OidcDiscoveryResult,+    oauthServerErrorResult,+  )+where++import Data.Aeson (Value, eitherDecode)+import Data.ByteString (ByteString)+import Data.Foldable (toList)+import Data.SOP (I (..), NP (..), NS (..))+import Data.Sequence (Seq)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TextEncoding+import Network.HTTP.Types qualified as HTTP+import Numeric.Natural (Natural)+import Servant (JSON, ServerError (..))+import Servant.API.MultiVerb+import Shomei.Prelude+import Shomei.Servant.OAuth (OAuthErrorResponse (..), TokenResponse)+import Text.Read (readMaybe)+import Web.HttpApiData (FromHttpApiData (parseHeader), ToHttpApiData (toHeader))++type OAuthErrorHeaders =+  '[ DescHeader "Cache-Control" "OAuth responses are not cacheable" Text,+     DescHeader "Pragma" "OAuth responses are not cacheable" Text,+     OptHeader (DescHeader "WWW-Authenticate" "Client authentication challenge" Text),+     OptHeader (DescHeader "Retry-After" "Seconds until retry" Natural)+   ]++data OAuthErrorWithHeaders = OAuthErrorWithHeaders+  { oauthErrorBody :: !OAuthErrorResponse,+    oauthCacheControl :: !Text,+    oauthPragma :: !Text,+    oauthAuthenticate :: !(Maybe Text),+    oauthRetryAfter :: !(Maybe Natural)+  }+  deriving stock (Eq, Show, Generic)++instance AsHeaders '[Text, Text, Maybe Text, Maybe Natural] OAuthErrorResponse OAuthErrorWithHeaders where+  toHeaders response =+    ( I response.oauthCacheControl :* I response.oauthPragma :* I response.oauthAuthenticate :* I response.oauthRetryAfter :* Nil,+      response.oauthErrorBody+    )+  fromHeaders (I oauthCacheControl :* I oauthPragma :* I oauthAuthenticate :* I oauthRetryAfter :* Nil, oauthErrorBody) =+    OAuthErrorWithHeaders {oauthErrorBody, oauthCacheControl, oauthPragma, oauthAuthenticate, oauthRetryAfter}++-- servant 0.20.3's generic header decoder rejects absent optional fields. OAuth explicitly+-- permits WWW-Authenticate and Retry-After to be absent, so preserve that contract in clients.+instance {-# OVERLAPPING #-} ServantHeaders OAuthErrorHeaders '[Text, Text, Maybe Text, Maybe Natural] where+  constructHeaders (I oauthCacheControl :* I oauthPragma :* I oauthAuthenticate :* I oauthRetryAfter :* Nil) =+    requiredHeader "Cache-Control" oauthCacheControl+      <> requiredHeader "Pragma" oauthPragma+      <> optionalHeader "WWW-Authenticate" oauthAuthenticate+      <> optionalHeader "Retry-After" oauthRetryAfter+  extractHeaders headers = do+    oauthCacheControl <- extractRequiredHeader "Cache-Control" headers+    oauthPragma <- extractRequiredHeader "Pragma" headers+    oauthAuthenticate <- extractOptionalHeader "WWW-Authenticate" headers+    oauthRetryAfter <- extractOptionalHeader "Retry-After" headers+    pure (I oauthCacheControl :* I oauthPragma :* I oauthAuthenticate :* I oauthRetryAfter :* Nil)++requiredHeader :: (ToHttpApiData a) => HTTP.HeaderName -> a -> [HTTP.Header]+requiredHeader name value = [(name, toHeader value)]++optionalHeader :: (ToHttpApiData a) => HTTP.HeaderName -> Maybe a -> [HTTP.Header]+optionalHeader name = maybe [] (requiredHeader name)++extractRequiredHeader :: (FromHttpApiData a) => HTTP.HeaderName -> Seq HTTP.Header -> Maybe a+extractRequiredHeader name headers = case matchingHeaderValues name headers of+  [value] -> decodeHeader value+  _ -> Nothing++extractOptionalHeader :: (FromHttpApiData a) => HTTP.HeaderName -> Seq HTTP.Header -> Maybe (Maybe a)+extractOptionalHeader name headers = case matchingHeaderValues name headers of+  [] -> Just Nothing+  [value] -> Just <$> decodeHeader value+  _ -> Nothing++matchingHeaderValues :: HTTP.HeaderName -> Seq HTTP.Header -> [ByteString]+matchingHeaderValues name = map snd . filter ((== name) . fst) . toList++decodeHeader :: (FromHttpApiData a) => ByteString -> Maybe a+decodeHeader = either (const Nothing) Just . parseHeader++type OAuthErrorResponses =+  '[ WithHeaders OAuthErrorHeaders OAuthErrorWithHeaders (RespondAs JSON 400 "OAuth request rejected" OAuthErrorResponse),+     WithHeaders OAuthErrorHeaders OAuthErrorWithHeaders (RespondAs JSON 401 "OAuth authentication failed" OAuthErrorResponse),+     WithHeaders OAuthErrorHeaders OAuthErrorWithHeaders (RespondAs JSON 404 "OAuth resource not found" OAuthErrorResponse),+     WithHeaders OAuthErrorHeaders OAuthErrorWithHeaders (RespondAs JSON 500 "OAuth server error" OAuthErrorResponse),+     WithHeaders OAuthErrorHeaders OAuthErrorWithHeaders (RespondAs JSON 503 "OAuth dependency unavailable" OAuthErrorResponse)+   ]++type OAuthResponses status description body = Respond status description body ': OAuthErrorResponses++type OAuthEmptyResponses status description = RespondEmpty status description ': OAuthErrorResponses++data OAuthResult a+  = OAuthSuccess !a+  | OAuthBadRequest !OAuthErrorWithHeaders+  | OAuthAuthenticationFailed !OAuthErrorWithHeaders+  | OAuthNotFound !OAuthErrorWithHeaders+  | OAuthInternal !OAuthErrorWithHeaders+  | OAuthUnavailable !OAuthErrorWithHeaders+  deriving stock (Eq, Show, Generic, Functor)++instance AsUnion (Respond status description a ': OAuthErrorResponses) (OAuthResult a) where+  toUnion = oauthToUnion+  fromUnion = oauthFromUnion++instance AsUnion (RespondEmpty status description ': OAuthErrorResponses) (OAuthResult ()) where+  toUnion = oauthToUnion+  fromUnion = oauthFromUnion++instance AsUnion (WithHeaders headers a response ': OAuthErrorResponses) (OAuthResult a) where+  toUnion = oauthToUnion+  fromUnion = oauthFromUnion++oauthToUnion :: OAuthResult a -> NS I '[a, OAuthErrorWithHeaders, OAuthErrorWithHeaders, OAuthErrorWithHeaders, OAuthErrorWithHeaders, OAuthErrorWithHeaders]+oauthToUnion = \case+  OAuthSuccess value -> Z (I value)+  OAuthBadRequest value -> S (Z (I value))+  OAuthAuthenticationFailed value -> S (S (Z (I value)))+  OAuthNotFound value -> S (S (S (Z (I value))))+  OAuthInternal value -> S (S (S (S (Z (I value)))))+  OAuthUnavailable value -> S (S (S (S (S (Z (I value))))))++oauthFromUnion :: NS I '[a, OAuthErrorWithHeaders, OAuthErrorWithHeaders, OAuthErrorWithHeaders, OAuthErrorWithHeaders, OAuthErrorWithHeaders] -> OAuthResult a+oauthFromUnion = \case+  Z (I value) -> OAuthSuccess value+  S (Z (I value)) -> OAuthBadRequest value+  S (S (Z (I value))) -> OAuthAuthenticationFailed value+  S (S (S (Z (I value)))) -> OAuthNotFound value+  S (S (S (S (Z (I value))))) -> OAuthInternal value+  S (S (S (S (S (Z (I value)))))) -> OAuthUnavailable value+  S (S (S (S (S (S impossible))))) -> case impossible of {}++type AuthorizeHeaders =+  '[ DescHeader "Location" "Redirect target" Text,+     DescHeader "Cache-Control" "Authorization redirects are not cacheable" Text+   ]++data AuthorizeRedirect = AuthorizeRedirect+  { authorizeLocation :: !Text,+    authorizeCacheControl :: !Text+  }+  deriving stock (Eq, Show, Generic)++instance AsHeaders '[Text, Text] () AuthorizeRedirect where+  toHeaders response = (I response.authorizeLocation :* I response.authorizeCacheControl :* Nil, ())+  fromHeaders (I authorizeLocation :* I authorizeCacheControl :* Nil, ()) = AuthorizeRedirect {authorizeLocation, authorizeCacheControl}++type TokenHeaders =+  '[ DescHeader "Cache-Control" "Token responses are not cacheable" Text,+     DescHeader "Pragma" "Token responses are not cacheable" Text+   ]++data TokenSuccess = TokenSuccess+  { tokenBody :: !TokenResponse,+    tokenCacheControl :: !Text,+    tokenPragma :: !Text+  }+  deriving stock (Eq, Show, Generic)++instance AsHeaders '[Text, Text] TokenResponse TokenSuccess where+  toHeaders response = (I response.tokenCacheControl :* I response.tokenPragma :* Nil, response.tokenBody)+  fromHeaders (I tokenCacheControl :* I tokenPragma :* Nil, tokenBody) = TokenSuccess {tokenBody, tokenCacheControl, tokenPragma}++type AuthorizeResponses = WithHeaders AuthorizeHeaders AuthorizeRedirect (RespondEmpty 302 "Redirect") ': OAuthErrorResponses++type AuthorizeResult = OAuthResult AuthorizeRedirect++type TokenResponses = WithHeaders TokenHeaders TokenSuccess (Respond 200 "Token issued" TokenResponse) ': OAuthErrorResponses++type TokenResult = OAuthResult TokenSuccess++type UserinfoResponses = OAuthResponses 200 "OIDC user information" Value++type UserinfoResult = OAuthResult Value++type IntrospectResponses = OAuthResponses 200 "Token status" Value++type IntrospectResult = OAuthResult Value++type RevokeResponses = OAuthEmptyResponses 200 "Token revoked"++type RevokeResult = OAuthResult ()++type OidcDiscoveryResponses = OAuthResponses 200 "OIDC discovery document" Value++type OidcDiscoveryResult = OAuthResult Value++oauthServerErrorResult :: ServerError -> OAuthResult a+oauthServerErrorResult err = constructor response+  where+    body =+      fromMaybe+        (OAuthErrorResponse "server_error" "the authorization server encountered an unexpected condition")+        (either (const Nothing) Just (eitherDecode err.errBody))+    response =+      OAuthErrorWithHeaders+        { oauthErrorBody = body,+          oauthCacheControl = headerText "Cache-Control" "no-store",+          oauthPragma = headerText "Pragma" "no-cache",+          oauthAuthenticate = optionalHeaderText "WWW-Authenticate",+          oauthRetryAfter = optionalHeaderText "Retry-After" >>= readMaybe . Text.unpack+        }+    constructor = case err.errHTTPCode of+      400 -> OAuthBadRequest+      401 -> OAuthAuthenticationFailed+      404 -> OAuthNotFound+      503 -> OAuthUnavailable+      _ -> OAuthInternal+    optionalHeaderText name = TextEncoding.decodeUtf8 <$> lookup name err.errHeaders+    headerText name fallback = fromMaybe fallback (optionalHeaderText name)
+ src/Shomei/Passkey/Api.hs view
@@ -0,0 +1,46 @@+-- | Passkey-owned registration, management, and passwordless-login routes.+module Shomei.Passkey.Api+  ( PasskeyApi (..),+    RegisterBeginRoute,+    RegisterCompleteRoute,+    ListPasskeysRoute,+    RemovePasskeyRoute,+    PasskeyLoginBeginRoute,+    PasskeyLoginCompleteRoute,+  )+where++import Servant.API+import Servant.API.MultiVerb (MultiVerb)+import Shomei.Id (PasskeyId)+import Shomei.Passkey.Dto+  ( PasskeyLoginCompleteRequest,+    PasskeyRegisterCompleteRequest,+  )+import Shomei.Passkey.Result+import Shomei.Prelude+import Shomei.Servant.Auth (Authenticated)+import Shomei.Servant.PreHandler (CsrfProtected, PreHandlerResponses, RateLimited)+import Shomei.Servant.Result (ApplicationContentTypes, BadRequestPreHandlerResponses)++type RegisterBeginRoute = "passkeys" :> "register" :> "begin" :> Authenticated :> CsrfProtected :> MultiVerb 'POST ApplicationContentTypes RegisterBeginResponses RegisterBeginResult++type RegisterCompleteRoute = "passkeys" :> "register" :> "complete" :> Authenticated :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] PasskeyRegisterCompleteRequest :> MultiVerb 'POST ApplicationContentTypes RegisterCompleteResponses RegisterCompleteResult++type ListPasskeysRoute = "passkeys" :> Authenticated :> MultiVerb 'GET ApplicationContentTypes ListPasskeysResponses ListPasskeysResult++type RemovePasskeyRoute = "passkeys" :> Authenticated :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "passkeyId" PasskeyId :> MultiVerb 'DELETE ApplicationContentTypes RemovePasskeyResponses RemovePasskeyResult++type PasskeyLoginBeginRoute = "login" :> "passkey" :> "begin" :> RateLimited :> MultiVerb 'POST ApplicationContentTypes PasskeyLoginBeginResponses PasskeyLoginBeginResult++type PasskeyLoginCompleteRoute = "login" :> "passkey" :> "complete" :> RateLimited :> RemoteHost :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] PasskeyLoginCompleteRequest :> MultiVerb 'POST ApplicationContentTypes PasskeyLoginCompleteResponses PasskeyLoginCompleteResult++data PasskeyApi mode = PasskeyApi+  { registerBegin :: mode :- RegisterBeginRoute,+    registerComplete :: mode :- RegisterCompleteRoute,+    list :: mode :- ListPasskeysRoute,+    remove :: mode :- RemovePasskeyRoute,+    loginBegin :: mode :- PasskeyLoginBeginRoute,+    loginComplete :: mode :- PasskeyLoginCompleteRoute+  }+  deriving stock (Generic)
+ src/Shomei/Passkey/Dto.hs view
@@ -0,0 +1,66 @@+-- | Passkey registration, management, and passwordless-login wire types.+module Shomei.Passkey.Dto+  ( PasskeyRegisterBeginResponse (..),+    PasskeyRegisterCompleteRequest (..),+    PasskeyResponse (..),+    PasskeyLoginBeginResponse (..),+    PasskeyLoginCompleteRequest (..),+    passkeyToResponse,+  )+where++import Data.Aeson (Value)+import Data.Text qualified as Text+import Data.Time.Format.ISO8601 (iso8601Show)+import Shomei.Id (idText)+import Shomei.Passkey.Domain (PasskeyCredential (..))+import Shomei.Prelude++data PasskeyRegisterBeginResponse = PasskeyRegisterBeginResponse+  { ceremonyId :: !Text,+    options :: !Value+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data PasskeyRegisterCompleteRequest = PasskeyRegisterCompleteRequest+  { ceremonyId :: !Text,+    credential :: !Value,+    label :: !(Maybe Text)+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data PasskeyResponse = PasskeyResponse+  { passkeyId :: !Text,+    label :: !(Maybe Text),+    transports :: ![Text],+    createdAt :: !Text,+    lastUsedAt :: !(Maybe Text)+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data PasskeyLoginBeginResponse = PasskeyLoginBeginResponse+  { ceremonyId :: !Text,+    options :: !Value+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data PasskeyLoginCompleteRequest = PasskeyLoginCompleteRequest+  { ceremonyId :: !Text,+    assertion :: !Value+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++passkeyToResponse :: PasskeyCredential -> PasskeyResponse+passkeyToResponse PasskeyCredential {passkeyId, label, transports, createdAt, lastUsedAt} =+  PasskeyResponse+    { passkeyId = idText passkeyId,+      label = label,+      transports = transports,+      createdAt = Text.pack (iso8601Show createdAt),+      lastUsedAt = Text.pack . iso8601Show <$> lastUsedAt+    }
+ src/Shomei/Passkey/Handler.hs view
@@ -0,0 +1,72 @@+-- | Passkey registration, listing, removal, and passwordless-login HTTP adapters.+module Shomei.Passkey.Handler (passkeyServer) where++import Data.Text (Text)+import Network.Socket (SockAddr)+import Servant (Handler)+import Servant.Server.Generic (AsServerT)+import Shomei.Delegation.Handler (denyUnderDelegation)+import Shomei.Id (CeremonyId, PasskeyId, idText, parseId)+import Shomei.Mfa.Workflow qualified as Mfa+import Shomei.Passkey.Api (PasskeyApi (..))+import Shomei.Passkey.Dto+import Shomei.Passkey.Result+import Shomei.Passkey.Workflow qualified as Passkey+import Shomei.Servant.Application (ApplicationHandler, port, rejectProblem, runApplicationHandler, workflow)+import Shomei.Servant.Auth (AuthUser (..))+import Shomei.Servant.ClientIp (clientIpText)+import Shomei.Servant.Cookie (tokenCookies)+import Shomei.Servant.Error (detailOccurrence, pcBadRequest)+import Shomei.Servant.Result (cookieResponse)+import Shomei.Servant.Seam (Env (..))+import Shomei.Session.Command (ProofContext (..))+import Shomei.Session.Dto (tokenPairToResponse)+import Shomei.Session.LoginAttempt.Domain (ClientIp (..))++passkeyServer :: Env -> PasskeyApi (AsServerT Handler)+passkeyServer env =+  PasskeyApi+    { registerBegin = registerBeginH env,+      registerComplete = registerCompleteH env,+      list = listH env,+      remove = removeH env,+      loginBegin = loginBeginH env,+      loginComplete = loginCompleteH env+    }++registerBeginH :: Env -> AuthUser -> Handler RegisterBeginResult+registerBeginH env user = runApplicationHandler do+  denyUnderDelegation env "passkey_register" user+  (ceremonyId, options) <- workflow env (Passkey.beginPasskeyRegistration env.config user.authUserId)+  pure PasskeyRegisterBeginResponse {ceremonyId = idText ceremonyId, options}++registerCompleteH :: Env -> AuthUser -> PasskeyRegisterCompleteRequest -> Handler RegisterCompleteResult+registerCompleteH env user request = runApplicationHandler do+  denyUnderDelegation env "passkey_register" user+  ceremonyId <- parseCeremonyId request.ceremonyId+  passkey <- workflow env (Passkey.completePasskeyRegistration env.config user.authUserId ceremonyId request.credential request.label)+  pure (passkeyToResponse passkey)++listH :: Env -> AuthUser -> Handler ListPasskeysResult+listH env user = runApplicationHandler (map passkeyToResponse <$> port env (Passkey.listPasskeys user.authUserId))++removeH :: Env -> AuthUser -> PasskeyId -> Handler RemovePasskeyResult+removeH env user passkeyId = runApplicationHandler do+  denyUnderDelegation env "passkey_remove" user+  workflow env (Passkey.removePasskey user.authUserId passkeyId)++loginBeginH :: Env -> Handler PasskeyLoginBeginResult+loginBeginH env = runApplicationHandler do+  (ceremonyId, options) <- workflow env (Mfa.beginPasswordlessLogin env.config)+  pure PasskeyLoginBeginResponse {ceremonyId = idText ceremonyId, options}++loginCompleteH :: Env -> SockAddr -> PasskeyLoginCompleteRequest -> Handler PasskeyLoginCompleteResult+loginCompleteH env peer request = runApplicationHandler do+  ceremonyId <- parseCeremonyId request.ceremonyId+  let pctx = ProofContext {clientIp = ClientIp (clientIpText peer), accountKeyOf = env.accountKeyOf}+  (_, tokens) <- workflow env (Mfa.completePasswordlessLogin env.config pctx ceremonyId request.assertion)+  pure (cookieResponse env.config (tokenCookies env.config tokens) (tokenPairToResponse env.config tokens))++parseCeremonyId :: Text -> ApplicationHandler CeremonyId+parseCeremonyId requestId =+  either (const (rejectProblem pcBadRequest (detailOccurrence "invalid ceremonyId"))) pure (parseId requestId)
+ src/Shomei/Passkey/Result.hs view
@@ -0,0 +1,43 @@+module Shomei.Passkey.Result+  ( RegisterBeginResponses,+    RegisterBeginResult,+    RegisterCompleteResponses,+    RegisterCompleteResult,+    ListPasskeysResponses,+    ListPasskeysResult,+    RemovePasskeyResponses,+    RemovePasskeyResult,+    PasskeyLoginBeginResponses,+    PasskeyLoginBeginResult,+    PasskeyLoginCompleteResponses,+    PasskeyLoginCompleteResult,+  )+where++import Shomei.Passkey.Dto+import Shomei.Servant.Result+import Shomei.Session.Dto (TokenPairResponse)++type RegisterBeginResponses = ApplicationResponses 200 "Passkey registration challenge" PasskeyRegisterBeginResponse++type RegisterBeginResult = ApplicationResult PasskeyRegisterBeginResponse++type RegisterCompleteResponses = ApplicationResponses 200 "Passkey registered" PasskeyResponse++type RegisterCompleteResult = ApplicationResult PasskeyResponse++type ListPasskeysResponses = ApplicationResponses 200 "Passkeys" [PasskeyResponse]++type ListPasskeysResult = ApplicationResult [PasskeyResponse]++type RemovePasskeyResponses = ApplicationEmptyResponses 204 "Passkey removed"++type RemovePasskeyResult = ApplicationResult ()++type PasskeyLoginBeginResponses = ApplicationResponses 200 "Passkey login challenge" PasskeyLoginBeginResponse++type PasskeyLoginBeginResult = ApplicationResult PasskeyLoginBeginResponse++type PasskeyLoginCompleteResponses = ApplicationCookieResponses 200 "Authenticated" TokenPairResponse++type PasskeyLoginCompleteResult = ApplicationResult (CookieResponse TokenPairResponse)
+ src/Shomei/Servant/Api.hs view
@@ -0,0 +1,90 @@+-- | Thin composition roots for Shōmei's concept-owned route records.+module Shomei.Servant.Api+  ( ShomeiRoutes (..),+    shomeiRoutesApi,+    shomeiThrottledRoutes,+    ApplicationApi (..),+    applicationApi,+    AppApi,+    ApplicationRoutes,+    OAuthRoutes,+    WellKnownRoutes,+    HealthRoutes,+    OpenApiRoute,+    Project (..),+  )+where++import Data.Aeson (Value)+import Servant.API+import Servant.Health (HealthApi)+import Shomei.Account.Admin.Api (AdminAccountApi)+import Shomei.Account.Api (AccountApi)+import Shomei.Account.User.Domain (User)+import Shomei.Audit.Api (AuditApi)+import Shomei.Authorization.Api (AuthorizationApi)+import Shomei.Mfa.Api (MfaApi)+import Shomei.OAuth.Api (OAuthApi)+import Shomei.Passkey.Api (PasskeyApi)+import Shomei.Prelude+import Shomei.Servant.Auth (Authenticated)+import Shomei.Servant.Authz (RequireRole)+import Shomei.Servant.Throttle (ThrottledRoute, throttledRoutesOf)+import Shomei.Session.Admin.Api (AdminSessionApi)+import Shomei.Session.Api (SessionApi)+import Shomei.SigningKey.Api (WellKnownApi)++-- | Versioned application routes, grouped by the concept that owns their wire contract and+-- handler adapter. Several fields intentionally share a path prefix; NamedRoutes dispatch uses+-- the complete route beneath each field rather than record declaration order.+data ApplicationApi mode = ApplicationApi+  { account :: mode :- "auth" :> NamedRoutes AccountApi,+    session :: mode :- "auth" :> NamedRoutes SessionApi,+    passkey :: mode :- "auth" :> NamedRoutes PasskeyApi,+    mfa :: mode :- "auth" :> NamedRoutes MfaApi,+    adminAccount :: mode :- "admin" :> NamedRoutes AdminAccountApi,+    adminSession :: mode :- "admin" :> NamedRoutes AdminSessionApi,+    authorization :: mode :- "admin" :> NamedRoutes AuthorizationApi,+    audit :: mode :- "admin" :> NamedRoutes AuditApi+  }+  deriving stock (Generic)++applicationApi :: Proxy (NamedRoutes ApplicationApi)+applicationApi = Proxy++-- | The exact served API. Standalone, embedded, OpenAPI, and client entry points all consume+-- this proxy.+type ApplicationRoutes = "v1" :> NamedRoutes ApplicationApi++type OAuthRoutes = "oauth" :> NamedRoutes OAuthApi++type WellKnownRoutes = ".well-known" :> NamedRoutes WellKnownApi++type HealthRoutes = "health" :> NamedRoutes HealthApi++type OpenApiRoute = "openapi.json" :> Get '[JSON] Value++data ShomeiRoutes mode = ShomeiRoutes+  { application :: mode :- ApplicationRoutes,+    oauth :: mode :- OAuthRoutes,+    wellKnown :: mode :- WellKnownRoutes,+    health :: mode :- HealthRoutes,+    openapi :: mode :- OpenApiRoute+  }+  deriving stock (Generic)++shomeiRoutesApi :: Proxy (NamedRoutes ShomeiRoutes)+shomeiRoutesApi = Proxy++shomeiThrottledRoutes :: [ThrottledRoute]+shomeiThrottledRoutes = throttledRoutesOf shomeiRoutesApi++newtype Project = Project {projectId :: Text}+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++-- | Embeddability proof: a host may mount the complete API beside its own authenticated routes.+type AppApi =+  NamedRoutes ShomeiRoutes+    :<|> Authenticated :> "projects" :> Get '[JSON] [Project]+    :<|> RequireRole "admin" :> "admin" :> "users" :> Get '[JSON] [User]
+ src/Shomei/Servant/Application.hs view
@@ -0,0 +1,43 @@+-- | Route-local control flow for typed application results.+--+-- 'ApplicationHandler' uses 'ExceptT' only inside a handler to short-circuit expected failures.+-- 'runApplicationHandler' turns that value into 'ApplicationResult'; it never calls Servant's+-- 'throwError'. This keeps pre-handler rejection and operation-owned outcomes visibly separate.+module Shomei.Servant.Application+  ( ApplicationHandler,+    runApplicationHandler,+    port,+    workflow,+    rejectAuth,+    rejectProblem,+  )+where++import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE)+import Data.Void (Void, absurd)+import Effectful (Eff)+import Servant (Handler)+import Shomei.Error (AuthError)+import Shomei.Servant.Error (ProblemOccurrence, ProblemSpec)+import Shomei.Servant.Result (ApplicationResult (..), applicationError, mapApplicationResult, problemResult)+import Shomei.Servant.Seam (AppEffects, Env, runPortResult, runWorkflowResult)++type ApplicationHandler = ExceptT (ApplicationResult Void) Handler++runApplicationHandler :: ApplicationHandler a -> Handler (ApplicationResult a)+runApplicationHandler action =+  runExceptT action >>= \case+    Left failure -> pure (mapApplicationResult absurd failure)+    Right value -> pure (ApplicationSuccess value)++port :: Env -> Eff AppEffects a -> ApplicationHandler a+port env action = ExceptT (either (Left . applicationError) Right <$> runPortResult env action)++workflow :: Env -> Eff AppEffects (Either AuthError a) -> ApplicationHandler a+workflow env action = ExceptT (either (Left . applicationError) Right <$> runWorkflowResult env action)++rejectAuth :: AuthError -> ApplicationHandler a+rejectAuth = throwE . applicationError++rejectProblem :: ProblemSpec -> ProblemOccurrence -> ApplicationHandler a+rejectProblem spec occurrence = throwE (problemResult spec occurrence)
+ src/Shomei/Servant/Auth.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}++-- | The 'Authenticated' combinator (custom 'AuthProtect' + 'AuthHandler') and the+-- 'AuthUser' principal it produces (MasterPlan IP-6), plus the CSRF gate that guards+-- cookie-borne credentials.+--+-- Authentication uses an enforcing custom combinator driven by an 'AuthHandler' registered in+-- the 'Servant.Context'. The handler is built with 'authHandler'+-- from the seam 'Env'; verification is derived from its port runner and configuration through+-- 'Shomei.Servant.Seam.verifyRequestToken'. This makes+-- @sessionCheckMode = VerifyTokenAndSession@ apply consistently without this module touching+-- @jose@ directly.+--+-- __Why the CSRF gate exists.__ A browser attaches cookies to a request automatically, even+-- when the request was triggered by a page on someone else's site. So a malicious page can+-- make a logged-in victim's browser POST to @\/v1\/auth\/logout@ or @\/v1\/auth\/password\/change@,+-- and the cookie rides along. The attacker cannot read the response, but the side effect is+-- the attack. Bearer tokens are immune — a foreign page cannot set an @Authorization@ header+-- — which is why the gate applies only to cookie-sourced credentials, and only to methods+-- that mutate.+module Shomei.Servant.Auth+  ( AuthUser (..),+    Authenticated,+    OAuthAuthenticated,+    CookiePolicy (..),+    cookiePolicyFromConfig,+    TokenSource (..),+    authHandler,+    extractToken,+    extractTokenFromHeaders,+    resolveAuthUser,+    originAllowed,+    originHeaderAllowed,+    isSafeMethod,+    csrfRejected,+    authUserFromClaims,+  )+where++import Data.ByteString qualified as BS+import Data.Kind (Type)+import Data.Set (Set)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Network.Wai (Request, requestHeaders, requestMethod)+import Servant+  ( Handler,+    ServerError,+    throwError,+    type (:>),+  )+import Servant.Server.Experimental.Auth+  ( AuthHandler,+    mkAuthHandler,+    unAuthHandler,+  )+import Servant.Server.Internal+  ( HasContextEntry,+    HasServer (..),+    addAuthCheck,+    delayedFailFatal,+    getContextEntry,+    runHandler,+    withRequest,+  )+import Shomei.Authorization.Claims.Domain (AuthClaims (..), Permission, Role, Scope)+import Shomei.Config (CookieConfig (..), ShomeiConfig (..), TokenTransport (..), transportUsesCookies)+import Shomei.Error (AuthError (..))+import Shomei.Id (SessionId, UserId)+import Shomei.Prelude+import Shomei.Servant.Cookie (sessionCookieName)+import Shomei.Servant.Error (bearerOccurrence, noProblemOccurrence, pcCsrfRejected, pcMissingToken, pcSessionExpired, pcSessionRevoked, pcTokenInvalidAuth, toProblemError)+import Shomei.Servant.OAuth qualified as OAuth+import Shomei.Servant.Seam (Env (..), verifyRequestToken)+import Web.Cookie (parseCookies)++-- | Shōmei's principal: the value the 'AuthHandler' hands to every authenticated+-- route once a token verifies. Carries the user id, session id, roles, scopes,+-- and the raw verified 'AuthClaims'.+data AuthUser = AuthUser+  { authUserId :: !UserId,+    authSessionId :: !SessionId,+    authRoles :: !(Set Role),+    authScopes :: !(Set Scope),+    authPermissions :: !(Set Permission),+    authClaims :: !AuthClaims+  }+  deriving stock (Generic)++-- | Put this before a route (or a 'NamedRoutes' record) to make its handler+-- receive a leading 'AuthUser'.+type Authenticated :: Type+data Authenticated++instance+  ( HasServer api ctx,+    HasContextEntry ctx (AuthHandler Request AuthUser)+  ) =>+  HasServer (Authenticated :> api) ctx+  where+  type ServerT (Authenticated :> api) m = AuthUser -> ServerT api m++  hoistServerWithContext _ pc nt srv =+    hoistServerWithContext (Proxy :: Proxy api) pc nt . srv++  route _ ctx subserver =+    route (Proxy :: Proxy api) ctx (subserver `addAuthCheck` withRequest authenticate)+    where+      authenticate req = do+        outcome <- liftIO (runHandler (unAuthHandler (getContextEntry ctx) req))+        either delayedFailFatal pure outcome++-- | OAuth/OIDC bearer authentication. It enforces the same verification and session policy as+-- 'Authenticated', accepts only the RFC 6750 bearer transport, and rejects with @invalid_token@+-- instead of an application problem.+type OAuthAuthenticated :: Type+data OAuthAuthenticated++instance+  ( HasServer api ctx,+    HasContextEntry ctx (AuthHandler Request AuthUser)+  ) =>+  HasServer (OAuthAuthenticated :> api) ctx+  where+  type ServerT (OAuthAuthenticated :> api) m = AuthUser -> ServerT api m++  hoistServerWithContext _ pc nt srv =+    hoistServerWithContext (Proxy :: Proxy api) pc nt . srv++  route _ ctx subserver =+    route (Proxy :: Proxy api) ctx (subserver `addAuthCheck` withRequest authenticate)+    where+      authenticate req = do+        case extractToken bearerOnlyPolicy req of+          Nothing -> delayedFailFatal OAuth.missingToken+          Just _ -> do+            outcome <- liftIO (runHandler (unAuthHandler (getContextEntry ctx) req))+            either (const (delayedFailFatal OAuth.invalidToken)) pure outcome++-- | Where a presented credential came from. Cookie-sourced credentials are subject to the+-- CSRF origin gate; bearer credentials never are.+data TokenSource = FromBearer | FromCookie+  deriving stock (Eq, Show)++-- | The transport policy the auth handler enforces: which credential sources are accepted,+-- and which origins may drive a cookie-authenticated mutation.+data CookiePolicy = CookiePolicy+  { transport :: !TokenTransport,+    allowedOrigins :: ![Text],+    sessionCookie :: !BS.ByteString+  }+  deriving stock (Eq, Show)++-- | The single place the auth policy is read out of runtime configuration, so every assembly+-- (server, tests, embedded hosts) enforces the same thing.+cookiePolicyFromConfig :: ShomeiConfig -> CookiePolicy+cookiePolicyFromConfig cfg =+  CookiePolicy+    { transport = cfg.tokenTransport,+      allowedOrigins = cfg.cookieConfig.allowedOrigins,+      sessionCookie = sessionCookieName cfg.cookieConfig+    }++bearerOnlyPolicy :: CookiePolicy+bearerOnlyPolicy = CookiePolicy BearerToken [] ""++-- | Project a verified 'AuthClaims' into the principal.+authUserFromClaims :: AuthClaims -> AuthUser+authUserFromClaims claims =+  AuthUser+    { authUserId = claims.subject,+      authSessionId = claims.sessionId,+      authRoles = claims.roles,+      authScopes = claims.scopes,+      authPermissions = claims.permissions,+      authClaims = claims+    }++-- | Build the auth handler. A missing token is a @401@; a failed verification is also a+-- @401@. Revoked and expired sessions carry their actionable problem codes; other failures stay+-- the undifferentiated @token_invalid@. A cookie-authenticated mutating+-- request from an origin that is not allow-listed is a @403 csrf_rejected@ — refused before+-- the token is even verified, because the credential itself is not admissible here.+authHandler :: Env -> AuthHandler Request AuthUser+authHandler env = mkAuthHandler handle+  where+    policy = cookiePolicyFromConfig env.config++    handle :: Request -> Handler AuthUser+    handle req = do+      (source, tok) <-+        maybe (throwError (toProblemError pcMissingToken bearerOccurrence)) pure (extractToken policy req)+      when (source == FromCookie && not (isSafeMethod req) && not (originAllowed policy.allowedOrigins req)) $+        throwError csrfRejected+      res <- liftIO (verifyRequestToken env tok)+      case res of+        Left e -> throwError (authFailure e)+        Right claims -> pure (authUserFromClaims claims)++-- | How an authentication failure becomes an HTTP response.+--+-- Deliberately not 'Shomei.Servant.Error.authErrorToServerError': that handler-layer mapping+-- turns 'SessionNotFound' into a 404, which would make a protected route look nonexistent.+-- Revocation and expiry are actionable to a caller already holding the token. Everything else,+-- including an unresolvable session id, fails closed as @401 token_invalid@.+authFailure :: AuthError -> ServerError+authFailure = \case+  SessionExpired -> toProblemError pcSessionExpired bearerOccurrence+  SessionRevoked -> toProblemError pcSessionRevoked bearerOccurrence+  _ -> toProblemError pcTokenInvalidAuth bearerOccurrence++-- | Extract the presented token and record where it came from.+--+-- 'BearerToken' reads the @Authorization@ header only — the cookie is __not__ a fallback,+-- because a deployment that never sets cookies must not accept them either. The cookie modes+-- try bearer first (non-browser callers and service tokens keep working) and fall back to the+-- configured session cookie.+extractToken :: CookiePolicy -> Request -> Maybe (TokenSource, Text)+extractToken policy req =+  extractTokenFromHeaders policy (header "Authorization") (header "Cookie")+  where+    header name = Text.decodeUtf8Lenient <$> lookup name (requestHeaders req)++-- | 'extractToken' over the header values directly, for routes that receive them as Servant+-- 'Servant.Header' inputs rather than as a WAI 'Request'.+--+-- @\/oauth\/authorize@ is such a route: it must /redirect/ an unauthenticated browser to the+-- host's login page rather than answer @401@, so it cannot use the 'Authenticated' combinator and+-- never sees a 'Request'. Sharing this function is what makes a future transport (the cookie mode+-- today, anything later) reach that endpoint without a second implementation. Compare+-- 'originHeaderAllowed', which exists for the same reason.+extractTokenFromHeaders :: CookiePolicy -> Maybe Text -> Maybe Text -> Maybe (TokenSource, Text)+extractTokenFromHeaders policy mAuthorization mCookie =+  ((FromBearer,) <$> bearer) <|> guard (transportUsesCookies policy.transport) *> ((FromCookie,) <$> cookieToken)+  where+    bearer :: Maybe Text+    bearer = mAuthorization >>= Text.stripPrefix "Bearer "++    cookieToken :: Maybe Text+    cookieToken = do+      raw <- mCookie+      val <- lookup policy.sessionCookie (parseCookies (Text.encodeUtf8 raw))+      pure (Text.decodeUtf8Lenient val)++-- | Verify whatever credential the headers carry, yielding 'Nothing' when there is none or it does+-- not verify. The authenticating core the 'AuthHandler' and @\/oauth\/authorize@ share.+--+-- No CSRF gate: the only caller that is not the 'AuthHandler' is a @GET@, and 'isSafeMethod' would+-- exempt it anyway. A caller that /can/ mutate must go through 'authHandler'.+resolveAuthUser ::+  Env ->+  -- | the @Authorization@ header+  Maybe Text ->+  -- | the @Cookie@ header+  Maybe Text ->+  IO (Maybe AuthUser)+resolveAuthUser env mAuthorization mCookie =+  case extractTokenFromHeaders policy mAuthorization mCookie of+    Nothing -> pure Nothing+    Just (_source, tok) -> either (const Nothing) (Just . authUserFromClaims) <$> verifyRequestToken env tok+  where+    policy = cookiePolicyFromConfig env.config++-- | Methods that cannot change state, and so need no CSRF protection.+isSafeMethod :: Request -> Bool+isSafeMethod req = requestMethod req `elem` ["GET", "HEAD", "OPTIONS"]++-- | Is this request driven by an allow-listed origin?+--+-- Prefers the @Origin@ header, which browsers set to the /initiating/ page's origin on every+-- cross-origin request and on same-origin POSTs, and which page JavaScript cannot forge.+-- Falls back to a @Referer@ prefix match for the few agents that omit @Origin@; the prefix+-- must end at a @\/@ or at the end of the header, so @https://evil.com@ cannot satisfy an+-- allow-list containing @https://evil.com.attacker.net@ — or vice versa.+--+-- With neither header present this returns 'False': a cookie-authenticated mutating request+-- carrying no origin information is either a non-browser client that should be sending a+-- bearer token, or an attack. Fail closed.+originAllowed :: [Text] -> Request -> Bool+originAllowed allowed req = originHeaderAllowed allowed (header "Origin") (header "Referer")+  where+    header name = Text.decodeUtf8Lenient <$> lookup name (requestHeaders req)++-- | 'originAllowed' over the header values directly, for routes that receive them as servant+-- 'Header' inputs rather than a WAI 'Request' — the refresh endpoint, which is unauthenticated+-- yet consumes a cookie.+originHeaderAllowed :: [Text] -> Maybe Text -> Maybe Text -> Bool+originHeaderAllowed allowed mOrigin mReferer = maybe refererAllowed (`elem` allowed) mOrigin+  where+    refererAllowed = maybe False matchesPrefix mReferer+    matchesPrefix referer = any (`isOriginPrefixOf` referer) allowed+    isOriginPrefixOf origin referer =+      case Text.stripPrefix origin referer of+        Just "" -> True+        Just rest -> Text.isPrefixOf "/" rest+        Nothing -> False++-- | The refusal for a cookie-authenticated mutating request from a disallowed origin. Shared+-- with the refresh handler, which applies the same gate to the configured refresh cookie.+--+-- This is an HTTP-layer error, not an 'Shomei.Error.AuthError': CSRF is a property of /how the+-- credential arrived/, which the core workflows never see.+csrfRejected :: ServerError+csrfRejected = toProblemError pcCsrfRejected noProblemOccurrence
+ src/Shomei/Servant/Authz.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Role/scope authorization as /enforcing/ Servant combinators.+--+-- Writing @RequireRole "admin" :> ...@ in a route type authenticates the caller and rejects a+-- principal that lacks the role with @403@ — with no handler code at all. The handler still+-- receives the 'AuthUser', exactly as it would under 'Authenticated'.+--+-- __These combinators replace 'Authenticated', they do not accompany it.__ A route carries+-- @RequireRole "admin" :> sub@ /instead of/ @Authenticated :> sub@: the instance below runs the+-- very same 'AuthHandler' from the Servant 'Servant.Context' that 'Authenticated' would, so the+-- token extraction, the CSRF gate, and the verifier are shared. Writing both would authenticate+-- twice and give the handler two 'AuthUser' arguments.+--+-- Why a combinator rather than a handler guard: a guard the route author forgets to call ships+-- a silently unprotected route, and the route type says otherwise. A combinator whose /absence/+-- of enforcement is impossible is the point. (These types were phantoms with no 'HasServer'+-- instance until MasterPlan 7 EP-1; a route that carried one enforced nothing.)+--+-- The guard functions 'requireRole' / 'requireScope' remain exported for composite conditions+-- a single type-level symbol cannot express — "role @admin@ OR scope @shomei:admin@" — which+-- the admin HTTP API needs.+--+-- These are Shōmei's built-in, flat, tier-1 authorization primitives: they read static claims+-- from an already-minted JWT. They are deliberately not resource-scoped+-- (@RequireRole \"editor\"@ cannot mean "editor /of this project/"). Claim changes remain stale+-- until the token expires, but a deployment using @VerifyTokenAndSession@ can reject an expired or+-- revoked backing session immediately. See @docs\/user\/security.md@ for where that boundary lies.+module Shomei.Servant.Authz+  ( RequireRole,+    RequireScope,+    RequirePermission,+    RequireAdmin,+    requireRole,+    requireScope,+    requireAdmin,+    adminRole,+    adminScope,+  )+where++import Data.Kind (Type)+import Data.Set qualified as Set+import Data.Text qualified as Text+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Network.Wai (Request)+import Servant+  ( Context,+    Handler,+    ServerError,+    throwError,+    type (:>),+  )+import Servant.Server.Experimental.Auth (AuthHandler, unAuthHandler)+import Servant.Server.Internal+  ( DelayedIO,+    HasContextEntry,+    HasServer (..),+    addAuthCheck,+    delayedFailFatal,+    getContextEntry,+    runHandler,+    withRequest,+  )+import Shomei.Authorization.Claims.Domain (Permission (..), Role (..), Scope (..))+import Shomei.Authorization.Scope.Domain (adminScope)+-- 'Shomei.Prelude' re-exports lens, whose 'Context' collides with servant's.+import Shomei.Prelude hiding (Context)+import Shomei.Servant.Auth (AuthUser (..))+import Shomei.Servant.Error (noProblemOccurrence, pcMissingPermission, pcMissingRole, pcMissingScope, toProblemError)++-- | Enforcing combinator: the route demands the named role. (The type parameter is named @r@,+-- not @role@: under GHC2024 @RoleAnnotations@ is on, so @role@ is a context-sensitive keyword+-- and cannot be a type-variable binder.)+type RequireRole :: Symbol -> Type+data RequireRole r++-- | Enforcing combinator: the route demands the named scope.+type RequireScope :: Symbol -> Type+data RequireScope s++-- | Enforcing combinator: the route demands the named __permission__ (EP-9) — i.e. @p@ must be a+-- member of the token's @permissions@ claim, else @403 missing_permission@. The handler still+-- receives the 'AuthUser', exactly as under 'RequireRole'.+--+-- This checks a __static claim__ minted at login\/refresh from the role → permission catalog:+-- rewiring which roles imply @p@, or a grant expiring, applies at the /next/ mint, not to an+-- outstanding token (see @docs\/user\/security.md@; @revokeAllUserSessions@ is the immediate+-- lever). It is __not__ a live authorization check. For relationship-based, instantly-revocable+-- decisions use the __en__ toolkit's term-level @En.Servant.Authorize.requirePermission@ guard (a+-- separate project Shōmei does not depend on); it shares this name because it expresses the same+-- /intent/ at a different freshness tier. See @docs\/user\/authorization.md@ for the boundary.+type RequirePermission :: Symbol -> Type+data RequirePermission p++-- | Enforcing combinator for Shōmei administration: the principal must carry either the+-- @admin@ role or the @shomei:admin@ scope.+type RequireAdmin :: Type+data RequireAdmin++-- | Guard: fail with @403@ unless the principal carries the role. Use this only for a condition+-- the type-level combinator cannot express; a plain "this route needs role X" belongs in the+-- route type, where it cannot be forgotten.+requireRole :: Role -> AuthUser -> Handler ()+requireRole role u+  | role `Set.member` u.authRoles = pure ()+  | otherwise = throwError missingRole++-- | Guard: fail with @403@ unless the principal carries the scope. See 'requireRole'.+requireScope :: Scope -> AuthUser -> Handler ()+requireScope scope u+  | scope `Set.member` u.authScopes = pure ()+  | otherwise = throwError missingScope++-- | The two 403 problem documents these combinators and guards raise. Shared so the type-level+-- and handler-level paths cannot answer differently.+missingRole, missingScope, missingPermission :: ServerError+missingRole = toProblemError pcMissingRole noProblemOccurrence+missingScope = toProblemError pcMissingScope noProblemOccurrence+missingPermission = toProblemError pcMissingPermission noProblemOccurrence++-- | The @admin@ role, granted through the 'Shomei.Authorization.Role.Store' (a human administrator).+adminRole :: Role+adminRole = Role "admin"++-- | The admin gate (EP-2): the principal must carry the @admin@ role __or__ the @shomei:admin@+-- scope.+--+-- This is a guard function rather than a route-type combinator because the condition is a+-- /disjunction/, and a single type-level symbol cannot express one. Both halves are needed: a+-- human administrator carries a granted role, while a database-less service administers with a+-- OAuth machine tokens carry scopes, not roles.+--+-- The failure is the same @403 missing_role@ document 'requireRole' raises. It deliberately does+-- not say "…or the @shomei:admin@ scope": telling an unauthorized caller exactly which of two+-- credentials would have worked is a hint they have no business receiving.+requireAdmin :: AuthUser -> Handler ()+requireAdmin u+  | adminRole `Set.member` u.authRoles = pure ()+  | adminScope `Set.member` u.authScopes = pure ()+  | otherwise = throwError missingRole++-- | Authenticate the request with the context-registered 'AuthHandler' — the same one+-- 'Shomei.Servant.Auth.Authenticated' uses — and hand the 'AuthUser' to @check@. A failure from+-- the auth handler itself (missing token, invalid token, CSRF rejection) propagates unchanged,+-- so an unauthenticated request still gets its @401@ rather than a @403@.+authorizedCheck ::+  (HasContextEntry ctx (AuthHandler Request AuthUser)) =>+  Context ctx ->+  (AuthUser -> Either ServerError AuthUser) ->+  Request ->+  DelayedIO AuthUser+authorizedCheck ctx check req = do+  outcome <- liftIO (runHandler (unAuthHandler (getContextEntry ctx) req))+  user <- either delayedFailFatal pure outcome+  either delayedFailFatal pure (check user)++instance+  ( HasServer api ctx,+    HasContextEntry ctx (AuthHandler Request AuthUser),+    KnownSymbol r+  ) =>+  HasServer (RequireRole r :> api) ctx+  where+  type ServerT (RequireRole r :> api) m = AuthUser -> ServerT api m++  hoistServerWithContext _ pc nt s =+    hoistServerWithContext (Proxy :: Proxy api) pc nt . s++  route _ ctx subserver =+    route (Proxy :: Proxy api) ctx (subserver `addAuthCheck` withRequest (authorizedCheck ctx check))+    where+      needed = Role (Text.pack (symbolVal (Proxy :: Proxy r)))+      check user+        | needed `Set.member` user.authRoles = Right user+        | otherwise = Left missingRole++instance+  ( HasServer api ctx,+    HasContextEntry ctx (AuthHandler Request AuthUser),+    KnownSymbol s+  ) =>+  HasServer (RequireScope s :> api) ctx+  where+  type ServerT (RequireScope s :> api) m = AuthUser -> ServerT api m++  hoistServerWithContext _ pc nt srv =+    hoistServerWithContext (Proxy :: Proxy api) pc nt . srv++  route _ ctx subserver =+    route (Proxy :: Proxy api) ctx (subserver `addAuthCheck` withRequest (authorizedCheck ctx check))+    where+      needed = Scope (Text.pack (symbolVal (Proxy :: Proxy s)))+      check user+        | needed `Set.member` user.authScopes = Right user+        | otherwise = Left missingScope++instance+  ( HasServer api ctx,+    HasContextEntry ctx (AuthHandler Request AuthUser),+    KnownSymbol p+  ) =>+  HasServer (RequirePermission p :> api) ctx+  where+  type ServerT (RequirePermission p :> api) m = AuthUser -> ServerT api m++  hoistServerWithContext _ pc nt srv =+    hoistServerWithContext (Proxy :: Proxy api) pc nt . srv++  route _ ctx subserver =+    route (Proxy :: Proxy api) ctx (subserver `addAuthCheck` withRequest (authorizedCheck ctx check))+    where+      needed = Permission (Text.pack (symbolVal (Proxy :: Proxy p)))+      check user+        | needed `Set.member` user.authPermissions = Right user+        | otherwise = Left missingPermission++instance+  ( HasServer api ctx,+    HasContextEntry ctx (AuthHandler Request AuthUser)+  ) =>+  HasServer (RequireAdmin :> api) ctx+  where+  type ServerT (RequireAdmin :> api) m = AuthUser -> ServerT api m++  hoistServerWithContext _ pc nt srv =+    hoistServerWithContext (Proxy :: Proxy api) pc nt . srv++  route _ ctx subserver =+    route (Proxy :: Proxy api) ctx (subserver `addAuthCheck` withRequest (authorizedCheck ctx check))+    where+      check user+        | adminRole `Set.member` user.authRoles = Right user+        | adminScope `Set.member` user.authScopes = Right user+        | otherwise = Left missingRole
+ src/Shomei/Servant/ClientIp.hs view
@@ -0,0 +1,63 @@+-- | Canonical textual client addresses shared by Servant handlers and WAI middleware.+module Shomei.Servant.ClientIp+  ( clientIpText,+    clientIpOf,+  )+where++import Data.List (maximumBy)+import Data.Ord (comparing)+import Data.Text qualified as Text+import Data.Word (Word16)+import Network.Socket (SockAddr (..), hostAddress6ToTuple, hostAddressToTuple)+import Numeric (showHex)+import Shomei.Prelude+import Shomei.Session.LoginAttempt.Domain (ClientIp (..))++clientIpOf :: SockAddr -> ClientIp+clientIpOf = ClientIp . clientIpText++-- | Render an IPv4 peer as a dotted quad and IPv6 according to RFC 5952.+-- The source port is deliberately omitted because the result is a security-policy key.+clientIpText :: SockAddr -> Text+clientIpText = \case+  SockAddrInet _ host ->+    let (a, b, c, d) = hostAddressToTuple host+     in Text.intercalate "." (Text.pack . show <$> [a, b, c, d])+  SockAddrInet6 _ _ host _ ->+    let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple host+     in renderIpv6 [a, b, c, d, e, f, g, h]+  SockAddrUnix path -> Text.pack path++renderIpv6 :: [Word16] -> Text+renderIpv6 groups =+  case longestZeroRun groups of+    Nothing -> joined groups+    Just (start, len) ->+      let before = joined (take start groups)+          after = joined (drop (start + len) groups)+       in case (Text.null before, Text.null after) of+            (True, True) -> "::"+            (True, False) -> "::" <> after+            (False, True) -> before <> "::"+            (False, False) -> before <> "::" <> after+  where+    joined = Text.intercalate ":" . fmap (Text.pack . (`showHex` ""))++-- RFC 5952 compresses the longest run of at least two zero groups, choosing the+-- leftmost run on a tie. 'maximumBy' is fed the reversed candidates so its+-- rightmost-on-equality behavior preserves that leftmost run.+longestZeroRun :: [Word16] -> Maybe (Int, Int)+longestZeroRun groups =+  case reverse (zeroRuns 0 groups) of+    [] -> Nothing+    runs -> Just (maximumBy (comparing snd) runs)++zeroRuns :: Int -> [Word16] -> [(Int, Int)]+zeroRuns _ [] = []+zeroRuns offset values@(value : rest)+  | value /= 0 = zeroRuns (offset + 1) rest+  | otherwise =+      let len = length (takeWhile (== 0) values)+          remaining = zeroRuns (offset + len) (drop len values)+       in if len >= 2 then (offset, len) : remaining else remaining
+ src/Shomei/Servant/Cookie.hs view
@@ -0,0 +1,143 @@+-- | Building Shōmei's transport cookies.+--+-- Two cookies, set together by every response that issues a token pair:+--+-- * @__Host-shomei_session@ — the access token when cookies are secure. @Path=\/@,+--   @Max-Age@ = @accessTokenTTL@.+-- * @__Secure-shomei_refresh@ — the refresh token when cookies are secure.+--   @Path=\/v1\/auth\/refresh@, @Max-Age@ =+--   @refreshTokenTTL@. Scoping it to the one endpoint that consumes it means the browser+--   never presents this long-lived credential anywhere else.+--+-- Both are @HttpOnly@, so page JavaScript cannot read them and an XSS payload cannot+-- exfiltrate the session. Both carry @Secure@ and a @SameSite@ policy from+-- 'Shomei.Config.CookieConfig'.+--+-- In 'Shomei.Config.BearerToken' mode 'applyCookies' emits no headers at all, so a bearer+-- deployment's responses are byte-for-byte what they were before cookies existed.+module Shomei.Servant.Cookie+  ( WithCookies,+    CookiePair (..),+    sessionCookieName,+    refreshCookieName,+    tokenCookies,+    clearedCookies,+    applyCookies,+    refreshTokenFromCookie,+  )+where++import Data.ByteString (ByteString)+import Data.Text.Encoding qualified as Text+import Data.Time (secondsToDiffTime)+import Servant (Header, Headers, addHeader, noHeader)+import Shomei.Config (CookieConfig (..), SameSitePolicy (..), ShomeiConfig (..), transportUsesCookies)+import Shomei.Prelude+import Shomei.Session.RefreshToken.Domain (RefreshToken (..))+import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..))+import Web.Cookie+  ( SameSiteOption,+    SetCookie,+    defaultSetCookie,+    parseCookies,+    sameSiteLax,+    sameSiteNone,+    sameSiteStrict,+    setCookieHttpOnly,+    setCookieMaxAge,+    setCookieName,+    setCookiePath,+    setCookieSameSite,+    setCookieSecure,+    setCookieValue,+  )+import Web.HttpApiData (toUrlPiece)++-- | A response body carrying the two @Set-Cookie@ headers. Both are always present in the+-- type; 'applyCookies' decides whether they carry a value.+type WithCookies a =+  Headers '[Header "Set-Cookie" Text, Header "Set-Cookie" Text] a++-- | The rendered @Set-Cookie@ values for the session and refresh cookies.+data CookiePair = CookiePair+  { sessionCookie :: !Text,+    refreshCookie :: !Text+  }+  deriving stock (Eq, Show)++sessionCookieName :: CookieConfig -> ByteString+sessionCookieName cfg+  | cfg.secure = "__Host-shomei_session"+  | otherwise = "shomei_session"++refreshCookieName :: CookieConfig -> ByteString+refreshCookieName cfg+  | cfg.secure = "__Secure-shomei_refresh"+  | otherwise = "shomei_refresh"++-- | The refresh cookie's @Path@ scope: the browser sends it to exactly one endpoint, so an+-- XSS anywhere else in the origin cannot read or replay it.+--+-- This must track the served path of 'Shomei.Servant.Api.ShomeiAPI'\'s @refresh@ route, which+-- 'Shomei.Servant.Api.ShomeiRoutes' mounts under @\/v1@. A host that mounts @ShomeiAPI@ at a+-- different prefix breaks the match and with it cookie-mode refresh.+refreshCookiePath :: ByteString+refreshCookiePath = "/v1/auth/refresh"++-- | The cookies that carry a freshly-issued token pair.+tokenCookies :: ShomeiConfig -> TokenPair -> CookiePair+tokenCookies cfg pair =+  CookiePair+    { sessionCookie = render (base (sessionCookieName cfg.cookieConfig) "/" cfg.accessTokenTTL) {setCookieValue = accessBytes},+      refreshCookie = render (base (refreshCookieName cfg.cookieConfig) refreshCookiePath cfg.refreshTokenTTL) {setCookieValue = refreshBytes}+    }+  where+    AccessToken accessText = pair.accessToken+    RefreshToken refreshText = pair.refreshToken+    accessBytes = Text.encodeUtf8 accessText+    refreshBytes = Text.encodeUtf8 refreshText+    base name path ttl =+      (cookieBase cfg name path) {setCookieMaxAge = Just (secondsToDiffTime (round ttl))}++-- | Cookies that delete their counterparts: same name, path, and flags (browsers match on+-- all three), empty value, @Max-Age=0@.+clearedCookies :: ShomeiConfig -> CookiePair+clearedCookies cfg =+  CookiePair+    { sessionCookie = render (expire (cookieBase cfg (sessionCookieName cfg.cookieConfig) "/")),+      refreshCookie = render (expire (cookieBase cfg (refreshCookieName cfg.cookieConfig) refreshCookiePath))+    }+  where+    expire c = c {setCookieValue = "", setCookieMaxAge = Just (secondsToDiffTime 0)}++cookieBase :: ShomeiConfig -> ByteString -> ByteString -> SetCookie+cookieBase cfg name path =+  defaultSetCookie+    { setCookieName = name,+      setCookiePath = Just path,+      setCookieHttpOnly = True,+      setCookieSecure = cfg.cookieConfig.secure,+      setCookieSameSite = Just (sameSiteOption cfg.cookieConfig.sameSite)+    }++sameSiteOption :: SameSitePolicy -> SameSiteOption+sameSiteOption = \case+  SameSiteStrict -> sameSiteStrict+  SameSiteLax -> sameSiteLax+  SameSiteNone -> sameSiteNone++-- | @web-cookie@'s @ToHttpApiData SetCookie@ renders exactly the header value we want+-- (@name=value; Path=…; Max-Age=…; HttpOnly; Secure; SameSite=Lax@).+render :: SetCookie -> Text+render = toUrlPiece++-- | Attach the cookies when the transport uses them; emit no headers otherwise.+applyCookies :: ShomeiConfig -> CookiePair -> a -> WithCookies a+applyCookies cfg pair body+  | transportUsesCookies cfg.tokenTransport = addHeader pair.sessionCookie (addHeader pair.refreshCookie body)+  | otherwise = noHeader (noHeader body)++-- | The configured refresh-cookie value from a raw @Cookie@ request header.+refreshTokenFromCookie :: CookieConfig -> Text -> Maybe Text+refreshTokenFromCookie cfg raw =+  Text.decodeUtf8 <$> lookup (refreshCookieName cfg) (parseCookies (Text.encodeUtf8 raw))
+ src/Shomei/Servant/Error.hs view
@@ -0,0 +1,607 @@+-- | The single error vocabulary of the HTTP surface, and the one function that renders it.+--+-- Every failure Shōmei returns — from a workflow, from the auth handler, from an authorization+-- combinator, from Servant's own request parser, from the rate-limit middleware — is an+-- __RFC 9457 problem document__ served as @application/problem+json@:+--+-- @+-- {"type":"https://github.com/shinzui/shomei/blob/master/docs/user/problem-details.md#token_invalid",+--  "title":"Token is invalid","status":401,"code":"token_invalid","retryable":false}+-- @+--+-- @type@ is the stable, dereferenceable primary identifier. @title@ is stable human text,+-- @status@ mirrors the HTTP status, and @code@ and @retryable@ are Shōmei extensions. Optional+-- @detail@ and @instance@ members describe a safe occurrence.+--+-- 'ProblemSpec' constants are the single source shared by the runtime mapping here and by the+-- OpenAPI error documentation in "Shomei.Servant.OpenApi", so a status or title cannot drift+-- between what the server sends and what the spec promises.+--+-- Two deliberate exemptions:+--+--   * health probe failures use the structured 'Servant.Health.ProbeResult' body,+--     not a problem document. It is a status report, not an error.+--   * The future @POST \/oauth\/token@ endpoint must use RFC 6749 §5.2's+--     @{"error":"invalid_grant",…}@ shape, which OAuth2 clients require. That surface belongs+--     to MasterPlan 7 EP-4 and is exempt from this envelope.+--+-- Never leaks internal detail: 'InvalidCredentials', 'UserNotActive', and 'AccountLocked' all+-- collapse to the same generic @401 invalid_login@ so account existence and status are not+-- disclosed, and 'InternalAuthError' carries no detail to the client.+module Shomei.Servant.Error+  ( -- * The envelope+    ProblemDetails (..),+    ProblemJSON,+    ProblemSpec (..),+    ProblemOccurrence (..),+    noProblemOccurrence,+    detailOccurrence,+    bearerOccurrence,+    retryAfterOccurrence,+    problemTypeFor,+    problemDetails,+    toProblemError,+    problemBody,+    problemHeaders,++    -- * The catalog+    problemCatalog,+    authErrorProblem,+    authErrorToServerError,++    -- * Servant's built-in failures+    shomeiErrorFormatters,++    -- * Specs with an 'AuthError' counterpart++    --+    -- Exported in full so "Shomei.Servant.OpenApi" can name them in its route→codes+    -- table: the spec's documented status and title are then literally the ones the+    -- server sends.+    pcInvalidEmail,+    pcInvalidLoginId,+    pcWeakPassword,+    pcEmailTaken,+    pcLoginIdTaken,+    pcInvalidLogin,+    pcTooManyRequests,+    pcSessionNotFound,+    pcSessionExpired,+    pcSessionRevoked,+    pcRefreshTokenInvalid,+    pcRefreshTokenExpired,+    pcTokenReuse,+    pcVerificationTokenInvalid,+    pcPasswordResetTokenInvalid,+    pcEmailAlreadyVerified,+    pcEmailNotVerified,+    pcTokenInvalid,+    pcPasskeyNotFound,+    pcCeremonyNotFound,+    pcWebAuthnFailed,+    pcMfaFailed,+    pcTotpDisabled,+    pcTotpAlreadyEnrolled,+    pcTotpEnrollmentNotFound,+    pcTotpCodeInvalid,+    pcRecoveryCodeInvalid,+    pcReauthenticationRequired,+    pcImpersonationForbidden,+    pcImpersonationTargetInvalid,+    pcImpersonationActionBlocked,+    pcUserNotFound,+    pcRoleNotDefined,+    pcInvalidUserStatus,+    pcUserHasNoEmail,+    pcDependencyUnavailable,+    pcInternal,++    -- * HTTP-layer specs (no 'AuthError' counterpart)+    pcMissingToken,+    pcTokenInvalidAuth,+    pcMissingRole,+    pcMissingScope,+    pcMissingPermission,+    pcCsrfRejected,+    pcBadRequest,+    pcPayloadTooLarge,+    pcBodyParseError,+    pcNotFound,+    pcMethodNotAllowed,+    pcSelfTargetForbidden,+    pcRoleNotGranted,++    -- * Statuses Servant does not ship+    err422,+    err429,+  )+where++import Control.Lens+import Data.Aeson (eitherDecode)+import Data.Aeson qualified as Aeson+import Data.HashMap.Strict.InsOrd.Compat qualified as IOHM+import Data.OpenApi (NamedSchema (..), ToSchema (..))+import Data.OpenApi qualified as O+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TextEncoding+import Network.HTTP.Media (MediaType)+import Network.HTTP.Types.Header (Header)+import Numeric.Natural (Natural)+import Servant+  ( Accept (..),+    ErrorFormatters (..),+    MimeRender (..),+    MimeUnrender (..),+    ServerError (..),+    defaultErrorFormatters,+    err400,+    err401,+    err403,+    err404,+    err405,+    err409,+    err413,+    err500,+    err503,+  )+import Shomei.Authorization.Claims.Domain (Role (..))+import Shomei.Error (AuthError (..))+import Shomei.Prelude++-- ---------------------------------------------------------------------------+-- Statuses Servant does not ship+-- ---------------------------------------------------------------------------++-- | HTTP 429 Too Many Requests.+err429 :: ServerError+err429 =+  ServerError+    { errHTTPCode = 429,+      errReasonPhrase = "Too Many Requests",+      errBody = "",+      errHeaders = []+    }++-- | HTTP 422 Unprocessable Content.+err422 :: ServerError+err422 =+  ServerError+    { errHTTPCode = 422,+      errReasonPhrase = "Unprocessable Content",+      errBody = "",+      errHeaders = []+    }++-- ---------------------------------------------------------------------------+-- The envelope+-- ---------------------------------------------------------------------------++-- | RFC 9457 body plus Shōmei's stable extension members.+data ProblemDetails = ProblemDetails+  { problemType :: !Text,+    title :: !Text,+    status :: !Int,+    detail :: !(Maybe Text),+    problemInstance :: !(Maybe Text),+    code :: !Text,+    retryable :: !Bool+  }+  deriving stock (Eq, Show, Generic)++problemJsonOptions :: Options+problemJsonOptions =+  defaultOptions+    { fieldLabelModifier = \case+        "problemType" -> "type"+        "problemInstance" -> "instance"+        field -> field,+      omitNothingFields = True+    }++instance ToJSON ProblemDetails where+  toJSON = genericToJSON problemJsonOptions++instance FromJSON ProblemDetails where+  parseJSON = genericParseJSON problemJsonOptions++-- | The fixed media type for application errors.+data ProblemJSON++instance Accept ProblemJSON where+  contentType _ = "application/problem+json" :: MediaType++instance MimeRender ProblemJSON ProblemDetails where+  mimeRender _ = Aeson.encode++instance MimeUnrender ProblemJSON ProblemDetails where+  mimeUnrender _ = eitherDecode++instance ToSchema ProblemDetails where+  declareNamedSchema _ = pure (NamedSchema (Just "ProblemDetails") problemDetailsSchema)++problemDetailsSchema :: O.Schema+problemDetailsSchema =+  mempty+    & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiObject+    & O.description ?~ "RFC 9457 Problem Details with Shomei code and retryability extensions."+    & O.properties+      .~ IOHM.fromList+        [ ("type", O.Inline (stringSchema & O.format ?~ "uri-reference")),+          ("title", O.Inline stringSchema),+          ("status", O.Inline (integerSchema & O.minimum_ ?~ 100 & O.maximum_ ?~ 599)),+          ("detail", O.Inline stringSchema),+          ("instance", O.Inline (stringSchema & O.format ?~ "uri-reference")),+          ("code", O.Inline stringSchema),+          ("retryable", O.Inline (mempty & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiBoolean))+        ]+    & O.required .~ ["type", "title", "status", "code", "retryable"]+    & O.additionalProperties ?~ O.AdditionalPropertiesAllowed True++stringSchema :: O.Schema+stringSchema = mempty & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiString++integerSchema :: O.Schema+integerSchema = mempty & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiInteger++-- | One stable error kind shared by handler results and pre-handler rendering.+--+-- These constants are the SINGLE SOURCE shared by 'authErrorToServerError' below and by the+-- OpenAPI error documentation, so the two cannot disagree about a status or a title.+data ProblemSpec = ProblemSpec+  { problemCode :: !Text,+    -- | the Servant base error; only its status and reason phrase are used+    problemStatus :: !ServerError,+    problemTitle :: !Text,+    problemRetryable :: !Bool+  }++problemSpec :: Text -> ServerError -> Text -> ProblemSpec+problemSpec problemCode problemStatus problemTitle =+  ProblemSpec {problemCode, problemStatus, problemTitle, problemRetryable = False}++retryableProblemSpec :: Text -> ServerError -> Text -> ProblemSpec+retryableProblemSpec problemCode problemStatus problemTitle =+  ProblemSpec {problemCode, problemStatus, problemTitle, problemRetryable = True}++-- | Safe occurrence-specific data and optional response headers.+data ProblemOccurrence = ProblemOccurrence+  { occurrenceDetail :: !(Maybe Text),+    instanceUri :: !(Maybe Text),+    wwwAuthenticate :: !(Maybe Text),+    retryAfterSeconds :: !(Maybe Natural)+  }+  deriving stock (Eq, Show, Generic)++noProblemOccurrence :: ProblemOccurrence+noProblemOccurrence = ProblemOccurrence Nothing Nothing Nothing Nothing++detailOccurrence :: Text -> ProblemOccurrence+detailOccurrence value = noProblemOccurrence {occurrenceDetail = Just value}++bearerOccurrence :: ProblemOccurrence+bearerOccurrence = noProblemOccurrence {wwwAuthenticate = Just "Bearer"}++retryAfterOccurrence :: Natural -> ProblemOccurrence+retryAfterOccurrence seconds = noProblemOccurrence {retryAfterSeconds = Just seconds}++problemTypeFor :: Text -> Text+problemTypeFor problemCode =+  "https://github.com/shinzui/shomei/blob/master/docs/user/problem-details.md#" <> problemCode++problemDetails :: ProblemSpec -> ProblemOccurrence -> ProblemDetails+problemDetails spec occurrence =+  ProblemDetails+    { problemType = problemTypeFor spec.problemCode,+      title = spec.problemTitle,+      status = spec.problemStatus.errHTTPCode,+      detail = occurrence.occurrenceDetail,+      problemInstance = occurrence.instanceUri,+      code = spec.problemCode,+      retryable = spec.problemRetryable+    }++problemBody :: ProblemSpec -> ProblemOccurrence -> Aeson.Value+problemBody spec = toJSON . problemDetails spec++-- | The response headers a problem document carries at a given status.+--+-- A 401 advertises the scheme the client should use (RFC 6750 §3); a 429 tells the client how+-- long to wait. The token bucket refills continuously, so 60 seconds is an honest upper bound+-- for a full per-minute budget rather than an exact wait.+problemHeaders :: ProblemOccurrence -> [Header]+problemHeaders occurrence =+  [("Content-Type", "application/problem+json")]+    <> foldMap (\value -> [("WWW-Authenticate", encodeUtf8 value)]) occurrence.wwwAuthenticate+    <> foldMap (\seconds -> [("Retry-After", showBytes seconds)]) occurrence.retryAfterSeconds+  where+    encodeUtf8 = TextEncoding.encodeUtf8+    showBytes = encodeUtf8 . Text.pack . show++-- | Render a spec as an RFC 9457 'ServerError'. 'Nothing' omits the @detail@ member.+toProblemError :: ProblemSpec -> ProblemOccurrence -> ServerError+toProblemError spec occurrence =+  spec.problemStatus+    { errBody = Aeson.encode (problemDetails spec occurrence),+      errHeaders = problemHeaders occurrence+    }++-- ---------------------------------------------------------------------------+-- Servant's own request-parsing failures+-- ---------------------------------------------------------------------------++-- | Replace Servant's plain-text 400/404 bodies with problem documents.+--+-- __Servant's 405 is not reachable from here.__ @ErrorFormatters@ has exactly four hooks —+-- body-parse, url-parse, header-parse, and not-found — while a method mismatch raises a+-- hardcoded @err405@ (empty body) inside @Servant.Server.Internal.methodCheck@. The+-- 'Shomei.Servant.Middleware.problemMiddleware' WAI layer converts that one.+shomeiErrorFormatters :: ErrorFormatters+shomeiErrorFormatters =+  defaultErrorFormatters+    { bodyParserErrorFormatter = \_typeRep _req msg ->+        toProblemError pcBodyParseError (detailOccurrence (Text.pack msg)),+      urlParseErrorFormatter = \_typeRep _req msg ->+        toProblemError pcBadRequest (detailOccurrence (Text.pack msg)),+      headerParseErrorFormatter = \_typeRep _req msg ->+        toProblemError pcBadRequest (detailOccurrence (Text.pack msg)),+      notFoundErrorFormatter = \_req -> toProblemError pcNotFound noProblemOccurrence+    }++-- ---------------------------------------------------------------------------+-- The catalog+-- ---------------------------------------------------------------------------++-- Specs with an 'AuthError' counterpart. The code/status/title triple is the stable public+-- identity used by both pre-handler rendering and typed handler results.++pcInvalidEmail, pcInvalidLoginId, pcWeakPassword :: ProblemSpec+pcInvalidEmail = problemSpec "invalid_email" err400 "Email is not valid"+pcInvalidLoginId = problemSpec "invalid_login_id" err400 "Login identifier is not valid"+pcWeakPassword = problemSpec "weak_password" err400 "Password does not meet policy"++pcEmailTaken, pcLoginIdTaken :: ProblemSpec+pcEmailTaken = problemSpec "email_taken" err409 "Email is already registered"+pcLoginIdTaken = problemSpec "login_id_taken" err409 "Login identifier is already registered"++-- | The single generic answer for a wrong password, an unknown account, and a locked account.+pcInvalidLogin :: ProblemSpec+pcInvalidLogin = problemSpec "invalid_login" err401 "Invalid login identifier or password"++pcTooManyRequests :: ProblemSpec+pcTooManyRequests = retryableProblemSpec "too_many_requests" err429 "Too many requests"++pcSessionNotFound, pcSessionExpired, pcSessionRevoked :: ProblemSpec+pcSessionNotFound = problemSpec "session_not_found" err404 "Session not found"+pcSessionExpired = problemSpec "session_expired" err401 "Session expired"+pcSessionRevoked = problemSpec "session_revoked" err401 "Session revoked"++pcRefreshTokenInvalid, pcRefreshTokenExpired, pcTokenReuse :: ProblemSpec+pcRefreshTokenInvalid = problemSpec "token_invalid" err401 "Token is invalid"+pcRefreshTokenExpired = problemSpec "token_expired" err401 "Refresh token expired"+pcTokenReuse = problemSpec "token_reuse" err401 "Refresh token reuse detected"++pcVerificationTokenInvalid, pcPasswordResetTokenInvalid, pcEmailAlreadyVerified :: ProblemSpec+pcVerificationTokenInvalid = problemSpec "verification_token_invalid" err400 "Verification token is invalid"+pcPasswordResetTokenInvalid = problemSpec "password_reset_token_invalid" err400 "Password reset token is invalid"+pcEmailAlreadyVerified = problemSpec "email_already_verified" err409 "Email is already verified"++-- | 403, not 401: the credential WAS correct; the account is simply not yet eligible.+pcEmailNotVerified :: ProblemSpec+pcEmailNotVerified = problemSpec "email_not_verified" err403 "Email address is not verified"++-- | The access token failed verification. Deliberately does not say why.+pcTokenInvalid :: ProblemSpec+pcTokenInvalid = problemSpec "token_invalid" err401 "Token is invalid"++pcPasskeyNotFound, pcCeremonyNotFound, pcWebAuthnFailed, pcMfaFailed :: ProblemSpec+pcPasskeyNotFound = problemSpec "passkey_not_found" err404 "Passkey not found"+pcCeremonyNotFound = problemSpec "ceremony_not_found" err404 "Registration ceremony not found or expired"+pcWebAuthnFailed = problemSpec "webauthn_verification_failed" err400 "Passkey registration could not be verified"+pcMfaFailed = problemSpec "mfa_failed" err401 "Multi-factor authentication failed"++-- | EP-7 TOTP / recovery-code failures. The invalid-code specs are 401s that deliberately do+-- not distinguish a wrong code from a replayed one from an absent credential.+pcTotpDisabled, pcTotpAlreadyEnrolled, pcTotpEnrollmentNotFound, pcTotpCodeInvalid, pcRecoveryCodeInvalid :: ProblemSpec+pcTotpDisabled = problemSpec "totp_disabled" err403 "TOTP is not enabled"+pcTotpAlreadyEnrolled = problemSpec "totp_already_enrolled" err409 "A TOTP credential is already enrolled"+pcTotpEnrollmentNotFound = problemSpec "totp_enrollment_not_found" err404 "No pending TOTP enrollment to verify"+pcTotpCodeInvalid = problemSpec "totp_code_invalid" err401 "TOTP code is invalid"+pcRecoveryCodeInvalid = problemSpec "recovery_code_invalid" err401 "Recovery code is invalid"++-- | EP-7: a sensitive self-service action (recovery-code regeneration) requires a recently issued+-- access token. Raised by the HTTP layer's freshness gate, not by an 'AuthError'.+pcReauthenticationRequired :: ProblemSpec+pcReauthenticationRequired = problemSpec "reauthentication_required" err403 "Recent authentication required for this action"++pcImpersonationForbidden, pcImpersonationTargetInvalid, pcImpersonationActionBlocked :: ProblemSpec+pcImpersonationForbidden = problemSpec "impersonation_forbidden" err403 "Not allowed to impersonate"+pcImpersonationTargetInvalid = problemSpec "impersonation_target_invalid" err400 "Invalid impersonation target"+pcImpersonationActionBlocked = problemSpec "impersonation_action_blocked" err403 "This action is not permitted while impersonating"++pcUserNotFound, pcRoleNotDefined, pcDependencyUnavailable, pcInternal :: ProblemSpec+pcUserNotFound = problemSpec "user_not_found" err404 "User not found"+pcRoleNotDefined = problemSpec "role_not_defined" err422 "Role not defined"+pcDependencyUnavailable = retryableProblemSpec "dependency_unavailable" err503 "Required dependency unavailable"+pcInternal = problemSpec "internal" err500 "Internal authentication error"++-- | EP-2's admin lifecycle. Both are 409s: the request was well-formed and authorized, but the+-- target's state refuses it.+pcInvalidUserStatus, pcUserHasNoEmail :: ProblemSpec+pcInvalidUserStatus = problemSpec "invalid_user_status" err409 "User is not in a state that allows this action"+pcUserHasNoEmail = problemSpec "user_has_no_email" err409 "User has no email address"++-- Specs raised by the HTTP layer, with no 'AuthError' counterpart.++-- | No credential was presented at all — distinct from one that failed verification.+pcMissingToken :: ProblemSpec+pcMissingToken = problemSpec "missing_token" err401 "Authentication required"++-- | The auth handler's invalid-token 401. Shares the @token_invalid@ code with 'pcTokenInvalid'+-- and, like it, deliberately does not distinguish expired from forged from malformed.+pcTokenInvalidAuth :: ProblemSpec+pcTokenInvalidAuth = problemSpec "token_invalid" err401 "Token is invalid"++pcMissingRole, pcMissingScope, pcMissingPermission, pcCsrfRejected :: ProblemSpec+pcMissingRole = problemSpec "missing_role" err403 "Missing required role"+pcMissingScope = problemSpec "missing_scope" err403 "Missing required scope"++-- | EP-9: the @RequirePermission@ combinator's 403 — the token's @permissions@ claim does not+-- contain the required capability. Distinct code from @missing_role@ so a client can tell a+-- role-gated route from a permission-gated one.+pcMissingPermission = problemSpec "missing_permission" err403 "Missing required permission"++pcCsrfRejected = problemSpec "csrf_rejected" err403 "Origin not allowed for cookie-authenticated request"++-- | A malformed or incomplete request the handler rejected; the @detail@ says what.+pcBadRequest :: ProblemSpec+pcBadRequest = problemSpec "bad_request" err400 "Bad request"++-- | The edge stopped reading a request after it crossed the configured body cap.+pcPayloadTooLarge :: ProblemSpec+pcPayloadTooLarge = problemSpec "payload_too_large" err413 "Request body too large"++-- | Servant could not parse the JSON request body; the @detail@ carries the parse message.+pcBodyParseError :: ProblemSpec+pcBodyParseError = problemSpec "body_parse_error" err400 "Request body could not be parsed"++pcNotFound, pcMethodNotAllowed :: ProblemSpec+pcNotFound = problemSpec "not_found" err404 "Resource not found"+pcMethodNotAllowed = problemSpec "method_not_allowed" err405 "Method not allowed"++-- | EP-2: an administrator tried to suspend or delete their own account. Refused so a single+-- mistyped request cannot lock the last administrator out of a deployment; the @shomei-admin@ CLI+-- on the box remains the escape hatch for genuinely removing one.+pcSelfTargetForbidden :: ProblemSpec+pcSelfTargetForbidden = problemSpec "self_target_forbidden" err403 "An administrator cannot perform this action on their own account"++-- | EP-2: a role revocation named a role the user did not hold. A @404@ rather than a silent+-- success, so a typo in the role name is visible.+pcRoleNotGranted :: ProblemSpec+pcRoleNotGranted = problemSpec "role_not_granted" err404 "User does not hold that role"++-- | Every problem kind Shōmei can emit. The OpenAPI documentation is generated from this list,+-- and a conformance test asserts every documented code appears here.+--+-- Note that @token_invalid@ appears three times (an invalid access token, an invalid refresh+-- token, and the auth handler's rejection): the code is what clients switch on, and those three+-- are the same condition to a client. The titles differ because the causes do.+problemCatalog :: [ProblemSpec]+problemCatalog =+  [ pcInvalidEmail,+    pcInvalidLoginId,+    pcWeakPassword,+    pcEmailTaken,+    pcLoginIdTaken,+    pcInvalidLogin,+    pcTooManyRequests,+    pcSessionNotFound,+    pcSessionExpired,+    pcSessionRevoked,+    pcRefreshTokenInvalid,+    pcRefreshTokenExpired,+    pcTokenReuse,+    pcVerificationTokenInvalid,+    pcPasswordResetTokenInvalid,+    pcEmailAlreadyVerified,+    pcEmailNotVerified,+    pcTokenInvalid,+    pcPasskeyNotFound,+    pcCeremonyNotFound,+    pcWebAuthnFailed,+    pcMfaFailed,+    pcTotpDisabled,+    pcTotpAlreadyEnrolled,+    pcTotpEnrollmentNotFound,+    pcTotpCodeInvalid,+    pcRecoveryCodeInvalid,+    pcReauthenticationRequired,+    pcImpersonationForbidden,+    pcImpersonationTargetInvalid,+    pcImpersonationActionBlocked,+    pcUserNotFound,+    pcRoleNotDefined,+    pcInvalidUserStatus,+    pcUserHasNoEmail,+    pcDependencyUnavailable,+    pcInternal,+    pcMissingToken,+    pcTokenInvalidAuth,+    pcMissingRole,+    pcMissingScope,+    pcMissingPermission,+    pcCsrfRejected,+    pcBadRequest,+    pcPayloadTooLarge,+    pcBodyParseError,+    pcNotFound,+    pcMethodNotAllowed,+    pcSelfTargetForbidden,+    pcRoleNotGranted+  ]++-- | The one total mapping from a domain error to its application problem and occurrence.+-- Returned handler results and thrown pre-handler errors deliberately share this function.+authErrorProblem :: AuthError -> (ProblemSpec, ProblemOccurrence)+authErrorProblem = \case+  InvalidEmail -> plain pcInvalidEmail+  InvalidLoginId -> plain pcInvalidLoginId+  WeakPassword _ -> plain pcWeakPassword+  EmailAlreadyRegistered -> plain pcEmailTaken+  LoginIdAlreadyRegistered -> plain pcLoginIdTaken+  InvalidCredentials -> plain pcInvalidLogin+  UserNotActive -> plain pcInvalidLogin+  AccountLocked -> plain pcInvalidLogin+  TooManyRequests -> (pcTooManyRequests, retryAfterOccurrence 60)+  SessionNotFound -> plain pcSessionNotFound+  SessionExpired -> plain pcSessionExpired+  SessionRevoked -> plain pcSessionRevoked+  RefreshTokenInvalid -> plain pcRefreshTokenInvalid+  RefreshTokenExpired -> plain pcRefreshTokenExpired+  RefreshTokenReuseDetected -> plain pcTokenReuse+  VerificationTokenInvalid -> plain pcVerificationTokenInvalid+  PasswordResetTokenInvalid -> plain pcPasswordResetTokenInvalid+  EmailAlreadyVerified -> plain pcEmailAlreadyVerified+  EmailNotVerified -> plain pcEmailNotVerified+  TokenInvalid _ -> plain pcTokenInvalid+  PasskeyNotFound -> plain pcPasskeyNotFound+  PendingCeremonyNotFound -> plain pcCeremonyNotFound+  WebAuthnCeremonyError _ -> plain pcWebAuthnFailed+  MfaAssertionInvalid -> plain pcMfaFailed+  TotpDisabled -> plain pcTotpDisabled+  TotpAlreadyEnrolled -> plain pcTotpAlreadyEnrolled+  TotpEnrollmentNotFound -> plain pcTotpEnrollmentNotFound+  TotpCodeInvalid -> plain pcTotpCodeInvalid+  RecoveryCodeInvalid -> plain pcRecoveryCodeInvalid+  ImpersonationForbidden -> plain pcImpersonationForbidden+  ImpersonationTargetInvalid -> plain pcImpersonationTargetInvalid+  ImpersonationActionBlocked -> plain pcImpersonationActionBlocked+  -- EP-4's two OAuth errors are raised only by 'Shomei.ServiceAccount.ClientCredentials.Workflow', whose sole+  -- caller is @POST \/oauth\/token@ — and that handler renders them through+  -- 'Shomei.Servant.OAuth.oauthError' in the RFC 6749 §5.2 shape, never through this function+  -- (see the exemption in this module's header). These two arms exist so the @\case@ stays total,+  -- and map to generic application errors only to keep this conversion total.+  OAuthClientInvalid -> plain pcInvalidLogin+  OAuthScopeInvalid -> plain pcBadRequest+  -- EP-6's two token-exchange errors are, like EP-4's above, raised only by the+  -- @POST \/oauth\/token@ dispatcher (via 'Shomei.OAuth.TokenExchange.Workflow'), which renders them in+  -- the RFC 6749 §5.2 shape, never through this function. These arms keep the @\case@ total and+  -- reuse existing catalog specs (400s) rather than minting codes no route can emit.+  OAuthGrantInvalid -> plain pcBadRequest+  OAuthRequestMalformed -> plain pcBadRequest+  UserNotFound -> plain pcUserNotFound+  -- The offending name is request-specific, so it belongs in 'detail', keeping 'title' stable+  -- for the OpenAPI catalog.+  RoleNotDefined (Role r) -> (pcRoleNotDefined, detailOccurrence r)+  InvalidUserStatus -> plain pcInvalidUserStatus+  UserHasNoEmail -> plain pcUserHasNoEmail+  DependencyUnavailable _ -> plain pcDependencyUnavailable+  InternalAuthError _ -> plain pcInternal+  where+    plain spec = (spec, noProblemOccurrence)++-- | Render a domain error at a pre-handler boundary.+authErrorToServerError :: AuthError -> ServerError+authErrorToServerError err =+  let (spec, occurrence) = authErrorProblem err+   in toProblemError spec occurrence
+ src/Shomei/Servant/Middleware.hs view
@@ -0,0 +1,39 @@+-- | The WAI layer that finishes what @ErrorFormatters@ cannot.+--+-- Servant lets you format its body-parse, url-parse, header-parse, and not-found failures+-- through 'Servant.ErrorFormatters'. It does __not__ let you format a method mismatch: a request+-- to a known path with the wrong verb raises a hardcoded @err405@ with an empty body from+-- @Servant.Server.Internal.methodCheck@, below any hook. This middleware converts that response+-- into the same RFC 9457 problem document every other failure carries.+--+-- Shōmei never returns 405 from a handler, so rewriting the status unconditionally is safe.+module Shomei.Servant.Middleware+  ( problemMiddleware,+    problemResponse,+  )+where++import Data.Aeson qualified as Aeson+import Data.ByteString.Char8 qualified as BS8+import Network.HTTP.Types (Status, mkStatus, statusCode)+import Network.Wai (Middleware, Response, responseLBS, responseStatus)+import Servant (ServerError (..))+import Shomei.Servant.Error (ProblemOccurrence, ProblemSpec (..), noProblemOccurrence, pcMethodNotAllowed, problemBody, problemHeaders)++-- | Build a WAI response carrying a problem document. Used by this module and by the+-- rate-limit middleware, which answers before Servant ever sees the request.+problemResponse :: ProblemSpec -> ProblemOccurrence -> Response+problemResponse spec occurrence =+  responseLBS (statusOf spec) (problemHeaders occurrence) (Aeson.encode (problemBody spec occurrence))++statusOf :: ProblemSpec -> Status+statusOf spec = mkStatus spec.problemStatus.errHTTPCode (BS8.pack spec.problemStatus.errReasonPhrase)++-- | Rewrite Servant's bare @405 Method Not Allowed@ into a problem document.+problemMiddleware :: Middleware+problemMiddleware app req respond =+  app req \res ->+    respond+      if statusCode (responseStatus res) == 405+        then problemResponse pcMethodNotAllowed noProblemOccurrence+        else res
+ src/Shomei/Servant/OAuth.hs view
@@ -0,0 +1,286 @@+-- | The OAuth2 wire mechanics for @POST \/oauth\/token@ (EP-4): the RFC 6749 §5.2 error shape,+-- client authentication, the success response, and the parameter readers the grant dispatcher+-- in "Shomei.OAuth.Handler" uses.+--+-- __This endpoint does not speak Shōmei's error envelope.__ Everywhere else, a failure is an+-- RFC 9457 problem document (see "Shomei.Servant.Error"). Under @\/oauth\/*@ a failure is+-- RFC 6749 §5.2's @{"error":"invalid_grant","error_description":"…"}@, because that is the shape+-- every stock OAuth2 client — Spring, ASP.NET, Go's @clientcredentials@, @oauth2-proxy@ — parses+-- by field name. Wrapping it would break them, which would defeat the entire point of speaking+-- the standard. The boundary is deliberate and permanent: everything under @\/oauth\/*@ speaks+-- the OAuth wire protocol; everything else speaks the application envelope.+--+-- The RFC 6749 error codes, and the statuses they carry:+--+--   * @invalid_request@ (400) — a required parameter is missing or malformed.+--   * @invalid_client@ (401) — client authentication failed. Also carries+--     @WWW-Authenticate: Basic realm="shomei"@ when the client attempted Basic authentication.+--   * @invalid_grant@ (400) — the presented grant is invalid, expired, or revoked.+--   * @unauthorized_client@ (400) — this client may not use this grant type.+--   * @unsupported_grant_type@ (400) — the server does not implement this @grant_type@.+--   * @invalid_scope@ (400) — the requested scope is malformed or exceeds what the client may hold.+module Shomei.Servant.OAuth+  ( -- * The RFC 6749 §5.2 error shape+    oauthError,+    missingToken,+    invalidToken,+    invalidClient,+    invalidRequest,+    unsupportedGrantType,+    OAuthErrorResponse (..),++    -- * Client authentication (RFC 6749 §2.3.1)+    ClientAuth (..),+    extractClientAuth,++    -- * Request parameters+    lookupParam,+    parseScopeParam,++    -- * The success response (RFC 6749 §5.1)+    TokenResponse (..),+  )+where++import Data.Aeson qualified as Aeson+import Data.ByteString qualified as BS+import Data.ByteString.Base64 qualified as B64+import Data.OpenApi (ToSchema (..), fromAesonOptions, genericDeclareNamedSchema)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Network.HTTP.Types.Status (Status, status400, status401, statusCode, statusMessage)+import Network.HTTP.Types.URI (urlDecode)+import Servant (ServerError (..))+import Shomei.Authorization.Claims.Domain (Scope (..))+import Shomei.Prelude+import Web.FormUrlEncoded (Form, lookupUnique)++-- ---------------------------------------------------------------------------+-- Errors+-- ---------------------------------------------------------------------------++data OAuthErrorResponse = OAuthErrorResponse+  { oauthErrorCode :: !Text,+    oauthErrorDescription :: !Text+  }+  deriving stock (Generic, Eq, Show)++oauthErrorOptions :: Aeson.Options+oauthErrorOptions =+  Aeson.defaultOptions+    { Aeson.fieldLabelModifier = \case+        "oauthErrorCode" -> "error"+        "oauthErrorDescription" -> "error_description"+        field -> field+    }++instance Aeson.ToJSON OAuthErrorResponse where+  toJSON = Aeson.genericToJSON oauthErrorOptions++instance Aeson.FromJSON OAuthErrorResponse where+  parseJSON = Aeson.genericParseJSON oauthErrorOptions++instance ToSchema OAuthErrorResponse where+  declareNamedSchema = genericDeclareNamedSchema (fromAesonOptions oauthErrorOptions)++-- | Render an RFC 6749 §5.2 error as a 'ServerError'.+--+-- The body is @{"error":…,"error_description":…}@ with @Content-Type: application\/json@.+-- @Cache-Control: no-store@ rides on every response from this endpoint, error included: an+-- intermediary must never cache a token endpoint's answer.+--+-- A 401 additionally carries @WWW-Authenticate: Basic realm="shomei"@, as RFC 6749 §5.2 requires+-- of an @invalid_client@ response to a request that used the Basic scheme. Shōmei sends it on+-- every @invalid_client@, which is permitted and simpler than remembering how the client tried.+oauthError :: Status -> Text -> Text -> ServerError+oauthError status code description =+  ServerError+    { errHTTPCode = statusCode status,+      errReasonPhrase = Text.unpack (TE.decodeUtf8 (statusMessage status)),+      errBody =+        Aeson.encode (OAuthErrorResponse code description),+      errHeaders =+        [ ("Content-Type", "application/json"),+          ("Cache-Control", "no-store"),+          ("Pragma", "no-cache")+        ]+          <> [("WWW-Authenticate", "Basic realm=\"shomei\"") | statusCode status == 401]+    }++-- | The single answer to every client-authentication failure: an unknown @client_id@, a wrong+-- secret, a revoked account, an absent credential, and a malformed @Authorization@ header all+-- produce this exact response. Nothing about which one occurred reaches the caller.+invalidClient :: ServerError+invalidClient = oauthError status401 "invalid_client" "client authentication failed"++-- | OIDC UserInfo bearer authentication failure. Unlike client authentication at the token,+-- introspection, and revocation endpoints, this challenge names the Bearer scheme and uses the+-- RFC 6750 @invalid_token@ code.+invalidToken :: ServerError+invalidToken =+  (oauthError status401 "invalid_token" "the access token is missing or invalid")+    { errHeaders =+        [ ("Content-Type", "application/json"),+          ("Cache-Control", "no-store"),+          ("Pragma", "no-cache"),+          ("WWW-Authenticate", "Bearer realm=\"shomei\", error=\"invalid_token\"")+        ]+    }++-- | A missing UserInfo bearer credential. RFC 6750 §3 says the challenge should omit an+-- @error@ attribute when the request supplied no authentication information; the JSON body stays+-- the same protocol-owned @invalid_token@ response.+missingToken :: ServerError+missingToken =+  invalidToken+    { errHeaders =+        [ ("Content-Type", "application/json"),+          ("Cache-Control", "no-store"),+          ("Pragma", "no-cache"),+          ("WWW-Authenticate", "Bearer realm=\"shomei\"")+        ]+    }++-- | A missing or malformed request parameter; @what@ names it.+invalidRequest :: Text -> ServerError+invalidRequest what = oauthError status400 "invalid_request" what++unsupportedGrantType :: Text -> ServerError+unsupportedGrantType grant =+  oauthError status400 "unsupported_grant_type" ("unsupported grant_type: " <> grant)++-- ---------------------------------------------------------------------------+-- Client authentication+-- ---------------------------------------------------------------------------++data ClientAuth = ClientAuth+  { clientId :: !Text,+    clientSecret :: !Text+  }+  deriving stock (Generic, Eq, Show)++-- | Extract the client's credentials from an @Authorization: Basic …@ header (RFC 6749's+-- @client_secret_basic@) or, failing that, from @client_id@\/@client_secret@ body parameters+-- (@client_secret_post@).+--+-- The header wins when present, even if body parameters also appear: RFC 6749 §2.3.1 says a+-- client MUST NOT use more than one authentication method, and preferring the header means a+-- malformed header is reported rather than silently ignored in favor of a body parameter.+--+-- Every failure is 'invalidClient'. A caller learns only "authentication failed".+extractClientAuth :: Maybe Text -> Form -> Either ServerError ClientAuth+extractClientAuth mAuthHeader form =+  case mAuthHeader >>= stripBasic of+    Just encoded -> decodeBasic encoded+    Nothing+      -- An Authorization header that is present but not Basic (a Bearer token, say) is not a+      -- fallback to body parameters: the client chose a scheme, and it is not one we accept.+      | isJust mAuthHeader -> Left invalidClient+      | otherwise -> fromBody+  where+    stripBasic h =+      let (scheme, rest) = Text.breakOn " " (Text.strip h)+       in if Text.toLower scheme == "basic" then Just (Text.strip rest) else Nothing++    -- Any decoding failure — bad base64, non-UTF-8 bytes, no colon — is just "authentication+    -- failed". The client learns nothing about which.+    orInvalidClient :: Either e a -> Either ServerError a+    orInvalidClient = either (const (Left invalidClient)) Right++    decodeBasic encoded = do+      raw <- orInvalidClient (B64.decodeBase64Untyped (TE.encodeUtf8 encoded))+      -- RFC 6749 §2.3.1 form-encodes both values before joining them with a colon. Split the+      -- encoded bytes on the first separator, decode each form component, and only then decode+      -- UTF-8; a secret may itself contain an encoded colon.+      let (encodedCid, rest) = BS.break (== 58) raw+      if BS.null rest+        then Left invalidClient+        else do+          cid <- orInvalidClient (TE.decodeUtf8' (urlDecode True encodedCid))+          secret <- orInvalidClient (TE.decodeUtf8' (urlDecode True (BS.drop 1 rest)))+          pure ClientAuth {clientId = cid, clientSecret = secret}++    fromBody = case (lookupParam "client_id" form, lookupParam "client_secret" form) of+      (Just cid, Just secret) -> pure ClientAuth {clientId = cid, clientSecret = secret}+      _ -> Left invalidClient++-- ---------------------------------------------------------------------------+-- Parameters+-- ---------------------------------------------------------------------------++-- | Read a single-valued form parameter. A parameter that appears more than once, or not at+-- all, is 'Nothing' — 'lookupUnique' is what enforces the "exactly once" part.+lookupParam :: Text -> Form -> Maybe Text+lookupParam k form = either (const Nothing) Just (lookupUnique k form)++-- | Parse the OAuth2 @scope@ parameter: a space-delimited list (RFC 6749 §3.3).+--+-- 'Nothing' means the parameter was absent, which the @client_credentials@ workflow reads as+-- "grant everything this account is allowed". @Just Set.empty@ — the caller sent @scope=@ or+-- @scope=\"   \"@ — is a distinct, malformed request, and the workflow refuses it with+-- @invalid_scope@ rather than silently granting nothing.+parseScopeParam :: Form -> Maybe (Set Scope)+parseScopeParam form = fmap toScopes (lookupParam "scope" form)+  where+    toScopes = Set.fromList . map Scope . Text.words++-- ---------------------------------------------------------------------------+-- The success response+-- ---------------------------------------------------------------------------++-- | RFC 6749 §5.1's access-token response.+--+-- The JSON keys are the RFC's, which are snake_case and therefore not derivable from Haskell+-- field names: the instances below are hand-written and must stay in step with the @ToSchema@+-- in "Shomei.Servant.OpenApi".+--+-- @scope@ is always present, even when the client sent none: it tells the client exactly what it+-- was granted rather than making it infer the server's default.+data TokenResponse = TokenResponse+  { accessToken :: !Text,+    -- | always @"Bearer"@+    tokenType :: !Text,+    -- | lifetime in seconds+    expiresIn :: !Int,+    -- | space-delimited granted scopes+    scope :: !Text,+    -- | present for the @authorization_code@ and @refresh_token@ grants (EP-5), absent for+    --     @client_credentials@ — a machine credential dies at its TTL and asks again.+    refreshToken :: !(Maybe Text),+    -- | present exactly when the granted scopes include @openid@ (EP-5)+    idToken :: !(Maybe Text),+    -- | RFC 8693 §2.2.1: the issued token's type URN, required on a token-exchange response and+    --     absent on every other grant (EP-6). Shōmei's exchange always issues an access token, so+    --     it is @urn:ietf:params:oauth:token-type:access_token@ when present.+    issuedTokenType :: !(Maybe Text)+  }+  deriving stock (Generic, Eq, Show)++-- | Absent optional members are __omitted__, never @null@: RFC 6749 §5.1 says a parameter that+-- does not apply is not sent, and a client that sees @"refresh_token": null@ may well store the+-- string @"null"@.+instance Aeson.ToJSON TokenResponse where+  toJSON r =+    Aeson.object+      ( [ "access_token" Aeson..= r.accessToken,+          "token_type" Aeson..= r.tokenType,+          "expires_in" Aeson..= r.expiresIn,+          "scope" Aeson..= r.scope+        ]+          <> foldMap (\t -> ["refresh_token" Aeson..= t]) r.refreshToken+          <> foldMap (\t -> ["id_token" Aeson..= t]) r.idToken+          <> foldMap (\t -> ["issued_token_type" Aeson..= t]) r.issuedTokenType+      )++instance Aeson.FromJSON TokenResponse where+  parseJSON = Aeson.withObject "TokenResponse" \o ->+    TokenResponse+      <$> o Aeson..: "access_token"+      <*> o Aeson..: "token_type"+      <*> o Aeson..: "expires_in"+      <*> o Aeson..: "scope"+      <*> o Aeson..:? "refresh_token"+      <*> o Aeson..:? "id_token"+      <*> o Aeson..:? "issued_token_type"
+ src/Shomei/Servant/Oidc.hs view
@@ -0,0 +1,87 @@+-- | The OpenID Connect discovery document (EP-5), served at+-- @GET \/.well-known\/openid-configuration@.+--+-- This one document is the entire point of the OIDC surface: Envoy's JWT filter, oauth2-proxy,+-- Spring Security, ASP.NET Core, and every OIDC client library configure themselves from it, so+-- a deployment that publishes it is consumable with zero Shōmei-specific integration code.+--+-- __The issuer is the base URL.__ OIDC Core requires the document to live at+-- @{issuer}\/.well-known\/openid-configuration@ and ID tokens to carry @iss = issuer@, so every+-- endpoint URL below is derived from 'Shomei.Config.issuer' rather than from a second+-- "public base URL" field that could disagree with it. The standalone server refuses to boot with+-- @oidcEnabled@ set and an issuer that is not an absolute @http(s)@ URL+-- (see @Shomei.Server.Boot.validateOidcIssuer@).+module Shomei.Servant.Oidc+  ( discoveryDocument,+    oidcEndpointBase,+    isAbsoluteHttpUrl,+    supportedScopes,+  )+where++import Data.Aeson (Value)+import Data.Aeson qualified as Aeson+import Data.Text qualified as Text+import Shomei.Authorization.Claims.Domain (Issuer (..))+import Shomei.Config (ShomeiConfig (..), configSigningAlgorithm)+import Shomei.Prelude+import Shomei.SigningKey.Domain (signingAlgorithmToText)++-- | The issuer with any trailing slashes removed, so @issuer <> "\/oauth\/token"@ never yields a+-- doubled slash. OIDC compares @iss@ byte-for-byte, so the issuer itself is published verbatim in+-- the @issuer@ member — only the /derived/ endpoint URLs are built on this normalized base.+oidcEndpointBase :: ShomeiConfig -> Text+oidcEndpointBase cfg = Text.dropWhileEnd (== '/') (issuerText cfg.issuer)+  where+    issuerText (Issuer t) = t++-- | Does this text parse as an absolute @http@ or @https@ URL? The boot-time issuer check.+--+-- Deliberately a prefix test rather than a full URI parse: the failure it must catch is the+-- default issuer @"shomei"@ (an opaque name, not a URL), which would produce a discovery document+-- advertising @shomei\/oauth\/token@ as an endpoint.+isAbsoluteHttpUrl :: Text -> Bool+isAbsoluteHttpUrl t = any (`Text.isPrefixOf` t) ["http://", "https://"]++-- | The scopes the discovery document advertises.+--+-- @openid@ is what makes a request an OIDC request (it is what causes an ID token to be issued).+-- @profile@ and @email@ are the conventional OIDC claim bundles. @offline_access@ is accepted and+-- ignored: Shōmei's session model always pairs an access token with a refresh token, so there is+-- no variant to gate (recorded in the ExecPlan's Decision Log).+supportedScopes :: [Text]+supportedScopes = ["openid", "profile", "email", "offline_access"]++-- | Build the discovery document from configuration alone.+--+-- A pure function of 'ShomeiConfig', so it needs no store, no clock, and no 'Shomei.Servant.Seam.Env'+-- field: the handler evaluates it per request, which costs one small object encode. (The @jwks@+-- route precomputes /its/ document because that one is derived from mutable key material reloaded+-- at runtime; this one is not.)+--+-- Only the subset EP-5 actually implements is advertised. In particular @response_types_supported@+-- is @["code"]@ alone: the implicit and hybrid flows are excluded by the OAuth 2.0 Security BCP,+-- and advertising a flow the server does not implement is worse than advertising nothing —+-- stock middleware would negotiate it.+discoveryDocument :: ShomeiConfig -> Value+discoveryDocument cfg =+  Aeson.object+    [ "issuer" Aeson..= issuerText cfg.issuer,+      "authorization_endpoint" Aeson..= (base <> "/oauth/authorize"),+      "token_endpoint" Aeson..= (base <> "/oauth/token"),+      "userinfo_endpoint" Aeson..= (base <> "/oauth/userinfo"),+      "introspection_endpoint" Aeson..= (base <> "/oauth/introspect"),+      "revocation_endpoint" Aeson..= (base <> "/oauth/revoke"),+      "jwks_uri" Aeson..= (base <> "/.well-known/jwks.json"),+      "response_types_supported" Aeson..= (["code"] :: [Text]),+      "grant_types_supported" Aeson..= (["authorization_code", "refresh_token", "client_credentials", "urn:ietf:params:oauth:grant-type:token-exchange"] :: [Text]),+      "code_challenge_methods_supported" Aeson..= (["S256"] :: [Text]),+      "id_token_signing_alg_values_supported"+        Aeson..= either (const []) (pure . signingAlgorithmToText) (configSigningAlgorithm cfg),+      "subject_types_supported" Aeson..= (["public"] :: [Text]),+      "scopes_supported" Aeson..= supportedScopes,+      "token_endpoint_auth_methods_supported" Aeson..= (["client_secret_basic", "client_secret_post"] :: [Text])+    ]+  where+    base = oidcEndpointBase cfg+    issuerText (Issuer t) = t
+ src/Shomei/Servant/OpenApi.hs view
@@ -0,0 +1,549 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- \| The OpenAPI 3.1 description of 'Shomei.Servant.Api.ShomeiRoutes', derived+-- directly from the Servant types (EP-27).+--+-- 'shomeiOpenApi' is the complete, enriched document; the @shomei-openapi@+-- executable serialises it to @docs/api/openapi.json@. The instances below are+-- everything @toOpenApi (Proxy \@(NamedRoutes ShomeiRoutes))@ needs to typecheck:+-- a 'ToSchema' per DTO, a free-form 'ToSchema' for aeson 'Value', a hand-written+-- 'ToSchema' for the tagged-union 'LoginResponse', a 'ToParamSchema' for the+-- 'PasskeyId' capture, and 'HasOpenApi' instances for the custom combinators.++-- | All instances here are orphans by design: 'ToSchema'/'ToParamSchema' and+-- 'HasOpenApi' belong to @openapi-hs@/@servant-openapi-hs@, while the DTOs and the+-- custom combinators belong to Shōmei. Concentrating them in one module (rather+-- than scattering them across concept DTO modules, 'Shomei.Servant.Auth', and+-- 'Shomei.Servant.Authz') keeps the OpenAPI dependency contained and the spec+-- assembly easy to find. The orphans are only ever resolved at the 'toOpenApi'+-- call site inside this module (and its executable/test), so there is no+-- incoherence risk. See EP-27 Decision Log.+module Shomei.Servant.OpenApi+  ( shomeiOpenApi,+    openApiValue,+  )+where++import Control.Lens+import Data.Aeson (Value (String), toJSON)+import Data.Char (isAlphaNum, toUpper)+-- openapi-hs 5 vendors the insertion-ordered map it used to take from+-- insert-ordered-containers; the OpenAPI record fields are keyed by this type.+import Data.HashMap.Strict.InsOrd.Compat qualified as IOHM+import Data.Maybe (isNothing)+import Data.OpenApi (ToParamSchema (..), ToSchema (..))+import Data.OpenApi qualified as O+import Data.OpenApi.Declare (runDeclare)+import Data.Proxy (Proxy (..))+import Data.Text qualified as T+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Servant.API+import Servant.API.MultiVerb (DescHeader, OptHeader)+import Servant.OpenApi (HasOpenApi (..))+import Servant.OpenApi.Internal (IsSwaggerResponseList (..), ToResponseHeader (..))+import Shomei.Account.Dto+  ( ChangePasswordRequest,+    ConfirmEmailVerificationRequest,+    ConfirmPasswordResetRequest,+    PasswordResetRequest,+    SignupRequest,+    SignupResponse,+    VerifyEmailRequest,+  )+import Shomei.Account.User.Dto (AdminStatusFilter, AdminUserResponse, AdminUsersPage, UserPageCursor, UserResponse)+import Shomei.Audit.Dto+  ( AuditEventResponse,+    AuditEventsPage,+    AuditPageCursor,+    AuditSessionId,+    AuditTimestamp,+    AuditUserId,+  )+import Shomei.Id (PasskeyId, SessionId, UserId)+import Shomei.Mfa.Dto+  ( MfaCompleteRequest,+    MfaProof,+    RecoveryCodesCountResponse,+    RecoveryCodesResponse,+    TotpEnrollResponse,+    TotpRemoveRequest,+    TotpVerifyRequest,+  )+import Shomei.Passkey.Dto+  ( PasskeyLoginBeginResponse,+    PasskeyLoginCompleteRequest,+    PasskeyRegisterBeginResponse,+    PasskeyRegisterCompleteRequest,+    PasskeyResponse,+  )+import Shomei.Servant.Api (ShomeiRoutes)+import Shomei.Servant.Auth (Authenticated, OAuthAuthenticated)+import Shomei.Servant.Authz (RequireAdmin, RequirePermission, RequireRole, RequireScope)+import Shomei.Servant.OAuth (TokenResponse)+import Shomei.Servant.PreHandler (CsrfProtected, PreHandlerResponses, RateLimited)+import Shomei.Servant.Result+  ( AuthenticationPreHandlerResponses,+    AuthorizationPreHandlerResponses,+    CsrfPreHandlerResponses,+    RateLimitPreHandlerResponses,+  )+import Shomei.Session.Dto (LoginRequest, LoginResponse, RefreshRequest, SessionResponse, TokenPairResponse)+import Web.FormUrlEncoded (Form)++-- servant-openapi-hs 5.1 understands MultiVerb and WithHeaders, but its released header+-- renderer only recognizes Servant's plain 'Header'. Bridge MultiVerb's public descriptive and+-- optional header wrappers here so the exact served proxy remains the source of the document.+instance (KnownSymbol name, KnownSymbol description, ToParamSchema a) => ToResponseHeader (DescHeader name description a) where+  toResponseHeader _ =+    ( T.pack (symbolVal (Proxy @name)),+      mempty+        & O.description ?~ T.pack (symbolVal (Proxy @description))+        & O.schema ?~ O.Inline (toParamSchema (Proxy @a))+    )++instance (ToResponseHeader header) => ToResponseHeader (OptHeader header) where+  toResponseHeader _ = toResponseHeader (Proxy @header)++-- ---------------------------------------------------------------------------+-- ToSchema for every DTO+--+-- Each DTO derives @ToJSON@ with default options (no field-label modifier), so+-- the generic 'declareNamedSchema' default produces a schema that matches the+-- wire JSON. The M4 conformance test ('validateEveryToJSON') enforces this.+-- ---------------------------------------------------------------------------++instance ToSchema SignupRequest++instance ToSchema SignupResponse++instance ToSchema LoginRequest++instance ToSchema RefreshRequest++instance ToSchema VerifyEmailRequest++instance ToSchema ConfirmEmailVerificationRequest++instance ToSchema PasswordResetRequest++instance ToSchema ConfirmPasswordResetRequest++instance ToSchema ChangePasswordRequest++instance ToSchema TokenPairResponse++instance ToSchema UserResponse++instance ToSchema SessionResponse++instance ToSchema MfaCompleteRequest++instance ToSchema TotpEnrollResponse++instance ToSchema TotpVerifyRequest++instance ToSchema TotpRemoveRequest++instance ToSchema RecoveryCodesResponse++instance ToSchema RecoveryCodesCountResponse++instance ToSchema PasskeyRegisterBeginResponse++instance ToSchema PasskeyRegisterCompleteRequest++instance ToSchema PasskeyResponse++instance ToSchema PasskeyLoginBeginResponse++instance ToSchema PasskeyLoginCompleteRequest++instance ToSchema AuditEventResponse++instance ToSchema AuditEventsPage++instance ToSchema AdminUserResponse++instance ToSchema AdminUsersPage++-- | EP-4's @POST \/oauth\/token@ (RFC 6749 §5.1). The wire keys are the RFC's snake_case names,+-- which the hand-written 'Aeson.ToJSON' in "Shomei.Servant.OAuth" emits, so this schema is+-- hand-written to match rather than derived. The conformance suite's 'validateEveryToJSON'+-- checks the two agree.+instance ToSchema TokenResponse where+  declareNamedSchema _ =+    pure $+      O.NamedSchema (Just "TokenResponse") $+        mempty+          & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiObject+          & O.description ?~ "An OAuth2 access-token response (RFC 6749 §5.1)."+          & O.properties+            .~ IOHM.fromList+              [ ("access_token", O.Inline (stringSchema & O.description ?~ "The signed JWT access token.")),+                ("token_type", O.Inline (stringSchema & O.description ?~ "Always \"Bearer\".")),+                ("expires_in", O.Inline (mempty & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiInteger & O.description ?~ "Token lifetime in seconds.")),+                ("scope", O.Inline (stringSchema & O.description ?~ "The space-delimited scopes actually granted.")),+                ( "refresh_token",+                  O.Inline+                    ( stringSchema+                        & O.description+                          ?~ "The rotating opaque refresh token. Present for the authorization_code and \+                             \refresh_token grants; omitted for client_credentials, whose tokens are \+                             \deliberately refresh-less."+                    )+                ),+                ( "id_token",+                  O.Inline+                    ( stringSchema+                        & O.description+                          ?~ "The signed OIDC ID token. Present exactly when the granted scopes include \+                             \`openid`. Its `aud` is the client_id, not the API audience: it is a \+                             \statement to the client, never a bearer credential."+                    )+                ),+                ( "issued_token_type",+                  O.Inline+                    ( stringSchema+                        & O.description+                          ?~ "RFC 8693 §2.2.1: the issued token's type URN. Present only on a \+                             \token-exchange response, where it is always \+                             \`urn:ietf:params:oauth:token-type:access_token`; omitted on every \+                             \other grant."+                    )+                )+              ]+          -- The three optional members are omitted rather than null when they do not apply, so they+          -- are documented as not required.+          & O.required .~ ["access_token", "token_type", "expires_in", "scope"]++-- | The @application\/x-www-form-urlencoded@ request body of @POST \/oauth\/token@.+--+-- The endpoint takes a raw 'Form' rather than a typed record, because it is a @grant_type@+-- dispatcher whose parameter set differs per grant (see "Shomei.Servant.Api"). The schema is+-- therefore an open object of string values, with the parameters this deployment reads described+-- for a human reading the spec.+instance ToSchema Form where+  declareNamedSchema _ =+    pure $+      O.NamedSchema (Just "TokenRequestForm") $+        mempty+          & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiObject+          & O.description+            ?~ "An RFC 6749 token request. `grant_type` selects the flow; the remaining \+               \parameters depend on it. For `client_credentials`: an optional space-delimited \+               \`scope`, plus `client_id`/`client_secret` when the client authenticates with \+               \`client_secret_post` rather than an `Authorization: Basic` header."+          & O.properties+            .~ IOHM.fromList+              [ ( "grant_type",+                  O.Inline+                    ( stringSchema+                        & O.enum_+                          ?~ [ String "client_credentials",+                               String "authorization_code",+                               String "refresh_token",+                               String "urn:ietf:params:oauth:grant-type:token-exchange"+                             ]+                    )+                ),+                ("scope", O.Inline stringSchema),+                ("client_id", O.Inline stringSchema),+                ("client_secret", O.Inline stringSchema),+                ("subject_token", O.Inline stringSchema),+                ("subject_token_type", O.Inline stringSchema),+                ("actor_token", O.Inline stringSchema),+                ("actor_token_type", O.Inline stringSchema),+                ("requested_token_type", O.Inline stringSchema)+              ]+          & O.required .~ ["grant_type"]+          & O.additionalProperties ?~ O.AdditionalPropertiesAllowed True++-- | Free-form JSON. Several DTOs carry an aeson 'Value' (opaque WebAuthn/JWKS+-- payloads), and @openapi-hs@ ships no 'ToSchema' for it. @additionalProperties:+-- true@ makes the schema accept any JSON: non-object values are unconstrained,+-- and object values may carry any properties. (A bare empty schema is *not*+-- enough — @openapi-hs@'s validator rejects unmentioned object properties unless+-- @additionalProperties@ explicitly permits them.)+instance ToSchema Value where+  declareNamedSchema _ =+    pure $+      O.NamedSchema (Just "AnyValue") $+        mempty & O.additionalProperties ?~ O.AdditionalPropertiesAllowed True++-- | 'MfaProof' uses a hand-written discriminator and flat payload fields. Keep its schema+-- aligned with that exact representation rather than Generic's constructor encoding.+instance ToSchema MfaProof where+  declareNamedSchema _ = do+    assertionRef <- O.declareSchemaRef (Proxy :: Proxy Value)+    let stringProp = O.Inline stringSchema+        tagged tag payloadName payloadSchema =+          mempty+            & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiObject+            & O.properties+              .~ IOHM.fromList+                [ ("type", O.Inline (stringSchema & O.enum_ ?~ [String tag])),+                  (payloadName, payloadSchema)+                ]+            & O.required .~ ["type", payloadName]+            & O.additionalProperties ?~ O.AdditionalPropertiesAllowed False+        passkeyBranch = tagged "passkey" "assertion" assertionRef+        totpBranch = tagged "totp" "code" stringProp+        recoveryBranch = tagged "recovery_code" "code" stringProp+    pure $+      O.NamedSchema (Just "MfaProof") $+        mempty & O.oneOf ?~ map O.Inline [passkeyBranch, totpBranch, recoveryBranch]++-- | 'LoginResponse' has a hand-written, @status@-tagged 'ToJSON' (a completed+-- login vs. an MFA challenge), so its schema is hand-written to match: a @oneOf@+-- of the two flat object shapes. Generic derivation would not reproduce the+-- custom JSON. This must agree with 'Shomei.Session.Dto.LoginResponse''s+-- instances — the M4 conformance test checks it.+instance ToSchema LoginResponse where+  declareNamedSchema _ = do+    userRef <- O.declareSchemaRef (Proxy :: Proxy UserResponse)+    tokenRef <- O.declareSchemaRef (Proxy :: Proxy TokenPairResponse)+    optionsRef <- O.declareSchemaRef (Proxy :: Proxy Value)+    let stringProp = O.Inline (mempty & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiString)+        completeBranch =+          mempty+            & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiObject+            & O.properties+              .~ IOHM.fromList+                [ ("status", stringProp),+                  ("user", userRef),+                  ("token", tokenRef)+                ]+            & O.required .~ ["status", "user", "token"]+        stringArrayProp =+          O.Inline+            ( mempty+                & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiArray+                & O.items ?~ O.OpenApiItemsObject stringProp+            )+        mfaBranch =+          mempty+            & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiObject+            & O.properties+              .~ IOHM.fromList+                [ ("status", stringProp),+                  ("ceremonyId", stringProp),+                  ("options", optionsRef),+                  ("methods", stringArrayProp)+                ]+            & O.required .~ ["status", "ceremonyId", "options", "methods"]+    pure $+      O.NamedSchema (Just "LoginResponse") $+        mempty & O.oneOf ?~ [O.Inline completeBranch, O.Inline mfaBranch]++-- | Every Shōmei id is a @KindID@ (a UUIDv7 behind a type-level prefix); its wire/capture form+-- is the TypeID string, e.g. @user_01h455vb4pex5vsknk084sn02q@.+instance ToParamSchema PasskeyId where+  toParamSchema _ = mempty & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiString++instance ToParamSchema UserId where+  toParamSchema _ = mempty & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiString++instance ToParamSchema SessionId where+  toParamSchema _ = mempty & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiString++instance ToParamSchema AuditUserId where+  toParamSchema _ = stringSchema++instance ToParamSchema AuditSessionId where+  toParamSchema _ = stringSchema++instance ToParamSchema AuditTimestamp where+  toParamSchema _ = stringSchema & O.format ?~ "date-time"++instance ToParamSchema AuditPageCursor where+  toParamSchema _ = stringSchema++instance ToParamSchema AdminStatusFilter where+  toParamSchema _ = stringSchema & O.enum_ ?~ ["active", "suspended", "deleted"]++instance ToParamSchema UserPageCursor where+  toParamSchema _ = stringSchema++-- ---------------------------------------------------------------------------+-- HasOpenApi for the custom combinators (none ship in servant-openapi-hs)+-- ---------------------------------------------------------------------------++-- | Register an HTTP bearer-JWT+-- security scheme in @components@ and require it on every operation of the+-- sub-API.+instance (HasOpenApi sub) => HasOpenApi (Authenticated :> sub) where+  toOpenApi _ = addTypedResponses (Proxy @AuthenticationPreHandlerResponses) (requireBearer (Proxy :: Proxy sub))++-- The protocol result list already owns its OAuth-shaped 401. This combinator contributes only+-- the bearer security requirement, never an application Problem Details response.+instance (HasOpenApi sub) => HasOpenApi (OAuthAuthenticated :> sub) where+  toOpenApi _ = requireBearer (Proxy :: Proxy sub)++-- | 'RequireRole' and 'RequireScope' authenticate the caller themselves (they run the same+-- 'Shomei.Servant.Auth.authHandler' 'Authenticated' does) and then check a claim. To a client+-- reading the spec that is the same contract — present a bearer token — plus a 403 if the+-- token lacks the role or scope. So both describe themselves exactly as 'Authenticated' does.+--+-- These must not be transparent pass-throughs: an operation carrying only 'RequireRole' would+-- otherwise be documented as unauthenticated, and generated clients would omit the token.+instance (HasOpenApi sub) => HasOpenApi (RequireRole (r :: Symbol) :> sub) where+  toOpenApi _ = addTypedResponses (Proxy @AuthorizationPreHandlerResponses) (requireBearer (Proxy :: Proxy sub))++instance (HasOpenApi sub) => HasOpenApi (RequireScope (s :: Symbol) :> sub) where+  toOpenApi _ = addTypedResponses (Proxy @AuthorizationPreHandlerResponses) (requireBearer (Proxy :: Proxy sub))++instance (HasOpenApi sub) => HasOpenApi (RequirePermission (p :: Symbol) :> sub) where+  toOpenApi _ = addTypedResponses (Proxy @AuthorizationPreHandlerResponses) (requireBearer (Proxy :: Proxy sub))++instance (HasOpenApi sub) => HasOpenApi (RequireAdmin :> sub) where+  toOpenApi _ = addTypedResponses (Proxy @AuthorizationPreHandlerResponses) (requireBearer (Proxy :: Proxy sub))++instance (HasOpenApi sub, IsSwaggerResponseList '[JSON] responses) => HasOpenApi (PreHandlerResponses responses :> sub) where+  toOpenApi _ = addTypedResponses (Proxy @responses) (toOpenApi (Proxy :: Proxy sub))++instance (HasOpenApi sub) => HasOpenApi (CsrfProtected :> sub) where+  toOpenApi _ = addTypedResponses (Proxy @CsrfPreHandlerResponses) (toOpenApi (Proxy :: Proxy sub))++instance (HasOpenApi sub) => HasOpenApi (RateLimited :> sub) where+  toOpenApi _ = addTypedResponses (Proxy @RateLimitPreHandlerResponses) (toOpenApi (Proxy :: Proxy sub))++-- | Add the responses a combinator can produce before its sub-handler runs. Operation-owned+-- alternatives are left-biased when a status overlaps, while otherwise-missing statuses and the+-- declared Problem Details schema are supplied from servant-openapi-hs's MultiVerb machinery.+addTypedResponses :: forall responses. (IsSwaggerResponseList '[JSON] responses) => Proxy responses -> O.OpenApi -> O.OpenApi+addTypedResponses _ spec =+  spec+    & O.components . O.schemas <>~ schemaDefinitions+    & O.allOperations . O.responses . O.responses+      %~ (`IOHM.union` (O.Inline <$> typedResponses))+  where+    (schemaDefinitions, typedResponses) =+      runDeclare (responseListSwagger @_ @'[JSON] @responses) mempty++-- | Register the bearer-JWT security scheme and require it on every operation of @sub@.+requireBearer :: (HasOpenApi sub) => Proxy sub -> O.OpenApi+requireBearer p =+  toOpenApi p+    & O.components . O.securitySchemes+      <>~ O.SecurityDefinitions (IOHM.singleton "bearerAuth" bearerScheme)+    & O.allOperations . O.security+      %~ (O.SecurityRequirement (IOHM.singleton "bearerAuth" []) :)+  where+    bearerScheme =+      O.SecurityScheme+        (O.SecuritySchemeHttp (O.HttpSchemeBearer (Just "jwt")))+        (Just "JWT access token")++stringSchema :: O.Schema+stringSchema = mempty & O.type_ ?~ O.OpenApiTypeSingle O.OpenApiString++-- ---------------------------------------------------------------------------+-- Spec hygiene: the bits servant-openapi-hs cannot know+-- ---------------------------------------------------------------------------++-- | Three corrections servant-openapi-hs's generic derivation cannot make on its own.+--+-- (a) A @204@, and a @200@\/@202@ whose body is servant's 'NoContent', is generated with a+-- @content@ map holding one media type and no schema. On a @204@ that is /invalid/ OpenAPI;+-- everywhere else it is noise that makes a generated client expect a body. Both are dropped.+--+-- (b) @description@ is REQUIRED on a response object, and servant-openapi-hs leaves it @""@ for+-- every success response. Filled from the status.+--+-- (c) Every Shōmei request body is mandatory, but @requestBody.required@ defaults to @false@,+-- which tells a generated client the body may be omitted.+withSpecHygiene :: O.OpenApi -> O.OpenApi+withSpecHygiene =+  (O.allOperations . O.responses . O.responses %~ IOHM.mapWithKey fixResponse)+    . (O.allOperations . O.requestBody . _Just . O._Inline . O.required ?~ True)+  where+    fixResponse :: O.HttpStatusCode -> O.Referenced O.Response -> O.Referenced O.Response+    fixResponse code = over O._Inline (dropEmptyContent . fillDescription code)++    dropEmptyContent resp+      | all (isNothing . view O.schema) (IOHM.elems (resp ^. O.content)) = resp & O.content .~ mempty+      | otherwise = resp++    fillDescription code resp+      | T.null (resp ^. O.description) = resp & O.description .~ describeStatus code+      | otherwise = resp++    -- The catch-all renders the WIRE form of the key: 'O.HttpStatusCode' is a data type as of+    -- openapi-hs 4.1, so its 'show' would emit @StatusCode 500@ rather than @500@.+    describeStatus = \case+      200 -> "Success."+      201 -> "Created."+      202 -> "Accepted: the request was validated; delivery happens out of band."+      204 -> "Success; no response body."+      O.StatusCode n -> "Response " <> T.pack (show n) <> "."+      O.StatusRange r -> "Responses in the " <> rangeKey r <> " class."++    rangeKey = \case+      O.R1XX -> "1XX"+      O.R2XX -> "2XX"+      O.R3XX -> "3XX"+      O.R4XX -> "4XX"+      O.R5XX -> "5XX"++-- ---------------------------------------------------------------------------+-- The assembled, enriched document+-- ---------------------------------------------------------------------------++-- | The complete, enriched OpenAPI 3.1 document for the Shōmei auth service, generated from+-- @Proxy (NamedRoutes ShomeiRoutes)@ — the served tree, so the documented paths are the ones a+-- client calls: application routes under @\/v1@, JWKS and the probes at the root.+shomeiOpenApi :: O.OpenApi+shomeiOpenApi =+  toOpenApi (Proxy :: Proxy (NamedRoutes ShomeiRoutes))+    & O.info . O.title .~ "Shōmei Authentication API"+    & O.info . O.version .~ "0.1.0.0"+    & O.info . O.description+      ?~ "Authentication, session, passkey, MFA, delegation, and token API for the Shōmei auth service."+    & O.servers .~ [localServer]+    & withOperationIds+    & withSpecHygiene+  where+    localServer = ("http://localhost:8080" :: O.Server) & O.description ?~ "Local development server"++-- | 'shomeiOpenApi' as JSON, computed once per process. Served by @GET \/openapi.json@, so a+-- deployed instance describes the binary it is actually running rather than whatever+-- @docs\/api\/openapi.json@ was committed. The document includes @\/openapi.json@ itself.+openApiValue :: Value+openApiValue = toJSON shomeiOpenApi++-- | Assign a stable @operationId@ to every operation, derived from its HTTP+-- method and path (e.g. @GET \/v1\/auth\/me@ → @getAuthMe@). Operations clients+-- generate from these get readable method names. Mirrors the helper in+-- @servant-openapi-hs@'s reference generator.+withOperationIds :: O.OpenApi -> O.OpenApi+withOperationIds = O.paths %~ imap setForPath+  where+    setForPath path =+      (O.get . _Just . O.operationId %~ orSet ("get" <> key))+        . (O.post . _Just . O.operationId %~ orSet ("create" <> key))+        . (O.put . _Just . O.operationId %~ orSet ("update" <> key))+        . (O.delete . _Just . O.operationId %~ orSet ("delete" <> key))+      where+        key = camel path+    orSet v = Just . maybe v id++-- | Turn a path like @"\/v1\/auth\/passkeys\/{passkeyId}"@ into @"AuthPasskeysPasskeyId"@.+--+-- The version segment is dropped: an @operationId@ names /what the operation does/, and+-- generated clients turn it into a method name. Folding @v1@ in would rename every method the+-- day the routes moved under @\/v1@, and rename them all again at @\/v2@ — churn that says+-- nothing about the operation. The path in @paths@ still carries the version, which is where a+-- client reads it from.+camel :: FilePath -> T.Text+camel = T.pack . concatMap capitalize . dropVersion . words . map keepAlnum+  where+    keepAlnum c = if isAlphaNum c then c else ' '+    capitalize [] = []+    capitalize (c : cs) = toUpper c : cs+    dropVersion ("v1" : rest) = rest+    dropVersion segments = segments
+ src/Shomei/Servant/PreHandler.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE StandaloneKindSignatures #-}++-- | Type-level markers for failures selected before an operation handler runs.+--+-- These combinators are runtime pass-throughs. Their response-list parameter or policy name is+-- consumed by OpenAPI derivation and conformance tests, while authentication, JSON/query/capture+-- decoding, CSRF enforcement, and rate limiting remain owned by their existing Servant or WAI+-- boundaries.+module Shomei.Servant.PreHandler+  ( PreHandlerResponses,+    CsrfProtected,+    RateLimited,+  )+where++import Data.Kind (Type)+import Servant (type (:>))+import Servant.Server.Internal (HasServer (..))+import Shomei.Prelude++type PreHandlerResponses :: [Type] -> Type+data PreHandlerResponses responses++type CsrfProtected :: Type+data CsrfProtected++type RateLimited :: Type+data RateLimited++instance (HasServer api ctx) => HasServer (PreHandlerResponses responses :> api) ctx where+  type ServerT (PreHandlerResponses responses :> api) m = ServerT api m+  route _ = route (Proxy :: Proxy api)+  hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)++instance (HasServer api ctx) => HasServer (CsrfProtected :> api) ctx where+  type ServerT (CsrfProtected :> api) m = ServerT api m+  route _ = route (Proxy :: Proxy api)+  hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)++instance (HasServer api ctx) => HasServer (RateLimited :> api) ctx where+  type ServerT (RateLimited :> api) m = ServerT api m+  route _ = route (Proxy :: Proxy api)+  hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)
+ src/Shomei/Servant/RemoteHost.hs view
@@ -0,0 +1,5 @@+-- | Compatibility re-export for hosts written before canonical client-IP rendering moved+-- to "Shomei.Servant.ClientIp".+module Shomei.Servant.RemoteHost (clientIpText) where++import Shomei.Servant.ClientIp (clientIpText)
+ src/Shomei/Servant/Result.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The shared typed response vocabulary for application routes.+--+-- Protocol APIs (OAuth and health) intentionally define their own response sums. Every ordinary+-- Shōmei application operation uses the fixed error tail below, so a new 'AuthError' remains a+-- total transport mapping and store unavailability is visible as an operation-owned 503.+module Shomei.Servant.Result+  ( AuthenticationPreHandlerResponses,+    AuthorizationPreHandlerResponses,+    BadRequestPreHandlerResponses,+    CsrfPreHandlerResponses,+    RateLimitPreHandlerResponses,+    ApplicationErrorResponses,+    ApplicationContentTypes,+    ApplicationResponses,+    ApplicationEmptyResponses,+    ApplicationCookieResponses,+    ApplicationCookieEmptyResponses,+    ApplicationResult (..),+    CookieHeaders,+    CookieResponse (..),+    WwwAuthenticateHeaders,+    ProblemWithAuthenticate (..),+    RetryAfterHeaders,+    ProblemWithRetryAfter (..),+    cookieResponse,+    applicationError,+    problemResult,+    fromPortResult,+    mapApplicationResult,+  )+where++import Data.ByteString (ByteString)+import Data.Foldable (toList)+import Data.SOP (I (..), NP (..), NS (..))+import Data.Sequence (Seq)+import Network.HTTP.Types qualified as HTTP+import Numeric.Natural (Natural)+import Servant (JSON, ServerError (..))+import Servant.API.MultiVerb+  ( AsHeaders (..),+    AsUnion (..),+    DescHeader,+    OptHeader,+    RespondAs,+    RespondEmpty,+    ServantHeaders (..),+    WithHeaders,+  )+import Shomei.Config (ShomeiConfig (..), transportUsesCookies)+import Shomei.Error (AuthError)+import Shomei.Prelude+import Shomei.Servant.Cookie (CookiePair (..))+import Shomei.Servant.Error+  ( ProblemDetails,+    ProblemJSON,+    ProblemOccurrence (..),+    ProblemSpec (..),+    authErrorProblem,+    problemDetails,+  )+import Web.HttpApiData (FromHttpApiData (parseHeader), ToHttpApiData (toHeader))++type WwwAuthenticateHeaders =+  '[OptHeader (DescHeader "WWW-Authenticate" "Bearer authentication challenge" Text)]++data ProblemWithAuthenticate = ProblemWithAuthenticate+  { authenticateProblem :: !ProblemDetails,+    authenticateHeader :: !(Maybe Text)+  }+  deriving stock (Eq, Show, Generic)++instance AsHeaders '[Maybe Text] ProblemDetails ProblemWithAuthenticate where+  toHeaders response = (I response.authenticateHeader :* Nil, response.authenticateProblem)+  fromHeaders (I authenticateHeader :* Nil, authenticateProblem) = ProblemWithAuthenticate {authenticateProblem, authenticateHeader}++instance {-# OVERLAPPING #-} ServantHeaders WwwAuthenticateHeaders '[Maybe Text] where+  constructHeaders (I authenticateHeader :* Nil) = optionalHeader "WWW-Authenticate" authenticateHeader+  extractHeaders headers = (\value -> I value :* Nil) <$> extractOptionalHeader "WWW-Authenticate" headers++type RetryAfterHeaders =+  '[OptHeader (DescHeader "Retry-After" "Seconds until the request may be retried" Natural)]++data ProblemWithRetryAfter = ProblemWithRetryAfter+  { retryProblem :: !ProblemDetails,+    retryAfterHeader :: !(Maybe Natural)+  }+  deriving stock (Eq, Show, Generic)++instance AsHeaders '[Maybe Natural] ProblemDetails ProblemWithRetryAfter where+  toHeaders response = (I response.retryAfterHeader :* Nil, response.retryProblem)+  fromHeaders (I retryAfterHeader :* Nil, retryProblem) = ProblemWithRetryAfter {retryProblem, retryAfterHeader}++instance {-# OVERLAPPING #-} ServantHeaders RetryAfterHeaders '[Maybe Natural] where+  constructHeaders (I retryAfterHeader :* Nil) = optionalHeader "Retry-After" retryAfterHeader+  extractHeaders headers = (\value -> I value :* Nil) <$> extractOptionalHeader "Retry-After" headers++type CookieHeaders =+  '[ OptHeader (DescHeader "Set-Cookie" "Session cookie" Text),+     OptHeader (DescHeader "Set-Cookie" "Refresh cookie" Text)+   ]++data CookieResponse a = CookieResponse+  { cookieBody :: !a,+    sessionCookieHeader :: !(Maybe Text),+    refreshCookieHeader :: !(Maybe Text)+  }+  deriving stock (Eq, Show, Generic, Functor)++instance AsHeaders '[Maybe Text, Maybe Text] a (CookieResponse a) where+  toHeaders response =+    ( I response.sessionCookieHeader :* I response.refreshCookieHeader :* Nil,+      response.cookieBody+    )+  fromHeaders (I sessionCookieHeader :* I refreshCookieHeader :* Nil, cookieBody) =+    CookieResponse {cookieBody, sessionCookieHeader, refreshCookieHeader}++-- servant 0.20.3's generic decoder requires every header to be present and partitions all+-- duplicate names into the first field. Shōmei's cookie response deliberately has two optional+-- Set-Cookie fields, so its client decoder must preserve absence and assign duplicates in order.+instance {-# OVERLAPPING #-} ServantHeaders CookieHeaders '[Maybe Text, Maybe Text] where+  constructHeaders (I sessionCookieHeader :* I refreshCookieHeader :* Nil) =+    optionalHeader "Set-Cookie" sessionCookieHeader+      <> optionalHeader "Set-Cookie" refreshCookieHeader+  extractHeaders headers = do+    values <- traverse decodeHeader (matchingHeaderValues "Set-Cookie" headers)+    case values of+      [] -> pure (I Nothing :* I Nothing :* Nil)+      [sessionCookieHeader] -> pure (I (Just sessionCookieHeader) :* I Nothing :* Nil)+      [sessionCookieHeader, refreshCookieHeader] ->+        pure (I (Just sessionCookieHeader) :* I (Just refreshCookieHeader) :* Nil)+      _ -> Nothing++optionalHeader :: (ToHttpApiData a) => HTTP.HeaderName -> Maybe a -> [HTTP.Header]+optionalHeader name = maybe [] (\value -> [(name, toHeader value)])++extractOptionalHeader :: (FromHttpApiData a) => HTTP.HeaderName -> Seq HTTP.Header -> Maybe (Maybe a)+extractOptionalHeader name headers = case matchingHeaderValues name headers of+  [] -> Just Nothing+  [value] -> Just <$> decodeHeader value+  _ -> Nothing++matchingHeaderValues :: HTTP.HeaderName -> Seq HTTP.Header -> [ByteString]+matchingHeaderValues name = map snd . filter ((== name) . fst) . toList++decodeHeader :: (FromHttpApiData a) => ByteString -> Maybe a+decodeHeader = either (const Nothing) Just . parseHeader++cookieResponse :: ShomeiConfig -> CookiePair -> a -> CookieResponse a+cookieResponse config cookies cookieBody+  | transportUsesCookies config.tokenTransport =+      CookieResponse+        { cookieBody,+          sessionCookieHeader = Just cookies.sessionCookie,+          refreshCookieHeader = Just cookies.refreshCookie+        }+  | otherwise = CookieResponse {cookieBody, sessionCookieHeader = Nothing, refreshCookieHeader = Nothing}++-- These small response lists are shared by the enforcing/pass-through combinators' OpenAPI+-- instances. Keeping them beside 'ApplicationErrorResponses' makes the pre-handler contract use+-- exactly the same media type, body, headers, and descriptions as the handler-owned result sum.+type AuthenticationPreHandlerResponses =+  '[ WithHeaders+       WwwAuthenticateHeaders+       ProblemWithAuthenticate+       (RespondAs ProblemJSON 401 "Authentication failed" ProblemDetails)+   ]++type AuthorizationPreHandlerResponses =+  '[ WithHeaders+       WwwAuthenticateHeaders+       ProblemWithAuthenticate+       (RespondAs ProblemJSON 401 "Authentication failed" ProblemDetails),+     RespondAs ProblemJSON 403 "Forbidden" ProblemDetails+   ]++type BadRequestPreHandlerResponses =+  '[RespondAs ProblemJSON 400 "Bad request" ProblemDetails]++type CsrfPreHandlerResponses =+  '[RespondAs ProblemJSON 403 "Forbidden" ProblemDetails]++type RateLimitPreHandlerResponses =+  '[ WithHeaders+       RetryAfterHeaders+       ProblemWithRetryAfter+       (RespondAs ProblemJSON 429 "Too many requests" ProblemDetails)+   ]++type ApplicationErrorResponses =+  '[ RespondAs ProblemJSON 400 "Bad request" ProblemDetails,+     WithHeaders+       WwwAuthenticateHeaders+       ProblemWithAuthenticate+       (RespondAs ProblemJSON 401 "Authentication failed" ProblemDetails),+     RespondAs ProblemJSON 403 "Forbidden" ProblemDetails,+     RespondAs ProblemJSON 404 "Not found" ProblemDetails,+     RespondAs ProblemJSON 409 "Conflict" ProblemDetails,+     RespondAs ProblemJSON 422 "Unprocessable content" ProblemDetails,+     WithHeaders+       RetryAfterHeaders+       ProblemWithRetryAfter+       (RespondAs ProblemJSON 429 "Too many requests" ProblemDetails),+     RespondAs ProblemJSON 500 "Internal server error" ProblemDetails,+     WithHeaders+       RetryAfterHeaders+       ProblemWithRetryAfter+       (RespondAs ProblemJSON 503 "Required dependency unavailable" ProblemDetails)+   ]++-- Both media types must be in the terminal content list: servant-client validates the response+-- Content-Type against this list before dispatching to a 'RespondAs' alternative.+type ApplicationContentTypes = '[JSON, ProblemJSON]++type ApplicationResponses status description body =+  RespondAs JSON status description body ': ApplicationErrorResponses++type ApplicationEmptyResponses status description =+  RespondEmpty status description ': ApplicationErrorResponses++type ApplicationCookieResponses status description body =+  WithHeaders CookieHeaders (CookieResponse body) (RespondAs JSON status description body)+    ': ApplicationErrorResponses++type ApplicationCookieEmptyResponses status description =+  WithHeaders CookieHeaders (CookieResponse ()) (RespondEmpty status description)+    ': ApplicationErrorResponses++data ApplicationResult a+  = ApplicationSuccess !a+  | ApplicationBadRequest !ProblemDetails+  | ApplicationAuthenticationFailed !ProblemWithAuthenticate+  | ApplicationForbidden !ProblemDetails+  | ApplicationNotFound !ProblemDetails+  | ApplicationConflict !ProblemDetails+  | ApplicationUnprocessable !ProblemDetails+  | ApplicationRateLimited !ProblemWithRetryAfter+  | ApplicationInternal !ProblemDetails+  | ApplicationUnavailable !ProblemWithRetryAfter+  deriving stock (Eq, Show, Generic, Functor)++-- | Load-bearing constructor-to-status mapping. It is intentionally written out: most error+-- arms have the same body type, so a generic derivation would make their order too easy to swap.+instance AsUnion (RespondAs JSON status description a ': ApplicationErrorResponses) (ApplicationResult a) where+  toUnion = \case+    ApplicationSuccess value -> Z (I value)+    ApplicationBadRequest value -> S (Z (I value))+    ApplicationAuthenticationFailed value -> S (S (Z (I value)))+    ApplicationForbidden value -> S (S (S (Z (I value))))+    ApplicationNotFound value -> S (S (S (S (Z (I value)))))+    ApplicationConflict value -> S (S (S (S (S (Z (I value))))))+    ApplicationUnprocessable value -> S (S (S (S (S (S (Z (I value)))))))+    ApplicationRateLimited value -> S (S (S (S (S (S (S (Z (I value))))))))+    ApplicationInternal value -> S (S (S (S (S (S (S (S (Z (I value)))))))))+    ApplicationUnavailable value -> S (S (S (S (S (S (S (S (S (Z (I value))))))))))++  fromUnion = \case+    Z (I value) -> ApplicationSuccess value+    S (Z (I value)) -> ApplicationBadRequest value+    S (S (Z (I value))) -> ApplicationAuthenticationFailed value+    S (S (S (Z (I value)))) -> ApplicationForbidden value+    S (S (S (S (Z (I value))))) -> ApplicationNotFound value+    S (S (S (S (S (Z (I value)))))) -> ApplicationConflict value+    S (S (S (S (S (S (Z (I value))))))) -> ApplicationUnprocessable value+    S (S (S (S (S (S (S (Z (I value)))))))) -> ApplicationRateLimited value+    S (S (S (S (S (S (S (S (Z (I value))))))))) -> ApplicationInternal value+    S (S (S (S (S (S (S (S (S (Z (I value)))))))))) -> ApplicationUnavailable value+    S (S (S (S (S (S (S (S (S (S (impossible)))))))))) -> absurdNS impossible++-- Empty and cookie successes have different MultiVerb response return types, while retaining+-- exactly the same fixed error-tail mapping.+instance AsUnion (RespondEmpty status description ': ApplicationErrorResponses) (ApplicationResult ()) where+  toUnion = applicationToUnion+  fromUnion = applicationFromUnion++instance AsUnion (WithHeaders CookieHeaders (CookieResponse a) response ': ApplicationErrorResponses) (ApplicationResult (CookieResponse a)) where+  toUnion = applicationToUnion+  fromUnion = applicationFromUnion++applicationToUnion :: ApplicationResult a -> NS I (a ': '[ProblemDetails, ProblemWithAuthenticate, ProblemDetails, ProblemDetails, ProblemDetails, ProblemDetails, ProblemWithRetryAfter, ProblemDetails, ProblemWithRetryAfter])+applicationToUnion = \case+  ApplicationSuccess value -> Z (I value)+  ApplicationBadRequest value -> S (Z (I value))+  ApplicationAuthenticationFailed value -> S (S (Z (I value)))+  ApplicationForbidden value -> S (S (S (Z (I value))))+  ApplicationNotFound value -> S (S (S (S (Z (I value)))))+  ApplicationConflict value -> S (S (S (S (S (Z (I value))))))+  ApplicationUnprocessable value -> S (S (S (S (S (S (Z (I value)))))))+  ApplicationRateLimited value -> S (S (S (S (S (S (S (Z (I value))))))))+  ApplicationInternal value -> S (S (S (S (S (S (S (S (Z (I value)))))))))+  ApplicationUnavailable value -> S (S (S (S (S (S (S (S (S (Z (I value))))))))))++applicationFromUnion :: NS I (a ': '[ProblemDetails, ProblemWithAuthenticate, ProblemDetails, ProblemDetails, ProblemDetails, ProblemDetails, ProblemWithRetryAfter, ProblemDetails, ProblemWithRetryAfter]) -> ApplicationResult a+applicationFromUnion = \case+  Z (I value) -> ApplicationSuccess value+  S (Z (I value)) -> ApplicationBadRequest value+  S (S (Z (I value))) -> ApplicationAuthenticationFailed value+  S (S (S (Z (I value)))) -> ApplicationForbidden value+  S (S (S (S (Z (I value))))) -> ApplicationNotFound value+  S (S (S (S (S (Z (I value)))))) -> ApplicationConflict value+  S (S (S (S (S (S (Z (I value))))))) -> ApplicationUnprocessable value+  S (S (S (S (S (S (S (Z (I value)))))))) -> ApplicationRateLimited value+  S (S (S (S (S (S (S (S (Z (I value))))))))) -> ApplicationInternal value+  S (S (S (S (S (S (S (S (S (Z (I value)))))))))) -> ApplicationUnavailable value+  S (S (S (S (S (S (S (S (S (S (impossible)))))))))) -> absurdNS impossible++absurdNS :: NS I '[] -> a+absurdNS = \case {}++applicationError :: AuthError -> ApplicationResult a+applicationError err = uncurry problemResult (authErrorProblem err)++fromPortResult :: Either AuthError a -> ApplicationResult a+fromPortResult = either applicationError ApplicationSuccess++problemResult :: ProblemSpec -> ProblemOccurrence -> ApplicationResult a+problemResult spec occurrence =+  case spec.problemStatus.errHTTPCode of+    400 -> ApplicationBadRequest body+    401 -> ApplicationAuthenticationFailed (ProblemWithAuthenticate body occurrence.wwwAuthenticate)+    403 -> ApplicationForbidden body+    404 -> ApplicationNotFound body+    409 -> ApplicationConflict body+    422 -> ApplicationUnprocessable body+    429 -> ApplicationRateLimited (ProblemWithRetryAfter body occurrence.retryAfterSeconds)+    503 -> ApplicationUnavailable (ProblemWithRetryAfter body occurrence.retryAfterSeconds)+    _ -> ApplicationInternal body+  where+    body = problemDetails spec occurrence++mapApplicationResult :: (a -> b) -> ApplicationResult a -> ApplicationResult b+mapApplicationResult f = \case+  ApplicationSuccess value -> ApplicationSuccess (f value)+  ApplicationBadRequest value -> ApplicationBadRequest value+  ApplicationAuthenticationFailed value -> ApplicationAuthenticationFailed value+  ApplicationForbidden value -> ApplicationForbidden value+  ApplicationNotFound value -> ApplicationNotFound value+  ApplicationConflict value -> ApplicationConflict value+  ApplicationUnprocessable value -> ApplicationUnprocessable value+  ApplicationRateLimited value -> ApplicationRateLimited value+  ApplicationInternal value -> ApplicationInternal value+  ApplicationUnavailable value -> ApplicationUnavailable value
+ src/Shomei/Servant/Seam.hs view
@@ -0,0 +1,131 @@+-- | The seam between the @effectful@ port stack and servant's 'Handler' (style A,+-- per-action — mirroring kizashi's @Kizashi.Http.Seam.effToHandler@).+--+-- 'AppEffects' is the canonical Shōmei port stack: the fixed, ordered effect list that+-- every interpreter assembly (the in-memory test stack here, the PostgreSQL + JWT stack+-- in EP-6) must provide a runner for. 'Env' carries that runner ('runPorts'), the+-- 'ShomeiConfig' and the precomputed public JWKS document for the @jwks@ route.+-- 'verifyRequestToken' derives HTTP authentication from that runner and configuration, so+-- @sessionCheckMode = VerifyTokenAndSession@ cannot be bypassed by assembly wiring. The two+-- result runners preserve typed failures for route-local response mapping.+module Shomei.Servant.Seam+  ( AppEffects,+    Env (..),+    verifyRequestToken,+    runPortResult,+    runWorkflowResult,+  )+where++import Data.Aeson (Value)+import Effectful (Eff, IOE)+import Servant (Handler)+import Shomei.Account.Credential.Store (CredentialStore)+import Shomei.Account.Notification.Store (Notifier)+import Shomei.Account.Password.Breach.Store (PasswordBreachChecker)+import Shomei.Account.Password.Hash.Store (PasswordHasher)+import Shomei.Account.PasswordReset.Store (PasswordResetTokenStore)+import Shomei.Account.User.Store (UserStore)+import Shomei.Account.Verification.Store (VerificationTokenStore)+import Shomei.Audit.Publisher.Store (AuthEventPublisher)+import Shomei.Audit.Reader.Store (AuthEventReader)+import Shomei.Authorization.Claims.Domain (AuthClaims)+import Shomei.Authorization.Claims.Store (ClaimsEnricher)+import Shomei.Authorization.Role.Store (RoleStore)+import Shomei.Config (ShomeiConfig)+import Shomei.Error (AuthError)+import Shomei.Mfa.RecoveryCode.Store (RecoveryCodeStore)+import Shomei.Mfa.Totp.Store (TotpCredentialStore)+import Shomei.OAuth.AuthorizationCode.Store (OAuthCodeStore)+import Shomei.OAuth.Client.Store (OAuthClientStore)+import Shomei.Passkey.Ceremony.Port (WebAuthnCeremony)+import Shomei.Passkey.Ceremony.Store (PendingCeremonyStore)+import Shomei.Passkey.Store (PasskeyStore)+import Shomei.Prelude+import Shomei.ServiceAccount.Store (ServiceAccountStore)+import Shomei.Session.Authentication.Workflow qualified as Wf+import Shomei.Session.LoginAttempt.Domain (AccountKey)+import Shomei.Session.LoginAttempt.Store (LoginAttemptStore)+import Shomei.Session.RefreshToken.Store (RefreshTokenStore)+import Shomei.Session.Store (SessionStore)+import Shomei.Session.Token.Domain (AccessToken (..))+import Shomei.Session.Token.Generator (TokenGen)+import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork)+import Shomei.SigningKey.Signer (TokenSigner)+import Shomei.SigningKey.Store (SigningKeyStore)+import Shomei.SigningKey.Verifier (TokenVerifier)+import Shomei.Time.Store (Clock)++-- | The canonical, ordered Shōmei port stack. Its order matches EP-2's+-- @Shomei.Test.InMemory.runInMemory@ so the same workflows run unchanged over the+-- in-memory and the real (EP-6) interpreter assemblies.+type AppEffects =+  '[ UserStore,+     RoleStore,+     CredentialStore,+     SessionStore,+     RefreshTokenStore,+     AuthUnitOfWork,+     VerificationTokenStore,+     PasswordResetTokenStore,+     LoginAttemptStore,+     PasskeyStore,+     PendingCeremonyStore,+     ServiceAccountStore,+     OAuthClientStore,+     OAuthCodeStore,+     TotpCredentialStore,+     RecoveryCodeStore,+     Notifier,+     ClaimsEnricher,+     WebAuthnCeremony,+     PasswordBreachChecker,+     PasswordHasher,+     TokenSigner,+     TokenVerifier,+     AuthEventPublisher,+     AuthEventReader,+     SigningKeyStore,+     Clock,+     TokenGen,+     IOE+   ]++-- | The runtime environment threaded to every handler.+data Env = Env+  { -- | the port-interpreter runner (in-memory in tests; postgres+jwt in EP-6)+    runPorts :: !(forall a. Eff AppEffects a -> IO (Either AuthError a)),+    config :: !ShomeiConfig,+    -- | the precomputed public JWKS document served at @\/.well-known\/jwks.json@. An+    --     'IO' getter rather than a 'Value' because the standalone server swaps its key+    --     material on rotation (a 'readIORef'); tests pass @pure@ of a static document.+    --     The document stays precomputed either way — no per-request re-encoding.+    jwksJson :: !(IO Value),+    -- | derive the abuse store's hashed account key from the principal's login-id text (SH-25:+    --     the abuse key tracks the login identifier you actually authenticate with, not the email).+    --     The server supplies a SHA-256 hash; tests may supply a trivial mapping.+    accountKeyOf :: !(Text -> AccountKey)+  }++-- | Verify a presented access token the way the seam's configuration says to.+--+-- This is the only way Shōmei's HTTP layer verifies a token, and it is derived rather than+-- supplied: 'runPorts' already interprets 'TokenVerifier', 'SessionStore' and 'Clock', which is+-- exactly what 'Shomei.Session.Authentication.Workflow.verifyToken' needs. The session check requested by+-- @sessionCheckMode = VerifyTokenAndSession@ therefore runs against the same stores the login and+-- refresh workflows write to.+--+-- Under the default @VerifyTokenOnly@ the workflow returns after the JWT check and issues no+-- query. Under @VerifyTokenAndSession@ it performs one session lookup per authenticated request.+verifyRequestToken :: Env -> Text -> IO (Either AuthError AuthClaims)+verifyRequestToken env raw = do+  result <- runPorts env (Wf.verifyToken (config env) (AccessToken raw))+  pure (result >>= id)++-- | Run a plain port action without rendering or throwing its typed error.+runPortResult :: Env -> Eff AppEffects a -> Handler (Either AuthError a)+runPortResult env action = liftIO (runPorts env action)++-- | Run a workflow and flatten interpreter and workflow failures without choosing HTTP.+runWorkflowResult :: Env -> Eff AppEffects (Either AuthError a) -> Handler (Either AuthError a)+runWorkflowResult env action = fmap (>>= id) (liftIO (runPorts env action))
+ src/Shomei/Servant/Server.hs view
@@ -0,0 +1,44 @@+-- | Thin composition root for the exact server tree.+module Shomei.Servant.Server+  ( shomeiRoutes,+    applicationServer,+  )+where++import Servant (Handler)+import Servant.Health (ProbeCheck, healthServer)+import Servant.Server.Generic (AsServerT)+import Shomei.Account.Handler (accountServer, adminAccountServer)+import Shomei.Audit.Handler (auditServer)+import Shomei.Authorization.Handler (authorizationServer)+import Shomei.Mfa.Handler (mfaServer)+import Shomei.OAuth.Handler (oauthServer)+import Shomei.Passkey.Handler (passkeyServer)+import Shomei.Servant.Api (ApplicationApi (..), ShomeiRoutes (..))+import Shomei.Servant.OpenApi (openApiValue)+import Shomei.Servant.Seam (Env)+import Shomei.Session.Handler (adminSessionServer, sessionServer)+import Shomei.SigningKey.Handler (wellKnownServer)++shomeiRoutes :: Env -> ProbeCheck -> ProbeCheck -> ShomeiRoutes (AsServerT Handler)+shomeiRoutes env liveness readiness =+  ShomeiRoutes+    { application = applicationServer env,+      oauth = oauthServer env,+      wellKnown = wellKnownServer env,+      health = healthServer liveness readiness,+      openapi = pure openApiValue+    }++applicationServer :: Env -> ApplicationApi (AsServerT Handler)+applicationServer env =+  ApplicationApi+    { account = accountServer env,+      session = sessionServer env,+      passkey = passkeyServer env,+      mfa = mfaServer env,+      adminAccount = adminAccountServer env,+      adminSession = adminSessionServer env,+      authorization = authorizationServer env,+      audit = auditServer env+    }
+ src/Shomei/Servant/Throttle.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Derive the rate-limited HTTP operation set from the same 'RateLimited' markers that annotate+-- the Servant API. The standalone WAI middleware consumes this value, so route declarations are+-- the single source of truth for both OpenAPI's 429 responses and runtime throttling.+module Shomei.Servant.Throttle+  ( PathSegment (..),+    ThrottledRoute (..),+    HasThrottledRoutes (..),+    throttledRoutesOf,+    matchesThrottledRoute,+  )+where++import Data.Text qualified as Text+import GHC.Generics (K1, M1, Rep, (:*:))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Network.HTTP.Types (Method)+import Servant.API+import Servant.API.MultiVerb (MultiVerb)+import Shomei.Prelude+import Shomei.Servant.Auth (Authenticated, OAuthAuthenticated)+import Shomei.Servant.Authz (RequireAdmin, RequirePermission, RequireRole, RequireScope)+import Shomei.Servant.PreHandler (CsrfProtected, PreHandlerResponses, RateLimited)++data PathSegment+  = Literal !Text+  | Wildcard+  deriving stock (Eq, Ord, Show)++data ThrottledRoute = ThrottledRoute+  { method :: !Method,+    path :: ![PathSegment]+  }+  deriving stock (Eq, Ord, Show)++class HasThrottledRoutes api where+  -- | Every operation below @api@ paired with whether a 'RateLimited' marker guards it.+  allRoutes :: Proxy api -> [(Bool, ThrottledRoute)]++throttledRoutesOf :: forall api. (HasThrottledRoutes api) => Proxy api -> [ThrottledRoute]+throttledRoutesOf proxy = [route | (True, route) <- allRoutes proxy]++matchesThrottledRoute :: [ThrottledRoute] -> Method -> [Text] -> Bool+matchesThrottledRoute routes requestMethod requestPath =+  any matches routes+  where+    matches route = route.method == requestMethod && pathMatches route.path requestPath+    pathMatches expected actual =+      length expected == length actual+        && and (zipWith segmentMatches expected actual)+    segmentMatches (Literal expected) actual = expected == actual+    segmentMatches Wildcard _ = True++instance (HasThrottledRoutes left, HasThrottledRoutes right) => HasThrottledRoutes (left :<|> right) where+  allRoutes _ = allRoutes (Proxy @left) <> allRoutes (Proxy @right)++instance (KnownSymbol segment, HasThrottledRoutes sub) => HasThrottledRoutes ((segment :: Symbol) :> sub) where+  allRoutes _ = prepend (Literal (Text.pack (symbolVal (Proxy @segment)))) (allRoutes (Proxy @sub))++instance (HasThrottledRoutes sub) => HasThrottledRoutes (Capture' mods name value :> sub) where+  allRoutes _ = prepend Wildcard (allRoutes (Proxy @sub))++instance (HasThrottledRoutes sub) => HasThrottledRoutes (RateLimited :> sub) where+  allRoutes _ = [(True, route) | (_, route) <- allRoutes (Proxy @sub)]++instance (HasThrottledRoutes sub) => HasThrottledRoutes (CsrfProtected :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (PreHandlerResponses responses :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (Authenticated :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (OAuthAuthenticated :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (RequireAdmin :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (RequireRole requiredRole :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (RequireScope scope :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (RequirePermission permission :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (RemoteHost :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (ReqBody' mods contentTypes value :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (Header' mods name value :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (QueryParam' mods name value :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (HasThrottledRoutes sub) => HasThrottledRoutes (QueryParams name value :> sub) where allRoutes _ = allRoutes (Proxy @sub)++instance (ReflectMethod method) => HasThrottledRoutes (Verb method status contentTypes value) where+  allRoutes _ = [(False, ThrottledRoute (reflectMethod (Proxy @method)) [])]++instance (ReflectMethod method) => HasThrottledRoutes (MultiVerb method contentTypes responses result) where+  allRoutes _ = [(False, ThrottledRoute (reflectMethod (Proxy @method)) [])]++instance HasThrottledRoutes Raw where+  allRoutes _ = []++class GHasThrottledRoutes representation where+  genericRoutes :: Proxy representation -> [(Bool, ThrottledRoute)]++instance (GHasThrottledRoutes inner) => GHasThrottledRoutes (M1 metadata meta inner) where+  genericRoutes _ = genericRoutes (Proxy @inner)++instance (GHasThrottledRoutes left, GHasThrottledRoutes right) => GHasThrottledRoutes (left :*: right) where+  genericRoutes _ = genericRoutes (Proxy @left) <> genericRoutes (Proxy @right)++instance (HasThrottledRoutes api) => GHasThrottledRoutes (K1 field api) where+  genericRoutes _ = allRoutes (Proxy @api)++instance+  (GHasThrottledRoutes (Rep (routes AsApi))) =>+  HasThrottledRoutes (NamedRoutes routes)+  where+  allRoutes _ = genericRoutes (Proxy @(Rep (routes AsApi)))++prepend :: PathSegment -> [(Bool, ThrottledRoute)] -> [(Bool, ThrottledRoute)]+prepend segment = map (fmap (\route -> route {path = segment : route.path}))
+ src/Shomei/Session/Admin/Api.hs view
@@ -0,0 +1,30 @@+-- | Administrative session routes.+module Shomei.Session.Admin.Api+  ( AdminSessionApi (..),+    ListSessionsRoute,+    RevokeSessionsRoute,+    RevokeSessionRoute,+  )+where++import Servant.API+import Servant.API.MultiVerb (MultiVerb)+import Shomei.Id (SessionId, UserId)+import Shomei.Prelude+import Shomei.Servant.Authz (RequireAdmin)+import Shomei.Servant.PreHandler (CsrfProtected, PreHandlerResponses)+import Shomei.Servant.Result (ApplicationContentTypes, BadRequestPreHandlerResponses)+import Shomei.Session.Result++type ListSessionsRoute = "users" :> RequireAdmin :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> "sessions" :> MultiVerb 'GET ApplicationContentTypes ListSessionsResponses ListSessionsResult++type RevokeSessionsRoute = "users" :> RequireAdmin :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> "sessions" :> MultiVerb 'DELETE ApplicationContentTypes RevokeSessionsResponses RevokeSessionsResult++type RevokeSessionRoute = "sessions" :> RequireAdmin :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "sessionId" SessionId :> MultiVerb 'DELETE ApplicationContentTypes RevokeSessionResponses RevokeSessionResult++data AdminSessionApi mode = AdminSessionApi+  { listSessions :: mode :- ListSessionsRoute,+    revokeSessions :: mode :- RevokeSessionsRoute,+    revokeSession :: mode :- RevokeSessionRoute+  }+  deriving stock (Generic)
+ src/Shomei/Session/Api.hs view
@@ -0,0 +1,34 @@+-- | Session-owned HTTP routes.+module Shomei.Session.Api+  ( SessionApi (..),+    LoginRoute,+    RefreshRoute,+    LogoutRoute,+    CurrentSessionRoute,+  )+where++import Servant.API+import Servant.API.MultiVerb (MultiVerb)+import Shomei.Prelude+import Shomei.Servant.Auth (Authenticated)+import Shomei.Servant.PreHandler (CsrfProtected, PreHandlerResponses, RateLimited)+import Shomei.Servant.Result (ApplicationContentTypes, BadRequestPreHandlerResponses)+import Shomei.Session.Dto (LoginRequest, RefreshRequest)+import Shomei.Session.Result++type LoginRoute = "login" :> RateLimited :> RemoteHost :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] LoginRequest :> MultiVerb 'POST ApplicationContentTypes LoginResponses LoginResult++type RefreshRoute = "refresh" :> RateLimited :> CsrfProtected :> Header "Cookie" Text :> Header "Origin" Text :> Header "Referer" Text :> PreHandlerResponses BadRequestPreHandlerResponses :> ReqBody '[JSON] RefreshRequest :> MultiVerb 'POST ApplicationContentTypes RefreshResponses RefreshResult++type LogoutRoute = "logout" :> Authenticated :> CsrfProtected :> MultiVerb 'POST ApplicationContentTypes LogoutResponses LogoutResult++type CurrentSessionRoute = Authenticated :> "session" :> MultiVerb 'GET ApplicationContentTypes CurrentSessionResponses CurrentSessionResult++data SessionApi mode = SessionApi+  { login :: mode :- LoginRoute,+    refresh :: mode :- RefreshRoute,+    logout :: mode :- LogoutRoute,+    currentSession :: mode :- CurrentSessionRoute+  }+  deriving stock (Generic)
+ src/Shomei/Session/Dto.hs view
@@ -0,0 +1,139 @@+-- | Session, token, and login wire types.+module Shomei.Session.Dto+  ( TokenPairResponse (..),+    LoginRequest (..),+    LoginResponse (..),+    RefreshRequest (..),+    SessionResponse (..),+    tokenPairToResponse,+    loginResultToResponse,+    sessionToResponse,+  )+where++import Data.Aeson (Value, object, withObject, (.:))+import Data.Aeson qualified as Aeson+import Data.Aeson.Types (Parser)+import Data.Maybe (catMaybes)+import Data.Text qualified as Text+import Data.Time.Format.ISO8601 (iso8601Show)+import Shomei.Account.User.Dto (UserResponse, userToResponse)+import Shomei.Config (ShomeiConfig (..), transportIncludesBodyTokens)+import Shomei.Id (idText)+import Shomei.Prelude+import Shomei.Session.Authentication.Workflow (LoginResult (..), MfaChallenge (..))+import Shomei.Session.Domain (Session (..), SessionStatus (..))+import Shomei.Session.RefreshToken.Domain (RefreshToken (..))+import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..))++data TokenPairResponse = TokenPairResponse+  { accessToken :: !(Maybe Text),+    refreshToken :: !(Maybe Text),+    expiresIn :: !Int+  }+  deriving stock (Generic)++instance ToJSON TokenPairResponse where+  toJSON response =+    object $+      catMaybes+        [ ("accessToken" Aeson..=) <$> response.accessToken,+          ("refreshToken" Aeson..=) <$> response.refreshToken,+          Just ("expiresIn" Aeson..= response.expiresIn)+        ]++instance FromJSON TokenPairResponse where+  parseJSON = withObject "TokenPairResponse" \objectValue ->+    TokenPairResponse+      <$> objectValue Aeson..:? "accessToken"+      <*> objectValue Aeson..:? "refreshToken"+      <*> objectValue .: "expiresIn"++data LoginRequest = LoginRequest+  { loginId :: !Text,+    password :: !Text+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data LoginResponse+  = LoginCompleteResponse+      { user :: !UserResponse,+        token :: !TokenPairResponse+      }+  | LoginMfaRequiredResponse+      { ceremonyId :: !Text,+        options :: !Value,+        methods :: ![Text]+      }+  deriving stock (Generic)++instance ToJSON LoginResponse where+  toJSON = \case+    LoginCompleteResponse user token ->+      object ["status" Aeson..= ("complete" :: Text), "user" Aeson..= user, "token" Aeson..= token]+    LoginMfaRequiredResponse ceremonyId options methods ->+      object+        [ "status" Aeson..= ("mfa_required" :: Text),+          "ceremonyId" Aeson..= ceremonyId,+          "options" Aeson..= options,+          "methods" Aeson..= methods+        ]++instance FromJSON LoginResponse where+  parseJSON = withObject "LoginResponse" \objectValue -> do+    status <- objectValue .: "status" :: Parser Text+    case status of+      "complete" -> LoginCompleteResponse <$> objectValue .: "user" <*> objectValue .: "token"+      "mfa_required" -> LoginMfaRequiredResponse <$> objectValue .: "ceremonyId" <*> objectValue .: "options" <*> objectValue .: "methods"+      other -> fail ("unknown login status: " <> Text.unpack other)++newtype RefreshRequest = RefreshRequest {refreshToken :: Maybe Text}+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++data SessionResponse = SessionResponse+  { sessionId :: !Text,+    userId :: !Text,+    createdAt :: !Text,+    expiresAt :: !Text,+    status :: !Text,+    revokedAt :: !(Maybe Text)+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++tokenPairToResponse :: ShomeiConfig -> TokenPair -> TokenPairResponse+tokenPairToResponse config pair =+  TokenPairResponse+    { accessToken = bodyToken (unAccess pair.accessToken),+      refreshToken = bodyToken (unRefresh pair.refreshToken),+      expiresIn = round (realToFrac pair.expiresIn :: Double)+    }+  where+    bodyToken token = if transportIncludesBodyTokens config.tokenTransport then Just token else Nothing+    unAccess (AccessToken token) = token+    unRefresh (RefreshToken token) = token++loginResultToResponse :: ShomeiConfig -> LoginResult -> LoginResponse+loginResultToResponse config = \case+  LoginComplete user pair ->+    LoginCompleteResponse {user = userToResponse user, token = tokenPairToResponse config pair}+  MfaRequired (MfaChallenge ceremonyId options methods) ->+    LoginMfaRequiredResponse {ceremonyId = idText ceremonyId, options = options, methods = methods}++sessionToResponse :: Session -> SessionResponse+sessionToResponse session =+  SessionResponse+    { sessionId = idText session.sessionId,+      userId = idText session.userId,+      createdAt = Text.pack (iso8601Show session.createdAt),+      expiresAt = Text.pack (iso8601Show session.expiresAt),+      status = renderStatus session.status,+      revokedAt = Text.pack . iso8601Show <$> session.revokedAt+    }+  where+    renderStatus = \case+      SessionActive -> "active"+      SessionRevoked -> "revoked"+      SessionExpired -> "expired"
+ src/Shomei/Session/Handler.hs view
@@ -0,0 +1,133 @@+-- | Session and administrative-session HTTP adapters.+module Shomei.Session.Handler+  ( sessionServer,+    adminSessionServer,+    clientIpText,+  )+where++import Network.Socket (SockAddr)+import Servant (Handler)+import Servant.Server.Generic (AsServerT)+import Shomei.Account.Admin.Workflow qualified as Admin+import Shomei.Account.Handler (requireExistingUser)+import Shomei.Account.LoginId.Domain (loginIdText, mkLoginId)+import Shomei.Account.Password.Domain (PlainPassword (..))+import Shomei.Config (CookieConfig (..), ShomeiConfig (..), transportUsesCookies)+import Shomei.Delegation.Handler (denyUnderDelegation)+import Shomei.Error (AuthError (SessionNotFound))+import Shomei.Id (SessionId, UserId)+import Shomei.Prelude+import Shomei.Servant.Application (port, rejectAuth, rejectProblem, runApplicationHandler, workflow)+import Shomei.Servant.Auth (AuthUser (..), originHeaderAllowed)+import Shomei.Servant.ClientIp (clientIpText)+import Shomei.Servant.Cookie+  ( clearedCookies,+    refreshTokenFromCookie,+    tokenCookies,+  )+import Shomei.Servant.Error+  ( detailOccurrence,+    noProblemOccurrence,+    pcBadRequest,+    pcCsrfRejected,+    pcSessionNotFound,+  )+import Shomei.Servant.Result (CookieResponse (..), cookieResponse)+import Shomei.Servant.Seam (Env (..))+import Shomei.Session.Admin.Api (AdminSessionApi (..))+import Shomei.Session.Api (SessionApi (..))+import Shomei.Session.Authentication.Workflow qualified as Authentication+import Shomei.Session.Command+  ( ClientContext (..),+    LoginCommand (..),+    LogoutCommand (..),+    RefreshCommand (..),+  )+import Shomei.Session.Dto+import Shomei.Session.LoginAttempt.Domain (ClientIp (..))+import Shomei.Session.RefreshToken.Domain (RefreshToken (..))+import Shomei.Session.Result+import Shomei.Session.Store (findSessionById, listSessionsForUser)++sessionServer :: Env -> SessionApi (AsServerT Handler)+sessionServer env =+  SessionApi+    { login = loginH env,+      refresh = refreshH env,+      logout = logoutH env,+      currentSession = currentSessionH env+    }++adminSessionServer :: Env -> AdminSessionApi (AsServerT Handler)+adminSessionServer env =+  AdminSessionApi+    { listSessions = adminListSessionsH env,+      revokeSessions = adminRevokeSessionsH env,+      revokeSession = adminRevokeSessionH env+    }++loginH :: Env -> SockAddr -> LoginRequest -> Handler LoginResult+loginH env peer request = runApplicationHandler do+  loginId <- either rejectAuth pure (mkLoginId request.loginId)+  let command = LoginCommand {loginId, password = PlainPassword request.password}+      context =+        ClientContext+          { clientIp = ClientIp (clientIpText peer),+            accountKey = env.accountKeyOf (loginIdText loginId)+          }+  result <- workflow env (Authentication.login env.config context command)+  pure case result of+    Authentication.LoginComplete _ pair ->+      cookieResponse env.config (tokenCookies env.config pair) (loginResultToResponse env.config result)+    Authentication.MfaRequired _ ->+      CookieResponse+        { cookieBody = loginResultToResponse env.config result,+          sessionCookieHeader = Nothing,+          refreshCookieHeader = Nothing+        }++refreshH :: Env -> Maybe Text -> Maybe Text -> Maybe Text -> RefreshRequest -> Handler RefreshResult+refreshH env cookieHeader origin referer request = runApplicationHandler do+  presented <- case request.refreshToken of+    Just token -> pure token+    Nothing+      | transportUsesCookies env.config.tokenTransport,+        Just raw <- cookieHeader,+        Just token <- refreshTokenFromCookie env.config.cookieConfig raw -> do+          unless (originHeaderAllowed env.config.cookieConfig.allowedOrigins origin referer) (rejectProblem pcCsrfRejected noProblemOccurrence)+          pure token+    Nothing -> rejectProblem pcBadRequest (detailOccurrence "refreshToken required")+  pair <- workflow env (Authentication.refresh env.config (RefreshCommand (RefreshToken presented)))+  pure (cookieResponse env.config (tokenCookies env.config pair) (tokenPairToResponse env.config pair))++logoutH :: Env -> AuthUser -> Handler LogoutResult+logoutH env user = runApplicationHandler do+  outcome <- port env (Authentication.logout env.config (LogoutCommand user.authSessionId))+  case outcome of+    Left SessionNotFound -> pure cleared+    Left err -> rejectAuth err+    Right () -> pure cleared+  where+    cleared = cookieResponse env.config (clearedCookies env.config) ()++currentSessionH :: Env -> AuthUser -> Handler CurrentSessionResult+currentSessionH env user = runApplicationHandler do+  found <- port env (findSessionById user.authSessionId)+  maybe (rejectProblem pcSessionNotFound noProblemOccurrence) (pure . sessionToResponse) found++adminListSessionsH :: Env -> AuthUser -> UserId -> Handler ListSessionsResult+adminListSessionsH env _ target = runApplicationHandler do+  _ <- requireExistingUser env target+  map sessionToResponse <$> port env (listSessionsForUser target)++adminRevokeSessionsH :: Env -> AuthUser -> UserId -> Handler RevokeSessionsResult+adminRevokeSessionsH env actor target = runApplicationHandler do+  denyUnderDelegation env "admin_revoke_sessions" actor+  _ <- requireExistingUser env target+  void $ workflow env (Admin.revokeUserSessions actor.authUserId target)++adminRevokeSessionH :: Env -> AuthUser -> SessionId -> Handler RevokeSessionResult+adminRevokeSessionH env actor sessionId = runApplicationHandler do+  denyUnderDelegation env "admin_revoke_session" actor+  workflow env (Admin.revokeOneSession actor.authUserId sessionId)
+ src/Shomei/Session/Result.hs view
@@ -0,0 +1,49 @@+-- | Named session response lists and handler result types.+module Shomei.Session.Result+  ( LoginResponses,+    LoginResult,+    RefreshResponses,+    RefreshResult,+    LogoutResponses,+    LogoutResult,+    CurrentSessionResponses,+    CurrentSessionResult,+    ListSessionsResponses,+    ListSessionsResult,+    RevokeSessionsResponses,+    RevokeSessionsResult,+    RevokeSessionResponses,+    RevokeSessionResult,+  )+where++import Shomei.Servant.Result+import Shomei.Session.Dto (LoginResponse, SessionResponse, TokenPairResponse)++type LoginResponses = ApplicationCookieResponses 200 "Authenticated" LoginResponse++type LoginResult = ApplicationResult (CookieResponse LoginResponse)++type RefreshResponses = ApplicationCookieResponses 200 "Tokens refreshed" TokenPairResponse++type RefreshResult = ApplicationResult (CookieResponse TokenPairResponse)++type LogoutResponses = ApplicationCookieEmptyResponses 204 "Logged out"++type LogoutResult = ApplicationResult (CookieResponse ())++type CurrentSessionResponses = ApplicationResponses 200 "Current session" SessionResponse++type CurrentSessionResult = ApplicationResult SessionResponse++type ListSessionsResponses = ApplicationResponses 200 "Sessions" [SessionResponse]++type ListSessionsResult = ApplicationResult [SessionResponse]++type RevokeSessionsResponses = ApplicationEmptyResponses 204 "Sessions revoked"++type RevokeSessionsResult = ApplicationResult ()++type RevokeSessionResponses = ApplicationEmptyResponses 204 "Session revoked"++type RevokeSessionResult = ApplicationResult ()
+ src/Shomei/SigningKey/Api.hs view
@@ -0,0 +1,18 @@+-- | Well-known discovery and signing-key routes.+module Shomei.SigningKey.Api (WellKnownApi (..), JwksRoute, OidcDiscoveryRoute) where++import Data.Aeson (Value)+import Servant.API+import Servant.API.MultiVerb (MultiVerb)+import Shomei.OAuth.Result (OidcDiscoveryResponses, OidcDiscoveryResult)+import Shomei.Prelude++type JwksRoute = "jwks.json" :> Get '[JSON] (Headers '[Header "Cache-Control" Text] Value)++type OidcDiscoveryRoute = "openid-configuration" :> MultiVerb 'GET '[JSON] OidcDiscoveryResponses OidcDiscoveryResult++data WellKnownApi mode = WellKnownApi+  { jwks :: mode :- JwksRoute,+    oidcDiscovery :: mode :- OidcDiscoveryRoute+  }+  deriving stock (Generic)
+ src/Shomei/SigningKey/Handler.hs view
@@ -0,0 +1,20 @@+-- | In-process discovery and signing-key HTTP adapters.+module Shomei.SigningKey.Handler (wellKnownServer) where++import Data.Aeson (Value)+import Servant (Handler, Header, Headers, addHeader)+import Servant.Server.Generic (AsServerT)+import Shomei.OAuth.Handler (oidcDiscoveryH)+import Shomei.Prelude+import Shomei.Servant.Seam (Env (..))+import Shomei.SigningKey.Api (WellKnownApi (..))++wellKnownServer :: Env -> WellKnownApi (AsServerT Handler)+wellKnownServer env =+  WellKnownApi+    { jwks = jwksH env,+      oidcDiscovery = oidcDiscoveryH env+    }++jwksH :: Env -> Handler (Headers '[Header "Cache-Control" Text] Value)+jwksH env = addHeader "public, max-age=300" <$> liftIO env.jwksJson
+ test-openapi/Main.hs view
@@ -0,0 +1,676 @@+{-# OPTIONS_GHC -Wno-missing-signatures -Wno-orphans #-}++-- | EP-27 M4 — OpenAPI 3.1 conformance for the served tree, 'Shomei.Servant.Api.ShomeiRoutes'.+--+-- Three layers:+--+--   1. 'validateEveryToJSON' — for every JSON body type in the API, generate+--      arbitrary values and check their 'ToJSON' encoding validates against the+--      generated 'ToSchema'. This is what catches schema/JSON drift, including+--      the hand-written 'LoginResponse' @oneOf@ and the free-form 'Value' fields.+--+--   2. Smoke assertions on the assembled 'shomeiOpenApi': the @openapi@ version+--      is @3.1.0@ and the document covers the expected number of paths.+--+--   3. EP-3: the error surface. Every documented error code exists in the runtime+--      'problemCatalog' at the documented status, so the spec cannot promise a code or a+--      status the server never sends; and the document 'Shomei.Servant.Error.problemBody'+--      actually writes for every catalog entry validates against the published @Problem@+--      schema, so the two halves of the envelope cannot drift apart. Plus the hygiene+--      invariants a generated client depends on: no @204@ carries content, no response+--      description is empty, every request body is required, and every authenticated+--      operation documents its @401@.+--+-- The 'Arbitrary' and 'Show' instances for the DTOs live here (orphans, test+-- only) so the production library carries no test dependency.+module Main (main) where++import Control.Monad (filterM)+import Data.Aeson (Result (..), ToJSON (..), Value (..), decode, eitherDecode, encode, fromJSON)+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KM+import Data.Char (isAsciiLower, isDigit)+import Data.Either (isLeft)+import Data.Foldable (toList)+import Data.Kind (Type)+import Data.List (nub, sort)+import Data.Maybe (isJust)+import Data.OpenApi (NamedSchema (..), Schema, ToSchema (..), validateJSON)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as TextIO+import Data.Type.Equality ((:~:) (Refl))+import GHC.TypeLits (Nat)+import Servant.API (NamedRoutes, NoContent (..), Verb, type (:>))+import Servant.API.MultiVerb (MultiVerb, Respond, RespondAs, WithHeaders)+import Servant.Health (ProbeResponses, ProbeStatus (..))+import Servant.OpenApi.Test (validateEveryToJSON)+import Servant.Server (ServerError (..))+import Shomei.Account.Admin.Api+import Shomei.Account.Api+import Shomei.Account.Dto+import Shomei.Account.User.Dto+import Shomei.Audit.Api+import Shomei.Audit.Dto+import Shomei.Authorization.Api+import Shomei.Mfa.Api+import Shomei.Mfa.Dto+import Shomei.OAuth.Api+import Shomei.Passkey.Api+import Shomei.Passkey.Dto+import Shomei.Servant.Api (OpenApiRoute, ShomeiRoutes)+import Shomei.Servant.Error (ProblemDetails (..), ProblemSpec (..), detailOccurrence, noProblemOccurrence, problemBody, problemCatalog, problemDetails, problemTypeFor, toProblemError)+import Shomei.Servant.OAuth (OAuthErrorResponse (..), TokenResponse (..))+import Shomei.Servant.OpenApi (shomeiOpenApi)+import Shomei.Session.Admin.Api+import Shomei.Session.Api+import Shomei.Session.Dto+import Shomei.SigningKey.Api+import System.Directory (doesFileExist)+import Test.Hspec+import Test.QuickCheck (Arbitrary (..), chooseInt, oneof)+import Test.QuickCheck.Instances ()++-- | @logout@ answers @204@ with @Set-Cookie@ headers. Servant models a header-carrying empty+-- response as a JSON-typed 'NoContent' body ('NoContentVerb' cannot carry headers), so+-- 'validateEveryToJSON' needs to generate and encode one. Test-only orphans; the wire response+-- is a genuine @204@ with no body.+instance Arbitrary NoContent where+  arbitrary = pure NoContent++-- Encoded as an empty object so it validates against the empty schema below. Nothing is+-- serialized on the wire: a 204 carries no body, and servant renders 'NoContent' as "".+instance ToJSON NoContent where+  toJSON NoContent = Object mempty++instance ToSchema NoContent where+  declareNamedSchema _ = pure (NamedSchema (Just "NoContent") mempty)++instance Arbitrary ProbeStatus where+  arbitrary = ProbeStatus <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ProblemDetails where+  arbitrary =+    ProblemDetails+      <$> pure "https://example.test/problems/example"+      <*> arbitrary+      <*> chooseInt (100, 599)+      <*> arbitrary+      <*> pure (Just "/requests/example")+      <*> arbitrary+      <*> arbitrary++instance Arbitrary OAuthErrorResponse where+  arbitrary = OAuthErrorResponse <$> arbitrary <*> arbitrary++data OutcomeModel = SingleOutcome | MultiOutcome++type ResponseModel :: Type -> OutcomeModel+type family ResponseModel route where+  ResponseModel (_ :> route) = ResponseModel route+  ResponseModel (MultiVerb method content responses result) = 'MultiOutcome+  ResponseModel (Verb method status content body) = 'SingleOutcome++type ResponseOwnsStatus :: Nat -> Type -> Bool+type family ResponseOwnsStatus status response where+  ResponseOwnsStatus status (Respond status description body) = 'True+  ResponseOwnsStatus status (Respond other description body) = 'False+  ResponseOwnsStatus status (RespondAs content status description body) = 'True+  ResponseOwnsStatus status (RespondAs content other description body) = 'False+  ResponseOwnsStatus status (WithHeaders headers result response) = ResponseOwnsStatus status response++type ResponsesOwnStatus :: Nat -> [Type] -> Bool+type family ResponsesOwnStatus status responses where+  ResponsesOwnStatus status '[] = 'False+  ResponsesOwnStatus status (response ': responses) = Or (ResponseOwnsStatus status response) (ResponsesOwnStatus status responses)++type Or :: Bool -> Bool -> Bool+type family Or left right where+  Or 'True right = 'True+  Or 'False right = right++type OperationOwnsStatus :: Nat -> Type -> Bool+type family OperationOwnsStatus status route where+  OperationOwnsStatus status (_ :> route) = OperationOwnsStatus status route+  OperationOwnsStatus status (MultiVerb method content responses result) = ResponsesOwnStatus status responses++type Classified route =+  ( ResponseModel route :~: 'MultiOutcome,+    OperationOwnsStatus 503 route :~: 'True+  )++accountWitnesses =+  ( (Refl, Refl) :: Classified SignupRoute,+    (Refl, Refl) :: Classified VerifyEmailRequestRoute,+    (Refl, Refl) :: Classified VerifyEmailConfirmRoute,+    (Refl, Refl) :: Classified PasswordResetRequestRoute,+    (Refl, Refl) :: Classified PasswordResetConfirmRoute,+    (Refl, Refl) :: Classified PasswordChangeRoute,+    (Refl, Refl) :: Classified MeRoute,+    (Refl, Refl) :: Classified ListUsersRoute,+    (Refl, Refl) :: Classified GetUserRoute,+    (Refl, Refl) :: Classified SuspendUserRoute,+    (Refl, Refl) :: Classified ReinstateUserRoute,+    (Refl, Refl) :: Classified DeleteUserRoute,+    (Refl, Refl) :: Classified AdminPasswordResetRoute+  )++sessionWitnesses =+  ( (Refl, Refl) :: Classified LoginRoute,+    (Refl, Refl) :: Classified RefreshRoute,+    (Refl, Refl) :: Classified LogoutRoute,+    (Refl, Refl) :: Classified CurrentSessionRoute,+    (Refl, Refl) :: Classified ListSessionsRoute,+    (Refl, Refl) :: Classified RevokeSessionsRoute,+    (Refl, Refl) :: Classified RevokeSessionRoute+  )++passkeyWitnesses =+  ( (Refl, Refl) :: Classified RegisterBeginRoute,+    (Refl, Refl) :: Classified RegisterCompleteRoute,+    (Refl, Refl) :: Classified ListPasskeysRoute,+    (Refl, Refl) :: Classified RemovePasskeyRoute,+    (Refl, Refl) :: Classified PasskeyLoginBeginRoute,+    (Refl, Refl) :: Classified PasskeyLoginCompleteRoute+  )++mfaWitnesses =+  ( (Refl, Refl) :: Classified MfaCompleteRoute,+    (Refl, Refl) :: Classified TotpEnrollRoute,+    (Refl, Refl) :: Classified TotpVerifyRoute,+    (Refl, Refl) :: Classified TotpDeleteRoute,+    (Refl, Refl) :: Classified RecoveryCodesGenerateRoute,+    (Refl, Refl) :: Classified RecoveryCodesCountRoute+  )++otherMultiWitnesses =+  ( (Refl, Refl) :: Classified AuditEventsRoute,+    (Refl, Refl) :: Classified GrantRoleRoute,+    (Refl, Refl) :: Classified RevokeRoleRoute,+    (Refl, Refl) :: Classified AuthorizeRoute,+    (Refl, Refl) :: Classified TokenRoute,+    (Refl, Refl) :: Classified UserinfoRoute,+    (Refl, Refl) :: Classified IntrospectRoute,+    (Refl, Refl) :: Classified RevokeRoute,+    (Refl, Refl) :: Classified OidcDiscoveryRoute+  )++ordinaryWitnesses =+  ( Refl :: ResponseModel JwksRoute :~: 'SingleOutcome,+    Refl :: ResponseModel OpenApiRoute :~: 'SingleOutcome+  )++health503Witness :: ResponsesOwnStatus 503 ProbeResponses :~: 'True+health503Witness = Refl++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  problemCatalogDocument <- runIO do+    let candidates = ["docs/user/problem-details.md", "../docs/user/problem-details.md"]+    existing <- filterM doesFileExist candidates+    case existing of+      path : _ -> TextIO.readFile path+      [] -> fail "docs/user/problem-details.md not found"++  describe "OpenAPI 3.1 schema: ToJSON matches ToSchema" $+    validateEveryToJSON (Proxy :: Proxy (NamedRoutes ShomeiRoutes))++  describe "strict authentication request decoding" $ do+    it "requires methods on the MFA login-response arm" $+      (eitherDecode "{\"status\":\"mfa_required\",\"ceremonyId\":\"c\",\"options\":{}}" :: Either String LoginResponse)+        `shouldSatisfy` isLeft++    it "rejects the removed flat MFA completion shape" $+      (eitherDecode "{\"ceremonyId\":\"c\",\"totpCode\":\"123456\"}" :: Either String MfaCompleteRequest)+        `shouldSatisfy` isLeft++    it "rejects extra proof arms in a tagged MFA proof" $+      (eitherDecode "{\"type\":\"totp\",\"code\":\"123456\",\"assertion\":{}}" :: Either String MfaProof)+        `shouldSatisfy` isLeft++  describe "shomeiOpenApi document" $ do+    it "declares OpenAPI version 3.1.0" $+      lookupTop "openapi" `shouldBe` Just (String "3.1.0")++    it "covers exactly 41 paths" $+      pathCount `shouldBe` 41++    it "covers the exact served method and path inventory" $+      sort (map fst operations) `shouldBe` expectedOperations++    -- 'ResponseModel' has no 'MultiVerb1' equation. Replacing any named route witness below+    -- with MultiVerb1 therefore makes this module fail to compile rather than silently pass.+    it "rejects MultiVerb1, keeps the exact ordinary allow-list, and gives every other JSON route an operation-owned 503" $+      accountWitnesses `seq`+        sessionWitnesses `seq`+          passkeyWitnesses `seq`+            mfaWitnesses `seq`+              otherMultiWitnesses `seq`+                ordinaryWitnesses `seq`+                  health503Witness `seq`+                    True `shouldBe` True++  describe "EP-4: /oauth/token speaks RFC 6749 behind a problem-details edge throttle" $ do+    it "declares the OAuthErrorResponse schema" $+      (lookupTop "components" >>= field "schemas" >>= field "OAuthErrorResponse") `shouldSatisfy` isJust++    -- Handler-owned failures stay in the shape a stock OAuth2 client parses. The sole exception+    -- is 429: the edge limiter answers before routing and therefore uses the shared problem+    -- document (with Retry-After), exactly as the runtime middleware does.+    it "documents only the edge 429 as problem+json on /oauth/token" $+      [ Key.toText status+      | (path, Object item) <- KM.toList paths,+        path == "/oauth/token",+        (_, Object op) <- KM.toList item,+        (status, resp) <- responsesOf op,+        isProblemResponse resp+      ]+        `shouldBe` ["429"]++    it "documents the protocol-owned error statuses" $+      responseStatusesAt "/oauth/token" `shouldBe` ["200", "400", "401", "404", "429", "500", "503"]++  describe "EP-5: the OIDC discovery document is on the OAuth side of the envelope boundary" $ do+    -- Reached by OIDC tooling, so its "provider disabled" refusal must be a shape that tooling+    -- parses. The OIDC route's protocol response list is the sole source of the alternative.+    it "documents no problem+json response on /.well-known/openid-configuration" $+      [ Key.toText status+      | (path, Object item) <- KM.toList paths,+        path == "/.well-known/openid-configuration",+        (_, Object op) <- KM.toList item,+        (status, resp) <- responsesOf op,+        isProblemResponse resp+      ]+        `shouldBe` []++    it "documents the 404 it answers when the provider is disabled" $+      "404" `shouldSatisfy` (`elem` responseStatusesAt "/.well-known/openid-configuration")++  describe "EP-5: /oauth/userinfo authenticates inside the OAuth envelope" $ do+    it "requires bearer authentication" $+      (requiresBearer <$> lookup "get /oauth/userinfo" operations) `shouldBe` Just True++    it "documents only OAuth JSON failures, never application problems" $+      [ Key.toText status+      | (path, Object item) <- KM.toList paths,+        path == "/oauth/userinfo",+        (_, Object op) <- KM.toList item,+        (status, resp) <- responsesOf op,+        isProblemResponse resp+      ]+        `shouldBe` []++  describe "EP-5: /oauth/authorize speaks RFC 6749, and only its no-redirect failures are statuses" $ do+    it "documents no problem+json response on /oauth/authorize" $+      [ Key.toText status+      | (path, Object item) <- KM.toList paths,+        path == "/oauth/authorize",+        (_, Object op) <- KM.toList item,+        (status, resp) <- responsesOf op,+        isProblemResponse resp+      ]+        `shouldBe` []++    -- Every OTHER authorize failure -- bad response_type, PKCE policy, disallowed scope -- is a+    -- 302 back to the validated redirect_uri, so it is not a status this operation declares.+    it "documents only protocol statuses rather than redirect query error values" $+      responseStatusesAt "/oauth/authorize" `shouldBe` ["302", "400", "401", "404", "500", "503"]++  describe "EP-3: the error surface cannot drift from the runtime catalog" $ do+    it "declares the ProblemDetails schema with the RFC 9457 profile members" $+      problemRequired `shouldBe` ["code", "retryable", "status", "title", "type"]++    -- The published schema and the bytes the server writes come from different code+    -- (`problemSchema` in OpenApi.hs, `problemBody` in Error.hs). Validate the real runtime+    -- document of every catalog entry, with and without a `detail`, against the schema as it+    -- appears in the serialized document — the artifact a client generator actually reads.+    it "validates the real runtime document of every catalog entry against the published Problem schema" $+      [ (problemCode p, isJust detail, errs)+      | p <- problemCatalog,+        detail <- [Nothing, Just "a request-specific explanation"],+        let occurrence = maybe noProblemOccurrence detailOccurrence detail,+        let errs = validateJSON mempty publishedProblemSchema (problemBody p occurrence),+        not (null errs)+      ]+        `shouldBe` []++    it "keeps body status, type, code, title, and retryability synchronized" $+      [ p.problemCode+      | p <- problemCatalog,+        let body = problemDetails p noProblemOccurrence,+        body.status /= errHTTPCode p.problemStatus+          || body.problemType /= problemTypeFor p.problemCode+          || body.code /= p.problemCode+          || body.title /= p.problemTitle+          || body.retryable /= p.problemRetryable+      ]+        `shouldBe` []++    it "uses a URI-safe code alphabet and a one-to-one type/code mapping" $ do+      [p.problemCode | p <- problemCatalog, Text.any (\c -> not (isAsciiLower c || isDigit c || c == '_')) p.problemCode] `shouldBe` []+      length (nub (map (problemTypeFor . problemCode) problemCatalog))+        `shouldBe` length (nub (map problemCode problemCatalog))++    it "documents an explicit public anchor for every code" $+      [p.problemCode | p <- problemCatalog, not (Text.isInfixOf ("id=\"" <> p.problemCode <> "\"") problemCatalogDocument)]+        `shouldBe` []++    it "renders matching RFC 9457 bodies and media types at the pre-handler boundary" $+      [ p.problemCode+      | p <- problemCatalog,+        let rendered = toProblemError p noProblemOccurrence,+        lookup "Content-Type" rendered.errHeaders /= Just "application/problem+json"+          || (decode rendered.errBody :: Maybe ProblemDetails) /= Just (problemDetails p noProblemOccurrence)+      ]+        `shouldBe` []++    it "decodes unknown RFC 9457 extension members" $+      (eitherDecode "{\"type\":\"https://example.test/problem\",\"title\":\"Example\",\"status\":400,\"code\":\"example\",\"retryable\":false,\"future\":true}" :: Either String ProblemDetails)+        `shouldSatisfy` either (const False) (const True)++    it "documents a 401 on every operation that requires a bearer token" $+      [key | (key, op) <- operations, requiresBearer op, not (declares "401" op)] `shouldBe` []++  describe "EP-3: spec hygiene a generated client depends on" $ do+    it "puts no content on a 204" $+      [key | (key, op) <- operations, responseHasContent "204" op] `shouldBe` []++    it "gives every response a non-empty description" $+      [key <> " " <> status | (key, op) <- operations, status <- emptyDescriptions op] `shouldBe` []++    it "marks every request body required" $+      [key | (key, op) <- operations, Just body <- [KM.lookup "requestBody" op], not (isRequired body)] `shouldBe` []+  where+    decoded :: KM.KeyMap Value+    decoded = case decode (encode shomeiOpenApi) of+      Just (Object o) -> o+      _ -> error "shomeiOpenApi did not encode to a JSON object"++    lookupTop k = KM.lookup k decoded++    paths = case lookupTop "paths" of+      Just (Object ps) -> ps+      _ -> error "shomeiOpenApi has no paths object"++    pathCount = KM.size paths++    problemSchemaJson = case lookupTop "components" >>= field "schemas" >>= field "ProblemDetails" of+      Just v -> v+      Nothing -> error "shomeiOpenApi has no components.schemas.ProblemDetails"++    -- Round-tripped through the serialized document on purpose: this is the schema a client+    -- generator reads, not the Haskell value that produced it.+    publishedProblemSchema :: Schema+    publishedProblemSchema = case fromJSON problemSchemaJson of+      Success s -> s+      Error e -> error ("components.schemas.Problem does not decode as a Schema: " <> e)++    problemRequired = case field "required" problemSchemaJson of+      Just (Array xs) -> sort [t | String t <- toList xs]+      _ -> error "shomeiOpenApi has no components.schemas.Problem.required"++    -- Every (method, path) operation object in the document, labelled for failure messages.+    operations :: [(Text, KM.KeyMap Value)]+    operations =+      [ (Key.toText method <> " " <> Key.toText path, op)+      | (path, Object item) <- KM.toList paths,+        (method, Object op) <- KM.toList item,+        method `elem` operationMethods+      ]++    operationMethods = ["get", "put", "post", "delete", "options", "head", "patch", "trace"]++    expectedOperations =+      sort+        [ "delete /v1/admin/sessions/{sessionId}",+          "delete /v1/admin/users/{userId}",+          "delete /v1/admin/users/{userId}/roles/{role}",+          "delete /v1/admin/users/{userId}/sessions",+          "delete /v1/auth/passkeys/{passkeyId}",+          "delete /v1/auth/totp",+          "get /.well-known/jwks.json",+          "get /.well-known/openid-configuration",+          "get /health/live",+          "get /health/ready",+          "get /oauth/authorize",+          "get /oauth/userinfo",+          "get /openapi.json",+          "get /v1/admin/audit/events",+          "get /v1/admin/users",+          "get /v1/admin/users/{userId}",+          "get /v1/admin/users/{userId}/sessions",+          "get /v1/auth/me",+          "get /v1/auth/passkeys",+          "get /v1/auth/recovery-codes",+          "get /v1/auth/session",+          "post /oauth/introspect",+          "post /oauth/revoke",+          "post /oauth/token",+          "post /v1/admin/users/{userId}/password-reset",+          "post /v1/admin/users/{userId}/reinstate",+          "post /v1/admin/users/{userId}/suspend",+          "post /v1/auth/login",+          "post /v1/auth/login/passkey/begin",+          "post /v1/auth/login/passkey/complete",+          "post /v1/auth/logout",+          "post /v1/auth/mfa/complete",+          "post /v1/auth/passkeys/register/begin",+          "post /v1/auth/passkeys/register/complete",+          "post /v1/auth/password-reset/confirm",+          "post /v1/auth/password-reset/request",+          "post /v1/auth/password/change",+          "post /v1/auth/recovery-codes",+          "post /v1/auth/refresh",+          "post /v1/auth/signup",+          "post /v1/auth/totp/enroll",+          "post /v1/auth/totp/verify",+          "post /v1/auth/verify-email/confirm",+          "post /v1/auth/verify-email/request",+          "put /v1/admin/users/{userId}/roles/{role}"+        ]++    responsesOf op = case KM.lookup "responses" op of+      Just (Object rs) -> [(status, r) | (status, Object r) <- KM.toList rs]+      _ -> []++    isProblemResponse resp = KM.member "application/problem+json" (contentOf resp)++    responseStatusesAt wanted =+      sort+        [ Key.toText status+        | (path, Object item) <- KM.toList paths,+          path == wanted,+          (_, Object op) <- KM.toList item,+          (status, _) <- responsesOf op+        ]++    contentOf resp = case KM.lookup "content" resp of+      Just (Object c) -> c+      _ -> KM.empty++    requiresBearer op = case KM.lookup "security" op of+      Just (Array xs) -> not (null xs)+      _ -> False++    declares status op = any ((== Key.fromText status) . fst) (responsesOf op)++    responseHasContent status op =+      or [KM.member "content" r | (s, r) <- responsesOf op, s == Key.fromText status]++    emptyDescriptions op =+      [ Key.toText status+      | (status, r) <- responsesOf op,+        KM.lookup "description" r `elem` [Nothing, Just (String "")]+      ]++    isRequired body = field "required" body == Just (Bool True)++    field :: Text -> Value -> Maybe Value+    field k = \case+      Object o -> KM.lookup (Key.fromText k) o+      _ -> Nothing++-- ---------------------------------------------------------------------------+-- Show instances (needed by validateEveryToJSON for counterexamples)+-- ---------------------------------------------------------------------------++deriving stock instance Show SignupRequest++deriving stock instance Show SignupResponse++deriving stock instance Show LoginRequest++deriving stock instance Show LoginResponse++deriving stock instance Show RefreshRequest++deriving stock instance Show VerifyEmailRequest++deriving stock instance Show ConfirmEmailVerificationRequest++deriving stock instance Show PasswordResetRequest++deriving stock instance Show ConfirmPasswordResetRequest++deriving stock instance Show ChangePasswordRequest++deriving stock instance Show TokenPairResponse++deriving stock instance Show UserResponse++deriving stock instance Show SessionResponse++deriving stock instance Show AdminUserResponse++deriving stock instance Show AdminUsersPage++deriving stock instance Show MfaCompleteRequest++deriving stock instance Show MfaProof++deriving stock instance Show TotpEnrollResponse++deriving stock instance Show TotpVerifyRequest++deriving stock instance Show TotpRemoveRequest++deriving stock instance Show RecoveryCodesResponse++deriving stock instance Show RecoveryCodesCountResponse++deriving stock instance Show PasskeyRegisterBeginResponse++deriving stock instance Show PasskeyRegisterCompleteRequest++deriving stock instance Show PasskeyResponse++deriving stock instance Show PasskeyLoginBeginResponse++deriving stock instance Show PasskeyLoginCompleteRequest++deriving stock instance Show AuditEventResponse++deriving stock instance Show AuditEventsPage++-- ---------------------------------------------------------------------------+-- Arbitrary instances (Text/Value come from quickcheck-instances)+-- ---------------------------------------------------------------------------++instance Arbitrary SignupRequest where+  arbitrary = SignupRequest <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary UserResponse where+  arbitrary = UserResponse <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary TokenPairResponse where+  arbitrary = TokenPairResponse <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary SignupResponse where+  arbitrary = SignupResponse <$> arbitrary <*> arbitrary++instance Arbitrary LoginRequest where+  arbitrary = LoginRequest <$> arbitrary <*> arbitrary++instance Arbitrary LoginResponse where+  arbitrary =+    oneof+      [ LoginCompleteResponse <$> arbitrary <*> arbitrary,+        LoginMfaRequiredResponse <$> arbitrary <*> arbitrary <*> arbitrary+      ]++instance Arbitrary RefreshRequest where+  arbitrary = RefreshRequest <$> arbitrary++instance Arbitrary VerifyEmailRequest where+  arbitrary = VerifyEmailRequest <$> arbitrary++instance Arbitrary ConfirmEmailVerificationRequest where+  arbitrary = ConfirmEmailVerificationRequest <$> arbitrary++instance Arbitrary PasswordResetRequest where+  arbitrary = PasswordResetRequest <$> arbitrary++instance Arbitrary ConfirmPasswordResetRequest where+  arbitrary = ConfirmPasswordResetRequest <$> arbitrary <*> arbitrary++instance Arbitrary ChangePasswordRequest where+  arbitrary = ChangePasswordRequest <$> arbitrary <*> arbitrary++instance Arbitrary MfaCompleteRequest where+  arbitrary = MfaCompleteRequest <$> arbitrary <*> arbitrary++instance Arbitrary MfaProof where+  arbitrary = oneof [PasskeyProof <$> arbitrary, TotpProof <$> arbitrary, RecoveryCodeProof <$> arbitrary]++instance Arbitrary TotpEnrollResponse where+  arbitrary = TotpEnrollResponse <$> arbitrary <*> arbitrary++instance Arbitrary TotpVerifyRequest where+  arbitrary = TotpVerifyRequest <$> arbitrary++instance Arbitrary TotpRemoveRequest where+  arbitrary = TotpRemoveRequest <$> arbitrary <*> arbitrary++instance Arbitrary RecoveryCodesResponse where+  arbitrary = RecoveryCodesResponse <$> arbitrary++instance Arbitrary RecoveryCodesCountResponse where+  arbitrary = RecoveryCodesCountResponse <$> arbitrary++instance Arbitrary PasskeyRegisterBeginResponse where+  arbitrary = PasskeyRegisterBeginResponse <$> arbitrary <*> arbitrary++instance Arbitrary PasskeyRegisterCompleteRequest where+  arbitrary = PasskeyRegisterCompleteRequest <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary PasskeyResponse where+  arbitrary = PasskeyResponse <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary PasskeyLoginBeginResponse where+  arbitrary = PasskeyLoginBeginResponse <$> arbitrary <*> arbitrary++instance Arbitrary PasskeyLoginCompleteRequest where+  arbitrary = PasskeyLoginCompleteRequest <$> arbitrary <*> arbitrary++instance Arbitrary TokenResponse where+  arbitrary = TokenResponse <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary SessionResponse where+  arbitrary = SessionResponse <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary AdminUserResponse where+  arbitrary = AdminUserResponse <$> arbitrary <*> arbitrary++instance Arbitrary AdminUsersPage where+  arbitrary = AdminUsersPage <$> arbitrary <*> arbitrary++instance Arbitrary AuditEventResponse where+  arbitrary =+    AuditEventResponse <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary AuditEventsPage where+  arbitrary = AuditEventsPage <$> arbitrary <*> arbitrary
+ test/Main.hs view
@@ -0,0 +1,3769 @@+{-# LANGUAGE TypeApplications #-}++-- | End-to-end HTTP test for @shomei-servant@.+--+-- Boots the 'ShomeiAPI' server in-process on an ephemeral port with a /hybrid/+-- interpreter stack — EP-2's in-memory stores together with EP-4's real @jose@ ES256+-- signer and verifier — so signing and verification are genuinely exercised (not+-- stubbed). Then drives @http-client@ requests and asserts the behaviors from the+-- plan's Purpose: signup, login, me (+ 401 on missing/garbage token), refresh+-- rotation, the public JWKS document, and the @RequireRole "admin"@ guard (403/200).+module Main (main) where++import Control.Monad (replicateM_)+import Crypto.JOSE.Compact (decodeCompact)+import Crypto.JOSE.Error (runJOSE)+import Crypto.JOSE.JWK (JWK, JWKSet)+import Crypto.JWT (ClaimsSet, JWTError, SignedJWT, defaultJWTValidationSettings, verifyClaims)+import Data.Aeson (Value (..), decode, encode, object, toJSON, (.=))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as K+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.CaseInsensitive qualified as CI+import Data.Foldable (forM_, toList)+import Data.Generics.Labels ()+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as Text+import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)+import Effectful (Eff, runEff)+import GHC.Generics (Generic)+import Network.HTTP.Client+  ( Manager,+    RequestBody (RequestBodyLBS),+    applyBasicAuth,+    defaultManagerSettings,+    httpLbs,+    method,+    newManager,+    parseRequest,+    redirectCount,+    requestBody,+    requestHeaders,+    responseBody,+    responseHeaders,+    responseStatus,+    urlEncodedBody,+  )+import Network.HTTP.Types (Header, statusCode)+import Network.HTTP.Types.URI (parseSimpleQuery, urlEncode)+import Network.Wai (Application, Request)+import Network.Wai.Handler.Warp (testWithApplication)+import Servant+  ( Context (EmptyContext, (:.)),+    ErrorFormatters,+    Get,+    Handler,+    JSON,+    NamedRoutes,+    Proxy (Proxy),+    Server,+    serveWithContext,+    type (:<|>) ((:<|>)),+    type (:>),+  )+import Servant.API.Generic (type (:-))+import Servant.Health (ProbeVerdict (Healthy))+import Servant.Server.Experimental.Auth (AuthHandler)+import Servant.Server.Generic (genericServe)+import Shomei.Account.Email.Domain (emailText, mkEmail)+import Shomei.Account.LoginId.Domain (mkLoginId)+import Shomei.Account.Notification.Domain (Notification (..))+import Shomei.Account.OneTimeToken.Domain (OneTimeToken (..))+import Shomei.Account.Password.Domain (PlainPassword (..))+import Shomei.Account.User.Domain (User (..), UserStatus (UserActive, UserSuspended))+import Shomei.Account.User.Dto (UserResponse)+import Shomei.Account.User.Store (updateUserStatus)+import Shomei.Audit.Event.Domain qualified as Event+import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Permission (..), Role (..), Scope (..))+import Shomei.Authorization.Role.Store (allowPermission, defineRole, disallowPermission)+import Shomei.Authorization.Role.Workflow (grantRoleTo, revokeRoleFrom)+import Shomei.Authorization.Scope.Domain (adminScope)+import Shomei.Config (CookieConfig (..), ImpersonationConfig (..), NotifierConfig (..), OAuthConfig (..), SessionCheckMode (..), ShomeiConfig (..), TokenTransport (..), TotpConfig (..), defaultShomeiConfig)+import Shomei.Error (AuthDependency (PostgreSQL), AuthError (DependencyUnavailable, InternalAuthError))+import Shomei.Id (SessionId, UserId, genOAuthClientId, genServiceAccountDbId, genSessionId, genUserId, idText, parseId)+import Shomei.Mfa.Totp.Algorithm (base32ToSecret, totpCode, totpCounter)+import Shomei.OAuth.AuthorizationCode.Domain (AuthorizationCode (..))+import Shomei.OAuth.Client.Domain (ClientType (..), NewOAuthClient (..))+import Shomei.OAuth.Client.Store (createOAuthClient)+import Shomei.OAuth.TokenExchange.Workflow (tokenExchangeSubjectScope)+import Shomei.OAuth.TokenGrant.Workflow (pkceChallengeFor)+import Shomei.Passkey.Domain (PublicKeyBytes (..), UserHandle (..), WebAuthnCredentialId (..))+import Shomei.Prelude ((^.))+import Shomei.Servant.Api (ShomeiRoutes)+import Shomei.Servant.Auth (AuthUser, authHandler)+import Shomei.Servant.Authz (RequirePermission, RequireRole, RequireScope)+import Shomei.Servant.Error (ProblemDetails (..), problemTypeFor, shomeiErrorFormatters)+import Shomei.Servant.Middleware (problemMiddleware)+import Shomei.Servant.Result (ApplicationResult (ApplicationInternal, ApplicationUnavailable), ProblemWithRetryAfter (..), applicationError)+import Shomei.Servant.Seam (AppEffects, Env (..))+import Shomei.Servant.Server (shomeiRoutes)+import Shomei.ServiceAccount.Domain (NewServiceAccount (..))+import Shomei.ServiceAccount.Secret (sha256Hex)+import Shomei.ServiceAccount.Store (createServiceAccount)+import Shomei.Session.Authentication.Workflow qualified as Wf+import Shomei.Session.Command (SignupCommand (..))+import Shomei.Session.LoginAttempt.Domain (AccountKey (..))+import Shomei.Session.Store (revokeAllUserSessions)+import Shomei.Session.Token.Domain (AccessToken (..))+import Shomei.SigningKey.Jwks.Jwt (KeySet (..), jwksDocument, keySetPublicJwks)+import Shomei.SigningKey.Key.Jwt (generateSigningKey)+import Shomei.SigningKey.Sign.Jwt (runTokenSignerJwt, signAccessToken)+import Shomei.SigningKey.Verify.Jwt (runTokenVerifierJwt)+import Shomei.Test.InMemory+  ( World (..),+    emptyWorld,+    runAuthEventPublisher,+    runAuthEventReader,+    runAuthUnitOfWork,+    runClaimsEnricherNull,+    runClock,+    runCredentialStore,+    runInMemory,+    runLoginAttemptStore,+    runNotifier,+    runOAuthClientStore,+    runOAuthCodeStore,+    runPasskeyStore,+    runPasswordBreachCheckerFake,+    runPasswordHasher,+    runPasswordResetTokenStore,+    runPendingCeremonyStore,+    runRecoveryCodeStore,+    runRefreshTokenStore,+    runRoleStore,+    runServiceAccountStore,+    runSessionStore,+    runSigningKeyStore,+    runTokenGen,+    runTotpCredentialStore,+    runUserStore,+    runVerificationTokenStore,+    runWebAuthnCeremonyFake,+  )+import Shomei.Time.Store (now)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase, (@?=))++serviceLoginId :: Text+serviceLoginId = "connector-rei"++servicePassword :: Text+servicePassword = "correct horse battery staple"++ingestScope :: Scope+ingestScope = Scope "kawa:ingest"++-- | The test API: the whole served Shōmei tree ('ShomeiRoutes', so application routes answer+-- under @\/v1@ exactly as they do in production) plus two host routes protected /only/ by the+-- 'RequireRole' and 'RequireScope' combinators. Their handlers contain no authorization code+-- at all, so the 401/403/200 assertions below prove the route type alone enforces — which is+-- the entire point of the combinators having 'HasServer' instances.+--+-- The two host routes are deliberately unversioned: they belong to the embedding application,+-- not to Shōmei, and a host is free to shape its own paths.+--+-- The combinators sit where 'Authenticated' used to: they run the same auth handler themselves+-- and pass the resulting 'AuthUser' through to the handler.+type TestAPI =+  NamedRoutes ShomeiRoutes+    :<|> RequireRole "admin" :> "admin" :> "users" :> Get '[JSON] [UserResponse]+    :<|> RequireScope "kawa:ingest" :> "ingest" :> Get '[JSON] [UserResponse]+    :<|> RequirePermission "projects:write" :> "host" :> "projects" :> Get '[JSON] [UserResponse]++data DispatchAccount mode = DispatchAccount+  { accountMarker :: mode :- "account" :> Get '[JSON] Text+  }+  deriving stock (Generic)++data DispatchSession mode = DispatchSession+  { sessionMarker :: mode :- "session" :> Get '[JSON] Text+  }+  deriving stock (Generic)++data DispatchAudit mode = DispatchAudit+  { auditMarker :: mode :- "audit" :> Get '[JSON] Text+  }+  deriving stock (Generic)++-- | Three independently owned records intentionally share one mount prefix. This is the+-- small, marker-valued dispatch witness for the same composition technique used by+-- 'Shomei.Servant.Api.ApplicationApi'.+data DispatchRoot mode = DispatchRoot+  { accountSlice :: mode :- "shared" :> NamedRoutes DispatchAccount,+    sessionSlice :: mode :- "shared" :> NamedRoutes DispatchSession,+    auditSlice :: mode :- "shared" :> NamedRoutes DispatchAudit+  }+  deriving stock (Generic)++dispatchApp :: Application+dispatchApp =+  genericServe+    DispatchRoot+      { accountSlice = DispatchAccount {accountMarker = pure "account"},+        sessionSlice = DispatchSession {sessionMarker = pure "session"},+        auditSlice = DispatchAudit {auditMarker = pure "audit"}+      }++dispatchScenario :: Int -> IO ()+dispatchScenario port = do+  manager <- newManager defaultManagerSettings+  forM_+    [ ("/shared/account", "account"),+      ("/shared/session", "session"),+      ("/shared/audit", "audit")+    ]+    \(path, expected) -> do+      (status, body) <- getJSON manager port path []+      status @?= 200+      body @?= Just (String expected)++testServer :: Env -> Server TestAPI+testServer env = shomeiRoutes env (pure Healthy) (pure Healthy) :<|> adminUsersH :<|> ingestH :<|> projectsH+  where+    adminUsersH :: AuthUser -> Handler [UserResponse]+    adminUsersH _user = pure []+    ingestH :: AuthUser -> Handler [UserResponse]+    ingestH _user = pure []+    -- No authorization code of its own: the RequirePermission combinator alone gates it.+    projectsH :: AuthUser -> Handler [UserResponse]+    projectsH _user = pure []++-- | The test app wraps the Servant application in 'problemMiddleware', exactly as+-- 'Shomei.Server.Boot.application' does, so the 405 assertions exercise the real stack.+app :: Env -> Application+app env = problemMiddleware (serveWithContext (Proxy @TestAPI) ctx (testServer env))+  where+    ctx :: Context '[AuthHandler Request AuthUser, ErrorFormatters]+    ctx =+      authHandler env+        :. shomeiErrorFormatters+        :. EmptyContext++-- | The hybrid runner: in-memory stores + real @jose@ signer/verifier, in the same+-- effect order as EP-2's @runInMemory@ (so 'AppEffects' lines up).+runHybrid :: IORef World -> JWK -> JWKSet -> ShomeiConfig -> Eff AppEffects a -> IO a+runHybrid ref jwk jwkset cfg =+  runEff+    . runTokenGen ref+    . runClock ref+    . runSigningKeyStore ref+    . runAuthEventReader ref+    . runAuthEventPublisher ref+    . runTokenVerifierJwt jwkset cfg+    . runTokenSignerJwt jwk cfg+    . runPasswordHasher ref+    . runPasswordBreachCheckerFake ref+    . runWebAuthnCeremonyFake ref+    . runClaimsEnricherNull+    . runNotifier ref+    . runRecoveryCodeStore ref+    . runTotpCredentialStore ref+    . runOAuthCodeStore ref+    . runOAuthClientStore ref+    . runServiceAccountStore ref+    . runPendingCeremonyStore ref+    . runPasskeyStore ref+    . runLoginAttemptStore ref+    . runPasswordResetTokenStore ref+    . runVerificationTokenStore ref+    . runAuthUnitOfWork ref+    . runRefreshTokenStore ref+    . runSessionStore ref+    . runCredentialStore ref+    . runRoleStore ref+    . runUserStore ref++-- | Grant the @admin@ role to a user through the real audited workflow, straight against the+-- in-memory world the server is running on. The next token minted for that user (by login or+-- refresh) will carry the role.+grantAdminTo :: IORef World -> Text -> IO ()+grantAdminTo ref userIdText = do+  uid <- parseUserId userIdText+  outcome <- runInMemory ref (grantRoleTo Nothing Nothing uid (Role "admin"))+  case outcome of+    Right True -> pure ()+    Right False -> assertFailure "expected the admin grant to be new"+    Left e -> assertFailure ("granting admin failed: " <> show e)++-- | The inverse. The next token minted for the user carries no @admin@ role.+revokeAdminFrom :: IORef World -> Text -> IO ()+revokeAdminFrom ref userIdText = do+  uid <- parseUserId userIdText+  outcome <- runInMemory ref (revokeRoleFrom Nothing uid (Role "admin"))+  case outcome of+    Right True -> pure ()+    Right False -> assertFailure "expected an admin grant to revoke"+    Left e -> assertFailure ("revoking admin failed: " <> show e)++parseUserId :: Text -> IO UserId+parseUserId t =+  either (\e -> assertFailure ("bad user id " <> show t <> ": " <> show e)) pure (parseId t)++-- | Revoke every session of a user straight against the in-memory world the server is running on,+-- without going through HTTP. This is what an administrator's suspend does+-- ('Shomei.Account.Admin.Workflow.suspendUser' calls the very same port operation), so a scenario that+-- uses it is reproducing the real incident, not an artificial one.+revokeAllSessionsOf :: IORef World -> Text -> IO ()+revokeAllSessionsOf ref userIdText = do+  uid <- parseUserId userIdText+  runInMemory ref do+    ts <- now+    revokeAllUserSessions uid ts++suspendUserIn :: IORef World -> UserId -> IO ()+suspendUserIn ref uid = runInMemory ref do+  ts <- now+  _ <- updateUserStatus uid [UserActive] UserSuspended ts+  pure ()++-- | EP-9 host helpers over the in-memory world: define a role, wire a permission on or off it,+-- and grant a role to a user through the audited workflow — the operator moves a token check+-- into the store, exactly as @shomei-admin roles@ would on a real box.+defineRoleIn :: IORef World -> Role -> IO ()+defineRoleIn ref role =+  runInMemory ref do+    ts <- now+    _ <- defineRole role Nothing ts+    pure ()++allowPermissionIn :: IORef World -> Role -> Permission -> IO ()+allowPermissionIn ref role perm =+  runInMemory ref do+    ts <- now+    _ <- allowPermission role perm ts+    pure ()++disallowPermissionIn :: IORef World -> Role -> Permission -> IO ()+disallowPermissionIn ref role perm =+  runInMemory ref do+    _ <- disallowPermission role perm+    pure ()++grantRoleIn :: IORef World -> Text -> Role -> IO ()+grantRoleIn ref userIdText role = do+  uid <- parseUserId userIdText+  outcome <- runInMemory ref (grantRoleTo Nothing Nothing uid role)+  either (\e -> assertFailure ("granting " <> show role <> " failed: " <> show e)) (const (pure ())) outcome++-- | Mint an access token carrying the @admin@ role by signing claims directly with the in-test+-- key. Kept alongside the real grant path in (g): it isolates the combinator's claim check from+-- the store, so a failure in one does not mask a failure in the other.+mkAdminToken :: JWK -> ShomeiConfig -> IO Text+mkAdminToken jwk cfg = do+  uid <- genUserId+  sid <- genSessionId+  t <- getCurrentTime+  let claims =+        AuthClaims+          { subject = uid,+            sessionId = sid,+            issuer = cfg.issuer,+            audience = cfg.audience,+            issuedAt = t,+            expiresAt = addUTCTime 900 t,+            authTime = t,+            scopes = Set.empty,+            roles = Set.fromList [Role "admin"],+            permissions = Set.empty,+            actor = Nothing,+            extraClaims = mempty+          }+  r <- signAccessToken jwk claims+  case r of+    Right (AccessToken tok) -> pure tok+    Left e -> assertFailure ("admin token signing failed: " <> show e)++-- | Mint a fresh access token carrying the impersonation scope (the workflows issue no+-- scopes, so a token holding @impersonate:user@ must be signed directly). Issued at the+-- world clock @t0@, so the freshness check passes against the in-memory 'Clock'.+-- | Mint an access token for a /named/ subject with the given roles, scopes, and (optional)+-- impersonation actor. EP-2's admin tests need this: the self-target refusal compares the token's+-- subject with the target, and the delegated-token refusal keys off the @act@ claim.+mkTokenFor :: JWK -> ShomeiConfig -> UserId -> Set.Set Role -> Set.Set Scope -> Maybe UserId -> IO Text+mkTokenFor jwk cfg uid roles scopes actor = do+  sid <- genSessionId+  t <- getCurrentTime+  mkTokenForSession jwk cfg uid sid roles scopes actor t++-- | Sign claims for an existing session at a caller-selected issuance time. Provenance and+-- session-liveness scenarios use this helper so a hand-minted token still names a real login.+mkTokenForSession :: JWK -> ShomeiConfig -> UserId -> SessionId -> Set.Set Role -> Set.Set Scope -> Maybe UserId -> UTCTime -> IO Text+mkTokenForSession jwk cfg uid sid roles scopes actor t = do+  let claims =+        AuthClaims+          { subject = uid,+            sessionId = sid,+            issuer = cfg.issuer,+            audience = cfg.audience,+            issuedAt = t,+            expiresAt = addUTCTime 900 t,+            authTime = t,+            scopes = scopes,+            roles = roles,+            permissions = Set.empty,+            actor = actor,+            extraClaims = mempty+          }+  r <- signAccessToken jwk claims+  case r of+    Right (AccessToken tok) -> pure tok+    Left e -> assertFailure ("could not sign token: " <> show e)++main :: IO ()+main = do+  jwk <- generateSigningKey+  let cfg = defaultShomeiConfig (Issuer "https://shomei.test") (Audience "shomei-clients")+      jwkset = keySetPublicJwks (KeySet jwk [])+  t0 <- getCurrentTime+  ref <- newIORef (emptyWorld t0)+  -- Build an 'Env' over a FRESH in-memory World. Each test case that mutates state must use+  -- its own env: tasty runs cases in parallel, so sharing one World IORef races.+  let mkEnvWith cfg' r =+        Env+          { runPorts = fmap Right . runHybrid r jwk jwkset cfg',+            config = cfg',+            jwksJson = pure (fromMaybe (Object KM.empty) (decode (jwksDocument [jwk]))),+            accountKeyOf = AccountKey+          }+      mkEnv = mkEnvWith cfg+      freshEnv = mkEnv <$> newIORef (emptyWorld t0)+      -- 'emailVerificationRequired' on, over its own World. The World ref comes back too, so+      -- the scenario can read the verification token the notifier captured.+      freshGatedEnv = do+        r <- newIORef (emptyWorld t0)+        pure (r, mkEnvWith gatedCfg r)+      -- The World ref comes back so the RequirePermission scenario can wire roles/permissions+      -- and grant them, exactly as an operator would through the admin CLI.+      freshPermissionEnv = do+        r <- newIORef (emptyWorld t0)+        pure (r, mkEnv r)+      -- The session-check knob turned ON, over its own World. The World ref comes back so the+      -- scenario can revoke the session out of band, exactly as an administrator would.+      sessionCheckCfg = cfg {sessionCheckMode = VerifyTokenAndSession}+      freshSessionCheckEnv = do+        r <- newIORef (emptyWorld t0)+        pure (r, mkEnvWith sessionCheckCfg r)+      gatedCfg = cfg {notifierConfig = cfg.notifierConfig {emailVerificationRequired = True}}+      -- One env per transport, each over its own World (tasty runs cases in parallel).+      cookieCfg = cfg {tokenTransport = HttpOnlyCookie}+      insecureCookieCfg = cookieCfg {cookieConfig = cookieCfg.cookieConfig {secure = False}}+      bothCfg = cfg {tokenTransport = BearerAndCookie}+      freshCookieEnv = mkEnvWith cookieCfg <$> newIORef (emptyWorld t0)+      freshInsecureCookieEnv = mkEnvWith insecureCookieCfg <$> newIORef (emptyWorld t0)+      freshBothEnv = mkEnvWith bothCfg <$> newIORef (emptyWorld t0)+      -- EP-4: a database-backed service account (not a config-defined one) in its own World.+      -- Returns its client_id, which the scenario authenticates with.+      freshOAuthEnv = do+        r <- newIORef (emptyWorld t0)+        clientId <- seedOAuthAccount r jwk jwkset cfg t0+        pure (clientId, mkEnv r)+      -- EP-5: the OIDC provider switched on. The issuer doubles as the published base URL, so+      -- every endpoint in the discovery document is derived from 'cfg's issuer.+      oidcCfg = cfg {oauthConfig = cfg.oauthConfig {oidcEnabled = True}}+      freshOidcEnv = mkEnvWith oidcCfg <$> newIORef (emptyWorld t0)+      -- EP-5 M2: an OIDC-enabled world holding one confidential and one public client. Returns+      -- the World ref (so a scenario can read the stored code row) and both client ids.+      freshAuthorizeEnv loginUrl = do+        r <- newIORef (emptyWorld t0)+        let c = oidcCfg {oauthConfig = oidcCfg.oauthConfig {loginUrl}}+        (confId, pubId) <- seedOAuthClients r jwk jwkset c t0+        pure (r, confId, pubId, mkEnvWith c r)+      -- The authorize path authenticates through 'resolveAuthUser', not the Servant combinator.+      -- Give it its own token-and-session world so revocation coverage proves that path is wired+      -- to the same derived verifier.+      freshSessionAuthorizeEnv = do+        r <- newIORef (emptyWorld t0)+        let c = sessionCheckCfg {oauthConfig = sessionCheckCfg.oauthConfig {oidcEnabled = True}}+        (confId, pubId) <- seedOAuthClients r jwk jwkset c t0+        pure (r, confId, pubId, mkEnvWith c r)+      -- EP-2's admin scenarios need the World ref (to grant the admin role in the store) and+      -- the signing key (to mint scoped/delegated tokens by hand).+      freshAdminEnv = do+        r <- newIORef (emptyWorld t0)+        pure (r, mkEnv r)+      -- EP-6: a world holding two database-backed service accounts — one with the+      -- token-exchange:subject gate scope, one without — for the RFC 8693 on-behalf-of scenario.+      freshExchangeEnv = do+        r <- newIORef (emptyWorld t0)+        gateId <- seedExchangeAccount r jwk jwkset cfg t0 "svcgate" (Set.fromList [ingestScope, tokenExchangeSubjectScope])+        noGateId <- seedExchangeAccount r jwk jwkset cfg t0 "svcnogate" (Set.singleton ingestScope)+        adminId <- seedExchangeAccount r jwk jwkset cfg t0 "svcadmin" (Set.singleton adminScope)+        pure (r, gateId, noGateId, adminId, mkEnv r)+      -- Plan 52 M3: two OAuth clients and service accounts on both sides of the global-admin+      -- boundary, isolated from the broader token-exchange matrix.+      freshRevokeEnv = do+        r <- newIORef (emptyWorld t0)+        (confId, _) <- seedOAuthClients r jwk jwkset oidcCfg t0+        otherConfId <- runHybrid r jwk jwkset oidcCfg do+          ocid <- genOAuthClientId+          client <-+            createOAuthClient+              NewOAuthClient+                { oauthClientId = ocid,+                  clientId = idText ocid,+                  secretHash = Just (sha256Hex confidentialClientSecret),+                  clientType = ConfidentialClient,+                  displayName = "other confidential",+                  redirectUris = [authorizeRedirectUri],+                  allowedScopes = Set.fromList [Scope "openid", Scope "profile", Scope "email"],+                  createdAt = t0+                }+          pure (client ^. #clientId)+        plainId <- seedExchangeAccount r jwk jwkset oidcCfg t0 "svcplain" (Set.singleton ingestScope)+        adminId <- seedExchangeAccount r jwk jwkset oidcCfg t0 "svcrevokeadmin" (Set.singleton adminScope)+        pure (confId, otherConfId, plainId, adminId, mkEnvWith oidcCfg r)+      -- Plan 51: OIDC on, a login URL configured (so a wrongful bounce is visible as a 302),+      -- both OAuth clients, and a service account holding the token-exchange gate scope.+      freshProvenanceEnv = do+        r <- newIORef (emptyWorld t0)+        let c = oidcCfg {oauthConfig = oidcCfg.oauthConfig {loginUrl = Just "https://host.test/login"}}+        (confId, pubId) <- seedOAuthClients r jwk jwkset c t0+        svcId <- seedExchangeAccount r jwk jwkset c t0 "svcprov" (Set.fromList [ingestScope, tokenExchangeSubjectScope])+        pure (r, confId, pubId, svcId, mkEnvWith c r)+      -- EP-7: TOTP enabled, over its own World. The World ref comes back so the scenario can+      -- read (and advance) the deterministic clock to move TOTP time-step counters forward.+      totpCfg = cfg {totpConfig = cfg.totpConfig {totpEnabled = True}}+      freshTotpEnv = do+        r <- newIORef (emptyWorld t0)+        pure (r, mkEnvWith totpCfg r)+      env = mkEnv ref+  adminToken <- mkAdminToken jwk cfg+  defaultMain (tests ref env freshEnv freshGatedEnv freshPermissionEnv freshSessionCheckEnv freshCookieEnv freshInsecureCookieEnv freshBothEnv freshOAuthEnv freshOidcEnv freshAuthorizeEnv freshSessionAuthorizeEnv freshAdminEnv freshExchangeEnv freshRevokeEnv freshProvenanceEnv freshTotpEnv t0 jwk cfg adminToken)++seedServiceUser :: IORef World -> JWK -> JWKSet -> ShomeiConfig -> IO User+seedServiceUser ref jwk jwkset cfg = do+  loginId <- either (assertFailure . ("bad service login id: " <>) . show) pure (mkLoginId serviceLoginId)+  email <- either (assertFailure . ("bad service email: " <>) . show) pure (mkEmail "connector-rei@example.com")+  result <-+    runHybrid+      ref+      jwk+      jwkset+      cfg+      ( Wf.signup+          cfg+          SignupCommand+            { loginId,+              email = Just email,+              password = PlainPassword servicePassword,+              displayName = Just "Connector Rei"+            }+      )+  case result of+    Right (user, _) -> pure user+    Left err -> assertFailure ("service user signup failed: " <> show err)++-- | EP-4: seed a database-backed service account (and its backing user) into the in-memory+-- world, returning its @client_id@. The secret is 'oauthClientSecret'.+seedOAuthAccount :: IORef World -> JWK -> JWKSet -> ShomeiConfig -> UTCTime -> IO Text+seedOAuthAccount ref jwk jwkset cfg createdAt = do+  serviceUser <- seedServiceUser ref jwk jwkset cfg+  runHybrid ref jwk jwkset cfg do+    said <- genServiceAccountDbId+    account <-+      createServiceAccount+        NewServiceAccount+          { serviceAccountId = said,+            clientId = idText said,+            userId = serviceUser ^. #userId,+            secretHash = sha256Hex oauthClientSecret,+            displayName = "rei connector",+            allowedScopes = Set.singleton ingestScope,+            createdAt+          }+    pure (account ^. #clientId)++oauthClientSecret :: Text+oauthClientSecret = "oauth+test:secret"++-- | EP-6: sign up a uniquely-named backing user (so several service accounts can coexist in one+-- world without colliding on the fixed 'seedServiceUser' identity).+seedServiceUserNamed :: IORef World -> JWK -> JWKSet -> ShomeiConfig -> Text -> IO User+seedServiceUserNamed ref jwk jwkset cfg name = do+  loginId <- either (assertFailure . ("bad service login id: " <>) . show) pure (mkLoginId name)+  email <- either (assertFailure . ("bad service email: " <>) . show) pure (mkEmail (name <> "@example.com"))+  result <-+    runHybrid+      ref+      jwk+      jwkset+      cfg+      (Wf.signup cfg SignupCommand {loginId, email = Just email, password = PlainPassword servicePassword, displayName = Just name})+  case result of+    Right (user, _) -> pure user+    Left err -> assertFailure ("named service user signup failed: " <> show err)++-- | EP-6: seed a database-backed service account with an explicit scope set, returning its+-- @client_id@. The secret is 'oauthClientSecret'.+seedExchangeAccount :: IORef World -> JWK -> JWKSet -> ShomeiConfig -> UTCTime -> Text -> Set.Set Scope -> IO Text+seedExchangeAccount ref jwk jwkset cfg createdAt name scopes = do+  serviceUser <- seedServiceUserNamed ref jwk jwkset cfg name+  runHybrid ref jwk jwkset cfg do+    said <- genServiceAccountDbId+    account <-+      createServiceAccount+        NewServiceAccount+          { serviceAccountId = said,+            clientId = idText said,+            userId = serviceUser ^. #userId,+            secretHash = sha256Hex oauthClientSecret,+            displayName = name,+            allowedScopes = scopes,+            createdAt+          }+    pure (account ^. #clientId)++-- | EP-4: @POST \/oauth\/token@ end to end, over the real Servant tree.+--+-- Proves the three things a stock OAuth2 client depends on: both client-authentication methods+-- work; a minted token is a real Shōmei token that satisfies the 'RequireScope' combinator on a+-- downstream route; and every failure is an RFC 6749 §5.2 object rather than a problem document.+scenarioOAuthToken :: Text -> Int -> IO ()+scenarioOAuthToken clientId port = do+  mgr <- newManager defaultManagerSettings++  -- (1) client_secret_basic, with an explicit in-allow-list scope.+  basic <-+    postForm+      mgr+      port+      "/oauth/token"+      (Just (clientId, oauthClientSecret))+      [("grant_type", "client_credentials"), ("scope", "kawa:ingest")]+  let (basicStatus, basicHdrs, basicBody) = basic+  basicStatus @?= 200+  -- RFC 6749 §5.1 requires the token response to be uncacheable.+  headerValue "Cache-Control" basicHdrs @?= Just "no-store"+  headerValue "Pragma" basicHdrs @?= Just "no-cache"+  doc <- must "basic: body" basicBody+  (dig ["token_type"] doc >>= asText) @?= Just "Bearer"+  (dig ["scope"] doc >>= asText) @?= Just "kawa:ingest"+  case dig ["expires_in"] doc of+    Just (Number n) -> (round n :: Int) @?= 300+    other -> assertFailure ("basic: expires_in not a number: " <> show other)+  token <- must "basic: access_token" (dig ["access_token"] doc >>= asText)++  -- (2) The minted token is a real Shōmei token: it satisfies the RequireScope combinator on a+  -- host route that contains no authorization code of its own.+  (ingestStatus, _) <- getJSON mgr port "/ingest" [("Authorization", "Bearer " <> Text.encodeUtf8 token)]+  ingestStatus @?= 200++  -- (3) client_secret_post: credentials in the body instead of the header. No scope parameter,+  -- so the account's whole allow-list is granted and echoed back.+  post <-+    postForm+      mgr+      port+      "/oauth/token"+      Nothing+      [ ("grant_type", "client_credentials"),+        ("client_id", Text.encodeUtf8 clientId),+        ("client_secret", Text.encodeUtf8 oauthClientSecret)+      ]+  let (postStatus, _, postBody) = post+  postStatus @?= 200+  postDoc <- must "post: body" postBody+  (dig ["scope"] postDoc >>= asText) @?= Just "kawa:ingest"++  -- (4) A wrong secret is invalid_client, with the Basic challenge.+  badSecret <-+    postForm mgr port "/oauth/token" (Just (clientId, "wrong")) [("grant_type", "client_credentials")]+  assertOAuthError "wrong secret" 401 "invalid_client" badSecret+  headerValue "WWW-Authenticate" (headersOf badSecret) @?= Just "Basic realm=\"shomei\""++  -- (5) An unknown client is the SAME response, byte for byte in its body: nothing discloses+  -- whether the client id exists.+  unknown <-+    postForm mgr port "/oauth/token" (Just ("svcacct_nope", "wrong")) [("grant_type", "client_credentials")]+  assertOAuthError "unknown client" 401 "invalid_client" unknown+  bodyOf unknown @?= bodyOf badSecret++  -- (6) No credentials at all is also invalid_client.+  noCreds <- postForm mgr port "/oauth/token" Nothing [("grant_type", "client_credentials")]+  assertOAuthError "no credentials" 401 "invalid_client" noCreds++  -- (7) A scope outside allowed_scopes is invalid_scope, not a silent downgrade.+  badScope <-+    postForm+      mgr+      port+      "/oauth/token"+      (Just (clientId, oauthClientSecret))+      [("grant_type", "client_credentials"), ("scope", "channel:egress")]+  assertOAuthError "scope outside allow-list" 400 "invalid_scope" badScope++  -- (8) An explicitly empty scope is invalid_scope, not "grant nothing".+  emptyScope <-+    postForm+      mgr+      port+      "/oauth/token"+      (Just (clientId, oauthClientSecret))+      [("grant_type", "client_credentials"), ("scope", "")]+  assertOAuthError "empty scope" 400 "invalid_scope" emptyScope++  -- (9) A missing grant_type is invalid_request...+  noGrant <- postForm mgr port "/oauth/token" (Just (clientId, oauthClientSecret)) []+  assertOAuthError "missing grant_type" 400 "invalid_request" noGrant++  -- (10) ...and a grant this server does not implement is unsupported_grant_type. (EP-5 made+  -- authorization_code and refresh_token supported arms; `password` is the OAuth Security BCP's+  -- omitted grant, which Shōmei will never add.)+  password <-+    postForm mgr port "/oauth/token" (Just (clientId, oauthClientSecret)) [("grant_type", "password")]+  assertOAuthError "grant_type=password" 400 "unsupported_grant_type" password++-- | A human's login token carries no scopes, so it must NOT satisfy the scope-guarded route that+-- an OAuth client-credentials token does. Guards against the grant leaking scopes onto sessions.+scenarioOAuthScopeIsolation :: Int -> IO ()+scenarioOAuthScopeIsolation port = do+  mgr <- newManager defaultManagerSettings+  let email = "scopeisolation@example.com" :: Text+      pw = "correct horse battery staple" :: Text+  (sStatus, sBody) <- postJSON mgr port "/v1/auth/signup" (object ["loginId" .= email, "email" .= email, "password" .= pw, "displayName" .= ("S" :: Text)])+  sStatus @?= 201+  doc <- must "signup body" sBody+  token <- must "signup access token" (dig ["token", "accessToken"] doc >>= asText)+  (ingestStatus, _, ingestBody) <- getRaw mgr port "/ingest" [("Authorization", "Bearer " <> Text.encodeUtf8 token)]+  ingestStatus @?= 403+  -- and it is a problem document, because /ingest is an ordinary route, not an /oauth/* one+  problem <- must "ingest 403 body" ingestBody+  (dig ["code"] problem >>= asText) @?= Just "missing_scope"++-- | EP-9 end-to-end: the @RequirePermission "projects:write"@ combinator on a host route enforces+-- with no handler code, and the check is /re-wireable/ from the role→permission catalog without+-- touching the route.+--+--   * no token → 401 (the combinator authenticates before it authorizes);+--   * a login token whose principal has the permission on none of its roles → 403;+--   * after granting a role that has the permission allowed, a fresh login token → 200;+--   * the re-wiring proof: disallow the permission from that role and it is 403 again at the next+--     mint; allow it to a /different/ role the user also holds and it is 200 again — the consumer+--     (this route) never changed.+scenarioRequirePermission :: IORef World -> Int -> IO ()+scenarioRequirePermission ref port = do+  mgr <- newManager defaultManagerSettings+  let email = "perms@example.com" :: Text+      pw = "correct horse battery staple" :: Text+      loginBody = object ["loginId" .= email, "password" .= pw]+      projects tok = fst <$> getJSON mgr port "/host/projects" (bearer tok)+      loginAccess = do+        (st, body) <- postJSON mgr port "/v1/auth/login" loginBody+        st @?= 200+        resp <- must "login body" body+        must "login accessToken" (dig ["token", "accessToken"] resp >>= asText)+      supportRole = Role "support"+      staffRole = Role "staff"+      writePerm = Permission "projects:write"++  -- Sign up and capture the user id (for the grants) and the first token (no roles yet).+  (sStatus, sBody) <- postJSON mgr port "/v1/auth/signup" (object ["loginId" .= email, "email" .= email, "password" .= pw, "displayName" .= ("P" :: Text)])+  sStatus @?= 201+  doc <- must "signup body" sBody+  uid <- must "signup user id" (dig ["user", "userId"] doc >>= asText)+  token0 <- must "signup access token" (dig ["token", "accessToken"] doc >>= asText)++  -- No token → 401; a token without the permission → 403.+  noTok <- projects ""+  -- An empty bearer is no usable credential, so the auth handler answers 401.+  (noHeaderStatus, _) <- getJSON mgr port "/host/projects" []+  noHeaderStatus @?= 401+  noTok @?= 401 -- "Bearer " with an empty token is still no valid token+  forbidden <- projects token0+  forbidden @?= 403++  -- Wire support → projects:write and grant support; a fresh login now opens the route.+  defineRoleIn ref supportRole+  allowPermissionIn ref supportRole writePerm+  grantRoleIn ref uid supportRole+  token1 <- loginAccess+  ok1 <- projects token1+  ok1 @?= 200+  -- The pre-grant token is unchanged (staleness contract): still 403.+  stale <- projects token0+  stale @?= 403++  -- Re-wiring proof, part 1: disallow the permission from support. The next mint loses it.+  disallowPermissionIn ref supportRole writePerm+  token2 <- loginAccess+  afterDisallow <- projects token2+  afterDisallow @?= 403++  -- Re-wiring proof, part 2: grant the user a SECOND role and allow the permission to it instead.+  -- The user reaches the same route again — with zero changes to the route or its handler.+  defineRoleIn ref staffRole+  grantRoleIn ref uid staffRole+  allowPermissionIn ref staffRole writePerm+  token3 <- loginAccess+  rewired <- projects token3+  rewired @?= 200++-- | Every failure, from every layer, is an RFC 9457 problem document.+--+-- Each assertion names the layer it exercises, because they fail for different reasons: the+-- auth handler and the authz combinator throw before any handler runs; principal parsing+-- throws inside one; Servant's @ErrorFormatters@ handle its own request parsers; and the bare+-- 405 a method mismatch raises sits below every Servant hook, converted by 'problemMiddleware'.+scenarioProblemEnvelope :: Int -> IO ()+scenarioProblemEnvelope port = do+  mgr <- newManager defaultManagerSettings++  -- (1) The auth handler: no credential at all. The commonest failure in any deployment.+  r1 <- getRaw mgr port "/v1/auth/me" []+  assertProblem "missing token" 401 "missing_token" r1+  headerValue "WWW-Authenticate" (headersOf r1) @?= Just "Bearer"++  -- (2) The auth handler: a credential that fails verification. Deliberately indistinguishable+  --     from an expired one -- the code is the same.+  r2 <- getRaw mgr port "/v1/auth/me" (bearer "garbage.token.value")+  assertProblem "invalid token" 401 "token_invalid" r2+  headerValue "WWW-Authenticate" (headersOf r2) @?= Just "Bearer"++  -- (3) The authorization combinator: authenticated, but lacking the role. 403, and no+  --     WWW-Authenticate -- the credential itself was fine.+  let signupBody' =+        object+          [ "loginId" .= ("envelope@example.com" :: Text),+            "email" .= ("envelope@example.com" :: Text),+            "password" .= ("correct horse battery staple" :: Text),+            "displayName" .= ("Envelope" :: Text)+          ]+  (_, sBody) <- postJSON mgr port "/v1/auth/signup" signupBody'+  sresp <- must "signup body" sBody+  access <- must "signup accessToken" (dig ["token", "accessToken"] sresp >>= asText)+  r3 <- getRaw mgr port "/admin/users" (bearer access)+  assertProblem "missing role" 403 "missing_role" r3+  headerValue "WWW-Authenticate" (headersOf r3) @?= Nothing++  -- (4) A structurally valid body missing the required loginId fails in Servant's decoder.+  r4 <- postRaw' mgr port "/v1/auth/login" [] (object ["password" .= ("x" :: Text)])+  assertProblem "missing required loginId" 400 "body_parse_error" r4+  assertBool "missing loginId carries a decoder detail" (isJust (bodyOf r4 >>= dig ["detail"]))++  -- (5) Servant's own body parser, via ErrorFormatters. The parse message rides in `detail`.+  r5 <- postRawBytes mgr port "/v1/auth/signup" "{"+  assertProblem "body parse error" 400 "body_parse_error" r5+  assertBool "body_parse_error carries a detail" (isJust (bodyOf r5 >>= dig ["detail"]))++  -- (6) Servant's not-found formatter.+  r6 <- getRaw mgr port "/no/such/route" []+  assertProblem "unknown route" 404 "not_found" r6++  -- (7) The method check -- below every Servant hook, rewritten by problemMiddleware.+  r7 <- getRaw mgr port "/v1/auth/login" []+  assertProblem "method not allowed" 405 "method_not_allowed" r7++-- | The versioning boundary: every application route answers only under @\/v1@, and the+-- protocol/infrastructure endpoints answer only at the root. Both halves are asserted, because+-- a record that accidentally nested the probes under @\/v1@ would still pass the first half.+--+-- The old unprefixed paths are gone outright — no redirect, no 410 — so an unmigrated client+-- gets a 404 problem document naming nothing it can act on but the CHANGELOG. That is the+-- declared cost of the pre-1.0 breaking window.+scenarioVersionBoundary :: Int -> IO ()+scenarioVersionBoundary port = do+  mgr <- newManager defaultManagerSettings++  -- The old paths are 404 -- and a 404 that is itself a problem document.+  old <- postRaw' mgr port "/auth/login" [] (object ["loginId" .= ("someone" :: Text)])+  assertProblem "old login path" 404 "not_found" old+  oldMe <- getRaw mgr port "/auth/me" []+  assertProblem "old me path" 404 "not_found" oldMe++  -- ...and the versioned one routes: no token, so the auth handler answers 401, which is proof+  -- the request reached the route rather than falling off the end of the tree.+  newMe <- getRaw mgr port "/v1/auth/me" []+  assertProblem "versioned me path routes" 401 "missing_token" newMe++  -- Probe leaves and JWKS stay at the root.+  (liveStatus, _) <- getJSON mgr port "/health/live" []+  liveStatus @?= 200+  (readyStatus, _) <- getJSON mgr port "/health/ready" []+  readyStatus @?= 200+  (jwksStatus, jwksHdrs, _) <- getRaw mgr port "/.well-known/jwks.json" []+  jwksStatus @?= 200+  headerValue "Cache-Control" jwksHdrs @?= Just "public, max-age=300"++  -- ...and nothing bleeds into /v1: the version prefix covers the application record only.+  v1Health <- getRaw mgr port "/v1/health/live" []+  assertProblem "no /v1/health/live" 404 "not_found" v1Health+  oldHealth <- getRaw mgr port "/health" []+  assertProblem "no compatibility /health route" 404 "not_found" oldHealth+  oldReady <- getRaw mgr port "/ready" []+  assertProblem "no compatibility /ready route" 404 "not_found" oldReady+  v1Jwks <- getRaw mgr port "/v1/.well-known/jwks.json" []+  assertProblem "no /v1/.well-known/jwks.json" 404 "not_found" v1Jwks++-- | The three status-code corrections, on one account.+--+-- Logout is the interesting one: it is now idempotent. A retry after a network blip, or a+-- double-tapped button, must succeed — "you are already logged out" is what the caller asked+-- for, not a failure. The second call reaches the handler because the default @sessionCheckMode@+-- is @VerifyTokenOnly@, so the access token still verifies against a revoked session; the+-- handler then swallows exactly 'SessionNotFound'.+scenarioStatusCodes :: Int -> IO ()+scenarioStatusCodes port = do+  mgr <- newManager defaultManagerSettings+  let email = "statuscodes@example.com" :: Text+      pw = "correct horse battery staple" :: Text++  -- Signup creates a user: 201, not 200.+  (sStatus, sBody) <- postJSON mgr port "/v1/auth/signup" (object ["loginId" .= email, "email" .= email, "password" .= pw, "displayName" .= ("S" :: Text)])+  sStatus @?= 201+  sresp <- must "signup body" sBody+  access <- must "signup accessToken" (dig ["token", "accessToken"] sresp >>= asText)++  -- The lifecycle *request* endpoints stay 202: the mail leaves the process later.+  (reqStatus, _) <- postJSON mgr port "/v1/auth/password-reset/request" (object ["email" .= email])+  reqStatus @?= 202++  -- Logging out twice succeeds twice.+  (out1, _) <- postJSONAuth mgr port "/v1/auth/logout" (bearer access) Null+  out1 @?= 204+  (out2, _) <- postJSONAuth mgr port "/v1/auth/logout" (bearer access) Null+  out2 @?= 204++-- ---------------------------------------------------------------------------+-- EP-2: the admin HTTP API+-- ---------------------------------------------------------------------------++-- | Sign a user up over HTTP and return @(userId, accessToken)@.+signupOver :: Manager -> Int -> Text -> IO (Text, Text)+signupOver mgr port email = do+  (status, body) <- postJSON mgr port "/v1/auth/signup" (object ["loginId" .= email, "email" .= email, "password" .= adminPassword, "displayName" .= ("U" :: Text)])+  status @?= 201+  resp <- must "signup body" body+  uid <- must "signup userId" (dig ["user", "userId"] resp >>= asText)+  tok <- must "signup accessToken" (dig ["token", "accessToken"] resp >>= asText)+  pure (uid, tok)++loginOver :: Manager -> Int -> Text -> IO Text+loginOver mgr port email = do+  (status, body) <- postJSON mgr port "/v1/auth/login" (object ["loginId" .= email, "password" .= adminPassword])+  status @?= 200+  resp <- must "login body" body+  must "login accessToken" (dig ["token", "accessToken"] resp >>= asText)++adminPassword :: Text+adminPassword = "correct horse battery staple"++-- | Promote a signed-up user to administrator through the real audited workflow, then log in so+-- the fresh token carries the granted role. This is exactly the bootstrap an operator performs+-- with @shomei-admin roles grant@.+becomeAdmin :: IORef World -> Manager -> Int -> Text -> IO Text+becomeAdmin ref mgr port email = do+  (uid, _) <- signupOver mgr port email+  grantAdminTo ref uid+  loginOver mgr port email++-- | The admin gate is a disjunction: the @admin@ role (a human) or the @shomei:admin@ scope (a+-- service token). Both work; neither is optional; an ordinary token is a 403 and no token a 401.+--+-- The 403 says @missing_role@ without mentioning the scope. Telling an unauthorized caller which+-- of two credentials would have let them in is a hint they have no business receiving.+scenarioAdminAuthzMatrix :: IORef World -> JWK -> ShomeiConfig -> Int -> IO ()+scenarioAdminAuthzMatrix ref jwk cfg port = do+  mgr <- newManager defaultManagerSettings+  (_, ordinaryToken) <- signupOver mgr port "ordinary@example.com"+  adminToken' <- becomeAdmin ref mgr port "gatekeeper@example.com"+  scopedUid <- genUserId+  scopedToken <- mkTokenFor jwk cfg scopedUid Set.empty (Set.singleton (Scope "shomei:admin")) Nothing++  noTok <- getRaw mgr port "/v1/admin/users" []+  assertProblem "no token" 401 "missing_token" noTok++  ordinary <- getRaw mgr port "/v1/admin/users" (bearer ordinaryToken)+  assertProblem "ordinary token" 403 "missing_role" ordinary+  assertBool+    "the 403 does not disclose that a shomei:admin scope would also work"+    (maybe True (not . T.isInfixOf "scope") (bodyOf ordinary >>= dig ["title"] >>= asText))++  (roleStatus, _) <- getJSON mgr port "/v1/admin/users" (bearer adminToken')+  roleStatus @?= 200+  (scopeStatus, _) <- getJSON mgr port "/v1/admin/users" (bearer scopedToken)+  scopeStatus @?= 200++-- | The lifecycle an operator actually drives: suspend a compromised account, watch the login+-- die and the sessions with it, reinstate, then soft-delete. The strict transitions mean a second+-- administrator racing the first gets a 409 rather than a misleading success.+scenarioAdminLifecycle :: IORef World -> Int -> IO ()+scenarioAdminLifecycle ref port = do+  mgr <- newManager defaultManagerSettings+  adminToken' <- becomeAdmin ref mgr port "boss@example.com"+  (targetId, _) <- signupOver mgr port "target@example.com"+  let target = "/v1/admin/users/" <> T.unpack targetId++  -- Suspend: the account stops working and its sessions are dead.+  (susp, _) <- postAuthNoBody mgr port (target <> "/suspend") (bearer adminToken')+  susp @?= 204+  (loginStatus, _) <- postJSON mgr port "/v1/auth/login" (object ["loginId" .= ("target@example.com" :: Text), "password" .= adminPassword])+  loginStatus @?= 401+  (sessStatus, sessBody) <- getJSON mgr port (target <> "/sessions") (bearer adminToken')+  sessStatus @?= 200+  sessions <- must "sessions body" sessBody+  case sessions of+    Array xs -> assertBool "every session is revoked" (all (\v -> (dig ["status"] v >>= asText) == Just "revoked") xs)+    _ -> assertFailure "expected a JSON array of sessions"++  -- A second admin racing the first learns the state already changed.+  again <- postRaw' mgr port (target <> "/suspend") (bearer adminToken') Null+  assertProblem "double suspend" 409 "invalid_user_status" again++  -- Reinstate: login works again.+  (rein, _) <- postAuthNoBody mgr port (target <> "/reinstate") (bearer adminToken')+  rein @?= 204+  (loginAgain, _) <- postJSON mgr port "/v1/auth/login" (object ["loginId" .= ("target@example.com" :: Text), "password" .= adminPassword])+  loginAgain @?= 200++  -- Soft delete: the row survives and is still listed, but refuses further transitions.+  (del, _) <- deleteAuth mgr port target (bearer adminToken')+  del @?= 204+  redelete <- deleteRaw mgr port target (bearer adminToken')+  assertProblem "delete twice" 409 "invalid_user_status" redelete+  (getStatus, getBody) <- getJSON mgr port target (bearer adminToken')+  getStatus @?= 200+  gotten <- must "get user body" getBody+  (dig ["user", "status"] gotten >>= asText) @?= Just "deleted"++  -- ...and appears in the ?status=deleted listing.+  (listStatus, listBody) <- getJSON mgr port "/v1/admin/users?status=deleted" (bearer adminToken')+  listStatus @?= 200+  listed <- must "list body" listBody+  case dig ["users"] listed of+    Just (Array xs) -> map (\v -> dig ["userId"] v >>= asText) (toList xs) @?= [Just targetId]+    _ -> assertFailure "expected a users array"++-- | Session revocation, one at a time and wholesale, and the audit row that names the admin who+-- did it. An administrative action nobody can be held responsible for is not an audit trail.+scenarioAdminSessionsAndAudit :: IORef World -> Int -> IO ()+scenarioAdminSessionsAndAudit ref port = do+  mgr <- newManager defaultManagerSettings+  adminToken' <- becomeAdmin ref mgr port "auditor@example.com"+  adminId <- must "admin id" . Just =<< userIdOf ref "auditor@example.com"+  (targetId, _) <- signupOver mgr port "victim@example.com"+  _ <- loginOver mgr port "victim@example.com" -- a second live session+  let target = "/v1/admin/users/" <> T.unpack targetId++  (sessStatus, sessBody) <- getJSON mgr port (target <> "/sessions") (bearer adminToken')+  sessStatus @?= 200+  sessions <- must "sessions" sessBody+  firstSession <- case sessions of+    Array xs | (s0 : _) <- toList xs -> must "session id" (dig ["sessionId"] s0 >>= asText)+    _ -> assertFailure "expected at least one session"++  (one, _) <- deleteAuth mgr port ("/v1/admin/sessions/" <> T.unpack firstSession) (bearer adminToken')+  one @?= 204+  (bulk, _) <- deleteAuth mgr port (target <> "/sessions") (bearer adminToken')+  bulk @?= 204++  (afterStatus, afterBody) <- getJSON mgr port (target <> "/sessions") (bearer adminToken')+  afterStatus @?= 200+  after <- must "sessions after" afterBody+  case after of+    Array xs -> assertBool "no session survives" (all (\v -> (dig ["status"] v >>= asText) == Just "revoked") xs)+    _ -> assertFailure "expected an array"++  -- The suspension event carries the acting admin, readable through the audit endpoint.+  (susp, _) <- postAuthNoBody mgr port (target <> "/suspend") (bearer adminToken')+  susp @?= 204+  (auditStatus, auditBody) <- getJSON mgr port "/v1/admin/audit/events?type=user_suspended" (bearer adminToken')+  auditStatus @?= 200+  audit <- must "audit body" auditBody+  case dig ["events"] audit of+    Just (Array xs)+      | (e0 : _) <- toList xs ->+          (dig ["payload", "actor"] e0 >>= asText) @?= Just adminId+    _ -> assertFailure "expected a user_suspended audit event"++-- | Roles over HTTP: a PUT grant is idempotent (set membership), a DELETE of a role the user+-- never held is a 404 rather than a silent success, and the granted role reaches the target's+-- NEXT token — never a token already in flight.+scenarioAdminRoles :: IORef World -> Int -> IO ()+scenarioAdminRoles ref port = do+  mgr <- newManager defaultManagerSettings+  adminToken' <- becomeAdmin ref mgr port "roler@example.com"+  (targetId, staleToken) <- signupOver mgr port "grantee@example.com"+  let roleUrl r = "/v1/admin/users/" <> T.unpack targetId <> "/roles/" <> r++  -- 'auditor' is not in the registry: the grant must fail loudly rather than mint a role no gate+  -- will ever check.+  undefinedRole <- putRaw mgr port (roleUrl "auditor") (bearer adminToken')+  assertProblem "granting an undefined role" 422 "role_not_defined" undefinedRole++  (grant, _) <- putAuth mgr port (roleUrl "admin") (bearer adminToken')+  grant @?= 204+  (regrant, _) <- putAuth mgr port (roleUrl "admin") (bearer adminToken')+  regrant @?= 204 -- idempotent++  -- The grant is in the store, but not in the token minted before it. Asserted behaviourally —+  -- by using the tokens — rather than by decoding the JWT: what matters is that the gate opens.+  stale <- getRaw mgr port "/v1/admin/users" (bearer staleToken)+  assertProblem "a token minted before the grant does not carry the role" 403 "missing_role" stale+  fresh <- loginOver mgr port "grantee@example.com"+  (freshStatus, _) <- getJSON mgr port "/v1/admin/users" (bearer fresh)+  freshStatus @?= 200++  (revoke, _) <- deleteAuth mgr port (roleUrl "admin") (bearer adminToken')+  revoke @?= 204+  revokeAgain <- deleteRaw mgr port (roleUrl "admin") (bearer adminToken')+  assertProblem "revoking a role the user does not hold" 404 "role_not_granted" revokeAgain++  blank <- putRaw mgr port ("/v1/admin/users/" <> T.unpack targetId <> "/roles/%20") (bearer adminToken')+  assertProblem "a blank role name" 400 "bad_request" blank++-- | Two refusals that protect the deployment from its own administrators: an operator+-- impersonating a customer cannot administer as that customer (privilege laundering), and an+-- administrator cannot suspend or delete themselves (locking everyone out with one typo).+--+-- Reads are allowed under impersonation: looking is not laundering.+scenarioAdminRefusals :: IORef World -> JWK -> ShomeiConfig -> Int -> IO ()+scenarioAdminRefusals ref jwk cfg port = do+  mgr <- newManager defaultManagerSettings+  adminToken' <- becomeAdmin ref mgr port "chief@example.com"+  adminIdText <- userIdOf ref "chief@example.com"+  adminId <- parseUserId adminIdText+  (targetId, _) <- signupOver mgr port "bystander@example.com"++  -- A delegated token: same admin role, but acting on behalf of somebody.+  operator <- genUserId+  delegated <- mkTokenFor jwk cfg adminId (Set.singleton (Role "admin")) Set.empty (Just operator)++  blocked <- postRaw' mgr port ("/v1/admin/users/" <> T.unpack targetId <> "/suspend") (bearer delegated) Null+  assertProblem "a delegated token may not administer" 403 "impersonation_action_blocked" blocked+  (readStatus, _) <- getJSON mgr port "/v1/admin/users" (bearer delegated)+  readStatus @?= 200 -- reads are fine++  -- An admin cannot suspend or delete their own account...+  selfSuspend <- postRaw' mgr port ("/v1/admin/users/" <> T.unpack adminIdText <> "/suspend") (bearer adminToken') Null+  assertProblem "self-suspend" 403 "self_target_forbidden" selfSuspend+  selfDelete <- deleteRaw mgr port ("/v1/admin/users/" <> T.unpack adminIdText) (bearer adminToken')+  assertProblem "self-delete" 403 "self_target_forbidden" selfDelete++  -- ...but may revoke their own sessions, which is what you do when your laptop is stolen.+  (selfSessions, _) <- deleteAuth mgr port ("/v1/admin/users/" <> T.unpack adminIdText <> "/sessions") (bearer adminToken')+  selfSessions @?= 204++  -- A typo'd user id must not report cheerful success. The revoke-sessions workflow answers+  -- "0 sessions ended" for a user who does not exist; the handler turns that into a 404.+  ghost <- genUserId+  ghostRevoke <- deleteRaw mgr port ("/v1/admin/users/" <> T.unpack (idText ghost) <> "/sessions") (bearer adminToken')+  assertProblem "revoking the sessions of a nonexistent user" 404 "user_not_found" ghostRevoke+  ghostGet <- getRaw mgr port ("/v1/admin/users/" <> T.unpack (idText ghost)) (bearer adminToken')+  assertProblem "fetching a nonexistent user" 404 "user_not_found" ghostGet++-- | The keyset walk over users: pages are disjoint and complete, and the last page carries no+-- cursor.+scenarioAdminPagination :: IORef World -> Int -> IO ()+scenarioAdminPagination ref port = do+  mgr <- newManager defaultManagerSettings+  adminToken' <- becomeAdmin ref mgr port "pager@example.com"+  _ <- signupOver mgr port "u1@example.com"+  _ <- signupOver mgr port "u2@example.com"+  _ <- signupOver mgr port "u3@example.com" -- four users in total, with the admin+  (s1, b1) <- getJSON mgr port "/v1/admin/users?limit=2" (bearer adminToken')+  s1 @?= 200+  page1 <- must "page 1" b1+  ids1 <- userIdsOf page1+  cursor <- must "page 1 nextCursor" (dig ["nextCursor"] page1 >>= asText)+  length ids1 @?= 2++  (s2, b2) <- getJSON mgr port ("/v1/admin/users?limit=2&before=" <> urlEncodeText cursor) (bearer adminToken')+  s2 @?= 200+  page2 <- must "page 2" b2+  ids2 <- userIdsOf page2+  length ids2 @?= 2++  -- The last page is full, so it still offers a cursor; the page after it is empty and does not.+  lastCursor <- must "page 2 nextCursor" (dig ["nextCursor"] page2 >>= asText)+  (s3, b3) <- getJSON mgr port ("/v1/admin/users?limit=2&before=" <> urlEncodeText lastCursor) (bearer adminToken')+  s3 @?= 200+  page3 <- must "page 3" b3+  ids3 <- userIdsOf page3+  ids3 @?= []+  (dig ["nextCursor"] page3) @?= Just Null++  assertBool "the pages are disjoint" (null (filter (`elem` ids2) ids1))+  length (ids1 <> ids2) @?= 4++  bad <- getRaw mgr port "/v1/admin/users?before=not-a-cursor" (bearer adminToken')+  assertProblem "a malformed cursor" 400 "bad_request" bad+  badStatus <- getRaw mgr port "/v1/admin/users?status=zombie" (bearer adminToken')+  assertProblem "an unknown status filter" 400 "bad_request" badStatus++userIdsOf :: Value -> IO [Text]+userIdsOf page = case dig ["users"] page of+  Just (Array xs) -> traverse (\v -> must "user id" (dig ["userId"] v >>= asText)) (toList xs)+  _ -> assertFailure "expected a users array"++-- | The user id of a signed-up account, read straight from the in-memory World.+userIdOf :: IORef World -> Text -> IO Text+userIdOf ref email = do+  w <- readIORef ref+  case [u | u <- Map.elems w.users, (emailText <$> u.email) == Just email] of+    (u : _) -> pure (idText u.userId)+    [] -> assertFailure ("no user with email " <> T.unpack email)++-- | DELETE / PUT exposing headers and body, for problem-document assertions.+deleteRaw :: Manager -> Int -> String -> [Header] -> IO RawResponse+deleteRaw mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "DELETE", requestHeaders = hdrs}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), responseHeaders resp, decode (responseBody resp))++putRaw :: Manager -> Int -> String -> [Header] -> IO RawResponse+putRaw mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "PUT", requestHeaders = hdrs}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), responseHeaders resp, decode (responseBody resp))++type RawResponse = (Int, [Header], Maybe Value)++statusOf :: RawResponse -> Int+statusOf (status, _, _) = status++headersOf :: RawResponse -> [Header]+headersOf (_, h, _) = h++bodyOf :: RawResponse -> Maybe Value+bodyOf (_, _, b) = b++-- | Assert the response is a problem document: the right status, @application/problem+json@, and+-- a body whose @code@ matches, whose @status@ member mirrors the HTTP status, and which carries+-- @type@ and @title@.+assertProblem :: String -> Int -> Text -> RawResponse -> IO ()+assertProblem what expectedStatus expectedCode (status, hdrs, body) = do+  status @?= expectedStatus+  headerValue "Content-Type" hdrs @?= Just "application/problem+json"+  doc <- must (what <> ": body") body+  (dig ["code"] doc >>= asText) @?= Just expectedCode+  (dig ["type"] doc >>= asText) @?= Just (problemTypeFor expectedCode)+  assertBool (what <> ": has retryability") (isJust (dig ["retryable"] doc))+  assertBool (what <> ": has a title") (isJust (dig ["title"] doc))+  case dig ["status"] doc of+    Just (Number n) -> (round n :: Int) @?= expectedStatus+    _ -> assertFailure (what <> ": problem document has no numeric status")++headerValue :: Text -> [Header] -> Maybe Text+headerValue name hdrs =+  listToMaybe [Text.decodeUtf8 v | (n, v) <- hdrs, n == CI.mk (Text.encodeUtf8 name)]++-- | GET, exposing status, headers, and the decoded body.+getRaw :: Manager -> Int -> String -> [Header] -> IO RawResponse+getRaw mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "GET", requestHeaders = hdrs}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), responseHeaders resp, decode (responseBody resp))++-- | POST a JSON value, exposing status, headers, and the decoded body.+postRaw' :: Manager -> Int -> String -> [Header] -> Value -> IO RawResponse+postRaw' mgr port path hdrs body = postRaw mgr port path hdrs body++-- | POST an @application\/x-www-form-urlencoded@ body, for the OAuth2 token endpoint.+--+-- @mBasic@, when given, applies RFC 6749's @client_secret_basic@:+-- @Authorization: Basic base64(client_id:client_secret)@, built by @http-client@'s+-- 'applyBasicAuth' so the test encodes it exactly as a real client would.+postForm :: Manager -> Int -> String -> Maybe (Text, Text) -> [(ByteString, ByteString)] -> IO RawResponse+postForm mgr port path mBasic params = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let withBody = urlEncodedBody params req0+      encoded = urlEncode True . Text.encodeUtf8+      req = maybe withBody (\(c, s) -> applyBasicAuth (encoded c) (encoded s) withBody) mBasic+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), responseHeaders resp, decode (responseBody resp))++-- | Assert an RFC 6749 §5.2 error response: the right status, @application\/json@ (never+-- @application\/problem+json@ — that would break a stock OAuth2 client), and an @error@ member+-- that matches. This is the assertion that pins the envelope boundary at runtime, as the+-- OpenAPI conformance suite pins it in the document.+assertOAuthError :: String -> Int -> Text -> RawResponse -> IO ()+assertOAuthError what expectedStatus expectedCode (status, hdrs, body) = do+  assertEqual (what <> ": status") expectedStatus status+  assertBool+    (what <> ": JSON content type")+    (maybe False ("application/json" `T.isPrefixOf`) (headerValue "Content-Type" hdrs))+  -- Never cached, error or not.+  assertEqual (what <> ": no-store") (Just "no-store") (headerValue "Cache-Control" hdrs)+  doc <- must (what <> ": body") body+  assertEqual (what <> ": error code") (Just expectedCode) (dig ["error"] doc >>= asText)+  assertBool (what <> ": has an error_description") (isJust (dig ["error_description"] doc))++-- | POST an arbitrary (here: malformed) body, to exercise Servant's body parser.+postRawBytes :: Manager -> Int -> String -> LBS.ByteString -> IO RawResponse+postRawBytes mgr port path raw = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req =+        req0+          { method = "POST",+            requestHeaders = [("Content-Type", "application/json")],+            requestBody = RequestBodyLBS raw+          }+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), responseHeaders resp, decode (responseBody resp))++-- | The session-check knob, end to end.+--+-- With @sessionCheckMode = VerifyTokenAndSession@, an access token whose session has been revoked+-- must be refused on an authenticated route -- immediately, not when the token expires. This is+-- the whole promise of the knob, and before plan 49 it did not hold: the auth handler verified+-- the JWT statelessly and never looked at the session store.+--+-- The token here is deliberately still well within its 15-minute lifetime; the ONLY thing that+-- changed is the session row.+scenarioSessionCheckMode :: IORef World -> Int -> IO ()+scenarioSessionCheckMode ref port = do+  mgr <- newManager defaultManagerSettings+  let email = "sessioncheck@example.com" :: Text+      pw = "correct horse battery staple" :: Text++  -- Sign up: we get a user id and a fresh, valid access token.+  (sStatus, sBody) <- postJSON mgr port "/v1/auth/signup" (object ["loginId" .= email, "email" .= email, "password" .= pw, "displayName" .= ("S" :: Text)])+  sStatus @?= 201+  sresp <- must "signup body" sBody+  uid <- must "signup userId" (dig ["user", "userId"] sresp >>= asText)+  access <- must "signup accessToken" (dig ["token", "accessToken"] sresp >>= asText)++  -- The token works, as it must.+  (beforeStatus, _) <- getJSON mgr port "/v1/auth/me" (bearer access)+  beforeStatus @?= 200++  -- An administrator revokes the session out of band. The access token is untouched and still+  -- unexpired.+  revokeAllSessionsOf ref uid++  -- THE ASSERTION. Before plan 49 this returns 200: the knob was a no-op.+  after <- getRaw mgr port "/v1/auth/me" (bearer access)+  assertProblem "a revoked session on an authenticated route" 401 "session_revoked" after++  -- The authorization combinators run the same AuthHandler before inspecting roles, scopes, or+  -- permissions. Revocation therefore stops each request with 401 before its 403 predicate.+  roleR <- getRaw mgr port "/admin/users" (bearer access)+  assertProblem "a revoked session on a RequireRole route" 401 "session_revoked" roleR+  scopeR <- getRaw mgr port "/ingest" (bearer access)+  assertProblem "a revoked session on a RequireScope route" 401 "session_revoked" scopeR+  permR <- getRaw mgr port "/host/projects" (bearer access)+  assertProblem "a revoked session on a RequirePermission route" 401 "session_revoked" permR++-- | The default mode remains stateless. Revoking the backing session does not invalidate a+-- still-unexpired access token unless the deployment opts into 'VerifyTokenAndSession'.+scenarioDefaultModeIgnoresSessionStore :: IORef World -> Int -> IO ()+scenarioDefaultModeIgnoresSessionStore ref port = do+  mgr <- newManager defaultManagerSettings+  (access, uid) <- signupTokenAndId mgr port "default-session-check"+  revokeAllSessionsOf ref uid+  (afterStatus, _) <- getJSON mgr port "/v1/auth/me" (bearer access)+  afterStatus @?= 200++tests :: IORef World -> Env -> IO Env -> IO (IORef World, Env) -> IO (IORef World, Env) -> IO (IORef World, Env) -> IO Env -> IO Env -> IO Env -> IO (Text, Env) -> IO Env -> (Maybe Text -> IO (IORef World, Text, Text, Env)) -> IO (IORef World, Text, Text, Env) -> IO (IORef World, Env) -> IO (IORef World, Text, Text, Text, Env) -> IO (Text, Text, Text, Text, Env) -> IO (IORef World, Text, Text, Text, Env) -> IO (IORef World, Env) -> UTCTime -> JWK -> ShomeiConfig -> Text -> TestTree+tests ref env freshEnv freshGatedEnv freshPermissionEnv freshSessionCheckEnv freshCookieEnv freshInsecureCookieEnv freshBothEnv freshOAuthEnv freshOidcEnv freshAuthorizeEnv freshSessionAuthorizeEnv freshAdminEnv freshExchangeEnv freshRevokeEnv freshProvenanceEnv freshTotpEnv t0 jwk cfg adminToken =+  testGroup+    "typed results and HTTP end-to-end (in-memory interpreters + in-test ES256 key)"+    [ testCase "dependency unavailability remains distinct from internal failure before serialization" $ do+        case applicationError (DependencyUnavailable PostgreSQL) :: ApplicationResult () of+          ApplicationUnavailable response -> do+            response.retryProblem.status @?= 503+            response.retryProblem.retryable @?= True+          _ -> assertFailure "expected ApplicationUnavailable"+        case applicationError (InternalAuthError "persisted value violated an invariant") :: ApplicationResult () of+          ApplicationInternal problem -> do+            problem.status @?= 500+            problem.retryable @?= False+          _ -> assertFailure "expected ApplicationInternal",+      testCase "same-prefix NamedRoutes dispatch every concept record to its distinct marker" $+        testWithApplication (pure dispatchApp) dispatchScenario,+      testCase "problem+json envelope from every layer (auth handler, authz, handler, servant formatters, method check)" $ do+        e <- freshEnv+        testWithApplication (pure (app e)) scenarioProblemEnvelope,+      testCase "the /v1 boundary: application routes are versioned, probes and JWKS are not" $ do+        e <- freshEnv+        testWithApplication (pure (app e)) scenarioVersionBoundary,+      testCase "status codes: signup 201, lifecycle requests still 202, logout idempotent (204/204)" $ do+        e <- freshEnv+        testWithApplication (pure (app e)) scenarioStatusCodes,+      testCase "sessionCheckMode=VerifyTokenAndSession: a revoked session is refused on an authenticated route" $ do+        (r, e) <- freshSessionCheckEnv+        testWithApplication (pure (app e)) (scenarioSessionCheckMode r),+      testCase "sessionCheckMode=VerifyTokenOnly: a revoked session does not add a stateful check" $ do+        (r, e) <- freshAdminEnv+        testWithApplication (pure (app e)) (scenarioDefaultModeIgnoresSessionStore r),+      testCase "admin API: the gate is role OR scope; no token 401, ordinary token 403" $ do+        (r, e) <- freshAdminEnv+        testWithApplication (pure (app e)) (scenarioAdminAuthzMatrix r jwk cfg),+      testCase "admin API: suspend → login dies + sessions revoked → 409 on repeat → reinstate → soft delete" $ do+        (r, e) <- freshAdminEnv+        testWithApplication (pure (app e)) (scenarioAdminLifecycle r),+      testCase "admin API: revoke one/all sessions; the audit event names the acting admin" $ do+        (r, e) <- freshAdminEnv+        testWithApplication (pure (app e)) (scenarioAdminSessionsAndAudit r),+      testCase "admin API: PUT role is idempotent, DELETE of an unheld role is 404, grants reach the next token" $ do+        (r, e) <- freshAdminEnv+        testWithApplication (pure (app e)) (scenarioAdminRoles r),+      testCase "admin API: delegated tokens cannot administer; an admin cannot suspend themselves" $ do+        (r, e) <- freshAdminEnv+        testWithApplication (pure (app e)) (scenarioAdminRefusals r jwk cfg),+      testCase "admin API: the user listing pages by keyset, disjoint and complete" $ do+        (r, e) <- freshAdminEnv+        testWithApplication (pure (app e)) (scenarioAdminPagination r),+      testCase "signup → verify/reset → login → me(±token) → refresh → jwks → RequireRole → passkey CRUD → MFA step-up → passwordless" $+        testWithApplication (pure (app env)) (scenario ref adminToken),+      testCase "signup/login by loginId with no email (email == null)" $ do+        e <- freshEnv+        testWithApplication (pure (app e)) scenarioNoEmail,+      testCase "signup reports duplicate email and login-id conflicts as 409" $ do+        e <- freshEnv+        testWithApplication (pure (app e)) scenarioSignupConflicts,+      testCase "signup rejects a missing loginId" $ do+        e <- freshEnv+        testWithApplication (pure (app e)) scenarioSignupRequiresLoginId,+      testCase "POST /oauth/token: client_credentials over both auth methods; RFC 6749 errors, not problem docs" $ do+        (clientId, e) <- freshOAuthEnv+        testWithApplication (pure (app e)) (scenarioOAuthToken clientId),+      testCase "POST /oauth/token: RFC 8693 token-exchange, both modes, denyUnderImpersonation inheritance, and wire refusals" $ do+        (_, gateId, noGateId, adminId, e) <- freshExchangeEnv+        testWithApplication (pure (app e)) (scenarioTokenExchange jwk cfg t0 gateId noGateId adminId),+      testCase "POST /oauth/token: privilege-minting exchanges require live, active principals in the default auth mode" $ do+        (r, gateId, _, _, e) <- freshExchangeEnv+        testWithApplication (pure (app e)) (scenarioExchangeRequiresLiveSessions r jwk cfg t0 gateId),+      testCase "EP-7 TOTP: enroll → verify → mfa_required(methods) → complete; replay 401; recovery gen/use/count; impersonation 403; remove; freshness 403" $ do+        (r, e) <- freshTotpEnv+        testWithApplication (pure (app e)) (scenarioTotp r jwk cfg),+      testCase "EP-4: a TOTP guessing loop is locked out after maxFailedLoginsPerAccount wrong codes" $ do+        (r, e) <- freshTotpEnv+        testWithApplication (pure (app e)) (scenarioTotpLockout r),+      testCase "GET /.well-known/openid-configuration: derived from the issuer when enabled, 404 in the OAuth shape when not" $ do+        e <- freshOidcEnv+        testWithApplication (pure (app e)) scenarioOidcDiscoveryEnabled+        d <- freshEnv+        testWithApplication (pure (app d)) scenarioOidcDiscoveryDisabled,+      testCase "GET /oauth/authorize: unknown client and unregistered redirect_uri are 400 and NEVER redirect" $ do+        (_, confId, _, e) <- freshAuthorizeEnv Nothing+        testWithApplication (pure (app e)) (scenarioAuthorizeNoRedirectRegime confId),+      testCase "GET /oauth/authorize: an authenticated request yields a code; parameter errors redirect with the state" $ do+        (r, confId, pubId, e) <- freshAuthorizeEnv Nothing+        testWithApplication (pure (app e)) (scenarioAuthorizeIssuesCode r confId pubId),+      testCase "an impersonation token cannot be laundered into a user session through authorize + code exchange" $ do+        (r, _, pubId, _, e) <- freshProvenanceEnv+        testWithApplication (pure (app e)) (scenarioNoLaunderingThroughAuthorize r jwk cfg t0 pubId),+      testCase "GET /oauth/authorize accepts only a live interactive session" $ do+        (r, confId, pubId, svcId, e) <- freshProvenanceEnv+        testWithApplication (pure (app e)) (scenarioAuthorizeProvenance r jwk cfg t0 confId pubId svcId),+      testCase "GET /oauth/authorize: token-and-session mode treats a revoked session as unauthenticated" $ do+        (r, confId, _, e) <- freshSessionAuthorizeEnv+        testWithApplication (pure (app e)) (scenarioAuthorizeRejectsRevokedSession r confId),+      testCase "GET /oauth/authorize: unauthenticated bounces to the host login page, or 401s when none is configured" $ do+        (_, confId, _, withLogin) <- freshAuthorizeEnv (Just "https://host.test/login")+        testWithApplication (pure (app withLogin)) (scenarioAuthorizeLoginRedirect confId)+        (_, confId', _, noLogin) <- freshAuthorizeEnv Nothing+        testWithApplication (pure (app noLogin)) (scenarioAuthorizeNoLoginUrl confId'),+      testCase "POST /oauth/token: authorization_code + PKCE + ID token; replay, wrong verifier, and a stolen code are one invalid_grant" $ do+        (r, confId, pubId, e) <- freshAuthorizeEnv Nothing+        testWithApplication (pure (app e)) (scenarioOAuthCodeExchange r jwk confId pubId),+      testCase "POST /oauth/token: refresh_token is bound to the client that minted the session" $ do+        (_, confId, _, e) <- freshAuthorizeEnv Nothing+        testWithApplication (pure (app e)) (scenarioOAuthRefreshRejectsUnboundSession confId),+      testCase "userinfo, introspection, and the revoke->introspect flip" $ do+        (_, confId, pubId, e) <- freshAuthorizeEnv Nothing+        testWithApplication (pure (app e)) (scenarioOAuthUserinfoIntrospectRevoke jwk confId pubId),+      testCase "POST /oauth/revoke: callers can revoke only sessions they own, except shomei:admin" $ do+        (confId, otherConfId, plainId, adminId, e) <- freshRevokeEnv+        testWithApplication (pure (app e)) (scenarioRevokeOwnership confId otherConfId plainId adminId),+      testCase "GET /oauth/userinfo: email and roles appear only under the email and profile scopes" $ do+        (_, confId, _, e) <- freshAuthorizeEnv Nothing+        testWithApplication (pure (app e)) (scenarioUserinfoScopeGating confId),+      testCase "a human login token carries no scopes, so it still fails the scope-guarded route" $ do+        e <- freshEnv+        testWithApplication (pure (app e)) scenarioOAuthScopeIsolation,+      testCase "RequirePermission: 401 no token, 403 without the permission, 200 with it, and re-wiring proves the indirection" $ do+        (r, e) <- freshPermissionEnv+        testWithApplication (pure (app e)) (scenarioRequirePermission r),+      testCase "emailVerificationRequired blocks login with 403 until the email is verified" $ do+        (r, e) <- freshGatedEnv+        testWithApplication (pure (app e)) (scenarioEmailVerificationRequired r),+      testCase "cookie transport: sets HttpOnly cookies, omits body tokens, authenticates, clears on logout" $ do+        e <- freshCookieEnv+        testWithApplication (pure (app e)) scenarioCookieTransport,+      testCase "cookie transport: CSRF gate on mutating requests (Origin / Referer / none / foreign)" $ do+        e <- freshCookieEnv+        testWithApplication (pure (app e)) scenarioCsrfMatrix,+      testCase "cookie transport: refresh reads the secure refresh cookie, rotates, and is CSRF-gated" $ do+        e <- freshCookieEnv+        testWithApplication (pure (app e)) scenarioCookieRefresh,+      testCase "cookieSecure=false keeps the bare names" $ do+        e <- freshInsecureCookieEnv+        testWithApplication (pure (app e)) scenarioInsecureCookieNames,+      testCase "hostile auth header bytes answer in the problem envelope" $ do+        e <- freshCookieEnv+        testWithApplication (pure (app e)) scenarioHostileAuthHeaders,+      testCase "bearer transport: no Set-Cookie, body tokens present, a cookie is not a credential" $ do+        e <- freshEnv+        testWithApplication (pure (app e)) scenarioBearerRejectsCookies,+      testCase "both transport: cookies set AND body tokens present" $ do+        e <- freshBothEnv+        testWithApplication (pure (app e)) scenarioBothTransport+    ]++-- | EP-5 M1: the discovery document is what makes Shōmei consumable by stock middleware, and+-- every URL in it is derived from the issuer — not from a second base-URL setting that could+-- disagree with the @iss@ claim in the tokens.+--+-- The test env's issuer is @https:\/\/shomei.test@ (see 'main'), so each endpoint below is that+-- issuer plus a fixed path.+scenarioOidcDiscoveryEnabled :: Int -> IO ()+scenarioOidcDiscoveryEnabled port = do+  mgr <- newManager defaultManagerSettings+  (status, hdrs, body) <- getRaw mgr port "/.well-known/openid-configuration" []+  status @?= 200+  headerValue "Content-Type" hdrs @?= Just "application/json;charset=utf-8"+  doc <- must "discovery document" body+  (dig ["issuer"] doc >>= asText) @?= Just "https://shomei.test"+  (dig ["authorization_endpoint"] doc >>= asText) @?= Just "https://shomei.test/oauth/authorize"+  (dig ["token_endpoint"] doc >>= asText) @?= Just "https://shomei.test/oauth/token"+  (dig ["userinfo_endpoint"] doc >>= asText) @?= Just "https://shomei.test/oauth/userinfo"+  (dig ["introspection_endpoint"] doc >>= asText) @?= Just "https://shomei.test/oauth/introspect"+  (dig ["revocation_endpoint"] doc >>= asText) @?= Just "https://shomei.test/oauth/revoke"+  -- The JWKS document really is served there, unversioned, by this same app.+  (dig ["jwks_uri"] doc >>= asText) @?= Just "https://shomei.test/.well-known/jwks.json"+  (jwksStatus, _) <- getJSON mgr port "/.well-known/jwks.json" []+  jwksStatus @?= 200+  -- Only the code flow is advertised: implicit and hybrid are excluded by the Security BCP, and+  -- advertising a flow the server does not implement makes stock middleware negotiate it.+  dig ["response_types_supported"] doc @?= Just (toJSON (["code"] :: [Text]))+  -- Only S256: `plain` exists for clients that cannot hash, and every modern library can.+  dig ["code_challenge_methods_supported"] doc @?= Just (toJSON (["S256"] :: [Text]))+  dig ["subject_types_supported"] doc @?= Just (toJSON (["public"] :: [Text]))+  -- EP-4's grant is advertised alongside the two EP-5 adds.+  dig ["grant_types_supported"] doc+    @?= Just (toJSON (["authorization_code", "refresh_token", "client_credentials", "urn:ietf:params:oauth:grant-type:token-exchange"] :: [Text]))+  -- The default test config signs with ES256.+  dig ["id_token_signing_alg_values_supported"] doc @?= Just (toJSON (["ES256"] :: [Text]))+  dig ["token_endpoint_auth_methods_supported"] doc+    @?= Just (toJSON (["client_secret_basic", "client_secret_post"] :: [Text]))++-- | With @oidcEnabled@ off (the default) the provider does not advertise. The refusal reaches+-- OIDC tooling, so it is an RFC 6749-shaped object rather than a problem document — the same+-- envelope boundary @\/oauth\/*@ observes.+scenarioOidcDiscoveryDisabled :: Int -> IO ()+scenarioOidcDiscoveryDisabled port = do+  mgr <- newManager defaultManagerSettings+  r@(_, hdrs, _) <- getRaw mgr port "/.well-known/openid-configuration" []+  assertOAuthError "discovery with the provider disabled" 404 "not_found" r+  assertBool+    "a disabled provider must not answer with a problem document"+    (headerValue "Content-Type" hdrs /= Just "application/problem+json")+  -- The whole OIDC surface is inert, not just the advertisement: deploying the code before+  -- flipping the flag is safe, and flipping it back makes the endpoints unreachable again.+  authorize <-+    getNoRedirect mgr port (authorizeUrl [("client_id", "oauthclient_x"), ("response_type", "code"), ("redirect_uri", authorizeRedirectUri)]) []+  assertOAuthError "authorize with the provider disabled" 404 "not_found" authorize+  headerValue "Location" (headersOf authorize) @?= Nothing+  -- Nothing else moved: the JWKS document is unconditional (verifiers need it regardless).+  (jwksStatus, _) <- getJSON mgr port "/.well-known/jwks.json" []+  jwksStatus @?= 200++-- | Seed one confidential and one public OAuth client into an in-memory world, returning their+-- client ids. Both register exactly one redirect URI; the exact-match rule is what the+-- no-redirect regime is built on.+seedOAuthClients :: IORef World -> JWK -> JWKSet -> ShomeiConfig -> UTCTime -> IO (Text, Text)+seedOAuthClients ref jwk jwkset cfg createdAt =+  runHybrid ref jwk jwkset cfg do+    confId <- genOAuthClientId+    pubId <- genOAuthClientId+    _ <-+      createOAuthClient+        NewOAuthClient+          { oauthClientId = confId,+            clientId = idText confId,+            secretHash = Just (sha256Hex confidentialClientSecret),+            clientType = ConfidentialClient,+            displayName = "confidential",+            redirectUris = [authorizeRedirectUri],+            allowedScopes = Set.fromList [Scope "openid", Scope "profile", Scope "email"],+            createdAt+          }+    _ <-+      createOAuthClient+        NewOAuthClient+          { oauthClientId = pubId,+            clientId = idText pubId,+            secretHash = Nothing,+            clientType = PublicClient,+            displayName = "public",+            redirectUris = [authorizeRedirectUri],+            allowedScopes = Set.singleton (Scope "openid"),+            createdAt+          }+    pure (idText confId, idText pubId)++-- | The one URI both seeded clients register.+authorizeRedirectUri :: Text+authorizeRedirectUri = "https://app.example.com/callback"++-- | The seeded confidential OAuth client's secret. (Distinct from 'oauthClientSecret', which is+-- EP-4's /service account/ secret: an OAuth client and a service account are different things.)+confidentialClientSecret :: Text+confidentialClientSecret = "confidential-client-secret"++-- | A well-formed PKCE S256 challenge (43 unpadded base64url characters).+testCodeChallenge :: Text+testCodeChallenge = T.replicate 43 "a"++-- | Build an @\/oauth\/authorize@ query string from @(key, value)@ pairs, percent-encoding both.+authorizeUrl :: [(Text, Text)] -> String+authorizeUrl params =+  "/oauth/authorize?" <> T.unpack (T.intercalate "&" [enc k <> "=" <> enc v | (k, v) <- params])+  where+    enc = Text.decodeUtf8 . urlEncode True . Text.encodeUtf8++-- | GET without following redirects, so a @302@ is the response under test rather than a fetch of+-- wherever it points.+getNoRedirect :: Manager -> Int -> String -> [Header] -> IO RawResponse+getNoRedirect mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "GET", requestHeaders = hdrs, redirectCount = 0}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), responseHeaders resp, decode (responseBody resp))++-- | The @Location@ header, split into its base and its decoded query parameters.+locationOf :: String -> RawResponse -> IO (Text, [(Text, Text)])+locationOf what r = do+  loc <- maybe (assertFailure (what <> ": no Location header")) pure (headerValue "Location" (headersOf r))+  let (base, query) = T.breakOn "?" loc+      pairs =+        [ (Text.decodeUtf8 k, Text.decodeUtf8 v)+        | (k, v) <- parseSimpleQuery (Text.encodeUtf8 (T.drop 1 query))+        ]+  pure (base, pairs)++-- | Sign up a user over HTTP and return their access token, for the authorize scenarios.+signupToken :: Manager -> Int -> Text -> IO Text+signupToken mgr port loginId = do+  (status, body) <-+    postJSON+      mgr+      port+      "/v1/auth/signup"+      (object ["loginId" .= loginId, "password" .= ("correct horse battery staple" :: Text), "displayName" .= ("" :: Text)])+  status @?= 201+  resp <- must "signup body" body+  must "signup accessToken" (dig ["token", "accessToken"] resp >>= asText)++-- | Like 'signupToken', but also returns the new user's id text — the impersonation-mode+-- @subject_token@ (a bare user id) and the identity a downstream verifier reads from @sub@.+signupTokenAndId :: Manager -> Int -> Text -> IO (Text, Text)+signupTokenAndId mgr port loginId = do+  (status, body) <-+    postJSON+      mgr+      port+      "/v1/auth/signup"+      (object ["loginId" .= loginId, "password" .= ("correct horse battery staple" :: Text), "displayName" .= ("" :: Text)])+  status @?= 201+  resp <- must "signup body" body+  tok <- must "signup accessToken" (dig ["token", "accessToken"] resp >>= asText)+  uid <- must "signup userId" (dig ["user", "userId"] resp >>= asText)+  pure (tok, uid)++-- | Sign up a principal and recover the typed user and session ids named by its real access+-- token. Hand-minted scoped tokens in the provenance scenarios remain bound to this live session.+signupPrincipal :: Manager -> Int -> JWK -> Text -> IO (Text, UserId, SessionId)+signupPrincipal mgr port jwk loginId = do+  (token, uidText) <- signupTokenAndId mgr port loginId+  uid <- parseUserId uidText+  claims <- verifyIdToken jwk token+  sidText <- case KM.lookup "sid" claims of+    Just (String sid) -> pure sid+    other -> assertFailure ("signup access token has no text sid claim: " <> show other)+  sid <- either (assertFailure . ("bad session id " <>) . show) pure (parseId sidText)+  pure (token, uid, sid)++-- | The exact critical chain from the August 2026 review: an operator impersonates a target and+-- presents that delegated token at authorize. Before plan 51 this response is a 302 carrying a+-- code; after the fix it is a non-redirecting 401 and the code store remains empty.+scenarioNoLaunderingThroughAuthorize :: IORef World -> JWK -> ShomeiConfig -> UTCTime -> Text -> Int -> IO ()+scenarioNoLaunderingThroughAuthorize ref jwk cfg issuedAt pubId port = do+  mgr <- newManager defaultManagerSettings+  (_, targetUid, _) <- signupPrincipal mgr port jwk "provenance-target"+  defineRoleIn ref (Role "support-viewer")+  grantRoleIn ref (idText targetUid) (Role "support-viewer")+  (_, operatorUid, operatorSid) <- signupPrincipal mgr port jwk "provenance-operator"+  operatorToken <-+    mkTokenForSession+      jwk+      cfg+      operatorUid+      operatorSid+      Set.empty+      (Set.singleton cfg.impersonationConfig.impersonateScope)+      Nothing+      issuedAt+  let teGrant = ("grant_type", "urn:ietf:params:oauth:grant-type:token-exchange")+      accessType = "urn:ietf:params:oauth:token-type:access_token"+      verifier = "provenance-verifier-with-enough-entropy-1234567890" :: Text+  exchange <-+    postForm+      mgr+      port+      "/oauth/token"+      Nothing+      [ teGrant,+        ("subject_token", Text.encodeUtf8 (idText targetUid)),+        ("subject_token_type", "urn:shomei:params:oauth:token-type:user-id"),+        ("actor_token", Text.encodeUtf8 operatorToken),+        ("actor_token_type", accessType),+        ("reason", "security regression")+      ]+  statusOf exchange @?= 200+  exchangeBody <- must "impersonation exchange body" (bodyOf exchange)+  delegated <- must "impersonation access_token" (dig ["access_token"] exchangeBody >>= asText)+  delegatedClaims <- verifyIdToken jwk delegated+  assertBool "the exchanged token is delegated" (isJust (KM.lookup "act" delegatedClaims))+  dig ["roles"] (Object delegatedClaims) @?= Just (toJSON ([] :: [Text]))++  let params =+        [ ("client_id", pubId),+          ("response_type", "code"),+          ("redirect_uri", authorizeRedirectUri),+          ("scope", "openid"),+          ("code_challenge", pkceChallengeFor verifier),+          ("code_challenge_method", "S256")+        ]+  response <- getNoRedirect mgr port (authorizeUrl params) (bearer delegated)+  assertOAuthError "delegated bearer at authorize" 401 "login_required" response+  headerValue "Location" (headersOf response) @?= Nothing+  Map.size . oauthCodes <$> readIORef ref >>= (@?= 0)++-- | A compact provenance matrix: an interactive session succeeds once; machine, on-behalf-of,+-- impersonation, and explicit @act@ credentials are refused; revoking the interactive session+-- makes the same token unauthenticated even under the default VerifyTokenOnly mode.+scenarioAuthorizeProvenance :: IORef World -> JWK -> ShomeiConfig -> UTCTime -> Text -> Text -> Text -> Int -> IO ()+scenarioAuthorizeProvenance ref jwk cfg issuedAt confId pubId svcId port = do+  mgr <- newManager defaultManagerSettings+  (userToken, userUid, _) <- signupPrincipal mgr port jwk "provenance-user"+  let verifier = "matrix-verifier-with-enough-entropy-123456789012345" :: Text+      interactiveParams =+        [ ("client_id", confId),+          ("response_type", "code"),+          ("redirect_uri", authorizeRedirectUri),+          ("scope", "openid")+        ]+      nonInteractiveParams =+        [ ("client_id", pubId),+          ("response_type", "code"),+          ("redirect_uri", authorizeRedirectUri),+          ("scope", "openid"),+          ("code_challenge", pkceChallengeFor verifier),+          ("code_challenge_method", "S256")+        ]+      refuse what token = do+        response <- getNoRedirect mgr port (authorizeUrl nonInteractiveParams) (bearer token)+        assertOAuthError what 401 "login_required" response+        headerValue "Location" (headersOf response) @?= Nothing++  interactive <- getNoRedirect mgr port (authorizeUrl interactiveParams) (bearer userToken)+  statusOf interactive @?= 302+  (_, interactiveQuery) <- locationOf "interactive authorize" interactive+  assertBool "an interactive session receives a code" (isJust (lookup "code" interactiveQuery))+  Map.size . oauthCodes <$> readIORef ref >>= (@?= 1)++  machineResponse <-+    postForm mgr port "/oauth/token" (Just (svcId, oauthClientSecret)) [("grant_type", "client_credentials")]+  statusOf machineResponse @?= 200+  machineBody <- must "client_credentials body" (bodyOf machineResponse)+  machineToken <- must "client_credentials access_token" (dig ["access_token"] machineBody >>= asText)+  refuse "client_credentials bearer at authorize" machineToken++  onBehalfResponse <-+    postForm+      mgr+      port+      "/oauth/token"+      (Just (svcId, oauthClientSecret))+      [ ("grant_type", "urn:ietf:params:oauth:grant-type:token-exchange"),+        ("subject_token", Text.encodeUtf8 userToken),+        ("subject_token_type", "urn:ietf:params:oauth:token-type:access_token"),+        ("scope", "kawa:ingest")+      ]+  statusOf onBehalfResponse @?= 200+  onBehalfBody <- must "on-behalf exchange body" (bodyOf onBehalfResponse)+  onBehalfToken <- must "on-behalf access_token" (dig ["access_token"] onBehalfBody >>= asText)+  refuse "on-behalf bearer at authorize" onBehalfToken++  (_, operatorUid, operatorSid) <- signupPrincipal mgr port jwk "provenance-matrix-operator"+  operatorToken <-+    mkTokenForSession+      jwk+      cfg+      operatorUid+      operatorSid+      Set.empty+      (Set.singleton cfg.impersonationConfig.impersonateScope)+      Nothing+      issuedAt+  impersonationResponse <-+    postForm+      mgr+      port+      "/oauth/token"+      Nothing+      [ ("grant_type", "urn:ietf:params:oauth:grant-type:token-exchange"),+        ("subject_token", Text.encodeUtf8 (idText userUid)),+        ("subject_token_type", "urn:shomei:params:oauth:token-type:user-id"),+        ("actor_token", Text.encodeUtf8 operatorToken),+        ("actor_token_type", "urn:ietf:params:oauth:token-type:access_token")+      ]+  statusOf impersonationResponse @?= 200+  impersonationBody <- must "impersonation matrix body" (bodyOf impersonationResponse)+  impersonationToken <- must "impersonation matrix access_token" (dig ["access_token"] impersonationBody >>= asText)+  refuse "impersonation bearer at authorize" impersonationToken++  explicitActor <- mkTokenFor jwk cfg userUid Set.empty Set.empty (Just operatorUid)+  refuse "explicit act bearer at authorize" explicitActor++  revokeAllSessionsOf ref (idText userUid)+  revoked <- getNoRedirect mgr port (authorizeUrl interactiveParams) (bearer userToken)+  statusOf revoked @?= 302+  (loginBase, loginQuery) <- locationOf "revoked interactive authorize" revoked+  loginBase @?= "https://host.test/login"+  assertBool "a dead session redirect carries no authorization code" (isNothing (lookup "code" loginQuery))+  Map.size . oauthCodes <$> readIORef ref >>= (@?= 1)++-- | EP-6: the RFC 8693 token-exchange grant end to end, over the real Servant tree — both modes and+-- every wire refusal.+--+--   * impersonation: an operator token exchanges a bare user id for a delegated token whose @sub@ is+--     the target and @act@ the operator; it resolves the customer on @\/auth\/me@ and inherits the+--     'denyUnderImpersonation' 403 on a credential change.+--   * on-behalf-of: an authenticated service account exchanges a user's access token for a narrowed+--     token that satisfies the @RequireScope@ route and carries the user's @sub@ + the service's @act@.+--+-- Every failure is an RFC 6749 §5.2 object, never a problem document.+scenarioTokenExchange :: JWK -> ShomeiConfig -> UTCTime -> Text -> Text -> Text -> Int -> IO ()+scenarioTokenExchange jwk cfg issuedAt gateClientId noGateClientId adminClientId port = do+  mgr <- newManager defaultManagerSettings+  let teGrant = ("grant_type", "urn:ietf:params:oauth:grant-type:token-exchange")+      userIdType = "urn:shomei:params:oauth:token-type:user-id"+      accessType = "urn:ietf:params:oauth:token-type:access_token"+      accessTypeText = "urn:ietf:params:oauth:token-type:access_token" :: Text+      enc = Text.encodeUtf8++  (_, operatorUid, operatorSid) <- signupPrincipal mgr port jwk "exchange-operator"+  impToken <-+    mkTokenForSession+      jwk+      cfg+      operatorUid+      operatorSid+      Set.empty+      (Set.singleton cfg.impersonationConfig.impersonateScope)+      Nothing+      issuedAt+  let staleIssuedAt = addUTCTime (negate (cfg.impersonationConfig.actorFreshnessWindow + 1)) issuedAt+  staleImpToken <-+    mkTokenForSession+      jwk+      cfg+      operatorUid+      operatorSid+      Set.empty+      (Set.singleton cfg.impersonationConfig.impersonateScope)+      Nothing+      staleIssuedAt++  -- ===== Impersonation mode =====+  (_, targetId) <- signupTokenAndId mgr port "exchange-target"+  impR <-+    postForm+      mgr+      port+      "/oauth/token"+      Nothing+      [ teGrant,+        ("subject_token", enc targetId),+        ("subject_token_type", userIdType),+        ("actor_token", enc impToken),+        ("actor_token_type", accessType),+        ("reason", "support ticket 4711")+      ]+  let (impStatus, impHdrs, impBody) = impR+  impStatus @?= 200+  headerValue "Cache-Control" impHdrs @?= Just "no-store"+  impDoc <- must "impersonation exchange body" impBody+  (dig ["token_type"] impDoc >>= asText) @?= Just "Bearer"+  (dig ["issued_token_type"] impDoc >>= asText) @?= Just accessTypeText+  impAccess <- must "impersonation access_token" (dig ["access_token"] impDoc >>= asText)+  impClaims <- verifyIdToken jwk impAccess+  KM.lookup "sub" impClaims @?= Just (String targetId)+  assertBool "impersonation token carries an act claim" (isJust (KM.lookup "act" impClaims))+  -- The delegated token resolves the TARGET on /auth/me.+  (meStatus, meBody) <- getJSON mgr port "/v1/auth/me" (bearer impAccess)+  meStatus @?= 200+  meResp <- must "me (delegated) body" meBody+  (dig ["userId"] meResp >>= asText) @?= Just targetId+  -- A credential change under the delegated token is refused 403 (the standard path inherits the gate).+  (pwStatus, pwBody) <-+    postJSONAuth+      mgr+      port+      "/v1/auth/password/change"+      (bearer impAccess)+      (object ["currentPassword" .= ("x" :: Text), "newPassword" .= ("y" :: Text)])+  pwStatus @?= 403+  (pwBody >>= dig ["code"] >>= asText) @?= Just "impersonation_action_blocked"++  -- Introspection (plan 42) reports the delegated token as active, with an `act` member naming the+  -- operator — the observability surface agrees with the token's contents. Introspection+  -- client-authenticates as the service account.+  introActive <-+    postForm mgr port "/oauth/introspect" (Just (gateClientId, oauthClientSecret)) [("token", enc impAccess)]+  introActiveDoc <- must "introspect (active) body" (bodyOf introActive)+  dig ["active"] introActiveDoc @?= Just (Bool True)+  assertBool "introspection reports the act member" (isJust (dig ["act", "sub"] introActiveDoc >>= asText))+  -- RFC 7009 revocation is the single stop mechanism for a delegated token. The gate service did+  -- not mint this impersonation session, so the explicitly privileged admin principal stops it.+  (stopStatus, _, _) <-+    postForm+      mgr+      port+      "/oauth/revoke"+      (Just (adminClientId, oauthClientSecret))+      [("token", enc impAccess), ("token_type_hint", "access_token")]+  stopStatus @?= 200+  introInactive <-+    postForm mgr port "/oauth/introspect" (Just (gateClientId, oauthClientSecret)) [("token", enc impAccess)]+  introInactiveDoc <- must "introspect (inactive) body" (bodyOf introInactive)+  dig ["active"] introInactiveDoc @?= Just (Bool False)++  -- A stale operator token is one generic invalid_grant.+  staleR <-+    postForm+      mgr+      port+      "/oauth/token"+      Nothing+      [teGrant, ("subject_token", enc targetId), ("subject_token_type", userIdType), ("actor_token", enc staleImpToken), ("actor_token_type", accessType)]+  assertOAuthError "stale operator" 400 "invalid_grant" staleR++  -- A requested_token_type other than access_token is invalid_request (we issue no refresh tokens).+  reqTypeR <-+    postForm+      mgr+      port+      "/oauth/token"+      Nothing+      [ teGrant,+        ("subject_token", enc targetId),+        ("subject_token_type", userIdType),+        ("actor_token", enc impToken),+        ("actor_token_type", accessType),+        ("requested_token_type", "urn:ietf:params:oauth:token-type:refresh_token")+      ]+  assertOAuthError "refresh requested_token_type" 400 "invalid_request" reqTypeR++  -- ===== Service on-behalf-of mode =====+  (userTok, userId) <- signupTokenAndId mgr port "exchange-user"+  obR <-+    postForm+      mgr+      port+      "/oauth/token"+      (Just (gateClientId, oauthClientSecret))+      [teGrant, ("subject_token", enc userTok), ("subject_token_type", accessType), ("scope", "kawa:ingest")]+  let (obStatus, obHdrs, obBody) = obR+  obStatus @?= 200+  headerValue "Cache-Control" obHdrs @?= Just "no-store"+  obDoc <- must "on-behalf body" obBody+  (dig ["scope"] obDoc >>= asText) @?= Just "kawa:ingest"+  (dig ["issued_token_type"] obDoc >>= asText) @?= Just accessTypeText+  obAccess <- must "on-behalf access_token" (dig ["access_token"] obDoc >>= asText)+  -- The narrowed token satisfies the RequireScope route.+  (ingestStatus, _) <- getJSON mgr port "/ingest" (bearer obAccess)+  ingestStatus @?= 200+  obClaims <- verifyIdToken jwk obAccess+  KM.lookup "sub" obClaims @?= Just (String userId)+  assertBool "on-behalf token carries a service act claim" (isJust (KM.lookup "act" obClaims))+  assertBool "the act is the service, not the user" (KM.lookup "act" obClaims /= Just (String userId))++  -- No client authentication (and an access-token subject) names neither mode: invalid_request.+  noAuthR <-+    postForm+      mgr+      port+      "/oauth/token"+      Nothing+      [teGrant, ("subject_token", enc userTok), ("subject_token_type", accessType), ("scope", "kawa:ingest")]+  assertOAuthError "on-behalf without client auth" 400 "invalid_request" noAuthR++  -- A service account WITHOUT the gate scope may not exchange at all: invalid_scope.+  noGateR <-+    postForm+      mgr+      port+      "/oauth/token"+      (Just (noGateClientId, oauthClientSecret))+      [teGrant, ("subject_token", enc userTok), ("subject_token_type", accessType), ("scope", "kawa:ingest")]+  assertOAuthError "service without gate scope" 400 "invalid_scope" noGateR++  -- Requesting the gate scope itself is never granted: an empty grant is invalid_scope.+  gateR <-+    postForm+      mgr+      port+      "/oauth/token"+      (Just (gateClientId, oauthClientSecret))+      [teGrant, ("subject_token", enc userTok), ("subject_token_type", accessType), ("scope", "token-exchange:subject")]+  assertOAuthError "requesting the gate scope" 400 "invalid_scope" gateR++  -- A scope outside the account's ceiling is invalid_scope.+  outsideR <-+    postForm+      mgr+      port+      "/oauth/token"+      (Just (gateClientId, oauthClientSecret))+      [teGrant, ("subject_token", enc userTok), ("subject_token_type", accessType), ("scope", "channel:egress")]+  assertOAuthError "scope outside ceiling" 400 "invalid_scope" outsideR++  -- A garbage subject token is one generic invalid_grant.+  garbageR <-+    postForm+      mgr+      port+      "/oauth/token"+      (Just (gateClientId, oauthClientSecret))+      [teGrant, ("subject_token", "not-a-real-token"), ("subject_token_type", accessType), ("scope", "kawa:ingest")]+  assertOAuthError "garbage subject token" 400 "invalid_grant" garbageR++-- | Privilege-minting exchanges force a live-session check even while ordinary route+-- authentication uses the default stateless mode. Impersonation additionally requires an active+-- operator account.+scenarioExchangeRequiresLiveSessions :: IORef World -> JWK -> ShomeiConfig -> UTCTime -> Text -> Int -> IO ()+scenarioExchangeRequiresLiveSessions ref jwk cfg issuedAt gateClientId port = do+  mgr <- newManager defaultManagerSettings+  let teGrant = ("grant_type", "urn:ietf:params:oauth:grant-type:token-exchange")+      accessType = "urn:ietf:params:oauth:token-type:access_token"+      enc = Text.encodeUtf8+      exchangeSubject token =+        postForm+          mgr+          port+          "/oauth/token"+          (Just (gateClientId, oauthClientSecret))+          [teGrant, ("subject_token", enc token), ("subject_token_type", accessType), ("scope", "kawa:ingest")]+      exchangeOperator target token =+        postForm+          mgr+          port+          "/oauth/token"+          Nothing+          [ teGrant,+            ("subject_token", enc (idText target)),+            ("subject_token_type", "urn:shomei:params:oauth:token-type:user-id"),+            ("actor_token", enc token),+            ("actor_token_type", accessType)+          ]+      scopedOperator uid sid =+        mkTokenForSession+          jwk+          cfg+          uid+          sid+          Set.empty+          (Set.singleton cfg.impersonationConfig.impersonateScope)+          Nothing+          issuedAt++  (subjectToken, subjectUid, _) <- signupPrincipal mgr port jwk "exchange-live-subject"+  statusOf <$> exchangeSubject subjectToken >>= (@?= 200)+  revokeAllSessionsOf ref (idText subjectUid)+  exchangeSubject subjectToken >>= assertOAuthError "revoked on-behalf subject" 400 "invalid_grant"++  (_, targetUid, _) <- signupPrincipal mgr port jwk "exchange-live-target"+  (_, revokedOperatorUid, revokedOperatorSid) <- signupPrincipal mgr port jwk "exchange-revoked-operator"+  revokedOperatorToken <- scopedOperator revokedOperatorUid revokedOperatorSid+  statusOf <$> exchangeOperator targetUid revokedOperatorToken >>= (@?= 200)+  revokeAllSessionsOf ref (idText revokedOperatorUid)+  exchangeOperator targetUid revokedOperatorToken >>= assertOAuthError "revoked impersonation operator" 400 "invalid_grant"++  (_, suspendedOperatorUid, suspendedOperatorSid) <- signupPrincipal mgr port jwk "exchange-suspended-operator"+  suspendedOperatorToken <- scopedOperator suspendedOperatorUid suspendedOperatorSid+  suspendUserIn ref suspendedOperatorUid+  exchangeOperator targetUid suspendedOperatorToken >>= assertOAuthError "suspended impersonation operator" 400 "invalid_grant"++-- | EP-5 M2, regime one: an unknown or revoked @client_id@, or a @redirect_uri@ that is not+-- registered, is a @400@ __with no Location header at all__.+--+-- This is the single most important behavior of the endpoint. A server that redirects an error to+-- an unvalidated @redirect_uri@ is an open redirector, and an attacker uses it to have this+-- endpoint hand authorization codes to a host of their choosing. Note these must fail /before/+-- authentication is even considered: none of the requests below carries a token.+scenarioAuthorizeNoRedirectRegime :: Text -> Int -> IO ()+scenarioAuthorizeNoRedirectRegime confId port = do+  mgr <- newManager defaultManagerSettings+  let base =+        [ ("response_type", "code"),+          ("redirect_uri", authorizeRedirectUri),+          ("code_challenge", testCodeChallenge),+          ("code_challenge_method", "S256")+        ]+      assertNoRedirect what r = do+        assertOAuthError what 400 "invalid_request" r+        headerValue "Location" (headersOf r) @?= Nothing++  unknown <- getNoRedirect mgr port (authorizeUrl (("client_id", "oauthclient_nope") : base)) []+  assertNoRedirect "unknown client_id" unknown++  missingClient <- getNoRedirect mgr port (authorizeUrl base) []+  assertNoRedirect "absent client_id" missingClient++  -- A near-miss on the registered URI: a path suffix. Exact string equality is the whole rule.+  mismatched <-+    getNoRedirect+      mgr+      port+      (authorizeUrl [("client_id", confId), ("response_type", "code"), ("redirect_uri", authorizeRedirectUri <> "/../evil")])+      []+  assertNoRedirect "unregistered redirect_uri" mismatched++  missingUri <- getNoRedirect mgr port (authorizeUrl [("client_id", confId), ("response_type", "code")]) []+  assertNoRedirect "absent redirect_uri" missingUri++-- | EP-5 M2: the happy path and regime two (an error redirect to the /validated/ URI).+scenarioAuthorizeIssuesCode :: IORef World -> Text -> Text -> Int -> IO ()+scenarioAuthorizeIssuesCode ref confId pubId port = do+  mgr <- newManager defaultManagerSettings+  token <- signupToken mgr port "authorize-user"+  let bearer' = [("Authorization", "Bearer " <> Text.encodeUtf8 token)]+      base =+        [ ("client_id", confId),+          ("response_type", "code"),+          ("redirect_uri", authorizeRedirectUri),+          ("scope", "openid profile"),+          ("state", "xyz&spliced=1"),+          ("nonce", "n-0S6"),+          ("code_challenge", testCodeChallenge),+          ("code_challenge_method", "S256")+        ]++  ok <- getNoRedirect mgr port (authorizeUrl base) bearer'+  let (status, hdrs, _) = ok+  status @?= 302+  headerValue "Cache-Control" hdrs @?= Just "no-store"+  (locBase, params) <- locationOf "authorize success" ok+  locBase @?= authorizeRedirectUri+  code <- maybe (assertFailure "no code in the redirect") pure (lookup "code" params)+  assertBool "the code is not empty" (not (T.null code))+  -- `state` round-trips verbatim, including the `&` that would splice a parameter if unencoded.+  lookup "state" params @?= Just "xyz&spliced=1"+  lookup "error" params @?= Nothing+  -- RFC 9207: the issuer identifies which provider answered, so a multi-provider client can+  -- detect a mix-up attack.+  lookup "iss" params @?= Just "https://shomei.test"++  -- The stored row is the code's digest, unconsumed, expiring 60 seconds out.+  world <- readIORef ref+  case Map.elems (oauthCodes world) of+    [stored] -> do+      stored.codeHash @?= sha256Hex code+      stored.consumedAt @?= Nothing+      stored.nonce @?= Just "n-0S6"+      stored.redirectUri @?= authorizeRedirectUri+      stored.clientId @?= confId+      stored.scopes @?= Set.fromList [Scope "openid", Scope "profile"]+      diffUTCTime stored.expiresAt stored.createdAt @?= 60+    other -> assertFailure ("expected exactly one stored code, got " <> show (length other))++  -- Regime two: the client_id and redirect_uri were valid, so the error goes back to the client+  -- at the URI we validated, with the state echoed so it can correlate the failure.+  let errorRedirect what expectedCode params' = do+        r <- getNoRedirect mgr port (authorizeUrl params') bearer'+        let (st, _, _) = r+        assertEqual (what <> ": status") 302 st+        (b, ps) <- locationOf what r+        assertEqual (what <> ": redirect target") authorizeRedirectUri b+        assertEqual (what <> ": error code") (Just expectedCode) (lookup "error" ps)+        assertEqual (what <> ": state echoed") (Just "xyz&spliced=1") (lookup "state" ps)+        assertBool (what <> ": no code is issued") (isNothing (lookup "code" ps))++  errorRedirect "response_type=token" "unsupported_response_type" (replaceParam "response_type" "token" base)+  errorRedirect "scope outside the allow-list" "invalid_scope" (replaceParam "scope" "openid admin:everything" base)+  errorRedirect "code_challenge_method=plain" "invalid_request" (replaceParam "code_challenge_method" "plain" base)++  -- A public client cannot skip PKCE: with no secret, the challenge is its only binding between+  -- this request and the exchange.+  errorRedirect+    "public client without a code_challenge"+    "invalid_request"+    [ ("client_id", pubId),+      ("response_type", "code"),+      ("redirect_uri", authorizeRedirectUri),+      ("scope", "openid"),+      ("state", "xyz&spliced=1")+    ]++  -- Exactly one code was ever minted, by the one successful request.+  world' <- readIORef ref+  Map.size (oauthCodes world') @?= 1++replaceParam :: Text -> Text -> [(Text, Text)] -> [(Text, Text)]+replaceParam k v = map (\(k', v') -> if k' == k then (k, v) else (k', v'))++-- | EP-5 M2: an unauthenticated authorize request bounces to the host's login page carrying the+-- reconstructed authorize URL in @return_to@. Shōmei ships no login UI and persists no pending+-- request; the whole state round-trips in that URL.+scenarioAuthorizeLoginRedirect :: Text -> Int -> IO ()+scenarioAuthorizeLoginRedirect confId port = do+  mgr <- newManager defaultManagerSettings+  let params =+        [ ("client_id", confId),+          ("response_type", "code"),+          ("redirect_uri", authorizeRedirectUri),+          ("scope", "openid"),+          ("state", "xyz"),+          ("code_challenge", testCodeChallenge),+          ("code_challenge_method", "S256")+        ]+  r <- getNoRedirect mgr port (authorizeUrl params) []+  let (status, _, _) = r+  status @?= 302+  (base, qs) <- locationOf "login redirect" r+  base @?= "https://host.test/login"+  returnTo <- maybe (assertFailure "no return_to") pure (lookup "return_to" qs)+  -- The URL is rebuilt from the parameters the handler validated, on the issuer's base -- never+  -- copied from anything the caller supplied.+  assertBool+    ("return_to points back at this provider's authorize endpoint: " <> T.unpack returnTo)+    ("https://shomei.test/oauth/authorize?" `T.isPrefixOf` returnTo)+  let (_, returnQuery) = T.breakOn "?" returnTo+      returnParams =+        [ (Text.decodeUtf8 k, Text.decodeUtf8 v)+        | (k, v) <- parseSimpleQuery (Text.encodeUtf8 (T.drop 1 returnQuery))+        ]+  -- Every parameter the user originally sent survives the round trip, so the host can send them+  -- back here after logging them in and the flow resumes unchanged.+  mapM_ (\(k, v) -> assertEqual ("return_to carries " <> T.unpack k) (Just v) (lookup k returnParams)) params++-- | With no @loginUrl@ configured there is nowhere to send the user, so the request is refused --+-- in the OAuth error shape, because the caller is OAuth tooling.+scenarioAuthorizeNoLoginUrl :: Text -> Int -> IO ()+scenarioAuthorizeNoLoginUrl confId port = do+  mgr <- newManager defaultManagerSettings+  r <-+    getNoRedirect+      mgr+      port+      (authorizeUrl [("client_id", confId), ("response_type", "code"), ("redirect_uri", authorizeRedirectUri)])+      []+  assertOAuthError "unauthenticated with no loginUrl" 401 "login_required" r+  headerValue "Location" (headersOf r) @?= Nothing++-- | @\/oauth\/authorize@ authenticates outside Servant's 'Authenticated' combinator, through+-- 'resolveAuthUser'. In token-and-session mode it must treat a revoked session as anonymous and+-- must not mint another authorization code.+scenarioAuthorizeRejectsRevokedSession :: IORef World -> Text -> Int -> IO ()+scenarioAuthorizeRejectsRevokedSession ref confId port = do+  mgr <- newManager defaultManagerSettings+  (token, uid) <- signupTokenAndId mgr port "authorize-revoked-session"+  let params =+        [ ("client_id", confId),+          ("response_type", "code"),+          ("redirect_uri", authorizeRedirectUri),+          ("scope", "openid"),+          ("state", "session-check"),+          ("code_challenge", testCodeChallenge),+          ("code_challenge_method", "S256")+        ]+      bearer' = bearer token++  live <- getNoRedirect mgr port (authorizeUrl params) bearer'+  let (liveStatus, _, _) = live+  liveStatus @?= 302+  (_, liveParams) <- locationOf "live session authorize" live+  assertBool "a live session receives a code" (isJust (lookup "code" liveParams))+  before <- Map.size . oauthCodes <$> readIORef ref+  before @?= 1++  revokeAllSessionsOf ref uid++  revoked <- getNoRedirect mgr port (authorizeUrl params) bearer'+  assertOAuthError "revoked session authorize" 401 "login_required" revoked+  headerValue "Location" (headersOf revoked) @?= Nothing+  after <- Map.size . oauthCodes <$> readIORef ref+  after @?= before++-- | EP-5 M3: the whole authorization-code exchange, over the real Servant tree with the real+-- ES256 signer.+--+-- Drives the flow exactly as a client does — authorize, parse the code out of the @Location@,+-- exchange it with the PKCE verifier — and then attacks it: replay, wrong verifier, missing+-- verifier, a different client, a mismatched @redirect_uri@. Every one of those must be an+-- indistinguishable @invalid_grant@, and none may mint a token.+scenarioOAuthCodeExchange :: IORef World -> JWK -> Text -> Text -> Int -> IO ()+scenarioOAuthCodeExchange ref jwk confId pubId port = do+  mgr <- newManager defaultManagerSettings+  token <- signupToken mgr port "exchange-user"+  let verifier = "a-high-entropy-code-verifier-of-sufficient-length-1234567890" :: Text+      challenge = pkceChallengeFor verifier+      basic = Just (confId, confidentialClientSecret)++      getCode client = do+        r <-+          getNoRedirect+            mgr+            port+            ( authorizeUrl+                [ ("client_id", client),+                  ("response_type", "code"),+                  ("redirect_uri", authorizeRedirectUri),+                  ("scope", "openid profile"),+                  ("nonce", "n-0S6"),+                  ("code_challenge", challenge),+                  ("code_challenge_method", "S256")+                ]+            )+            [("Authorization", "Bearer " <> Text.encodeUtf8 token)]+        (_, params) <- locationOf "authorize" r+        maybe (assertFailure "no code in the redirect") pure (lookup "code" params)++      exchange extra = postForm mgr port "/oauth/token" basic ([("grant_type", "authorization_code")] <> extra)++      exchangeOf code =+        exchange+          [ ("code", Text.encodeUtf8 code),+            ("redirect_uri", Text.encodeUtf8 authorizeRedirectUri),+            ("code_verifier", Text.encodeUtf8 verifier)+          ]++  -- (1) The happy path: three tokens, and the ID token really verifies against the served key.+  code <- getCode confId+  ok@(okStatus, okHdrs, _) <- exchangeOf code+  okStatus @?= 200+  headerValue "Cache-Control" okHdrs @?= Just "no-store"+  body <- must "token body" (bodyOf ok)+  accessToken <- must "access_token" (dig ["access_token"] body >>= asText)+  refreshToken <- must "refresh_token" (dig ["refresh_token"] body >>= asText)+  idToken <- must "id_token" (dig ["id_token"] body >>= asText)+  accessClaims <- verifyIdToken jwk accessToken+  accessSessionId <- case KM.lookup "sid" accessClaims of+    Just (String sid) -> pure sid+    other -> assertFailure ("the access token has no string sid: " <> show other)+  (dig ["token_type"] body >>= asText) @?= Just "Bearer"+  (dig ["scope"] body >>= asText) @?= Just "openid profile"++  -- The ID token is a real JWS over the same key, addressed to the client, echoing the nonce.+  idClaims <- verifyIdToken jwk idToken+  (KM.lookup "aud" idClaims) @?= Just (String confId)+  (KM.lookup "nonce" idClaims) @?= Just (String "n-0S6")+  (KM.lookup "iss" idClaims) @?= Just (String "https://shomei.test")+  assertBool "auth_time is a number of seconds, not a timestamp string" $+    case KM.lookup "auth_time" idClaims of+      Just (Number _) -> True+      _ -> False+  -- Its `sub` is the very user the access token names.+  accessSub <- subjectOf mgr port accessToken+  KM.lookup "sub" idClaims @?= Just (String accessSub)+  -- An ID token is not a credential: presenting it as a bearer token is refused.+  (meWithId, _) <- getJSON mgr port "/v1/auth/me" [("Authorization", "Bearer " <> Text.encodeUtf8 idToken)]+  meWithId @?= 401++  -- (2) Replay: the code is single-use, and the replay is indistinguishable from an unknown code.+  replay <- exchangeOf code+  assertOAuthError "replaying a code" 400 "invalid_grant" replay+  afterReplay <- introspect mgr port basic accessToken+  (dig ["active"] afterReplay) @?= Just (Aeson.Bool False)+  replayKilledRefresh <-+    postForm+      mgr+      port+      "/oauth/token"+      basic+      [("grant_type", "refresh_token"), ("refresh_token", Text.encodeUtf8 refreshToken)]+  assertOAuthError "the replayed code revokes the session's refresh family" 400 "invalid_grant" replayKilledRefresh+  replayEvents <-+    mapMaybe+      (\case Event.OAuthCodeReplayed details -> Just details; _ -> Nothing)+      . publishedEvents+      <$> readIORef ref+  case replayEvents of+    [details] -> do+      details.clientId @?= confId+      details.presentedBy @?= confId+      idText details.sessionId @?= accessSessionId+    other -> assertFailure ("expected one oauth_code_replayed event, got " <> show other)+  unknown <- exchangeOf "not-a-real-code"+  assertOAuthError "an unknown code" 400 "invalid_grant" unknown+  assertEqual "a replay and an unknown code are indistinguishable" (bodyOf replay) (bodyOf unknown)++  -- (3) A wrong or absent PKCE verifier. Note each burns its own fresh code.+  wrongVerifier <- do+    c <- getCode confId+    exchange+      [ ("code", Text.encodeUtf8 c),+        ("redirect_uri", Text.encodeUtf8 authorizeRedirectUri),+        ("code_verifier", "the-wrong-verifier-entirely-0000000000000000000000")+      ]+  assertOAuthError "a wrong code_verifier" 400 "invalid_grant" wrongVerifier++  absentVerifier <- do+    c <- getCode confId+    exchange [("code", Text.encodeUtf8 c), ("redirect_uri", Text.encodeUtf8 authorizeRedirectUri)]+  assertOAuthError "an absent code_verifier when a challenge was stored" 400 "invalid_grant" absentVerifier++  -- (4) A mismatched redirect_uri at the exchange.+  mismatchedUri <- do+    c <- getCode confId+    exchange+      [ ("code", Text.encodeUtf8 c),+        ("redirect_uri", "https://app.example.com/somewhere-else"),+        ("code_verifier", Text.encodeUtf8 verifier)+      ]+  assertOAuthError "a mismatched redirect_uri" 400 "invalid_grant" mismatchedUri++  -- (5) A stolen code exchanged by a DIFFERENT client. The public client authenticates with a bare+  -- client_id, which is exactly what a code thief would present.+  stolen <- do+    c <- getCode confId+    postForm+      mgr+      port+      "/oauth/token"+      Nothing+      [ ("grant_type", "authorization_code"),+        ("client_id", Text.encodeUtf8 pubId),+        ("code", Text.encodeUtf8 c),+        ("redirect_uri", Text.encodeUtf8 authorizeRedirectUri),+        ("code_verifier", Text.encodeUtf8 verifier)+      ]+  assertOAuthError "a code stolen by another client" 400 "invalid_grant" stolen++  -- (6) A wrong client secret is invalid_client, not invalid_grant: the client never authenticated.+  badSecret <- do+    c <- getCode confId+    postForm+      mgr+      port+      "/oauth/token"+      (Just (confId, "not-the-secret"))+      [ ("grant_type", "authorization_code"),+        ("code", Text.encodeUtf8 c),+        ("redirect_uri", Text.encodeUtf8 authorizeRedirectUri),+        ("code_verifier", Text.encodeUtf8 verifier)+      ]+  assertOAuthError "a wrong client secret" 401 "invalid_client" badSecret++  -- (7) The refresh grant rotates, and is bound to the client that minted the session.+  let refreshWith who params = postForm mgr port "/oauth/token" who ([("grant_type", "refresh_token")] <> params)+  rotationCode <- getCode confId+  rotationGrant <- exchangeOf rotationCode+  rotationBody <- must "rotation token body" (bodyOf rotationGrant)+  rotatingRefresh <- must "rotation refresh_token" (dig ["refresh_token"] rotationBody >>= asText)++  -- The bespoke endpoint has no client identity, so it cannot rotate a client-bound token. The+  -- refusal must not spend the token: the owning OAuth client uses the same token below.+  (bespokeStatus, bespokeBody) <-+    postJSON mgr port "/v1/auth/refresh" (object ["refreshToken" .= rotatingRefresh])+  bespokeStatus @?= 401+  (bespokeBody >>= dig ["code"] >>= asText) @?= Just "token_invalid"++  -- A different client cannot rotate this token, and the refusal does NOT revoke the family.+  wrongClient <- refreshWith Nothing [("client_id", Text.encodeUtf8 pubId), ("refresh_token", Text.encodeUtf8 rotatingRefresh)]+  assertOAuthError "another client refreshing" 400 "invalid_grant" wrongClient++  rotated <- refreshWith basic [("refresh_token", Text.encodeUtf8 rotatingRefresh)]+  let (rotStatus, _, _) = rotated+  rotStatus @?= 200+  rotBody <- must "rotate body" (bodyOf rotated)+  newRefresh <- must "rotated refresh_token" (dig ["refresh_token"] rotBody >>= asText)+  (dig ["scope"] rotBody >>= asText) @?= Just "openid profile"+  assertBool "the refresh token really rotated" (newRefresh /= rotatingRefresh)+  assertBool "the rotation mints a new access token" (isJust (dig ["access_token"] rotBody >>= asText))+  -- A refresh does not mint an ID token: its nonce and auth_time belong to the authorize request.+  dig ["id_token"] rotBody @?= Nothing++  -- Replaying the now-used refresh token is reuse: the family and the session die.+  reuse <- refreshWith basic [("refresh_token", Text.encodeUtf8 rotatingRefresh)]+  assertOAuthError "replaying a rotated refresh token" 400 "invalid_grant" reuse+  dead <- refreshWith basic [("refresh_token", Text.encodeUtf8 newRefresh)]+  assertOAuthError "the whole family is revoked after reuse" 400 "invalid_grant" dead++-- | A session minted by password login carries no @oauth_client_id@, so it cannot be refreshed at+-- the OAuth token endpoint at all — only at the endpoint that created it.+scenarioOAuthRefreshRejectsUnboundSession :: Text -> Int -> IO ()+scenarioOAuthRefreshRejectsUnboundSession confId port = do+  mgr <- newManager defaultManagerSettings+  (status, body) <-+    postJSON+      mgr+      port+      "/v1/auth/signup"+      (object ["loginId" .= ("unbound-user" :: Text), "password" .= ("correct horse battery staple" :: Text), "displayName" .= ("" :: Text)])+  status @?= 201+  resp <- must "signup body" body+  refreshToken <- must "signup refreshToken" (dig ["token", "refreshToken"] resp >>= asText)++  r <-+    postForm+      mgr+      port+      "/oauth/token"+      (Just (confId, confidentialClientSecret))+      [("grant_type", "refresh_token"), ("refresh_token", Text.encodeUtf8 refreshToken)]+  assertOAuthError "an OAuth client refreshing a password-login session" 400 "invalid_grant" r++  -- And the bespoke endpoint still rotates it, unchanged.+  (bespoke, _) <- postJSON mgr port "/v1/auth/refresh" (object ["refreshToken" .= refreshToken])+  bespoke @?= 200++-- | The @sub@ claim of an access token, read back through the server's own @\/v1\/auth\/me@.+subjectOf :: Manager -> Int -> Text -> IO Text+subjectOf mgr port accessToken = do+  (status, body) <- getJSON mgr port "/v1/auth/me" [("Authorization", "Bearer " <> Text.encodeUtf8 accessToken)]+  status @?= 200+  resp <- must "me body" body+  must "me userId" (dig ["userId"] resp >>= asText)++-- | Verify an ID token's signature against the test signing key and return its claims.+--+-- Verifying rather than merely decoding is the point: an ID token a relying party cannot check is+-- worthless, and only signing it with the same active key and @kid@ as the access token makes it+-- checkable against the JWKS document this deployment already publishes.+verifyIdToken :: JWK -> Text -> IO (KM.KeyMap Value)+verifyIdToken jwk idToken = do+  result <- runJOSE @JWTError do+    jwt <- decodeCompact (LBS.fromStrict (Text.encodeUtf8 idToken))+    -- `aud` is the client_id, so the audience predicate accepts anything: what is under test is+    -- the signature and the claim contents, which the caller asserts on.+    verifyClaims (defaultJWTValidationSettings (const True)) jwk (jwt :: SignedJWT)+  case result of+    Left e -> assertFailure ("the id_token failed signature verification: " <> show (e :: JWTError))+    Right claims -> case toJSON (claims :: ClaimsSet) of+      Object o -> pure o+      other -> assertFailure ("id_token claims were not an object: " <> show other)++-- | EP-5 M4: userinfo, introspection, and revocation, and the revoke->introspect flip that is+-- this plan's headline acceptance behavior.+scenarioOAuthUserinfoIntrospectRevoke :: JWK -> Text -> Text -> Int -> IO ()+scenarioOAuthUserinfoIntrospectRevoke jwk confId pubId port = do+  mgr <- newManager defaultManagerSettings+  token <- signupToken mgr port "resource-user"+  let verifier = "another-high-entropy-verifier-of-good-length-abcdefghij" :: Text+      challenge = pkceChallengeFor verifier+      basic = Just (confId, confidentialClientSecret)+  code <- do+    r <-+      getNoRedirect+        mgr+        port+        ( authorizeUrl+            [ ("client_id", confId),+              ("response_type", "code"),+              ("redirect_uri", authorizeRedirectUri),+              ("scope", "openid profile"),+              ("code_challenge", challenge),+              ("code_challenge_method", "S256")+            ]+        )+        [("Authorization", "Bearer " <> Text.encodeUtf8 token)]+    (_, params) <- locationOf "authorize" r+    maybe (assertFailure "no code") pure (lookup "code" params)+  resp <-+    postForm+      mgr+      port+      "/oauth/token"+      basic+      [ ("grant_type", "authorization_code"),+        ("code", Text.encodeUtf8 code),+        ("redirect_uri", Text.encodeUtf8 authorizeRedirectUri),+        ("code_verifier", Text.encodeUtf8 verifier)+      ]+  body <- must "token body" (bodyOf resp)+  accessToken <- must "access_token" (dig ["access_token"] body >>= asText)+  refreshToken <- must "refresh_token" (dig ["refresh_token"] body >>= asText)+  idToken <- must "id_token" (dig ["id_token"] body >>= asText)++  -- userinfo: sub matches the ID token's sub, and it is bearer-protected.+  (uiStatus, uiBody) <- getJSON mgr port "/oauth/userinfo" [("Authorization", "Bearer " <> Text.encodeUtf8 accessToken)]+  uiStatus @?= 200+  ui <- must "userinfo body" uiBody+  uiSub <- must "userinfo sub" (dig ["sub"] ui >>= asText)+  idSub <- idTokenSub jwk idToken+  uiSub @?= idSub+  assertBool "userinfo carries scopes" (isJust (dig ["scopes"] ui))+  noTokenUi@(_, noTokenHeaders, _) <- getRaw mgr port "/oauth/userinfo" []+  assertOAuthError "userinfo without a bearer token" 401 "invalid_token" noTokenUi+  headerValue "WWW-Authenticate" noTokenHeaders+    @?= Just "Bearer realm=\"shomei\""+  assertBool+    "userinfo authentication failures stay outside the problem envelope"+    (headerValue "Content-Type" noTokenHeaders /= Just "application/problem+json")++  -- introspection requires client auth; without it, 401.+  noAuth <- postForm mgr port "/oauth/introspect" Nothing [("token", Text.encodeUtf8 accessToken)]+  assertOAuthError "introspect without client auth" 401 "invalid_client" noAuth+  -- A public client cannot introspect either: it holds no secret.+  pubAuth <- postForm mgr port "/oauth/introspect" Nothing [("client_id", Text.encodeUtf8 pubId), ("token", Text.encodeUtf8 accessToken)]+  assertOAuthError "a public client introspecting" 401 "invalid_client" pubAuth++  -- A live access token introspects active, with the RFC 7662 fields.+  active <- introspect mgr port basic accessToken+  (dig ["active"] active) @?= Just (Aeson.Bool True)+  (dig ["token_type"] active >>= asText) @?= Just "Bearer"+  (dig ["scope"] active >>= asText) @?= Just "openid profile"+  (dig ["sub"] active >>= asText) @?= Just uiSub+  assertBool "introspection reports sid" (isJust (dig ["sid"] active))++  -- Garbage introspects inactive, at 200 (never an error, to prevent probing).+  garbage <- introspect mgr port basic "not-a-token"+  garbage @?= object ["active" .= False]++  -- A token-type hint is an optimization, never a requirement. The JWT attempt falls through to+  -- opaque refresh-token lookup and reports the live refresh token at 200.+  activeRefresh <- introspect mgr port basic refreshToken+  dig ["active"] activeRefresh @?= Just (Aeson.Bool True)+  (dig ["token_type"] activeRefresh >>= asText) @?= Just "refresh_token"++  -- The flip: revoke the refresh token, and the access token's session dies with it, so+  -- introspection -- which is session-aware regardless of sessionCheckMode -- now reports inactive.+  (revStatus, _, _) <- postForm mgr port "/oauth/revoke" basic [("token", Text.encodeUtf8 refreshToken), ("token_type_hint", "refresh_token")]+  revStatus @?= 200+  afterRevoke <- introspect mgr port basic accessToken+  (dig ["active"] afterRevoke) @?= Just (Aeson.Bool False)+  -- The refresh token no longer rotates.+  reuse <- postForm mgr port "/oauth/token" basic [("grant_type", "refresh_token"), ("refresh_token", Text.encodeUtf8 refreshToken)]+  assertOAuthError "a revoked refresh token" 400 "invalid_grant" reuse+  -- Revoking an unknown token is still 200 (RFC 7009 forbids erroring, to prevent probing).+  (unknownRev, _, _) <- postForm mgr port "/oauth/revoke" basic [("token", "nonexistent")]+  unknownRev @?= 200++-- | Mint one authorization-code session through the seeded confidential client. These focused+-- M3 scenarios care about the resulting session boundary, not the already-covered ID token.+issueOAuthSession :: Manager -> Int -> Text -> Text -> Text -> IO (Text, Text)+issueOAuthSession mgr port confId userToken requestedScopes = do+  let verifier = "m3-session-verifier-with-enough-entropy-1234567890" :: Text+      challenge = pkceChallengeFor verifier+      basic = Just (confId, confidentialClientSecret)+  authorize <-+    getNoRedirect+      mgr+      port+      ( authorizeUrl+          [ ("client_id", confId),+            ("response_type", "code"),+            ("redirect_uri", authorizeRedirectUri),+            ("scope", requestedScopes),+            ("code_challenge", challenge),+            ("code_challenge_method", "S256")+          ]+      )+      (bearer userToken)+  (_, params) <- locationOf "M3 authorize" authorize+  code <- maybe (assertFailure "M3 authorize returned no code") pure (lookup "code" params)+  grant <-+    postForm+      mgr+      port+      "/oauth/token"+      basic+      [ ("grant_type", "authorization_code"),+        ("code", Text.encodeUtf8 code),+        ("redirect_uri", Text.encodeUtf8 authorizeRedirectUri),+        ("code_verifier", Text.encodeUtf8 verifier)+      ]+  statusOf grant @?= 200+  body <- must "M3 authorization-code response" (bodyOf grant)+  access <- must "M3 access_token" (dig ["access_token"] body >>= asText)+  refresh <- must "M3 refresh_token" (dig ["refresh_token"] body >>= asText)+  pure (access, refresh)++-- | RFC 7009 ownership matrix. A non-owner receives the RFC-mandated indistinguishable 200 but+-- cannot change the session; a service account with @shomei:admin@ is the explicit global escape+-- hatch.+scenarioRevokeOwnership :: Text -> Text -> Text -> Text -> Int -> IO ()+scenarioRevokeOwnership confId otherConfId plainId adminId port = do+  mgr <- newManager defaultManagerSettings+  userToken <- signupToken mgr port "revoke-owner-user"+  (accessToken, refreshToken) <- issueOAuthSession mgr port confId userToken "openid profile"+  let owner = Just (confId, confidentialClientSecret)++  (otherStatus, _, _) <-+    postForm+      mgr+      port+      "/oauth/revoke"+      (Just (otherConfId, confidentialClientSecret))+      [("token", Text.encodeUtf8 refreshToken), ("token_type_hint", "refresh_token")]+  otherStatus @?= 200++  rotation <-+    postForm+      mgr+      port+      "/oauth/token"+      owner+      [("grant_type", "refresh_token"), ("refresh_token", Text.encodeUtf8 refreshToken)]+  statusOf rotation @?= 200+  rotationBody <- must "owner rotation body" (bodyOf rotation)+  rotatedAccess <- must "owner rotated access_token" (dig ["access_token"] rotationBody >>= asText)++  (plainStatus, _, _) <-+    postForm+      mgr+      port+      "/oauth/revoke"+      (Just (plainId, oauthClientSecret))+      [("token", Text.encodeUtf8 rotatedAccess), ("token_type_hint", "access_token")]+  plainStatus @?= 200+  afterPlain <- introspect mgr port owner rotatedAccess+  dig ["active"] afterPlain @?= Just (Aeson.Bool True)++  (adminStatus, _, _) <-+    postForm+      mgr+      port+      "/oauth/revoke"+      (Just (adminId, oauthClientSecret))+      [("token", Text.encodeUtf8 rotatedAccess), ("token_type_hint", "access_token")]+  adminStatus @?= 200+  afterAdmin <- introspect mgr port owner rotatedAccess+  dig ["active"] afterAdmin @?= Just (Aeson.Bool False)+  -- The original access token named the same session and is dead too.+  originalAfterAdmin <- introspect mgr port owner accessToken+  dig ["active"] originalAfterAdmin @?= Just (Aeson.Bool False)++-- | OIDC Core §5.4 claim filtering: the subject and the token's own scope list are always+-- useful, while identity-profile fields require the scope bundles that name them.+scenarioUserinfoScopeGating :: Text -> Int -> IO ()+scenarioUserinfoScopeGating confId port = do+  mgr <- newManager defaultManagerSettings+  (signupStatus, signupBody) <-+    postJSON+      mgr+      port+      "/v1/auth/signup"+      ( object+          [ "loginId" .= ("userinfo-scope-user" :: Text),+            "email" .= ("userinfo-scope@example.com" :: Text),+            "password" .= ("correct horse battery staple" :: Text),+            "displayName" .= ("Userinfo Scope" :: Text)+          ]+      )+  signupStatus @?= 201+  signup <- must "userinfo signup body" signupBody+  userToken <- must "userinfo signup access token" (dig ["token", "accessToken"] signup >>= asText)++  (minimalAccess, _) <- issueOAuthSession mgr port confId userToken "openid"+  (minimalStatus, minimalBody) <- getJSON mgr port "/oauth/userinfo" (bearer minimalAccess)+  minimalStatus @?= 200+  minimal <- must "minimal userinfo" minimalBody+  assertBool "minimal userinfo carries sub" (isJust (dig ["sub"] minimal >>= asText))+  assertBool "minimal userinfo carries scopes" (isJust (dig ["scopes"] minimal))+  dig ["email"] minimal @?= Nothing+  dig ["email_verified"] minimal @?= Nothing+  dig ["roles"] minimal @?= Nothing++  (fullAccess, _) <- issueOAuthSession mgr port confId userToken "openid profile email"+  (fullStatus, fullBody) <- getJSON mgr port "/oauth/userinfo" (bearer fullAccess)+  fullStatus @?= 200+  full <- must "full userinfo" fullBody+  (dig ["email"] full >>= asText) @?= Just "userinfo-scope@example.com"+  dig ["email_verified"] full @?= Just (Aeson.Bool False)+  assertBool "profile scope includes roles" (isJust (dig ["roles"] full))++introspect :: Manager -> Int -> Maybe (Text, Text) -> Text -> IO Value+introspect mgr port basic tok = do+  r <- postForm mgr port "/oauth/introspect" basic [("token", Text.encodeUtf8 tok)]+  must "introspection body" (bodyOf r)++-- | The @sub@ claim of an ID token, read through the same signature-verifying path the M3 test+-- uses (so it doubles as a second check that the token verifies). @jwk@ is the test signing key.+idTokenSub :: JWK -> Text -> IO Text+idTokenSub jwk idToken = do+  claims <- verifyIdToken jwk idToken+  case KM.lookup "sub" claims of+    Just (String s) -> pure s+    _ -> assertFailure "id_token has no string sub"++-- | SH-25 M4 acceptance: an HTTP caller can sign up with ONLY a @loginId@ (no email). The+-- returned user has that login id and a @null@ email, and the same identifier logs in.+scenarioNoEmail :: Int -> IO ()+scenarioNoEmail port = do+  mgr <- newManager defaultManagerSettings+  let pw = "correct horse battery staple" :: Text+      signupB = object ["loginId" .= ("agent-x" :: Text), "password" .= pw, "displayName" .= ("" :: Text)]+  (sStatus, sBody) <- postJSON mgr port "/v1/auth/signup" signupB+  sStatus @?= 201+  sresp <- must "signup body" sBody+  (dig ["user", "loginId"] sresp >>= asText) @?= Just "agent-x"+  dig ["user", "email"] sresp @?= Just Null+  (lStatus, lBody) <- postJSON mgr port "/v1/auth/login" (object ["loginId" .= ("agent-x" :: Text), "password" .= pw])+  lStatus @?= 200+  lresp <- must "login body" lBody+  assertBool "login by identifier yields a token" (isJust (dig ["token", "accessToken"] lresp >>= asText))++scenarioSignupConflicts :: Int -> IO ()+scenarioSignupConflicts port = do+  mgr <- newManager defaultManagerSettings+  let email = "dup@example.com" :: Text+      password = "correct horse battery staple" :: Text+      signupBody loginId = object ["loginId" .= (loginId :: Text), "email" .= email, "password" .= password, "displayName" .= ("" :: Text)]+  first <- postRaw mgr port "/v1/auth/signup" [] (signupBody "dup-one")+  statusOf first @?= 201+  duplicateEmail <- postRaw mgr port "/v1/auth/signup" [] (signupBody "dup-two")+  assertProblem "duplicate email" 409 "email_taken" duplicateEmail+  duplicateLogin <- postRaw mgr port "/v1/auth/signup" [] (signupBody "dup-one")+  assertProblem "duplicate login id" 409 "login_id_taken" duplicateLogin++-- | A signup principal is explicit: email is contact data and cannot stand in for @loginId@.+scenarioSignupRequiresLoginId :: Int -> IO ()+scenarioSignupRequiresLoginId port = do+  mgr <- newManager defaultManagerSettings+  let em = "grace@example.com" :: Text+      pw = "correct horse battery staple" :: Text+      signupB = object ["email" .= em, "password" .= pw, "displayName" .= ("" :: Text)]+  (sStatus, sBody) <- postJSON mgr port "/v1/auth/signup" signupB+  sStatus @?= 400+  (sBody >>= dig ["code"] >>= asText) @?= Just "body_parse_error"++-- | With @emailVerificationRequired@ on, signup still hands out its initial pair (changing+-- that would break the response shape), but the first re-login and the first refresh are+-- refused with @403 email_not_verified@ — a distinct code, because the password was correct.+-- Confirming the emailed token unblocks both.+scenarioEmailVerificationRequired :: IORef World -> Int -> IO ()+scenarioEmailVerificationRequired ref port = do+  mgr <- newManager defaultManagerSettings+  let em = "unverified@example.com" :: Text+      pw = "correct horse battery staple" :: Text+      loginBody = object ["loginId" .= em, "password" .= pw]+  (sStatus, sBody) <- postJSON mgr port "/v1/auth/signup" (object ["loginId" .= em, "email" .= em, "password" .= pw, "displayName" .= ("" :: Text)])+  sStatus @?= 201+  sresp <- must "signup body" sBody+  refreshTok <- must "signup refreshToken" (dig ["token", "refreshToken"] sresp >>= asText)++  -- Unverified: a correct password is refused, and so is a silent renewal.+  (blockedLogin, blockedBody) <- postJSON mgr port "/v1/auth/login" loginBody+  blockedLogin @?= 403+  bresp <- must "blocked login body" blockedBody+  (dig ["code"] bresp >>= asText) @?= Just "email_not_verified"+  (blockedRefresh, _) <- postJSON mgr port "/v1/auth/refresh" (object ["refreshToken" .= refreshTok])+  blockedRefresh @?= 403++  -- Verify the email, and both work again.+  (reqStatus, _) <- postJSON mgr port "/v1/auth/verify-email/request" (object ["email" .= em])+  reqStatus @?= 202+  token <- latestVerificationToken ref+  (confirmStatus, _) <- postJSON mgr port "/v1/auth/verify-email/confirm" (object ["token" .= token])+  confirmStatus @?= 200 -- the verification completes synchronously; nothing is pending+  (okLogin, okBody) <- postJSON mgr port "/v1/auth/login" loginBody+  okLogin @?= 200+  okResp <- must "login body" okBody+  assertBool "verified login yields a token" (isJust (dig ["token", "accessToken"] okResp >>= asText))++-- Cookie transport -----------------------------------------------------------++cookieEmail :: Text+cookieEmail = "cookie@example.com"++cookiePassword :: Text+cookiePassword = "correct horse battery staple"++cookieSignupBody :: Value+cookieSignupBody = object ["loginId" .= cookieEmail, "email" .= cookieEmail, "password" .= cookiePassword, "displayName" .= ("C" :: Text)]++-- | The origin the default 'CookieConfig' allows.+allowedOrigin :: Header+allowedOrigin = ("Origin", "http://localhost:8080")++foreignOrigin :: Header+foreignOrigin = ("Origin", "https://evil.example.com")++-- | Sign up in cookie mode and return the two cookie values.+cookieSignup :: Manager -> Int -> IO (Text, Text, Maybe Value)+cookieSignup mgr port = do+  (status, hdrs, body) <- postRaw mgr port "/v1/auth/signup" [] cookieSignupBody+  status @?= 201+  let cookies = setCookies hdrs+  sess <- must "secure session cookie" (cookieValueOf secureSessionCookieName cookies)+  refr <- must "secure refresh cookie" (cookieValueOf secureRefreshCookieName cookies)+  pure (sess, refr, body)++secureSessionCookieName :: Text+secureSessionCookieName = "__Host-shomei_session"++secureRefreshCookieName :: Text+secureRefreshCookieName = "__Secure-shomei_refresh"++sessionCookieHeader :: Text -> Header+sessionCookieHeader v = ("Cookie", Text.encodeUtf8 (secureSessionCookieName <> "=" <> v))++refreshCookieHeader :: Text -> Header+refreshCookieHeader v = ("Cookie", Text.encodeUtf8 (secureRefreshCookieName <> "=" <> v))++-- | Cookie mode: the attributes browsers rely on, the token-free body, cookie authentication,+-- and logout clearing.+scenarioCookieTransport :: Int -> IO ()+scenarioCookieTransport port = do+  mgr <- newManager defaultManagerSettings+  (status, hdrs, body) <- postRaw mgr port "/v1/auth/signup" [] cookieSignupBody+  status @?= 201+  let cookies = setCookies hdrs+  length cookies @?= 2++  sess <- must "secure session cookie" (cookieValueOf secureSessionCookieName cookies)+  sessionAttrs <- must "secure session attributes" (listToMaybe (filter (T.isPrefixOf (secureSessionCookieName <> "=")) cookies))+  refreshAttrs <- must "secure refresh attributes" (listToMaybe (filter (T.isPrefixOf (secureRefreshCookieName <> "=")) cookies))++  -- HttpOnly is what puts the token out of an XSS payload's reach.+  assertBool ("session HttpOnly: " <> T.unpack sessionAttrs) ("HttpOnly" `T.isInfixOf` sessionAttrs)+  assertBool "session Secure" ("Secure" `T.isInfixOf` sessionAttrs)+  assertBool "session SameSite=Lax" ("SameSite=Lax" `T.isInfixOf` sessionAttrs)+  assertBool "session Path=/" ("Path=/;" `T.isInfixOf` sessionAttrs)+  assertBool "session Max-Age=900" ("Max-Age=900" `T.isInfixOf` sessionAttrs)+  -- The long-lived credential is presented to exactly one endpoint.+  assertBool ("refresh Path: " <> T.unpack refreshAttrs) ("Path=/v1/auth/refresh" `T.isInfixOf` refreshAttrs)+  assertBool "refresh HttpOnly" ("HttpOnly" `T.isInfixOf` refreshAttrs)+  assertBool "refresh Max-Age=2592000" ("Max-Age=2592000" `T.isInfixOf` refreshAttrs)++  -- The body carries no token values at all — not nulls, not empty strings.+  resp <- must "signup body" body+  assertBool "no accessToken key" (isNothing (dig ["token", "accessToken"] resp))+  assertBool "no refreshToken key" (isNothing (dig ["token", "refreshToken"] resp))+  assertBool "expiresIn present" (isJust (dig ["token", "expiresIn"] resp))++  -- A GET authenticated only by the cookie works, and needs no Origin (safe method).+  (meStatus, _) <- getJSON mgr port "/v1/auth/me" [sessionCookieHeader sess]+  meStatus @?= 200++  -- OIDC userinfo is an RFC 6750 bearer resource, even when application routes accept cookies.+  cookieUserinfo <- getRaw mgr port "/oauth/userinfo" [sessionCookieHeader sess]+  assertOAuthError "userinfo rejects cookie credentials" 401 "invalid_token" cookieUserinfo++  -- Logout clears both cookies: same names, empty values, Max-Age=0.+  (outStatus, outHdrs, _) <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess, allowedOrigin] Null+  outStatus @?= 204+  let cleared = setCookies outHdrs+  length cleared @?= 2+  assertBool ("session cleared: " <> show cleared) (any (\c -> (secureSessionCookieName <> "=;") `T.isPrefixOf` c && "Max-Age=0" `T.isInfixOf` c) cleared)+  assertBool ("refresh cleared: " <> show cleared) (any (\c -> (secureRefreshCookieName <> "=;") `T.isPrefixOf` c && "Max-Age=0" `T.isInfixOf` c) cleared)++-- | The CSRF matrix on a cookie-authenticated mutating route.+scenarioCsrfMatrix :: Int -> IO ()+scenarioCsrfMatrix port = do+  mgr <- newManager defaultManagerSettings+  (sess, _, _) <- cookieSignup mgr port++  -- No Origin, no Referer: fail closed. This is the attack shape.+  (noneStatus, _, noneBody) <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess] Null+  noneStatus @?= 403+  nb <- must "csrf body" noneBody+  (dig ["code"] nb >>= asText) @?= Just "csrf_rejected"++  -- A foreign origin: refused.+  (evilStatus, _, _) <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess, foreignOrigin] Null+  evilStatus @?= 403++  -- Referer fallback, for agents that omit Origin.+  (refStatus, _, _) <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess, ("Referer", "http://localhost:8080/app/settings")] Null+  refStatus @?= 204++  -- A Referer that merely *starts with* an allowed origin must not pass.+  (sess2, _, _) <- cookieSignupAs mgr port "csrf2@example.com"+  (badRefStatus, _, _) <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess2, ("Referer", "http://localhost:8080.evil.com/x")] Null+  badRefStatus @?= 403++  -- An allow-listed Origin: accepted.+  (okStatus, _, _) <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess2, allowedOrigin] Null+  okStatus @?= 204++  -- A bearer credential is never CSRF-gated, even from a foreign origin: a page cannot set+  -- the Authorization header, and gating it would break every non-browser client.+  (sess3, _, _) <- cookieSignupAs mgr port "csrf3@example.com"+  (bearerStatus, _, _) <- postRaw mgr port "/v1/auth/logout" [("Authorization", Text.encodeUtf8 ("Bearer " <> sess3)), foreignOrigin] Null+  bearerStatus @?= 204++-- | Sign up a distinct account in cookie mode.+cookieSignupAs :: Manager -> Int -> Text -> IO (Text, Text, Maybe Value)+cookieSignupAs mgr port email = do+  (status, hdrs, body) <- postRaw mgr port "/v1/auth/signup" [] (object ["loginId" .= email, "email" .= email, "password" .= cookiePassword, "displayName" .= ("C" :: Text)])+  status @?= 201+  let cookies = setCookies hdrs+  sess <- must "secure session cookie" (cookieValueOf secureSessionCookieName cookies)+  refr <- must "secure refresh cookie" (cookieValueOf secureRefreshCookieName cookies)+  pure (sess, refr, body)++-- | Refresh from the cookie: rotates, re-sets cookies, and is CSRF-gated like any mutation.+scenarioCookieRefresh :: Int -> IO ()+scenarioCookieRefresh port = do+  mgr <- newManager defaultManagerSettings+  (_, refr, _) <- cookieSignup mgr port++  -- Without an Origin the cookie-borne refresh token is refused.+  (noOrigin, _, _) <- postRaw mgr port "/v1/auth/refresh" [refreshCookieHeader refr] (object [])+  noOrigin @?= 403++  -- With an allow-listed Origin it rotates and hands back fresh cookies.+  (okStatus, okHdrs, okBody) <- postRaw mgr port "/v1/auth/refresh" [refreshCookieHeader refr, allowedOrigin] (object [])+  okStatus @?= 200+  let cookies = setCookies okHdrs+  newRefresh <- must "rotated secure refresh cookie" (cookieValueOf secureRefreshCookieName cookies)+  assertBool "the refresh token rotated" (newRefresh /= refr)+  resp <- must "refresh body" okBody+  assertBool "cookie mode omits body tokens on refresh" (isNothing (dig ["accessToken"] resp))++  -- Presenting the old token again is reuse: rotation already consumed it.+  (reuseStatus, _, _) <- postRaw mgr port "/v1/auth/refresh" [refreshCookieHeader refr, allowedOrigin] (object [])+  assertBool ("old refresh token must be rejected, got " <> show reuseStatus) (reuseStatus >= 400)++-- | Bearer mode: no cookies emitted, body tokens present, and — the review's finding — a+-- cookie is not accepted as a credential.+scenarioBearerRejectsCookies :: Int -> IO ()+scenarioBearerRejectsCookies port = do+  mgr <- newManager defaultManagerSettings+  (status, hdrs, body) <- postRaw mgr port "/v1/auth/signup" [] cookieSignupBody+  status @?= 201+  setCookies hdrs @?= []+  resp <- must "signup body" body+  access <- must "accessToken" (dig ["token", "accessToken"] resp >>= asText)+  assertBool "refreshToken present" (isJust (dig ["token", "refreshToken"] resp))++  -- The bearer token authenticates.+  (bearerStatus, _) <- getJSON mgr port "/v1/auth/me" [("Authorization", Text.encodeUtf8 ("Bearer " <> access))]+  bearerStatus @?= 200++  -- The very same token presented as a session cookie does not. Before this plan the+  -- cookie fallback was unconditional and this returned 200.+  (cookieStatus, _) <- getJSON mgr port "/v1/auth/me" [sessionCookieHeader access]+  cookieStatus @?= 401++-- | Both: cookies AND body tokens, for clients migrating between transports.+scenarioBothTransport :: Int -> IO ()+scenarioBothTransport port = do+  mgr <- newManager defaultManagerSettings+  (status, hdrs, body) <- postRaw mgr port "/v1/auth/signup" [] cookieSignupBody+  status @?= 201+  length (setCookies hdrs) @?= 2+  resp <- must "signup body" body+  assertBool "accessToken present in both mode" (isJust (dig ["token", "accessToken"] resp))+  assertBool "refreshToken present in both mode" (isJust (dig ["token", "refreshToken"] resp))+  sess <- must "secure session cookie" (cookieValueOf secureSessionCookieName (setCookies hdrs))+  (meStatus, _) <- getJSON mgr port "/v1/auth/me" [sessionCookieHeader sess]+  meStatus @?= 200++-- | Disabling Secure is a development escape hatch. Prefixes whose browser invariants require+-- Secure must disappear together with the attribute, and the configured bare name must still+-- authenticate the request.+scenarioInsecureCookieNames :: Int -> IO ()+scenarioInsecureCookieNames port = do+  mgr <- newManager defaultManagerSettings+  (status, hdrs, _) <- postRaw mgr port "/v1/auth/signup" [] cookieSignupBody+  status @?= 201+  let cookies = setCookies hdrs+  sess <- must "bare session cookie" (cookieValueOf "shomei_session" cookies)+  _ <- must "bare refresh cookie" (cookieValueOf "shomei_refresh" cookies)+  assertBool "secure session name is absent" (isNothing (cookieValueOf secureSessionCookieName cookies))+  assertBool "secure refresh name is absent" (isNothing (cookieValueOf secureRefreshCookieName cookies))+  assertBool "Secure is absent" (all (not . T.isInfixOf "; Secure") cookies)+  (meStatus, _) <- getJSON mgr port "/v1/auth/me" [("Cookie", Text.encodeUtf8 ("shomei_session=" <> sess))]+  meStatus @?= 200++-- | Header bytes are attacker input. Invalid UTF-8 must become an ordinary rejected credential+-- or origin, never an exception that escapes Servant and becomes a transport-level 500.+scenarioHostileAuthHeaders :: Int -> IO ()+scenarioHostileAuthHeaders port = do+  mgr <- newManager defaultManagerSettings+  (sess, _, _) <- cookieSignupAs mgr port "hostile-headers@example.com"+  let invalid = BS.pack [0xff]+  badAuthorization <- getRaw mgr port "/v1/auth/me" [("Authorization", "Bearer " <> invalid)]+  assertProblem "invalid UTF-8 Authorization" 401 "token_invalid" badAuthorization+  badCookie <- getRaw mgr port "/v1/auth/me" [("Cookie", invalid)]+  assertProblem "invalid UTF-8 Cookie" 401 "missing_token" badCookie+  badOrigin <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess, ("Origin", invalid)] Null+  assertProblem "invalid UTF-8 Origin" 403 "csrf_rejected" badOrigin+  badReferer <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess, ("Referer", invalid)] Null+  assertProblem "invalid UTF-8 Referer" 403 "csrf_rejected" badReferer++scenario :: IORef World -> Text -> Int -> IO ()+scenario ref adminToken port = do+  mgr <- newManager defaultManagerSettings++  -- (a) signup+  (sStatus, sBody) <- postJSON mgr port "/v1/auth/signup" signupBody+  sStatus @?= 201+  sresp <- must "signup body" sBody+  (dig ["user", "email"] sresp >>= asText) @?= Just email+  (dig ["user", "status"] sresp >>= asText) @?= Just "active"+  adaUserId <- must "signup userId" (dig ["user", "userId"] sresp >>= asText)+  assertBool "signup access token present" (isJust (dig ["token", "accessToken"] sresp >>= asText))+  assertBool "signup refresh token present" (isJust (dig ["token", "refreshToken"] sresp >>= asText))++  -- (a2) verify email via notifier-captured token+  (verifyReqStatus, _) <- postJSON mgr port "/v1/auth/verify-email/request" (object ["email" .= email])+  verifyReqStatus @?= 202+  emailVerificationToken <- latestVerificationToken ref+  (verifyConfirmStatus, _) <- postJSON mgr port "/v1/auth/verify-email/confirm" (object ["token" .= emailVerificationToken])+  verifyConfirmStatus @?= 200++  -- (b) login+  (lStatus, lBody) <- postJSON mgr port "/v1/auth/login" loginBody+  lStatus @?= 200+  lresp <- must "login body" lBody+  access <- must "login accessToken" (dig ["token", "accessToken"] lresp >>= asText)+  refreshTok <- must "login refreshToken" (dig ["token", "refreshToken"] lresp >>= asText)++  -- (c) me with Bearer+  (meStatus, meBody) <- getJSON mgr port "/v1/auth/me" (bearer access)+  meStatus @?= 200+  meresp <- must "me body" meBody+  (dig ["email"] meresp >>= asText) @?= Just email++  -- (d) me without and with garbage token+  (noTokStatus, _) <- getJSON mgr port "/v1/auth/me" []+  noTokStatus @?= 401+  (garbageStatus, _) <- getJSON mgr port "/v1/auth/me" (bearer "garbage.token.value")+  garbageStatus @?= 401++  -- (e) refresh rotates the token+  (rStatus, rBody) <- postJSON mgr port "/v1/auth/refresh" (object ["refreshToken" .= refreshTok])+  rStatus @?= 200+  rresp <- must "refresh body" rBody+  newRefresh <- must "rotated refreshToken" (dig ["refreshToken"] rresp >>= asText)+  assertBool "rotated refresh token differs" (newRefresh /= refreshTok)++  -- (f) jwks document: public key with kid, no private "d"+  (jStatus, jBody) <- getJSON mgr port "/.well-known/jwks.json" []+  jStatus @?= 200+  jwks <- must "jwks body" jBody+  assertBool "jwks has keys[].kid" (jwksHasKid jwks)+  assertBool "jwks has no private 'd'" (not (hasKeyDeep "d" jwks))++  -- (g) The RequireRole combinator enforces, with no handler guard behind it.+  --+  --     No token → 401 (the combinator authenticates before it authorizes); a token whose+  --     principal lacks the role → 403; a token minted AFTER a real grant → 200.+  (noTokenAdminStatus, _) <- getJSON mgr port "/admin/users" []+  noTokenAdminStatus @?= 401+  (garbageAdminStatus, _) <- getJSON mgr port "/admin/users" (bearer "garbage.token.value")+  garbageAdminStatus @?= 401+  (forbiddenStatus, _) <- getJSON mgr port "/admin/users" (bearer access)+  forbiddenStatus @?= 403++  -- A hand-signed token carrying the role passes: the combinator reads the claim.+  (adminStatus, _) <- getJSON mgr port "/admin/users" (bearer adminToken)+  adminStatus @?= 200++  -- ...and so does one minted by the real path: grant the role to the logged-in user through+  -- the audited workflow, log in again, and the fresh token opens the same door. This is the+  -- whole loop the plan exists to close — before EP-1, no production flow could mint this token.+  grantAdminTo ref adaUserId+  (grantedLoginStatus, grantedLoginBody) <- postJSON mgr port "/v1/auth/login" loginBody+  grantedLoginStatus @?= 200+  grantedResp <- must "post-grant login body" grantedLoginBody+  grantedAccess <- must "post-grant accessToken" (dig ["token", "accessToken"] grantedResp >>= asText)+  (grantedStatus, _) <- getJSON mgr port "/admin/users" (bearer grantedAccess)+  grantedStatus @?= 200++  -- The pre-grant token is unchanged: a JWT is self-contained, so the role appears only on+  -- tokens minted after the grant (the staleness contract in docs/user/security.md).+  (staleStatus, _) <- getJSON mgr port "/admin/users" (bearer access)+  staleStatus @?= 403++  -- Revoke it again, and the next mint has no role — the other half of the same contract.+  -- (This also restores the pre-grant state for the rest of the scenario, whose later logins+  -- mint fresh tokens for this very user and expect them to be non-admin.)+  revokeAdminFrom ref adaUserId+  (revokedLoginStatus, revokedLoginBody) <- postJSON mgr port "/v1/auth/login" loginBody+  revokedLoginStatus @?= 200+  revokedResp <- must "post-revoke login body" revokedLoginBody+  revokedAccess <- must "post-revoke accessToken" (dig ["token", "accessToken"] revokedResp >>= asText)+  (revokedStatus, _) <- getJSON mgr port "/admin/users" (bearer revokedAccess)+  revokedStatus @?= 403++  -- (g2) The RequireScope combinator enforces the same way. An ordinary login token carries no+  --      scopes; only an OAuth machine token holds 'kawa:ingest' (exercised in the OAuth suite).+  (noTokenIngestStatus, _) <- getJSON mgr port "/ingest" []+  noTokenIngestStatus @?= 401+  (ingestForbiddenStatus, _) <- getJSON mgr port "/ingest" (bearer revokedAccess)+  ingestForbiddenStatus @?= 403++  -- (h) password-reset request/confirm allows login with the new password.+  (resetReqStatus, _) <- postJSON mgr port "/v1/auth/password-reset/request" (object ["email" .= email])+  resetReqStatus @?= 202+  resetToken <- latestResetToken ref+  let changedPassword = "correct horse battery staple two" :: Text+  (resetConfirmStatus, _) <-+    postJSON+      mgr+      port+      "/v1/auth/password-reset/confirm"+      (object ["token" .= resetToken, "newPassword" .= changedPassword])+  resetConfirmStatus @?= 200+  (newLoginStatus, newLoginBody) <- postJSON mgr port "/v1/auth/login" (object ["loginId" .= email, "password" .= changedPassword])+  newLoginStatus @?= 200+  newLoginResp <- must "new login body" newLoginBody+  access2 <- must "new login accessToken" (dig ["token", "accessToken"] newLoginResp >>= asText)++  -- (i) passkey: begin → complete → list → delete (authenticated with the fresh token)+  (beginStatus, beginBody) <- postJSONAuth mgr port "/v1/auth/passkeys/register/begin" (bearer access2) (object [])+  beginStatus @?= 200+  bresp <- must "begin body" beginBody+  cid <- must "ceremonyId" (dig ["ceremonyId"] bresp >>= asText)+  chal <- must "challenge" (dig ["options", "challenge"] bresp >>= asText)+  let cred =+        object+          [ "challenge" .= chal,+            "credentialId" .= WebAuthnCredentialId "passkey-cred-1",+            "userHandle" .= UserHandle "passkey-uh-1",+            "publicKey" .= PublicKeyBytes "passkey-pk-1"+          ]+      completeBody = object ["ceremonyId" .= cid, "credential" .= cred, "label" .= ("YubiKey" :: Text)]+  (compStatus, compBody) <- postJSONAuth mgr port "/v1/auth/passkeys/register/complete" (bearer access2) completeBody+  compStatus @?= 200+  cresp <- must "complete body" compBody+  pkId <- must "passkeyId" (dig ["passkeyId"] cresp >>= asText)+  (dig ["label"] cresp >>= asText) @?= Just "YubiKey"++  (listStatus, listBody) <- getJSON mgr port "/v1/auth/passkeys" (bearer access2)+  listStatus @?= 200+  listResp <- must "list body" listBody+  case listResp of+    Array xs -> assertBool "one passkey listed" (length xs == 1)+    _ -> assertFailure "expected a JSON array of passkeys"++  (delStatus, _) <- deleteAuth mgr port ("/v1/auth/passkeys/" <> T.unpack pkId) (bearer access2)+  delStatus @?= 204++  (list2Status, list2Body) <- getJSON mgr port "/v1/auth/passkeys" (bearer access2)+  list2Status @?= 200+  list2Resp <- must "list2 body" list2Body+  case list2Resp of+    Array xs -> assertBool "no passkeys after delete" (null xs)+    _ -> assertFailure "expected a JSON array after delete"++  -- (j) re-completing the now-consumed ceremony is a 404+  (badStatus, _) <-+    postJSONAuth+      mgr+      port+      "/v1/auth/passkeys/register/complete"+      (bearer access2)+      (object ["ceremonyId" .= cid, "credential" .= cred])+  badStatus @?= 404++  -- (k) a passkey route without a bearer token is a 401+  (unauthStatus, _) <- getJSON mgr port "/v1/auth/passkeys" []+  unauthStatus @?= 401++  -- (l) re-enroll a passkey so the account now requires MFA at the next password login.+  (rbStatus, rbBody) <- postJSONAuth mgr port "/v1/auth/passkeys/register/begin" (bearer access2) (object [])+  rbStatus @?= 200+  rbresp <- must "mfa enroll begin body" rbBody+  rbCid <- must "mfa enroll ceremonyId" (dig ["ceremonyId"] rbresp >>= asText)+  rbChal <- must "mfa enroll challenge" (dig ["options", "challenge"] rbresp >>= asText)+  let credAssertion challengeText =+        object+          [ "challenge" .= challengeText,+            "credentialId" .= WebAuthnCredentialId "passkey-cred-2",+            "userHandle" .= UserHandle "passkey-uh-2",+            "publicKey" .= PublicKeyBytes "passkey-pk-2"+          ]+  (rcStatus, _) <-+    postJSONAuth+      mgr+      port+      "/v1/auth/passkeys/register/complete"+      (bearer access2)+      (object ["ceremonyId" .= rbCid, "credential" .= credAssertion rbChal, "label" .= ("MFA Key" :: Text)])+  rcStatus @?= 200++  -- (m) the password login now returns an MFA challenge and NO token.+  (mfaLoginStatus, mfaLoginBody) <- postJSON mgr port "/v1/auth/login" (object ["loginId" .= email, "password" .= changedPassword])+  mfaLoginStatus @?= 200+  mfaLoginResp <- must "mfa login body" mfaLoginBody+  (dig ["status"] mfaLoginResp >>= asText) @?= Just "mfa_required"+  assertBool "no access token in the mfa_required body" (isNothing (dig ["token"] mfaLoginResp))+  mfaCeremonyId <- must "mfa login ceremonyId" (dig ["ceremonyId"] mfaLoginResp >>= asText)+  mfaChallenge <- must "mfa login challenge" (dig ["options", "challenge"] mfaLoginResp >>= asText)++  -- (n) completing MFA with a valid assertion yields a token pair.+  (mfaCompleteStatus, mfaCompleteBody) <-+    postJSON+      mgr+      port+      "/v1/auth/mfa/complete"+      (object ["ceremonyId" .= mfaCeremonyId, "proof" .= object ["type" .= ("passkey" :: Text), "assertion" .= credAssertion mfaChallenge]])+  mfaCompleteStatus @?= 200+  mfaCompleteResp <- must "mfa complete body" mfaCompleteBody+  mfaAccess <- must "mfa complete accessToken" (dig ["accessToken"] mfaCompleteResp >>= asText)++  -- (o) the MFA-issued access token authenticates /auth/me.+  (meMfaStatus, _) <- getJSON mgr port "/v1/auth/me" (bearer mfaAccess)+  meMfaStatus @?= 200++  -- (p) re-submitting the now-consumed ceremony is a 404.+  (mfaStaleStatus, _) <-+    postJSON+      mgr+      port+      "/v1/auth/mfa/complete"+      (object ["ceremonyId" .= mfaCeremonyId, "proof" .= object ["type" .= ("passkey" :: Text), "assertion" .= credAssertion mfaChallenge]])+  mfaStaleStatus @?= 404++  -- (q) passwordless login: begin → complete → me, no password.+  (plBeginStatus, plBeginBody) <- postJSON mgr port "/v1/auth/login/passkey/begin" (object [])+  plBeginStatus @?= 200+  plBeginResp <- must "passwordless begin body" plBeginBody+  plCid <- must "passwordless ceremonyId" (dig ["ceremonyId"] plBeginResp >>= asText)+  plChal <- must "passwordless challenge" (dig ["options", "challenge"] plBeginResp >>= asText)+  (plCompleteStatus, plCompleteBody) <-+    postJSON mgr port "/v1/auth/login/passkey/complete" (object ["ceremonyId" .= plCid, "assertion" .= credAssertion plChal])+  plCompleteStatus @?= 200+  plResp <- must "passwordless complete body" plCompleteBody+  plAccess <- must "passwordless accessToken" (dig ["accessToken"] plResp >>= asText)+  (mePlStatus, _) <- getJSON mgr port "/v1/auth/me" (bearer plAccess)+  mePlStatus @?= 200++  -- (r) EP-7 audit retrieval: admin reads the trail; non-admin/no-token are refused;+  -- filters and keyset pagination behave.+  (auditNoTokStatus, _) <- getJSON mgr port "/v1/admin/audit/events" []+  auditNoTokStatus @?= 401+  (auditForbiddenStatus, _) <- getJSON mgr port "/v1/admin/audit/events" (bearer plAccess)+  auditForbiddenStatus @?= 403+  (auditStatus, auditBody) <- getJSON mgr port "/v1/admin/audit/events" (bearer adminToken)+  auditStatus @?= 200+  auditResp <- must "audit body" auditBody+  case dig ["events"] auditResp of+    Just (Array xs) -> assertBool "audit trail is non-empty" (not (null xs))+    _ -> assertFailure "expected an events array"++  -- type filter: every returned row is a login_succeeded (and there is at least one)+  (auditTypeStatus, auditTypeBody) <- getJSON mgr port "/v1/admin/audit/events?type=login_succeeded" (bearer adminToken)+  auditTypeStatus @?= 200+  auditTypeResp <- must "audit type body" auditTypeBody+  case dig ["events"] auditTypeResp of+    Just (Array xs) -> do+      assertBool "at least one login_succeeded event" (not (null xs))+      assertBool+        "every returned event is login_succeeded"+        (all (\e -> (field "eventType" e >>= asText) == Just "login_succeeded") (toList xs))+    _ -> assertFailure "expected an events array"++  -- a malformed UUID filter is a 400+  (auditBadStatus, _) <- getJSON mgr port "/v1/admin/audit/events?user=not-a-uuid" (bearer adminToken)+  auditBadStatus @?= 400++  -- keyset pagination: limit=1, then follow nextCursor; the two pages are disjoint.+  (p1Status, p1Body) <- getJSON mgr port "/v1/admin/audit/events?limit=1" (bearer adminToken)+  p1Status @?= 200+  p1Resp <- must "audit page1 body" p1Body+  p1Events <- case dig ["events"] p1Resp of+    Just (Array xs) -> pure (toList xs)+    _ -> assertFailure "expected events array (page1)"+  assertBool "page1 has exactly one event" (length p1Events == 1)+  cursor <- must "page1 nextCursor" (dig ["nextCursor"] p1Resp >>= asText)+  let p1Id = listToMaybe p1Events >>= field "eventId" >>= asText+  (p2Status, p2Body) <-+    getJSON mgr port ("/v1/admin/audit/events?limit=1&before=" <> urlEncodeText cursor) (bearer adminToken)+  p2Status @?= 200+  p2Resp <- must "audit page2 body" p2Body+  p2Events <- case dig ["events"] p2Resp of+    Just (Array xs) -> pure (toList xs)+    _ -> assertFailure "expected events array (page2)"+  assertBool "page2 has exactly one event" (length p2Events == 1)+  let p2Id = listToMaybe p2Events >>= field "eventId" >>= asText+  assertBool "the two pages are disjoint" (p1Id /= p2Id)+  where+    email = "ada@example.com" :: Text+    password = "correct horse battery staple" :: Text+    signupBody = object ["loginId" .= email, "email" .= email, "password" .= password, "displayName" .= ("Ada Lovelace" :: Text)]+    loginBody = object ["loginId" .= email, "password" .= password]++latestVerificationToken :: IORef World -> IO Text+latestVerificationToken ref = do+  w <- readIORef ref+  case w.sentNotifications of+    EmailVerificationRequested {token = OneTimeToken t} : _ -> pure t+    _ -> assertFailure "expected email-verification notification"++latestResetToken :: IORef World -> IO Text+latestResetToken ref = do+  w <- readIORef ref+  case w.sentNotifications of+    PasswordResetRequested {token = OneTimeToken t} : _ -> pure t+    _ -> assertFailure "expected password-reset notification"++-- | EP-7: the TOTP + recovery-code flow end to end over HTTP. The in-memory World's clock is+-- fixed, so the scenario advances it deliberately to move TOTP time-step counters forward (a+-- confirmed code cannot be reused for a login at the same counter — the strictly-greater replay+-- rule) and, at the end, to age a token past the freshness window.+scenarioTotp :: IORef World -> JWK -> ShomeiConfig -> Int -> IO ()+scenarioTotp r jwk cfg port = do+  mgr <- newManager defaultManagerSettings+  let email = "totp@example.com" :: Text+      pw = "correct horse battery staple totp" :: Text+      login = postJSON mgr port "/v1/auth/login" (object ["loginId" .= email, "password" .= pw])+      complete cid proof = postJSON mgr port "/v1/auth/mfa/complete" (object ["ceremonyId" .= cid, "proof" .= proof])++  -- signup, then a first (factor-free) login for a working token.+  (suStatus, _) <- postJSON mgr port "/v1/auth/signup" (object ["loginId" .= email, "email" .= email, "password" .= pw, "displayName" .= ("T" :: Text)])+  suStatus @?= 201+  (liStatus, liBody) <- login+  liStatus @?= 200+  (liBody >>= dig ["status"] >>= asText) @?= Just "complete"+  access <- must "login accessToken" (liBody >>= dig ["token", "accessToken"] >>= asText)++  -- Move the deterministic World clock ~12 minutes into the PAST relative to the real wall clock,+  -- then step it forward. Tokens minted at these World times keep an @nbf@/@exp@ that jose (which+  -- validates against the real clock) still accepts, while their time-step counters advance so a+  -- confirmed code cannot be replayed at the next login (the strictly-greater rule).+  now0 <- clock <$> readIORef r+  let start = addUTCTime (-720) now0+  setClock r start++  -- enroll: secret shown once, plus an otpauth URI.+  (enStatus, enBody) <- postAuthNoBody mgr port "/v1/auth/totp/enroll" (bearer access)+  assertEqual ("enroll body: " <> show enBody) 200 enStatus+  secretB32 <- must "enroll secret" (enBody >>= dig ["secret"] >>= asText)+  assertBool "otpauth uri present" (isJust (enBody >>= dig ["otpauthUri"]))+  secret <- either (\e -> assertFailure ("bad base32 secret: " <> e)) pure (base32ToSecret secretB32)+  let codeAt t = totpCode 6 secret (totpCounter t)++  -- activate with the current code.+  (vStatus, _) <- postJSONAuth mgr port "/v1/auth/totp/verify" (bearer access) (object ["code" .= codeAt start])+  vStatus @?= 200++  -- step the clock so a login-complete code is a strictly-later counter than the confirming one.+  let t1 = addUTCTime 60 start+  setClock r t1++  -- login now challenges; a TOTP-only user gets empty options and a methods list naming totp.+  (m1Status, m1Body) <- login+  m1Status @?= 200+  (m1Body >>= dig ["status"] >>= asText) @?= Just "mfa_required"+  m1Methods <- must "methods" (m1Body >>= dig ["methods"] >>= asTextArray)+  assertBool "totp advertised in methods" ("totp" `elem` m1Methods)+  (m1Body >>= dig ["options"]) @?= Just (object [])+  cid1 <- must "ceremonyId" (m1Body >>= dig ["ceremonyId"] >>= asText)++  -- complete with the code for the current counter.+  let code1 = codeAt t1+  (c1Status, c1Body) <- complete cid1 (object ["type" .= ("totp" :: Text), "code" .= code1])+  c1Status @?= 200+  totpAccess <- must "totp accessToken" (c1Body >>= dig ["accessToken"] >>= asText)+  totpRefresh <- must "totp refreshToken" (c1Body >>= dig ["refreshToken"] >>= asText)++  -- replaying that same code at a fresh challenge fails: its counter is now spent.+  (m2Status, m2Body) <- login+  m2Status @?= 200+  cid2 <- must "cid2" (m2Body >>= dig ["ceremonyId"] >>= asText)+  (rStatus, rBody) <- complete cid2 (object ["type" .= ("totp" :: Text), "code" .= code1])+  rStatus @?= 401+  (rBody >>= dig ["code"] >>= asText) @?= Just "totp_code_invalid"++  -- The removed flat compatibility shape fails before any workflow runs.+  (oldShapeStatus, _) <-+    postJSON+      mgr+      port+      "/v1/auth/mfa/complete"+      (object ["ceremonyId" .= ("webauthn_ceremony_x" :: Text), "totpCode" .= code1])+  oldShapeStatus @?= 400++  -- generate recovery codes (the token is fresh: issued at the current clock).+  (gStatus, gBody) <- postAuthNoBody mgr port "/v1/auth/recovery-codes" (bearer totpAccess)+  gStatus @?= 200+  codes <- must "recovery codes" (gBody >>= dig ["codes"] >>= asTextArray)+  length codes @?= 10+  (cntStatus, cntBody) <- getJSON mgr port "/v1/auth/recovery-codes" (bearer totpAccess)+  cntStatus @?= 200+  (cntBody >>= dig ["remaining"] >>= asInt) @?= Just 10++  -- complete a login with a recovery code; the count then drops by one.+  (m3Status, m3Body) <- login+  m3Status @?= 200+  m3Methods <- must "m3 methods" (m3Body >>= dig ["methods"] >>= asTextArray)+  assertBool "recovery_code advertised in methods" ("recovery_code" `elem` m3Methods)+  cid3 <- must "cid3" (m3Body >>= dig ["ceremonyId"] >>= asText)+  firstRecovery <- must "first recovery code" (listToMaybe codes)+  (rc1Status, rc1Body) <- complete cid3 (object ["type" .= ("recovery_code" :: Text), "code" .= firstRecovery])+  rc1Status @?= 200+  rcAccess <- must "recovery accessToken" (rc1Body >>= dig ["accessToken"] >>= asText)+  (cnt2Status, cnt2Body) <- getJSON mgr port "/v1/auth/recovery-codes" (bearer rcAccess)+  cnt2Status @?= 200+  (cnt2Body >>= dig ["remaining"] >>= asInt) @?= Just 9++  -- the same recovery code cannot be spent twice.+  (m4Status, m4Body) <- login+  m4Status @?= 200+  cid4 <- must "cid4" (m4Body >>= dig ["ceremonyId"] >>= asText)+  (rc2Status, rc2Body) <- complete cid4 (object ["type" .= ("recovery_code" :: Text), "code" .= firstRecovery])+  rc2Status @?= 401+  (rc2Body >>= dig ["code"] >>= asText) @?= Just "recovery_code_invalid"++  -- enrolling under a delegated (impersonation) token is refused with an audited 403.+  delegatedTok <- do+    uid <- genUserId+    sid <- genSessionId+    opUid <- genUserId+    let claims =+          AuthClaims+            { subject = uid,+              sessionId = sid,+              issuer = cfg.issuer,+              audience = cfg.audience,+              issuedAt = start,+              expiresAt = addUTCTime 900 start,+              authTime = start,+              scopes = Set.empty,+              roles = Set.empty,+              permissions = Set.empty,+              actor = Just opUid,+              extraClaims = mempty+            }+    signAccessToken jwk claims >>= either (\e -> assertFailure ("sign delegated: " <> show e)) (\(AccessToken t) -> pure t)+  (impStatus, impBody) <- postAuthNoBody mgr port "/v1/auth/totp/enroll" (bearer delegatedTok)+  impStatus @?= 403+  (impBody >>= dig ["code"] >>= asText) @?= Just "impersonation_action_blocked"++  -- remove the factor with a current code (step the clock again so the code is a later counter),+  -- after which login no longer challenges (recovery codes alone do not trigger MFA).+  let t2 = addUTCTime 60 t1+  setClock r t2+  (delStatus, _) <- deleteAuthBody mgr port "/v1/auth/totp" (bearer totpAccess) (object ["code" .= codeAt t2])+  delStatus @?= 204+  (afterStatus, afterBody) <- login+  afterStatus @?= 200+  (afterBody >>= dig ["status"] >>= asText) @?= Just "complete"++  -- TOTP removal and recovery-code regeneration both require recent credential proof. Advancing+  -- the World clock ages the earlier token (its jose exp is checked against real time, so it stays+  -- otherwise valid); refreshing rotates iat but must preserve the earlier auth_time.+  let t3 = addUTCTime 600 t1+  setClock r t3+  (staleDeleteStatus, staleDeleteBody) <- deleteAuthBody mgr port "/v1/auth/totp" (bearer totpAccess) (object ["code" .= codeAt t3])+  staleDeleteStatus @?= 403+  (staleDeleteBody >>= dig ["code"] >>= asText) @?= Just "reauthentication_required"+  (refreshStatus, refreshBody) <- postJSON mgr port "/v1/auth/refresh" (object ["refreshToken" .= totpRefresh])+  refreshStatus @?= 200+  refreshedAccess <- must "refreshed accessToken" (refreshBody >>= dig ["accessToken"] >>= asText)+  (frStatus, frBody) <- postAuthNoBody mgr port "/v1/auth/recovery-codes" (bearer refreshedAccess)+  frStatus @?= 403+  (frBody >>= dig ["code"] >>= asText) @?= Just "reauthentication_required"++-- | Regression for EP-4's account-wide second-factor budget. Five wrong TOTP proofs must lock+-- the account even when each proof follows a correct password, and a ceremony created before+-- the lockout must not let the correct code through afterward.+scenarioTotpLockout :: IORef World -> Int -> IO ()+scenarioTotpLockout r port = do+  mgr <- newManager defaultManagerSettings+  let email = "totp-lockout@example.com" :: Text+      pw = "correct horse battery staple totp lockout" :: Text+      login = postJSON mgr port "/v1/auth/login" (object ["loginId" .= email, "password" .= pw])+      complete cid code =+        postJSON+          mgr+          port+          "/v1/auth/mfa/complete"+          (object ["ceremonyId" .= cid, "proof" .= object ["type" .= ("totp" :: Text), "code" .= code]])+      challenge = do+        (status, body) <- login+        status @?= 200+        (body >>= dig ["status"] >>= asText) @?= Just "mfa_required"+        must "lockout ceremonyId" (body >>= dig ["ceremonyId"] >>= asText)++  (signupStatus, _) <-+    postJSON+      mgr+      port+      "/v1/auth/signup"+      (object ["loginId" .= email, "email" .= email, "password" .= pw, "displayName" .= ("Lockout" :: Text)])+  signupStatus @?= 201+  (loginStatus, loginBody) <- login+  loginStatus @?= 200+  access <- must "lockout login accessToken" (loginBody >>= dig ["token", "accessToken"] >>= asText)++  now0 <- clock <$> readIORef r+  let start = now0+  setClock r start+  (enrollStatus, enrollBody) <- postAuthNoBody mgr port "/v1/auth/totp/enroll" (bearer access)+  enrollStatus @?= 200+  secretB32 <- must "lockout enroll secret" (enrollBody >>= dig ["secret"] >>= asText)+  secret <- either (\e -> assertFailure ("bad base32 secret: " <> e)) pure (base32ToSecret secretB32)+  let codeAt t = totpCode 6 secret (totpCounter t)+  (verifyStatus, _) <-+    postJSONAuth mgr port "/v1/auth/totp/verify" (bearer access) (object ["code" .= codeAt start])+  verifyStatus @?= 200++  let proofTime = addUTCTime 60 start+      correct = codeAt proofTime+      wrong = if correct == "000000" then "999999" else "000000"+  setClock r proofTime++  replicateM_ 4 do+    cid <- challenge+    (status, body) <- complete cid wrong+    status @?= 401+    (body >>= dig ["code"] >>= asText) @?= Just "totp_code_invalid"++  cidA <- challenge+  cidB <- challenge+  (fifthStatus, fifthBody) <- complete cidA wrong+  fifthStatus @?= 401+  (fifthBody >>= dig ["code"] >>= asText) @?= Just "totp_code_invalid"++  (lockedCompletionStatus, lockedCompletionBody) <- complete cidB correct+  assertEqual ("locked completion body: " <> show lockedCompletionBody) 401 lockedCompletionStatus+  (lockedCompletionBody >>= dig ["code"] >>= asText) @?= Just "totp_code_invalid"++  (lockedLoginStatus, lockedLoginBody) <- login+  assertEqual ("locked login body: " <> show lockedLoginBody) 401 lockedLoginStatus+  (lockedLoginBody >>= dig ["code"] >>= asText) @?= Just "invalid_login"++-- Request helpers (parseRequest does not throw on non-2xx, so 401/403/404 come back+-- as ordinary responses).++postJSON :: Manager -> Int -> String -> Value -> IO (Int, Maybe Value)+postJSON mgr port path body = do+  (status, _, b) <- postRaw mgr port path [] body+  pure (status, b)++-- | POST with arbitrary headers, exposing the response's headers too — the cookie tests+-- assert on @Set-Cookie@.+postRaw :: Manager -> Int -> String -> [Header] -> Value -> IO (Int, [Header], Maybe Value)+postRaw mgr port path hdrs body = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req =+        req0+          { method = "POST",+            requestHeaders = ("Content-Type", "application/json") : hdrs,+            requestBody = RequestBodyLBS (encode body)+          }+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), responseHeaders resp, decode (responseBody resp))++-- | The @Set-Cookie@ values of a response, in order.+setCookies :: [Header] -> [Text]+setCookies hdrs = [Text.decodeUtf8 v | (n, v) <- hdrs, n == "Set-Cookie"]++-- | The value of the named cookie from a @Set-Cookie@ list (the bit before the first @;@).+cookieValueOf :: Text -> [Text] -> Maybe Text+cookieValueOf name =+  listToMaybe . mapMaybe (T.stripPrefix (name <> "=") . T.takeWhile (/= ';'))++getJSON :: Manager -> Int -> String -> [Header] -> IO (Int, Maybe Value)+getJSON mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "GET", requestHeaders = hdrs}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), decode (responseBody resp))++-- | POST a JSON body with extra headers (e.g. a Bearer token).+postJSONAuth :: Manager -> Int -> String -> [Header] -> Value -> IO (Int, Maybe Value)+postJSONAuth mgr port path hdrs body = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req =+        req0+          { method = "POST",+            requestHeaders = ("Content-Type", "application/json") : hdrs,+            requestBody = RequestBodyLBS (encode body)+          }+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), decode (responseBody resp))++-- | DELETE with extra headers (e.g. a Bearer token).+deleteAuth :: Manager -> Int -> String -> [Header] -> IO (Int, Maybe Value)+deleteAuth mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "DELETE", requestHeaders = hdrs}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), decode (responseBody resp))++-- | DELETE with a JSON body and extra headers (the TOTP-removal shape).+deleteAuthBody :: Manager -> Int -> String -> [Header] -> Value -> IO (Int, Maybe Value)+deleteAuthBody mgr port path hdrs body = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req =+        req0+          { method = "DELETE",+            requestHeaders = ("Content-Type", "application/json") : hdrs,+            requestBody = RequestBodyLBS (encode body)+          }+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), decode (responseBody resp))++-- | PUT with a bearer token and no body (the role-grant shape).+putAuth :: Manager -> Int -> String -> [Header] -> IO (Int, Maybe Value)+putAuth mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "PUT", requestHeaders = hdrs}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), decode (responseBody resp))++-- | POST with a bearer token and no body (suspend/reinstate/password-reset).+postAuthNoBody :: Manager -> Int -> String -> [Header] -> IO (Int, Maybe Value)+postAuthNoBody mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "POST", requestHeaders = hdrs}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), decode (responseBody resp))++bearer :: Text -> [Header]+bearer tok = [("Authorization", "Bearer " <> Text.encodeUtf8 tok)]++-- | Percent-encode a query-string value (the audit cursor carries @:@, @.@, @;@).+urlEncodeText :: Text -> String+urlEncodeText = T.unpack . Text.decodeUtf8 . urlEncode True . Text.encodeUtf8++-- JSON navigation helpers.++must :: String -> Maybe a -> IO a+must label = maybe (assertFailure ("missing: " <> label)) pure++field :: Text -> Value -> Maybe Value+field k (Object o) = KM.lookup (K.fromText k) o+field _ _ = Nothing++dig :: [Text] -> Value -> Maybe Value+dig ks v0 = foldl (\mv k -> mv >>= field k) (Just v0) ks++asText :: Value -> Maybe Text+asText (String t) = Just t+asText _ = Nothing++asTextArray :: Value -> Maybe [Text]+asTextArray (Array xs) = traverse asText (toList xs)+asTextArray _ = Nothing++asInt :: Value -> Maybe Int+asInt (Number n) = Just (round n)+asInt _ = Nothing++-- | Move the in-memory World's deterministic clock (EP-7 tests advance it to step TOTP counters+-- forward and to age a token past the freshness window).+setClock :: IORef World -> UTCTime -> IO ()+setClock r t = modifyIORef' r (\w -> w {clock = t})++-- | Does the document have @keys@ as a non-empty array whose first element has a @kid@?+jwksHasKid :: Value -> Bool+jwksHasKid v = case dig ["keys"] v of+  Just (Array xs) -> case toList xs of+    (k0 : _) -> isJust (field "kid" k0)+    [] -> False+  _ -> False++-- | Recursively: does any object anywhere in the value carry a key named @k@?+hasKeyDeep :: Text -> Value -> Bool+hasKeyDeep k = go+  where+    go (Object o) = any (\(kk, vv) -> K.toText kk == k || go vv) (KM.toList o)+    go (Array xs) = any go (toList xs)+    go _ = False