diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/app/openapi/Main.hs b/app/openapi/Main.hs new file mode 100644 --- /dev/null +++ b/app/openapi/Main.hs @@ -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) diff --git a/shomei-servant.cabal b/shomei-servant.cabal new file mode 100644 --- /dev/null +++ b/shomei-servant.cabal @@ -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 diff --git a/src/Shomei/Account/Admin/Api.hs b/src/Shomei/Account/Admin/Api.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Admin/Api.hs @@ -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) diff --git a/src/Shomei/Account/Api.hs b/src/Shomei/Account/Api.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Api.hs @@ -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) diff --git a/src/Shomei/Account/Dto.hs b/src/Shomei/Account/Dto.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Dto.hs @@ -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) diff --git a/src/Shomei/Account/Handler.hs b/src/Shomei/Account/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Handler.hs @@ -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 diff --git a/src/Shomei/Account/Result.hs b/src/Shomei/Account/Result.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Result.hs @@ -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 () diff --git a/src/Shomei/Account/User/Dto.hs b/src/Shomei/Account/User/Dto.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/User/Dto.hs @@ -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 diff --git a/src/Shomei/Audit/Api.hs b/src/Shomei/Audit/Api.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Audit/Api.hs @@ -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) diff --git a/src/Shomei/Audit/Dto.hs b/src/Shomei/Audit/Dto.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Audit/Dto.hs @@ -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 diff --git a/src/Shomei/Audit/Handler.hs b/src/Shomei/Audit/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Audit/Handler.hs @@ -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) diff --git a/src/Shomei/Audit/Result.hs b/src/Shomei/Audit/Result.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Audit/Result.hs @@ -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 diff --git a/src/Shomei/Authorization/Api.hs b/src/Shomei/Authorization/Api.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Authorization/Api.hs @@ -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) diff --git a/src/Shomei/Authorization/Handler.hs b/src/Shomei/Authorization/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Authorization/Handler.hs @@ -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 diff --git a/src/Shomei/Authorization/Result.hs b/src/Shomei/Authorization/Result.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Authorization/Result.hs @@ -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 () diff --git a/src/Shomei/Delegation/Handler.hs b/src/Shomei/Delegation/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Delegation/Handler.hs @@ -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 diff --git a/src/Shomei/Mfa/Api.hs b/src/Shomei/Mfa/Api.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/Api.hs @@ -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) diff --git a/src/Shomei/Mfa/Dto.hs b/src/Shomei/Mfa/Dto.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/Dto.hs @@ -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) diff --git a/src/Shomei/Mfa/Handler.hs b/src/Shomei/Mfa/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/Handler.hs @@ -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 + } diff --git a/src/Shomei/Mfa/Result.hs b/src/Shomei/Mfa/Result.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/Result.hs @@ -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 diff --git a/src/Shomei/OAuth/Api.hs b/src/Shomei/OAuth/Api.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/Api.hs @@ -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) diff --git a/src/Shomei/OAuth/Handler.hs b/src/Shomei/OAuth/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/Handler.hs @@ -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" diff --git a/src/Shomei/OAuth/Result.hs b/src/Shomei/OAuth/Result.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/Result.hs @@ -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) diff --git a/src/Shomei/Passkey/Api.hs b/src/Shomei/Passkey/Api.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Passkey/Api.hs @@ -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) diff --git a/src/Shomei/Passkey/Dto.hs b/src/Shomei/Passkey/Dto.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Passkey/Dto.hs @@ -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 + } diff --git a/src/Shomei/Passkey/Handler.hs b/src/Shomei/Passkey/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Passkey/Handler.hs @@ -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) diff --git a/src/Shomei/Passkey/Result.hs b/src/Shomei/Passkey/Result.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Passkey/Result.hs @@ -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) diff --git a/src/Shomei/Servant/Api.hs b/src/Shomei/Servant/Api.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Api.hs @@ -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] diff --git a/src/Shomei/Servant/Application.hs b/src/Shomei/Servant/Application.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Application.hs @@ -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) diff --git a/src/Shomei/Servant/Auth.hs b/src/Shomei/Servant/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Auth.hs @@ -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 diff --git a/src/Shomei/Servant/Authz.hs b/src/Shomei/Servant/Authz.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Authz.hs @@ -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 diff --git a/src/Shomei/Servant/ClientIp.hs b/src/Shomei/Servant/ClientIp.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/ClientIp.hs @@ -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 diff --git a/src/Shomei/Servant/Cookie.hs b/src/Shomei/Servant/Cookie.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Cookie.hs @@ -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)) diff --git a/src/Shomei/Servant/Error.hs b/src/Shomei/Servant/Error.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Error.hs @@ -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 diff --git a/src/Shomei/Servant/Middleware.hs b/src/Shomei/Servant/Middleware.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Middleware.hs @@ -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 diff --git a/src/Shomei/Servant/OAuth.hs b/src/Shomei/Servant/OAuth.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/OAuth.hs @@ -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" diff --git a/src/Shomei/Servant/Oidc.hs b/src/Shomei/Servant/Oidc.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Oidc.hs @@ -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 diff --git a/src/Shomei/Servant/OpenApi.hs b/src/Shomei/Servant/OpenApi.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/OpenApi.hs @@ -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 diff --git a/src/Shomei/Servant/PreHandler.hs b/src/Shomei/Servant/PreHandler.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/PreHandler.hs @@ -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) diff --git a/src/Shomei/Servant/RemoteHost.hs b/src/Shomei/Servant/RemoteHost.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/RemoteHost.hs @@ -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) diff --git a/src/Shomei/Servant/Result.hs b/src/Shomei/Servant/Result.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Result.hs @@ -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 diff --git a/src/Shomei/Servant/Seam.hs b/src/Shomei/Servant/Seam.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Seam.hs @@ -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)) diff --git a/src/Shomei/Servant/Server.hs b/src/Shomei/Servant/Server.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Server.hs @@ -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 + } diff --git a/src/Shomei/Servant/Throttle.hs b/src/Shomei/Servant/Throttle.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Servant/Throttle.hs @@ -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})) diff --git a/src/Shomei/Session/Admin/Api.hs b/src/Shomei/Session/Admin/Api.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Admin/Api.hs @@ -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) diff --git a/src/Shomei/Session/Api.hs b/src/Shomei/Session/Api.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Api.hs @@ -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) diff --git a/src/Shomei/Session/Dto.hs b/src/Shomei/Session/Dto.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Dto.hs @@ -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" diff --git a/src/Shomei/Session/Handler.hs b/src/Shomei/Session/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Handler.hs @@ -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) diff --git a/src/Shomei/Session/Result.hs b/src/Shomei/Session/Result.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Result.hs @@ -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 () diff --git a/src/Shomei/SigningKey/Api.hs b/src/Shomei/SigningKey/Api.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Api.hs @@ -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) diff --git a/src/Shomei/SigningKey/Handler.hs b/src/Shomei/SigningKey/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Handler.hs @@ -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 diff --git a/test-openapi/Main.hs b/test-openapi/Main.hs new file mode 100644 --- /dev/null +++ b/test-openapi/Main.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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