shomei-servant 0.2.0.0 → 0.3.0.0

raw patch · 25 files changed

+589/−174 lines, 25 filesdep ~shomei-coredep ~shomei-jwtdep ~shomei-servantPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: shomei-core, shomei-jwt, shomei-servant

API changes (from Hackage documentation)

Files

• CHANGELOG.md +22/−0
• shomei-servant.cabal +117/−97
• src/Shomei/Account/Handler.hs +3/−3
• src/Shomei/Audit/Dto.hs +6/−1
• src/Shomei/Authorization/Handler.hs +1/−1
• src/Shomei/Mfa/Dto.hs +4/−1
• src/Shomei/Mfa/Handler.hs +1/−1
• src/Shomei/OAuth/Handler.hs +2/−0
• src/Shomei/Passkey/Dto.hs +3/−1
• src/Shomei/Passkey/Handler.hs +1/−1
• src/Shomei/Servant/Api.hs +2/−2
• src/Shomei/Servant/Auth.hs +16/−9
• src/Shomei/Servant/Authz.hs +1/−0
• src/Shomei/Servant/CachedJson.hs +31/−0
• src/Shomei/Servant/Error.hs +10/−1
• src/Shomei/Servant/Middleware.hs +10/−2
• src/Shomei/Servant/OAuth.hs +15/−2
• src/Shomei/Servant/OpenApi.hs +54/−6
• src/Shomei/Servant/Server.hs +2/−2
• src/Shomei/Session/Admin/Api.hs +2/−1
• src/Shomei/Session/Dto.hs +48/−6
• src/Shomei/Session/Handler.hs +13/−7
• src/Shomei/Session/Result.hs +3/−3
• test-openapi/Main.hs +50/−7
• test/Main.hs +172/−20

@@ -4,6 +4,28 @@ [PVP](https://pvp.haskell.org/) and is versioned independently of the other Shōmei packages. +## 0.3.0.0 — 2026-11-05++- **Breaking:** internal dependency bounds follow the 0.3 API series.++- **Breaking (Haskell route type only):** OpenApiRoute returns `CachedJson`; use `cachedJsonValue` for its parsed document. The URL, application/json media type, JSON schema and bytes are preserved. Shared standalone/embedded assembly now renders one forced byte representation per document version.++- **Breaking:** PostgreSQL assembly uses the managed `Shomei.Persistence.Pool.Postgres.Pool` and its `UsageError`, `use` and `release` operations. Interrupted/failed sessions discard their connection and restore capacity; the external pool dependency is removed.++- Machine and delegated mints atomically enforce the configurable active principal ceiling (default 1000), preserving existing sessions after lowering the cap. Expiry frees capacity; finite sweeper retention bounds ordinary history by issuance rate and retention.++- **Breaking:** database transactions use the bounded statement wrapper; session bulk revocation returns winning IDs and the audited unit of work returns a count. Administrative session HTTP listing returns a keyset page (default 50, maximum 200). Server transaction limits default to three attempts/five seconds.++- Enforce finite new-write identity, display-name, passkey-label and role/scope budgets; preserve legacy identity authentication and snapshots. Login passwords over 256 code points fail before credential proof accounting. PostgreSQL adds migration 0039; see `docs/user/input-limits.md`.++- Bearer scheme matching is case-insensitive and accepts multiple ASCII separator spaces.+  Invalid or duplicate Authorization credentials fail closed; a present malformed header+  cannot fall back to a session cookie. Missing and invalid credentials retain distinct challenges.+- Basic client authentication rejects malformed percent escapes before form decoding.++- **Breaking:** `LoginRequest`, `MfaCompleteRequest` and `PasskeyLoginCompleteRequest` gain an+  optional `remember`, and `TokenPairResponse` gains `remembered`, present in every token pair.+ ## 0.2.0.0 — 2026-08-27  - **Breaking:** requires `shomei-core ^>=0.2.0.0`.

@@ -1,7 +1,7 @@-cabal-version:   3.0-name:            shomei-servant-version:         0.2.0.0-synopsis:        Servant API, handlers, and auth combinators for Shōmei+cabal-version: 3.0+name: shomei-servant+version: 0.3.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@@ -12,28 +12,33 @@   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+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+  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+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wpartial-fields+    -Wredundant-constraints  common shared-  default-language:   GHC2024+  default-language: GHC2024   default-extensions:     BlockArguments     DataKinds@@ -50,8 +55,8 @@     TypeOperators  library-  import:          warnings, shared-  hs-source-dirs:  src+  import: warnings, shared+  hs-source-dirs: src   exposed-modules:     Shomei.Account.Admin.Api     Shomei.Account.Api@@ -82,6 +87,7 @@     Shomei.Servant.Application     Shomei.Servant.Auth     Shomei.Servant.Authz+    Shomei.Servant.CachedJson     Shomei.Servant.ClientIp     Shomei.Servant.Cookie     Shomei.Servant.Error@@ -104,53 +110,57 @@     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+    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.3.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+  import: warnings, shared   hs-source-dirs: app/openapi-  main-is:        Main.hs-  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  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+    aeson-pretty >=0.8 && <0.9,+    base >=4.18 && <5,+    bytestring >=0.11 && <0.13,+    shomei-servant ^>=0.3.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+  import: warnings, shared+  type: exitcode-stdio-1.0+  hs-source-dirs: test-openapi+  main-is: Main.hs   default-extensions:     DerivingStrategies     FlexibleInstances@@ -159,49 +169,59 @@     TypeApplications     UndecidableInstances -  ghc-options:        -threaded -rtsopts -with-rtsopts=-N -freduction-depth=0+  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+    QuickCheck >=2.14 && <2.17,+    aeson >=2.1 && <2.3,+    base >=4.18 && <5,+    bytestring >=0.11 && <0.13,+    directory >=1.3 && <1.4,+    hspec >=2.11 && <2.12,+    openapi-hs >=5.0 && <6,+    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.3.0.0,+    text >=2.0 && <2.2,  test-suite shomei-servant-test-  import:         warnings, shared-  type:           exitcode-stdio-1.0+  import: warnings, shared+  type: exitcode-stdio-1.0   hs-source-dirs: test-  main-is:        Main.hs-  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  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+    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.3.0.0,+    shomei-jwt ^>=0.3.0.0,+    shomei-servant ^>=0.3.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,

@@ -15,7 +15,7 @@ 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.Email.Domain (mkEmail, parseStoredEmail) import Shomei.Account.Lifecycle.Workflow qualified as Account import Shomei.Account.LoginId.Domain (mkLoginId) import Shomei.Account.OneTimeToken.Domain (OneTimeToken (..))@@ -92,7 +92,7 @@  verifyEmailRequestH :: Env -> VerifyEmailRequest -> Handler VerifyEmailRequestResult verifyEmailRequestH env request = runApplicationHandler do-  email <- either rejectAuth pure (mkEmail request.email)+  email <- either rejectAuth pure (parseStoredEmail request.email)   workflow env (Account.requestEmailVerification env.config (Account.RequestEmailVerification email))  verifyEmailConfirmH :: Env -> ConfirmEmailVerificationRequest -> Handler VerifyEmailConfirmResult@@ -101,7 +101,7 @@  passwordResetRequestH :: Env -> PasswordResetRequest -> Handler PasswordResetRequestResult passwordResetRequestH env request = runApplicationHandler do-  email <- either rejectAuth pure (mkEmail request.email)+  email <- either rejectAuth pure (parseStoredEmail request.email)   workflow env (Account.requestPasswordReset env.config (Account.RequestPasswordReset email))  passwordResetConfirmH :: Env -> ConfirmPasswordResetRequest -> Handler PasswordResetConfirmResult

@@ -13,9 +13,12 @@ where  import Data.Aeson (Value)+import Data.Aeson qualified as Aeson import Data.Text qualified as Text import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show) import Data.UUID qualified as UUID+import Shomei.Audit.Event.Codec (reconstructAuthEvent)+import Shomei.Audit.Event.Domain qualified as Event import Shomei.Audit.Reader.Store (AuditCursor (..), StoredAuthEvent (..)) import Shomei.Id (SessionId, UserId, idText, parseId) import Shomei.Prelude@@ -83,7 +86,9 @@       userId = UUID.toText <$> stored.storedUserId,       sessionId = UUID.toText <$> stored.storedSessionId,       createdAt = Text.pack (iso8601Show stored.storedCreatedAt),-      payload = stored.storedPayload+      payload = case reconstructAuthEvent stored.storedEventType stored.storedPayload of+        Right (Event.SessionRevoked details) -> Aeson.toJSON details+        _ -> stored.storedPayload     }  encodeCursor :: AuditCursor -> Text

@@ -38,7 +38,7 @@  parseRole :: Text -> ApplicationHandler Role parseRole value-  | Text.null trimmed = rejectProblem pcBadRequest (detailOccurrence "role must not be blank")+  | Text.length value > 128 || Text.null trimmed = rejectProblem pcBadRequest (detailOccurrence "role must be non-blank and at most 128 characters")   | otherwise = pure (Role trimmed)   where     trimmed = Text.strip value

@@ -51,7 +51,10 @@  data MfaCompleteRequest = MfaCompleteRequest   { ceremonyId :: !Text,-    proof :: !MfaProof+    proof :: !MfaProof,+    -- | stay signed in, as on @POST /v1/auth/login@; a password sign-in that needs a second+    --     factor makes the decision here, because the password step issues no session.+    remember :: !(Maybe Bool)   }   deriving stock (Generic)   deriving anyclass (FromJSON, ToJSON)

@@ -47,7 +47,7 @@       (const (rejectProblem pcBadRequest (detailOccurrence "invalid ceremonyId")))       pure       (parseId request.ceremonyId)-  (_, tokens) <- workflow env (Mfa.completeMfa env.config (proofContext env peer) ceremonyId (mfaCompletionOf request))+  (_, tokens) <- workflow env (Mfa.completeMfaWith env.config (proofContext env peer) (request.remember == Just True) ceremonyId (mfaCompletionOf request))   pure (cookieResponse env.config (tokenCookies env.config tokens) (tokenPairToResponse env.config tokens))  totpEnrollH :: Env -> AuthUser -> Handler TotpEnrollResult

@@ -454,6 +454,7 @@ -- a stock caller learns nothing of Shōmei's impersonation policy internals. exchangeErrorFor :: AuthError -> ServerError exchangeErrorFor = \case+  SessionLimitReached -> OAuth.oauthError status503 "temporarily_unavailable" "active session limit reached"   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"@@ -678,6 +679,7 @@ -- problem-details envelope, which this endpoint must not emit. oauthErrorFor :: AuthError -> ServerError oauthErrorFor = \case+  SessionLimitReached -> OAuth.oauthError status503 "temporarily_unavailable" "active session limit reached"   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

@@ -50,7 +50,9 @@  data PasskeyLoginCompleteRequest = PasskeyLoginCompleteRequest   { ceremonyId :: !Text,-    assertion :: !Value+    assertion :: !Value,+    -- | stay signed in, as on @POST /v1/auth/login@.+    remember :: !(Maybe Bool)   }   deriving stock (Generic)   deriving anyclass (FromJSON, ToJSON)

@@ -64,7 +64,7 @@ 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)+  (_, tokens) <- workflow env (Mfa.completePasswordlessLoginWith env.config pctx (request.remember == Just True) ceremonyId request.assertion)   pure (cookieResponse env.config (tokenCookies env.config tokens) (tokenPairToResponse env.config tokens))  parseCeremonyId :: Text -> ApplicationHandler CeremonyId

@@ -15,7 +15,6 @@   ) where -import Data.Aeson (Value) import Servant.API import Servant.Health (HealthApi) import Shomei.Account.Admin.Api (AdminAccountApi)@@ -29,6 +28,7 @@ import Shomei.Prelude import Shomei.Servant.Auth (Authenticated) import Shomei.Servant.Authz (RequireRole)+import Shomei.Servant.CachedJson (CachedJson) import Shomei.Servant.Throttle (ThrottledRoute, throttledRoutesOf) import Shomei.Session.Admin.Api (AdminSessionApi) import Shomei.Session.Api (SessionApi)@@ -62,7 +62,7 @@  type HealthRoutes = "health" :> NamedRoutes HealthApi -type OpenApiRoute = "openapi.json" :> Get '[JSON] Value+type OpenApiRoute = "openapi.json" :> Get '[JSON] CachedJson  data ShomeiRoutes mode = ShomeiRoutes   { application :: mode :- ApplicationRoutes,

@@ -74,6 +74,7 @@ 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 Shomei.Session.Token.Bearer (parseBearer) import Web.Cookie (parseCookies)  -- | Shōmei's principal: the value the 'AuthHandler' hands to every authenticated@@ -134,7 +135,7 @@     where       authenticate req = do         case extractToken bearerOnlyPolicy req of-          Nothing -> delayedFailFatal OAuth.missingToken+          Nothing -> delayedFailFatal (if hasAuthorization req then OAuth.invalidToken else OAuth.missingToken)           Just _ -> do             outcome <- liftIO (runHandler (unAuthHandler (getContextEntry ctx) req))             either (const (delayedFailFatal OAuth.invalidToken)) pure outcome@@ -191,7 +192,7 @@     handle :: Request -> Handler AuthUser     handle req = do       (source, tok) <--        maybe (throwError (toProblemError pcMissingToken bearerOccurrence)) pure (extractToken policy req)+        maybe (throwError (toProblemError (if hasAuthorization req then pcTokenInvalidAuth else pcMissingToken) bearerOccurrence)) pure (extractToken policy req)       when (source == FromCookie && not (isSafeMethod req) && not (originAllowed policy.allowedOrigins req)) $         throwError csrfRejected       res <- liftIO (verifyRequestToken env tok)@@ -200,6 +201,9 @@         Right claims -> pure (authUserFromClaims claims)  -- | How an authentication failure becomes an HTTP response.+hasAuthorization :: Request -> Bool+hasAuthorization = any ((== "Authorization") . fst) . requestHeaders+ -- -- Deliberately not 'Shomei.Servant.Error.authErrorToServerError': that handler-layer mapping -- turns 'SessionNotFound' into a 404, which would make a protected route look nonexistent.@@ -215,11 +219,13 @@ -- -- '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.+-- accept an explicit bearer header (non-browser callers and service tokens keep working),+-- and read the configured cookie only when Authorization is absent. extractToken :: CookiePolicy -> Request -> Maybe (TokenSource, Text)-extractToken policy req =-  extractTokenFromHeaders policy (header "Authorization") (header "Cookie")+extractToken policy req = case [value | (name, value) <- requestHeaders req, name == "Authorization"] of+  [] -> extractTokenFromHeaders policy Nothing (header "Cookie")+  [value] -> extractTokenFromHeaders policy (Just (Text.decodeUtf8Lenient value)) (header "Cookie")+  _ -> Nothing   where     header name = Text.decodeUtf8Lenient <$> lookup name (requestHeaders req) @@ -232,11 +238,12 @@ -- 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)+extractTokenFromHeaders policy mAuthorization mCookie = case mAuthorization of+  Just _ -> (FromBearer,) <$> bearer+  Nothing -> guard (transportUsesCookies policy.transport) *> ((FromCookie,) <$> cookieToken)   where     bearer :: Maybe Text-    bearer = mAuthorization >>= Text.stripPrefix "Bearer "+    bearer = mAuthorization >>= parseBearer      cookieToken :: Maybe Text     cookieToken = do

@@ -66,6 +66,7 @@   ) 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 (..))

@@ -0,0 +1,31 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | A JSON document and its once-forced wire representation. The private constructor+-- keeps the parsed document and bytes consistent. Used by shared HTTP assembly, including+-- embedded hosts; clients can recover the ordinary Value with 'cachedJsonValue'.+module Shomei.Servant.CachedJson (CachedJson, cacheJson, cachedJsonValue, cachedJsonBytes) where++import Data.Aeson (FromJSON (..), ToJSON (..), Value, encode)+import Data.ByteString.Lazy qualified as LBS+import Servant.API (JSON, MimeRender (..))++data CachedJson = CachedJson !Value !LBS.ByteString deriving (Eq, Show)++cacheJson :: Value -> CachedJson+cacheJson value = CachedJson value (LBS.fromStrict (LBS.toStrict (encode value)))++cachedJsonValue :: CachedJson -> Value+cachedJsonValue (CachedJson value _) = value++cachedJsonBytes :: CachedJson -> LBS.ByteString+cachedJsonBytes (CachedJson _ bytes) = bytes++instance ToJSON CachedJson where+  toJSON = cachedJsonValue++instance FromJSON CachedJson where+  parseJSON value = pure (cacheJson value)++instance {-# OVERLAPPING #-} MimeRender JSON CachedJson where+  mimeRender _ = cachedJsonBytes

@@ -77,6 +77,8 @@     pcEmailNotVerified,     pcTokenInvalid,     pcPasskeyNotFound,+    pcPasskeyLimitReached,+    pcSessionLimitReached,     pcCeremonyNotFound,     pcWebAuthnFailed,     pcMfaFailed,@@ -394,8 +396,10 @@ pcTokenInvalid :: ProblemSpec pcTokenInvalid = problemSpec "token_invalid" err401 "Token is invalid" -pcPasskeyNotFound, pcCeremonyNotFound, pcWebAuthnFailed, pcMfaFailed :: ProblemSpec+pcPasskeyNotFound, pcPasskeyLimitReached, pcSessionLimitReached, pcCeremonyNotFound, pcWebAuthnFailed, pcMfaFailed :: ProblemSpec pcPasskeyNotFound = problemSpec "passkey_not_found" err404 "Passkey not found"+pcSessionLimitReached = retryableProblemSpec "session_limit_reached" err429 "Active machine or delegated session limit reached"+pcPasskeyLimitReached = problemSpec "passkey_limit_reached" err409 "Passkey enrollment limit reached" 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"@@ -507,6 +511,8 @@     pcEmailNotVerified,     pcTokenInvalid,     pcPasskeyNotFound,+    pcPasskeyLimitReached,+    pcSessionLimitReached,     pcCeremonyNotFound,     pcWebAuthnFailed,     pcMfaFailed,@@ -544,6 +550,7 @@ -- Returned handler results and thrown pre-handler errors deliberately share this function. authErrorProblem :: AuthError -> (ProblemSpec, ProblemOccurrence) authErrorProblem = \case+  InvalidInput -> plain pcBadRequest   InvalidEmail -> plain pcInvalidEmail   InvalidLoginId -> plain pcInvalidLoginId   WeakPassword _ -> plain pcWeakPassword@@ -565,6 +572,8 @@   EmailNotVerified -> plain pcEmailNotVerified   TokenInvalid _ -> plain pcTokenInvalid   PasskeyNotFound -> plain pcPasskeyNotFound+  SessionLimitReached -> plain pcSessionLimitReached+  PasskeyLimitReached -> plain pcPasskeyLimitReached   PendingCeremonyNotFound -> plain pcCeremonyNotFound   WebAuthnCeremonyError _ -> plain pcWebAuthnFailed   MfaAssertionInvalid -> plain pcMfaFailed

@@ -16,9 +16,10 @@ 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 Network.Wai (Middleware, Response, pathInfo, requestHeaders, responseLBS, responseStatus) import Servant (ServerError (..))-import Shomei.Servant.Error (ProblemOccurrence, ProblemSpec (..), noProblemOccurrence, pcMethodNotAllowed, problemBody, problemHeaders)+import Shomei.Servant.Error (ProblemOccurrence, ProblemSpec (..), bearerOccurrence, noProblemOccurrence, pcMethodNotAllowed, pcTokenInvalidAuth, problemBody, problemHeaders)+import Shomei.Servant.OAuth qualified as OAuth  -- | 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.@@ -31,6 +32,13 @@  -- | Rewrite Servant's bare @405 Method Not Allowed@ into a problem document. problemMiddleware :: Middleware+problemMiddleware _ req respond+  | length [() | (name, _) <- requestHeaders req, name == "Authorization"] > 1 =+      if "oauth" `elem` pathInfo req+        then+          let err = OAuth.invalidRequest "multiple Authorization headers"+           in respond (responseLBS (mkStatus err.errHTTPCode (BS8.pack err.errReasonPhrase)) err.errHeaders err.errBody)+        else respond (problemResponse pcTokenInvalidAuth bearerOccurrence) problemMiddleware app req respond =   app req \res ->     respond

@@ -198,9 +198,22 @@       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)))+          cidBytes <- decodeFormComponent encodedCid+          secretBytes <- decodeFormComponent (BS.drop 1 rest)+          cid <- orInvalidClient (TE.decodeUtf8' cidBytes)+          secret <- orInvalidClient (TE.decodeUtf8' secretBytes)           pure ClientAuth {clientId = cid, clientSecret = secret}++    -- http-types preserves malformed percent escapes; reject those rather than treating+    -- them as literal secret bytes. Decode exactly once, after splitting the Basic pair.+    decodeFormComponent bytes+      | validEscapes (BS.unpack bytes) = Right (urlDecode True bytes)+      | otherwise = Left invalidClient+    validEscapes [] = True+    validEscapes (37 : a : b : rest) = hex a && hex b && validEscapes rest+    validEscapes (37 : _) = False+    validEscapes (_ : rest) = validEscapes rest+    hex c = (c >= 48 && c <= 57) || (c >= 65 && c <= 70) || (c >= 97 && c <= 102)      fromBody = case (lookupParam "client_id" form, lookupParam "client_secret" form) of       (Just cid, Just secret) -> pure ClientAuth {clientId = cid, clientSecret = secret}

@@ -26,12 +26,14 @@ module Shomei.Servant.OpenApi   ( shomeiOpenApi,     openApiValue,+    openApiDocument,   ) 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@@ -84,6 +86,7 @@ import Shomei.Servant.Api (ShomeiRoutes) import Shomei.Servant.Auth (Authenticated, OAuthAuthenticated) import Shomei.Servant.Authz (RequireAdmin, RequirePermission, RequireRole, RequireScope)+import Shomei.Servant.CachedJson (CachedJson, cacheJson) import Shomei.Servant.OAuth (TokenResponse) import Shomei.Servant.PreHandler (CsrfProtected, PreHandlerResponses, RateLimited) import Shomei.Servant.Result@@ -92,7 +95,7 @@     CsrfPreHandlerResponses,     RateLimitPreHandlerResponses,   )-import Shomei.Session.Dto (LoginRequest, LoginResponse, RefreshRequest, SessionResponse, TokenPairResponse)+import Shomei.Session.Dto (LoginRequest, LoginResponse, RefreshRequest, SessionPageCursor, SessionResponse, SessionsPage, TokenPairResponse) import Web.FormUrlEncoded (Form)  -- servant-openapi-hs 5.1 understands MultiVerb and WithHeaders, but its released header@@ -117,11 +120,25 @@ -- wire JSON. The M4 conformance test ('validateEveryToJSON') enforces this. -- --------------------------------------------------------------------------- -instance ToSchema SignupRequest+instance ToSchema SignupRequest where+  declareNamedSchema proxy = do+    named <- O.genericDeclareNamedSchema O.defaultSchemaOptions proxy+    pure $+      named+        & O.schema . O.description ?~ "New email addresses are limited to 254 UTF-8 bytes; limits apply before and after normalization."+        & O.schema . O.properties . ix "loginId" . O._Inline . O.maxLength ?~ 256+        & O.schema . O.properties . ix "password" . O._Inline . O.maxLength ?~ 256+        & O.schema . O.properties . ix "displayName" . O._Inline . O.maxLength ?~ 256  instance ToSchema SignupResponse -instance ToSchema LoginRequest+instance ToSchema LoginRequest where+  declareNamedSchema proxy = do+    named <- O.genericDeclareNamedSchema O.defaultSchemaOptions proxy+    pure $+      named+        & O.schema . O.description ?~ "Legacy login identifiers may exceed the new-write limit. Oversized passwords are rejected before credential lookup or proof accounting."+        & O.schema . O.properties . ix "password" . O._Inline . O.maxLength ?~ 256  instance ToSchema RefreshRequest @@ -131,14 +148,32 @@  instance ToSchema PasswordResetRequest -instance ToSchema ConfirmPasswordResetRequest+instance ToSchema ConfirmPasswordResetRequest where+  declareNamedSchema proxy = do+    named <- O.genericDeclareNamedSchema O.defaultSchemaOptions proxy+    pure $+      named+        & O.schema . O.description ?~ "New password policy has a hard maximum of 256 Unicode code points."+        & O.schema . O.properties . ix "newPassword" . O._Inline . O.maxLength ?~ 256 -instance ToSchema ChangePasswordRequest+instance ToSchema ChangePasswordRequest where+  declareNamedSchema proxy = do+    named <- O.genericDeclareNamedSchema O.defaultSchemaOptions proxy+    pure $+      named+        & O.schema . O.description ?~ "Password values have a hard maximum of 256 Unicode code points."+        & O.schema . O.properties . ix "currentPassword" . O._Inline . O.maxLength ?~ 256+        & O.schema . O.properties . ix "newPassword" . O._Inline . O.maxLength ?~ 256  instance ToSchema TokenPairResponse  instance ToSchema UserResponse +instance ToSchema SessionsPage++instance ToParamSchema SessionPageCursor where+  toParamSchema _ = stringSchema & O.description ?~ "Opaque session keyset cursor from nextCursor."+ instance ToSchema SessionResponse  instance ToSchema MfaCompleteRequest@@ -155,7 +190,13 @@  instance ToSchema PasskeyRegisterBeginResponse -instance ToSchema PasskeyRegisterCompleteRequest+instance ToSchema PasskeyRegisterCompleteRequest where+  declareNamedSchema proxy = do+    named <- O.genericDeclareNamedSchema O.defaultSchemaOptions proxy+    pure $+      named+        & O.schema . O.description ?~ "Passkey labels are limited to 128 Unicode code points."+        & O.schema . O.properties . ix "label" . O._Inline . O.maxLength ?~ 128  instance ToSchema PasskeyResponse @@ -547,3 +588,10 @@     capitalize (c : cs) = toUpper c : cs     dropVersion ("v1" : rest) = rest     dropVersion segments = segments++-- | One encoded document per program version; Servant renders its cached bytes directly.+openApiDocument :: CachedJson+openApiDocument = cacheJson openApiValue++instance ToSchema CachedJson where+  declareNamedSchema _ = declareNamedSchema (Proxy @Value)

@@ -15,7 +15,7 @@ import Shomei.OAuth.Handler (oauthServer) import Shomei.Passkey.Handler (passkeyServer) import Shomei.Servant.Api (ApplicationApi (..), ShomeiRoutes (..))-import Shomei.Servant.OpenApi (openApiValue)+import Shomei.Servant.OpenApi (openApiDocument) import Shomei.Servant.Seam (Env) import Shomei.Session.Handler (adminSessionServer, sessionServer) import Shomei.SigningKey.Handler (wellKnownServer)@@ -27,7 +27,7 @@       oauth = oauthServer env,       wellKnown = wellKnownServer env,       health = healthServer liveness readiness,-      openapi = pure openApiValue+      openapi = pure openApiDocument     }  applicationServer :: Env -> ApplicationApi (AsServerT Handler)

@@ -14,9 +14,10 @@ import Shomei.Servant.Authz (RequireAdmin) import Shomei.Servant.PreHandler (CsrfProtected, PreHandlerResponses) import Shomei.Servant.Result (ApplicationContentTypes, BadRequestPreHandlerResponses)+import Shomei.Session.Dto (SessionPageCursor) import Shomei.Session.Result -type ListSessionsRoute = "users" :> RequireAdmin :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> "sessions" :> MultiVerb 'GET ApplicationContentTypes ListSessionsResponses ListSessionsResult+type ListSessionsRoute = "users" :> RequireAdmin :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> "sessions" :> QueryParam "limit" Int :> QueryParam "before" SessionPageCursor :> MultiVerb 'GET ApplicationContentTypes ListSessionsResponses ListSessionsResult  type RevokeSessionsRoute = "users" :> RequireAdmin :> CsrfProtected :> PreHandlerResponses BadRequestPreHandlerResponses :> Capture "userId" UserId :> "sessions" :> MultiVerb 'DELETE ApplicationContentTypes RevokeSessionsResponses RevokeSessionsResult 

@@ -5,6 +5,10 @@     LoginResponse (..),     RefreshRequest (..),     SessionResponse (..),+    SessionsPage (..),+    SessionPageCursor (..),+    encodeSessionCursor,+    decodeSessionCursor,     tokenPairToResponse,     loginResultToResponse,     sessionToResponse,@@ -16,20 +20,27 @@ import Data.Aeson.Types (Parser) import Data.Maybe (catMaybes) import Data.Text qualified as Text-import Data.Time.Format.ISO8601 (iso8601Show)+import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show)+import Data.UUID qualified as UUID import Shomei.Account.User.Dto (UserResponse, userToResponse) import Shomei.Config (ShomeiConfig (..), transportIncludesBodyTokens)-import Shomei.Id (idText)+import Shomei.Id (idText, sessionIdFromUUID, sessionIdToUUID) 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.Store (SessionCursor (..)) import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..))+import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))  data TokenPairResponse = TokenPairResponse   { accessToken :: !(Maybe Text),     refreshToken :: !(Maybe Text),-    expiresIn :: !Int+    expiresIn :: !Int,+    -- | whether the session behind these tokens is remembered (signed in with @remember@), so a+    --     browser-facing embedder can decide between persistent and browser-session cookies.+    --     Always present in Shōmei's own responses; optional on the wire for older servers.+    remembered :: !(Maybe Bool)   }   deriving stock (Generic) @@ -39,7 +50,8 @@       catMaybes         [ ("accessToken" Aeson..=) <$> response.accessToken,           ("refreshToken" Aeson..=) <$> response.refreshToken,-          Just ("expiresIn" Aeson..= response.expiresIn)+          Just ("expiresIn" Aeson..= response.expiresIn),+          ("remembered" Aeson..=) <$> response.remembered         ]  instance FromJSON TokenPairResponse where@@ -48,10 +60,13 @@       <$> objectValue Aeson..:? "accessToken"       <*> objectValue Aeson..:? "refreshToken"       <*> objectValue .: "expiresIn"+      <*> objectValue Aeson..:? "remembered"  data LoginRequest = LoginRequest   { loginId :: !Text,-    password :: !Text+    password :: !Text,+    -- | stay signed in: a remembered session lasts @rememberedSessionTTL@. Absent means no.+    remember :: !(Maybe Bool)   }   deriving stock (Generic)   deriving anyclass (FromJSON, ToJSON)@@ -108,7 +123,8 @@   TokenPairResponse     { accessToken = bodyToken (unAccess pair.accessToken),       refreshToken = bodyToken (unRefresh pair.refreshToken),-      expiresIn = round (realToFrac pair.expiresIn :: Double)+      expiresIn = round (realToFrac pair.expiresIn :: Double),+      remembered = Just pair.remembered     }   where     bodyToken token = if transportIncludesBodyTokens config.tokenTransport then Just token else Nothing@@ -137,3 +153,29 @@       SessionActive -> "active"       SessionRevoked -> "revoked"       SessionExpired -> "expired"++data SessionsPage = SessionsPage+  { sessions :: ![SessionResponse],+    nextCursor :: !(Maybe Text)+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype SessionPageCursor = SessionPageCursor {sessionCursor :: SessionCursor}+  deriving stock (Eq, Show)++instance FromHttpApiData SessionPageCursor where+  parseUrlPiece value = maybe (Left "invalid session cursor") (Right . SessionPageCursor) (decodeSessionCursor value)++instance ToHttpApiData SessionPageCursor where+  toUrlPiece = encodeSessionCursor . (.sessionCursor)++encodeSessionCursor :: SessionCursor -> Text+encodeSessionCursor cursor = Text.pack (iso8601Show cursor.cursorCreatedAt) <> ";" <> UUID.toText (sessionIdToUUID cursor.cursorSessionId)++decodeSessionCursor :: Text -> Maybe SessionCursor+decodeSessionCursor value = case Text.breakOn ";" value of+  (timestamp, rest)+    | Just identifier <- Text.stripPrefix ";" rest ->+        SessionCursor <$> iso8601ParseM (Text.unpack timestamp) <*> (sessionIdFromUUID <$> UUID.fromText identifier)+  _ -> Nothing

@@ -11,7 +11,7 @@ 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.LoginId.Domain (loginIdText, parseLoginIdForAuthentication) import Shomei.Account.Password.Domain (PlainPassword (..)) import Shomei.Config (CookieConfig (..), ShomeiConfig (..), transportUsesCookies) import Shomei.Delegation.Handler (denyUnderDelegation)@@ -44,11 +44,12 @@     LogoutCommand (..),     RefreshCommand (..),   )+import Shomei.Session.Domain (Session (..)) 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)+import Shomei.Session.Store (SessionCursor (..), SessionListQuery (..), clampSessionLimit, findSessionById, listSessionPage)  sessionServer :: Env -> SessionApi (AsServerT Handler) sessionServer env =@@ -69,8 +70,8 @@  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}+  loginId <- either rejectAuth pure (parseLoginIdForAuthentication request.loginId)+  let command = LoginCommand {loginId, password = PlainPassword request.password, remember = request.remember == Just True}       context =         ClientContext           { clientIp = ClientIp (clientIpText peer),@@ -116,10 +117,15 @@   found <- port env (findSessionById user.authSessionId)   maybe (rejectProblem pcSessionNotFound noProblemOccurrence) (pure . sessionToResponse) found -adminListSessionsH :: Env -> AuthUser -> UserId -> Handler ListSessionsResult-adminListSessionsH env _ target = runApplicationHandler do+adminListSessionsH :: Env -> AuthUser -> UserId -> Maybe Int -> Maybe SessionPageCursor -> Handler ListSessionsResult+adminListSessionsH env _ target limit cursor = runApplicationHandler do   _ <- requireExistingUser env target-  map sessionToResponse <$> port env (listSessionsForUser target)+  let pageSize = clampSessionLimit (fromMaybe 50 limit)+  rows <- port env (listSessionPage target (SessionListQuery pageSize ((.sessionCursor) <$> cursor)))+  let nextCursor = case reverse rows of+        lastRow : _ | length rows == pageSize -> Just (encodeSessionCursor (SessionCursor lastRow.createdAt lastRow.sessionId))+        _ -> Nothing+  pure (SessionsPage (map sessionToResponse rows) nextCursor)  adminRevokeSessionsH :: Env -> AuthUser -> UserId -> Handler RevokeSessionsResult adminRevokeSessionsH env actor target = runApplicationHandler do

@@ -18,7 +18,7 @@ where  import Shomei.Servant.Result-import Shomei.Session.Dto (LoginResponse, SessionResponse, TokenPairResponse)+import Shomei.Session.Dto (LoginResponse, SessionResponse, SessionsPage, TokenPairResponse)  type LoginResponses = ApplicationCookieResponses 200 "Authenticated" LoginResponse @@ -36,9 +36,9 @@  type CurrentSessionResult = ApplicationResult SessionResponse -type ListSessionsResponses = ApplicationResponses 200 "Sessions" [SessionResponse]+type ListSessionsResponses = ApplicationResponses 200 "Sessions" SessionsPage -type ListSessionsResult = ApplicationResult [SessionResponse]+type ListSessionsResult = ApplicationResult SessionsPage  type RevokeSessionsResponses = ApplicationEmptyResponses 204 "Sessions revoked" 

@@ -25,10 +25,12 @@ -- only) so the production library carries no test dependency. module Main (main) where -import Control.Monad (filterM)+import Control.Exception (evaluate)+import Control.Monad (filterM, forM_) 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.ByteString.Lazy qualified as LBS import Data.Char (isAsciiLower, isDigit) import Data.Either (isLeft) import Data.Foldable (toList)@@ -41,8 +43,9 @@ import Data.Text qualified as Text import Data.Text.IO qualified as TextIO import Data.Type.Equality ((:~:) (Refl))+import GHC.Conc (getAllocationCounter) import GHC.TypeLits (Nat)-import Servant.API (NamedRoutes, NoContent (..), Verb, type (:>))+import Servant.API (JSON, NamedRoutes, NoContent (..), Verb, mimeRender, type (:>)) import Servant.API.MultiVerb (MultiVerb, Respond, RespondAs, WithHeaders) import Servant.Health (ProbeResponses, ProbeStatus (..)) import Servant.OpenApi.Test (validateEveryToJSON)@@ -60,14 +63,16 @@ import Shomei.Passkey.Api import Shomei.Passkey.Dto import Shomei.Servant.Api (OpenApiRoute, ShomeiRoutes)+import Shomei.Servant.CachedJson (CachedJson, cacheJson, cachedJsonBytes, cachedJsonValue) 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.Servant.OpenApi (openApiDocument, openApiValue, shomeiOpenApi) import Shomei.Session.Admin.Api import Shomei.Session.Api import Shomei.Session.Dto import Shomei.SigningKey.Api import System.Directory (doesFileExist)+import System.Mem (performGC) import Test.Hspec import Test.QuickCheck (Arbitrary (..), chooseInt, oneof) import Test.QuickCheck.Instances ()@@ -232,6 +237,19 @@       (eitherDecode "{\"type\":\"totp\",\"code\":\"123456\",\"assertion\":{}}" :: Either String MfaProof)         `shouldSatisfy` isLeft +  describe "cached OpenAPI wire document" $ do+    it "serves the same JSON object directly and reuses its serialized bytes" $ do+      let bytes = mimeRender (Proxy @JSON) openApiDocument+      eitherDecode bytes `shouldBe` Right openApiValue+      bytes `shouldBe` encode openApiValue+      cachedJsonValue openApiDocument `shouldBe` openApiValue+      bytes `shouldBe` cachedJsonBytes openApiDocument+    it "measures 1000 render allocations against the uncached Value renderer" $ do+      _ <- evaluate (LBS.length (cachedJsonBytes openApiDocument))+      old <- allocated (forM_ [1 .. 1000] (\i -> renderValue i openApiValue >>= evaluate . LBS.length))+      cached <- allocated (forM_ [1 .. 1000] (\i -> renderCached i >>= evaluate . LBS.length))+      writeFile "/tmp/shomei-openapi-allocations.txt" ("renders=1000 uncached_bytes=" <> show old <> " cached_bytes=" <> show cached <> "\n")+      cached `shouldSatisfy` (< old `div` 10)   describe "shomeiOpenApi document" $ do     it "declares OpenAPI version 3.1.0" $       lookupTop "openapi" `shouldBe` Just (String "3.1.0")@@ -542,6 +560,8 @@  deriving stock instance Show UserResponse +deriving stock instance Show SessionsPage+ deriving stock instance Show SessionResponse  deriving stock instance Show AdminUserResponse@@ -587,13 +607,13 @@   arbitrary = UserResponse <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary  instance Arbitrary TokenPairResponse where-  arbitrary = TokenPairResponse <$> arbitrary <*> arbitrary <*> arbitrary+  arbitrary = TokenPairResponse <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary  instance Arbitrary SignupResponse where   arbitrary = SignupResponse <$> arbitrary <*> arbitrary  instance Arbitrary LoginRequest where-  arbitrary = LoginRequest <$> arbitrary <*> arbitrary+  arbitrary = LoginRequest <$> arbitrary <*> arbitrary <*> arbitrary  instance Arbitrary LoginResponse where   arbitrary =@@ -621,7 +641,7 @@   arbitrary = ChangePasswordRequest <$> arbitrary <*> arbitrary  instance Arbitrary MfaCompleteRequest where-  arbitrary = MfaCompleteRequest <$> arbitrary <*> arbitrary+  arbitrary = MfaCompleteRequest <$> arbitrary <*> arbitrary <*> arbitrary  instance Arbitrary MfaProof where   arbitrary = oneof [PasskeyProof <$> arbitrary, TotpProof <$> arbitrary, RecoveryCodeProof <$> arbitrary]@@ -654,11 +674,14 @@   arbitrary = PasskeyLoginBeginResponse <$> arbitrary <*> arbitrary  instance Arbitrary PasskeyLoginCompleteRequest where-  arbitrary = PasskeyLoginCompleteRequest <$> arbitrary <*> arbitrary+  arbitrary = PasskeyLoginCompleteRequest <$> arbitrary <*> arbitrary <*> arbitrary  instance Arbitrary TokenResponse where   arbitrary = TokenResponse <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +instance Arbitrary SessionsPage where+  arbitrary = SessionsPage <$> arbitrary <*> arbitrary+ instance Arbitrary SessionResponse where   arbitrary = SessionResponse <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary @@ -674,3 +697,23 @@  instance Arbitrary AuditEventsPage where   arbitrary = AuditEventsPage <$> arbitrary <*> arbitrary++-- IO boundaries prevent the optimizer from sharing the deliberately uncached baseline.+{-# NOINLINE renderValue #-}+renderValue :: Int -> Value -> IO LBS.ByteString+renderValue iteration value = evaluate iteration >> evaluate (mimeRender (Proxy @JSON) value)++{-# NOINLINE renderCached #-}+renderCached :: Int -> IO LBS.ByteString+renderCached iteration = evaluate iteration >> evaluate (mimeRender (Proxy @JSON) openApiDocument)++allocated :: IO a -> IO Integer+allocated action = do+  performGC+  before <- getAllocationCounter+  _ <- action+  after <- getAllocationCounter+  pure (fromIntegral before - fromIntegral after)++instance Arbitrary CachedJson where+  arbitrary = cacheJson <$> arbitrary

@@ -10,7 +10,7 @@ -- rotation, the public JWKS document, and the @RequireRole "admin"@ guard (403/200). module Main (main) where -import Control.Monad (replicateM_)+import Control.Monad (replicateM, replicateM_, void) import Crypto.JOSE.Compact (decodeCompact) import Crypto.JOSE.Error (runJOSE) import Crypto.JOSE.JWK (JWK, JWKSet)@@ -55,6 +55,7 @@ import Network.HTTP.Types (Header, statusCode) import Network.HTTP.Types.URI (parseSimpleQuery, urlEncode) import Network.Wai (Application, Request)+import Network.Wai qualified as Wai import Network.Wai.Handler.Warp (testWithApplication) import Servant   ( Context (EmptyContext, (:.)),@@ -71,16 +72,19 @@   ) import Servant.API.Generic (type (:-)) import Servant.Health (ProbeVerdict (Healthy))-import Servant.Server.Experimental.Auth (AuthHandler)+import Servant.Server.Experimental.Auth (AuthHandler, unAuthHandler) import Servant.Server.Generic (genericServe)+import Servant.Server.Internal (runHandler)+import Shomei.Account.Credential.Store (createPasswordCredential) import Shomei.Account.Email.Domain (emailText, mkEmail)-import Shomei.Account.LoginId.Domain (mkLoginId)+import Shomei.Account.LoginId.Domain (mkLoginId, parseLoginIdForAuthentication) 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.Password.Hash.Store (hashPassword)+import Shomei.Account.User.Domain (NewUser (..), User (..), UserStatus (UserActive, UserSuspended)) import Shomei.Account.User.Dto (UserResponse)-import Shomei.Account.User.Store (updateUserStatus)+import Shomei.Account.User.Store (createUser, 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)@@ -102,6 +106,7 @@ import Shomei.Servant.Authz (RequirePermission, RequireRole, RequireScope) import Shomei.Servant.Error (ProblemDetails (..), problemTypeFor, shomeiErrorFormatters) import Shomei.Servant.Middleware (problemMiddleware)+import Shomei.Servant.OpenApi (openApiValue) import Shomei.Servant.Result (ApplicationResult (ApplicationInternal, ApplicationUnavailable), ProblemWithRetryAfter (..), applicationError) import Shomei.Servant.Seam (AppEffects, Env (..)) import Shomei.Servant.Server (shomeiRoutes)@@ -110,6 +115,8 @@ import Shomei.ServiceAccount.Store (createServiceAccount) import Shomei.Session.Authentication.Workflow qualified as Wf import Shomei.Session.Command (SignupCommand (..))+import Shomei.Session.Domain (Session (..))+import Shomei.Session.Domain qualified as SessionDomain import Shomei.Session.LoginAttempt.Domain (AccountKey (..)) import Shomei.Session.Store (revokeAllUserSessions) import Shomei.Session.Token.Domain (AccessToken (..))@@ -316,7 +323,7 @@   uid <- parseUserId userIdText   runInMemory ref do     ts <- now-    revokeAllUserSessions uid ts+    void (revokeAllUserSessions uid ts)  suspendUserIn :: IORef World -> UserId -> IO () suspendUserIn ref uid = runInMemory ref do@@ -582,7 +589,7 @@     pure (account ^. #clientId)  oauthClientSecret :: Text-oauthClientSecret = "oauth+test:secret"+oauthClientSecret = "oauth+test:secret%GG"  -- | 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).@@ -640,6 +647,18 @@       [("grant_type", "client_credentials"), ("scope", "kawa:ingest")]   let (basicStatus, basicHdrs, basicBody) = basic   basicStatus @?= 200+  -- A malformed percent escape must fail even when a lenient decoder would produce+  -- the exact stored secret. Correct form encoding above uses %25GG instead.+  rawBasic <- parseRequest ("http://127.0.0.1:" <> show port <> "/oauth/token")+  malformedReply <-+    httpLbs+      ( applyBasicAuth+          (urlEncode True (Text.encodeUtf8 clientId))+          "oauth%2Btest%3Asecret%GG"+          (urlEncodedBody [("grant_type", "client_credentials")] rawBasic)+      )+      mgr+  statusCode (responseStatus malformedReply) @?= 401   -- RFC 6749 §5.1 requires the token response to be uncacheable.   headerValue "Cache-Control" basicHdrs @?= Just "no-store"   headerValue "Pragma" basicHdrs @?= Just "no-cache"@@ -1009,8 +1028,8 @@   (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)+  case dig ["sessions"] sessions of+    Just (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.@@ -1055,8 +1074,8 @@   (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)+  firstSession <- case dig ["sessions"] sessions of+    Just (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')@@ -1067,8 +1086,8 @@   (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)+  case dig ["sessions"] after of+    Just (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.@@ -1119,6 +1138,13 @@   blank <- putRaw mgr port ("/v1/admin/users/" <> T.unpack targetId <> "/roles/%20") (bearer adminToken')   assertProblem "a blank role name" 400 "bad_request" blank +  let maximumRole = T.replicate 128 "界"+  defineRoleIn ref (Role maximumRole)+  (maximumRoleStatus, _) <- putAuth mgr port (roleUrl (urlEncodeText maximumRole)) (bearer adminToken')+  maximumRoleStatus @?= 204+  oversizedRole <- putRaw mgr port (roleUrl (urlEncodeText (T.replicate 129 "界"))) (bearer adminToken')+  assertProblem "overlong role rejected before grant lookup" 400 "bad_request" oversizedRole+ -- | 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).@@ -1369,7 +1395,31 @@ 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+    [ testCase "OpenAPI HTTP responses reuse the exact JSON document and media type" $ do+        e <- freshEnv+        testWithApplication (pure (app e)) $ \port -> do+          manager <- newManager defaultManagerSettings+          request <- parseRequest ("http://127.0.0.1:" <> show port <> "/openapi.json")+          replicateM_ 16 do+            response <- httpLbs request manager+            statusCode (responseStatus response) @?= 200+            lookup "Content-Type" (responseHeaders response) @?= Just "application/json;charset=utf-8"+            responseBody response @?= encode openApiValue,+      testCase "OAuth machine quota returns a retryable OAuth error after its last slot" $ do+        (clientId, e) <- freshOAuthEnv+        testWithApplication (pure (app e {config = e.config {maxActiveNonInteractiveSessions = 1}})) $ \port -> do+          mgr <- newManager defaultManagerSettings+          first <- postForm mgr port "/oauth/token" (Just (clientId, oauthClientSecret)) [("grant_type", "client_credentials")]+          statusOf first @?= 200+          second <- postForm mgr port "/oauth/token" (Just (clientId, oauthClientSecret)) [("grant_type", "client_credentials")]+          assertOAuthError "machine quota" 503 "temporarily_unavailable" second,+      testCase "HTTP session pages default to 50, cap at 200 and walk tied timestamps" $ do+        (r, e) <- freshPermissionEnv+        testWithApplication (pure (app e)) (scenarioSessionPaging r),+      testCase "input boundaries and legacy HTTP login" $ do+        (r, e) <- freshPermissionEnv+        testWithApplication (pure (app e)) (scenarioInputBounds r),+      testCase "dependency unavailability remains distinct from internal failure before serialization" $ do         case applicationError (DependencyUnavailable PostgreSQL) :: ApplicationResult () of           ApplicationUnavailable response -> do             response.retryProblem.status @?= 503@@ -1416,7 +1466,7 @@         (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),+        testWithApplication (pure (app env {config = env.config {maxPasskeysPerUser = 1}})) (scenario ref adminToken),       testCase "signup/login by loginId with no email (email == null)" $ do         e <- freshEnv         testWithApplication (pure (app e)) scenarioNoEmail,@@ -1495,7 +1545,7 @@         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,+        testWithApplication (pure (app e)) (scenarioCsrfMatrix e),       testCase "cookie transport: refresh reads the secure refresh cookie, rotates, and is CSRF-gated" $ do         e <- freshCookieEnv         testWithApplication (pure (app e)) scenarioCookieRefresh,@@ -2957,11 +3007,18 @@   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+scenarioCsrfMatrix :: Env -> Int -> IO ()+scenarioCsrfMatrix env port = do   mgr <- newManager defaultManagerSettings   (sess, _, _) <- cookieSignup mgr port +  forM_ ["HEAD", "OPTIONS"] \safeMethod -> do+    let request = Wai.defaultRequest {Wai.requestMethod = safeMethod, Wai.requestHeaders = [sessionCookieHeader sess]}+    outcome <- runHandler (unAuthHandler (authHandler env) request)+    case outcome of+      Right _ -> pure ()+      Left err -> assertFailure ("safe method was CSRF rejected: " <> show err)+   -- No Origin, no Referer: fail closed. This is the attack shape.   (noneStatus, _, noneBody) <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess] Null   noneStatus @?= 403@@ -2971,6 +3028,10 @@   -- A foreign origin: refused.   (evilStatus, _, _) <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess, foreignOrigin] Null   evilStatus @?= 403+  (nullStatus, _, _) <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess, ("Origin", "null")] Null+  nullStatus @?= 403+  (precedenceStatus, _, _) <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess, foreignOrigin, ("Referer", "http://localhost:8080/settings")] Null+  precedenceStatus @?= 403    -- Referer fallback, for agents that omit Origin.   (refStatus, _, _) <- postRaw mgr port "/v1/auth/logout" [sessionCookieHeader sess, ("Referer", "http://localhost:8080/app/settings")] Null@@ -3123,6 +3184,12 @@   -- (c) me with Bearer   (meStatus, meBody) <- getJSON mgr port "/v1/auth/me" (bearer access)   meStatus @?= 200+  (lowerStatus, _) <- getJSON mgr port "/v1/auth/me" [("Authorization", "bEaReR   " <> Text.encodeUtf8 access)]+  lowerStatus @?= 200+  (duplicateStatus, _) <- getJSON mgr port "/v1/auth/me" (bearer access <> bearer access)+  duplicateStatus @?= 401+  duplicateAuthorize <- getRaw mgr port "/oauth/authorize" (bearer access <> bearer access)+  assertOAuthError "duplicate Authorization at authorize" 400 "invalid_request" duplicateAuthorize   meresp <- must "me body" meBody   (dig ["email"] meresp >>= asText) @?= Just email @@ -3225,13 +3292,20 @@             "userHandle" .= UserHandle "passkey-uh-1",             "publicKey" .= PublicKeyBytes "passkey-pk-1"           ]-      completeBody = object ["ceremonyId" .= cid, "credential" .= cred, "label" .= ("YubiKey" :: Text)]+      completeBody = object ["ceremonyId" .= cid, "credential" .= cred, "label" .= T.replicate 128 "🔑"]+  (badLabelStatus, _) <- postJSONAuth mgr port "/v1/auth/passkeys/register/complete" (bearer access2) (object ["ceremonyId" .= cid, "credential" .= cred, "label" .= T.replicate 129 "🔑"])+  badLabelStatus @?= 400   (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"+  (dig ["label"] cresp >>= asText) @?= Just (T.replicate 128 "🔑") +  (fullStatus, fullBody) <- postJSONAuth mgr port "/v1/auth/passkeys/register/begin" (bearer access2) (object [])+  fullStatus @?= 409+  fullProblem <- must "quota problem" fullBody+  (dig ["code"] fullProblem >>= asText) @?= Just "passkey_limit_reached"+   (listStatus, listBody) <- getJSON mgr port "/v1/auth/passkeys" (bearer access2)   listStatus @?= 200   listResp <- must "list body" listBody@@ -3767,3 +3841,81 @@     go (Object o) = any (\(kk, vv) -> K.toText kk == k || go vv) (KM.toList o)     go (Array xs) = any go (toList xs)     go _ = False++scenarioInputBounds :: IORef World -> Int -> IO ()+scenarioInputBounds ref port = do+  mgr <- newManager defaultManagerSettings+  let pw = "correct horse battery staple" :: Text+      signupBody ident email name = object ["loginId" .= (ident :: Text), "email" .= (email :: Maybe Text), "password" .= pw, "displayName" .= (name :: Text)]+  forM_+    [ ("login", signupBody (T.replicate 257 "🔑") Nothing ""),+      ("email", signupBody "bad-email" (Just (T.replicate 126 "é" <> "@a.b")) ""),+      ("name", signupBody "bad-name" Nothing (T.replicate 257 "🔑"))+    ]+    $ \(field, body) -> do+      (status, _) <- postJSON mgr port "/v1/auth/signup" body+      assertEqual (T.unpack field) 400 status+  (accepted, _) <- postJSON mgr port "/v1/auth/signup" (signupBody (T.replicate 256 "🔑") (Just (T.replicate 125 "é" <> "@a.b")) (T.replicate 256 "🔑"))+  accepted @?= 201+  let legacyText = T.replicate 257 "界"+      legacy = either (error . show) id (parseLoginIdForAuthentication legacyText)+  _ <- runInMemory ref do+    user <- createUser (NewUser legacy Nothing Nothing)+    hash <- hashPassword (PlainPassword pw)+    createPasswordCredential user.userId legacy Nothing hash+  (loggedIn, body) <- postJSON mgr port "/v1/auth/login" (object ["loginId" .= legacyText, "password" .= pw])+  loggedIn @?= 200+  doc <- must "legacy login snapshot" body+  dig ["user", "loginId"] doc @?= Just (String legacyText)+  forM_ [legacyText, "unknown-bounded-account"] $ \ident -> do+    (status, _) <- postJSON mgr port "/v1/auth/login" (object ["loginId" .= ident, "password" .= T.replicate 257 "🔐"])+    status @?= 400++  let maximumScope = T.replicate 128 "s"+  accountId <- runInMemory ref do+    user <- createUser (NewUser (either (error . show) id (mkLoginId "scope-boundary-machine")) Nothing Nothing)+    said <- genServiceAccountDbId+    ts <- now+    account <- createServiceAccount (NewServiceAccount said (idText said) user.userId (sha256Hex oauthClientSecret) "Scope boundary" (Set.singleton (Scope maximumScope)) ts)+    pure (idText (account ^. #serviceAccountId))+  maximumGrant <- postForm mgr port "/oauth/token" (Just (accountId, oauthClientSecret)) [("grant_type", "client_credentials"), ("scope", Text.encodeUtf8 maximumScope)]+  statusOf maximumGrant @?= 200+  maximumBody <- must "maximum scope response" (bodyOf maximumGrant)+  dig ["scope"] maximumBody @?= Just (String maximumScope)+  oversizedGrant <- postForm mgr port "/oauth/token" (Just (accountId, oauthClientSecret)) [("grant_type", "client_credentials"), ("scope", Text.encodeUtf8 (T.replicate 129 "s"))]+  assertOAuthError "overlong scope rejected" 400 "invalid_scope" oversizedGrant++scenarioSessionPaging :: IORef World -> Int -> IO ()+scenarioSessionPaging ref port = do+  mgr <- newManager defaultManagerSettings+  admin <- becomeAdmin ref mgr port "paging-admin@example.com"+  (targetId, _) <- signupOver mgr port "paging-target@example.com"+  uid <- parseUserId targetId+  world <- readIORef ref+  template <- case [s | s <- Map.elems world.sessions, s.userId == uid] of+    s : _ -> pure s+    _ -> assertFailure "missing target session"+  identifiers <- replicateM 205 genSessionId+  modifyIORef' ref (\w -> w {sessions = foldr (\sid -> Map.insert sid template {SessionDomain.sessionId = sid}) w.sessions identifiers})+  let base = "/v1/admin/users/" <> T.unpack targetId <> "/sessions"+      readPage path = do+        (status, body) <- getJSON mgr port path (bearer admin)+        status @?= 200+        doc <- must "session page" body+        values <- case dig ["sessions"] doc of+          Just (Array xs) -> traverse (\v -> must "session ID" (dig ["sessionId"] v >>= asText)) (toList xs)+          _ -> assertFailure "missing sessions array"+        pure (values, dig ["nextCursor"] doc >>= asText)+  (defaults, _) <- readPage base+  length defaults @?= 50+  (capped, _) <- readPage (base <> "?limit=10000")+  length capped @?= 200+  let walk cursor accumulated = do+        let suffix = maybe "" (\c -> "&before=" <> urlEncodeText c) cursor+        (values, next) <- readPage (base <> "?limit=73" <> suffix)+        case next of+          Nothing -> pure (accumulated <> values)+          Just c -> walk (Just c) (accumulated <> values)+  allIds <- walk Nothing []+  length allIds @?= 206+  Set.size (Set.fromList allIds) @?= 206