diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,75 @@ +# Changelog for shomei-core + +All notable changes to `shomei-core` 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:** `AccessToken`, `RefreshToken`, and `TokenPair` no longer expose generic JSON + instances, and token `Show` output is redacted. `LoginFailedData` replaces the submitted + `loginId` with an optional hashed `accountKey` and resolved `userId`; resolved failures now + populate the audit envelope's `user_id` column. +- **Breaking:** `SmtpConfig` no longer contains the SMTP password and `WebhookConfig` no longer + contains the webhook signing secret. Runtime credentials belong to the server or embedding + host, so `Show`/`ToJSON` of `ShomeiConfig` cannot expose them. +- **Breaking:** `configSigningAlgorithm` now returns `Either Text SigningAlgorithm`; embedding + applications must reject invalid hand-built signing configuration instead of receiving an + implicit `ES256` fallback. +- **Breaking:** login-attempt recording, TOTP/passkey counters, user-status changes, session + revocation, and credential-reset tails now expose compare-and-swap or transactional operations. + Single-use transitions report whether they won, login failures are recorded and counted + atomically, and password reset/change revokes every affected session in the same unit of work. +- **Breaking:** `StoredSigningKey` gains `revokedAt`, and `SigningKeyStore` gains the atomic + `ReplaceActiveSigningKey` operation. The in-memory interpreter stamps every lifecycle timestamp. +- **Breaking:** `SigningKeyConfig` gains `allowedClockSkewSeconds`; the reserved custom-claim set + now also excludes `nbf` and `jti`. +- **Breaking:** `Session` and `NewSession` now carry a `kind` that records whether the session was + established interactively, by `client_credentials`, or by delegation. +- OAuth authorize accepts only a live interactive session and refuses machine, delegated, or + explicit-actor credentials. +- RFC 8693 exchange and impersonation always verify the presented session; impersonation also + requires an active operator account. +- Authorization-code exchange now honours `emailVerificationRequired`. +- OAuth sessions persist their granted scopes; refresh preserves them and refuses a minting-client + mismatch, including use through the bespoke refresh workflow. +- OAuth-client registration and authorize refuse reserved privilege scopes while service accounts + remain their intended holders. +- Authorization-code rows bind to their minted sessions; replay revokes the session and refresh + family and emits `oauth_code_replayed`. The core revocation policy models client and + service-account ownership plus the `shomei:admin` escape hatch. + +## 0.1.0.0 — 2026-08-24 + +Initial release. The transport-agnostic heart of the Shōmei authentication +toolkit. + +- Domain model for accounts, sessions, credentials, and audit events. The + principal is a free-form, case-insensitive `loginId` with email as an + optional attribute; email-first callers keep working because `loginId` + defaults to the email when only an email is supplied. +- `effectful` port interfaces for every side effect — user, credential, + session, refresh-token, one-time-token, role, service-account, OAuth client + and authorization-code, MFA, passkey, and signing-key stores, plus the + clock, token generator, audit publisher/reader, notifier, and breach + checker — with an in-memory interpreter (`Shomei.Test.InMemory`) for tests. +- Account lifecycle workflows: signup, login, refresh, logout, email + verification, and password reset/change. One-time token consumption and + refresh-token rotation are compare-and-swap operations, and the write tails + are made atomic by an `AuthUnitOfWork` port. +- Password policy with configurable rules, context-aware validation, + an embedded common-password dictionary, and a `PasswordBreached` violation + backed by a `PasswordBreachChecker` port. +- Authorization: a role registry, role-permission tables, expiring role + grants, claims enrichment from the role catalog at every mint, and a + reserved `permissions` claim. +- OAuth 2.0 / OpenID Connect: authorization-code, refresh, and + `client_credentials` grants, ID tokens, database-backed service accounts, + and the RFC 8693 token-exchange (delegation and impersonation) workflow + with an `act` actor claim. +- Multi-factor authentication: RFC 6238 TOTP, recovery codes, and the + WebAuthn passkey ceremony port for enrollment, step-up, and passwordless + login. +- Abuse protection: brute-force account lockout and per-IP/per-account + throttling. Absolute session expiry is enforced in refresh and token + verification, and login is free of an account-enumeration timing oracle. 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/data/common-passwords.txt b/data/common-passwords.txt new file mode 100644 --- /dev/null +++ b/data/common-passwords.txt @@ -0,0 +1,48 @@ +# Shōmei bundled common-password dictionary (EP-2). +# Each non-blank, non-comment line is one common password, lowercased. +# THIS IS A STARTER LIST. For production, REPLACE or EXTEND it with a full +# top-10k list such as SecLists "10-million-password-list-top-10000" +# (https://github.com/danielmiessler/SecLists) and commit the larger file. +password +123456 +123456789 +12345678 +12345 +qwerty +abc123 +password1 +password123 +passwordpassword +iloveyou +admin +welcome +monkey +dragon +letmein +football +111111 +123123 +qwertyuiop +sunshine +master +000000 +shadow +ashley +michael +superman +qazwsx +trustno1 +hello +whatever +freedom +princess +starwars +login +passw0rd +zaq12wsx +baseball +welcome123 +adminadmin +letmein123 +iloveyou1 +qwerty123456 diff --git a/shomei-core.cabal b/shomei-core.cabal new file mode 100644 --- /dev/null +++ b/shomei-core.cabal @@ -0,0 +1,205 @@ +cabal-version: 3.0 +name: shomei-core +version: 0.2.0.0 +synopsis: + Transport-agnostic domain: types, commands, events, errors, and effects + +description: + shomei-core is the heart of the Shōmei authentication toolkit: the domain + model, commands, events, and errors, together with the effectful effect + interfaces (stores, clock, token generator, signing key) that every workflow + is written against. It has no database, HTTP, or JWT dependency, so the + account, session, OAuth, MFA, passkey, and authorization workflows can be + run against the bundled in-memory interpreter in a test suite and against + PostgreSQL in production without changing a line. All other Shōmei packages + depend on it. + +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 + +-- Embedded at compile time by Shomei.Account.Password.Common.Domain via Template Haskell. +extra-source-files: data/common-passwords.txt + +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 + DeriveAnyClass + DuplicateRecordFields + MultilineStrings + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + QualifiedDo + TemplateHaskell + +library + import: warnings, shared + hs-source-dirs: src + exposed-modules: + Shomei.Account.Admin.Workflow + Shomei.Account.Credential.Domain + Shomei.Account.Credential.Store + Shomei.Account.Email.Domain + Shomei.Account.Lifecycle.Workflow + Shomei.Account.LoginId.Domain + Shomei.Account.Notification.Domain + Shomei.Account.Notification.Store + Shomei.Account.OneTimeToken.Domain + Shomei.Account.Password.Breach.Store + Shomei.Account.Password.Breach.Workflow + Shomei.Account.Password.Common.Domain + Shomei.Account.Password.Domain + Shomei.Account.Password.Hash.Store + Shomei.Account.PasswordReset.Domain + Shomei.Account.PasswordReset.Store + Shomei.Account.User.Domain + Shomei.Account.User.Store + Shomei.Account.Verification.Domain + Shomei.Account.Verification.Store + Shomei.Audit.Event.Codec + Shomei.Audit.Event.Domain + Shomei.Audit.Publisher.Store + Shomei.Audit.Reader.Store + Shomei.Authorization.Claims.Domain + Shomei.Authorization.Claims.Store + Shomei.Authorization.Role.Store + Shomei.Authorization.Role.Workflow + Shomei.Authorization.Scope.Domain + Shomei.Config + Shomei.Delegation.Workflow + Shomei.Error + Shomei.Id + Shomei.Mfa.RecoveryCode.Store + Shomei.Mfa.Totp.Algorithm + Shomei.Mfa.Totp.Domain + Shomei.Mfa.Totp.Store + Shomei.Mfa.Totp.Workflow + Shomei.Mfa.Workflow + Shomei.OAuth.AuthorizationCode.Domain + Shomei.OAuth.AuthorizationCode.Store + Shomei.OAuth.Authorize.Workflow + Shomei.OAuth.Client.Domain + Shomei.OAuth.Client.Store + Shomei.OAuth.Client.Workflow + Shomei.OAuth.IdToken.Domain + Shomei.OAuth.Revocation.Domain + Shomei.OAuth.TokenExchange.Workflow + Shomei.OAuth.TokenGrant.Workflow + Shomei.Passkey.Ceremony.Port + Shomei.Passkey.Ceremony.Store + Shomei.Passkey.Domain + Shomei.Passkey.Store + Shomei.Passkey.Workflow + Shomei.Prelude + Shomei.ServiceAccount.ClientCredentials.Workflow + Shomei.ServiceAccount.Domain + Shomei.ServiceAccount.Secret + Shomei.ServiceAccount.Store + Shomei.Session.Authentication.Workflow + Shomei.Session.Command + Shomei.Session.Domain + Shomei.Session.LoginAttempt.Domain + Shomei.Session.LoginAttempt.Store + Shomei.Session.LoginAttempt.Workflow + Shomei.Session.RefreshToken.Domain + Shomei.Session.RefreshToken.Store + Shomei.Session.Store + Shomei.Session.Token.Domain + Shomei.Session.Token.Generator + Shomei.Session.UnitOfWork.Store + Shomei.Session.Workflow + Shomei.SigningKey.Domain + Shomei.SigningKey.Signer + Shomei.SigningKey.Store + Shomei.SigningKey.Verifier + Shomei.Test.InMemory + Shomei.Time.Store + + 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 + , crypton >=1.1 && <1.2 + , effectful >=2.5 && <2.8 + , effectful-core >=2.5 && <2.8 + , file-embed >=0.0.15 && <0.0.17 + , generic-lens >=2.2 && <2.4 + , http-api-data >=0.6 && <0.8 + , lens >=5.2 && <5.4 + , mmzk-typeid >=0.7 && <0.8 + , ram >=0.22 && <0.23 + , text >=2.0 && <2.2 + , time >=1.12 && <1.15 + , uuid >=1.3 && <1.4 + +test-suite shomei-core-test + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + other-modules: + Shomei.Account.Admin.WorkflowSpec + Shomei.Account.Lifecycle.CostSpec + Shomei.Account.Password.DomainSpec + Shomei.Account.Verification.WorkflowSpec + Shomei.AccountSpec + Shomei.Audit.Event.CodecSpec + Shomei.Authorization.Role.WorkflowSpec + Shomei.BreachSpec + Shomei.Delegation.WorkflowSpec + Shomei.LockoutSpec + Shomei.Mfa.Totp.AlgorithmSpec + Shomei.Mfa.Totp.StoreSpec + Shomei.Mfa.WorkflowSpec + Shomei.OAuth.Authorize.WorkflowSpec + Shomei.OAuth.Client.WorkflowSpec + Shomei.OAuth.Revocation.DomainSpec + Shomei.OAuth.TokenExchange.WorkflowSpec + Shomei.OAuth.TokenGrant.WorkflowSpec + Shomei.OAuthClientStoreSpec + Shomei.OAuthCodeStoreSpec + Shomei.Passkey.WorkflowSpec + Shomei.PasskeyStoreSpec + Shomei.ServiceAccount.ClientCredentials.WorkflowSpec + Shomei.ServiceAccountStoreSpec + Shomei.Session.Authentication.ConcurrencySpec + Shomei.Session.Authentication.TimingSpec + Shomei.Session.Authentication.WorkflowSpec + Shomei.WebAuthnCeremonySpec + + build-depends: + , aeson >=2.1 && <2.3 + , async >=2.2 && <2.3 + , base >=4.18 && <5 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.9 + , effectful >=2.5 && <2.8 + , effectful-core >=2.5 && <2.8 + , generic-lens >=2.2 && <2.4 + , shomei-core ^>=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 diff --git a/src/Shomei/Account/Admin/Workflow.hs b/src/Shomei/Account/Admin/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Admin/Workflow.hs @@ -0,0 +1,145 @@ +-- | The audited administrative lifecycle workflows (EP-2 of MasterPlan 7): suspending, +-- reinstating and deleting a user, and revoking sessions on their behalf. +-- +-- Every function takes the acting administrator's 'UserId' first and the target second, and +-- records the actor on the audit event it publishes. That is the whole reason these live in a +-- workflow rather than in the HTTP handlers: an administrative state change that leaves no trace +-- of /who/ made it is not an audit trail. +-- +-- __These workflows neither authenticate nor authorize.__ They do not check that the acting user +-- holds the @admin@ role, and they do not refuse a self-targeted suspension. Those are HTTP-layer +-- policy (see @Shomei.Servant.Authz.requireAdmin@ and the handlers' self-target refusal), because +-- a different surface may reasonably decide differently — the @shomei-admin@ CLI, for instance, +-- has no notion of a caller at all. +-- +-- Status transitions are strict rather than idempotent: suspending an already-suspended user is +-- an 'InvalidUserStatus' error, not a silent success. Two administrators responding to one +-- incident must be able to tell which of them actually changed the state. +-- +-- Deletion is a __soft delete__ ('UserDeleted' status), never a row removal: sessions, role +-- grants, and audit events reference the user row, and the trail must survive the account. +module Shomei.Account.Admin.Workflow + ( suspendUser, + reinstateUser, + deleteUser, + revokeUserSessions, + revokeOneSession, + ) +where + +import Effectful (Eff, (:>)) +import Shomei.Account.User.Domain (User (..), UserStatus (..)) +import Shomei.Account.User.Store (UserStore, findUserById, updateUserStatus) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Error (AuthError (..)) +import Shomei.Id (SessionId, UserId) +import Shomei.Prelude +import Shomei.Session.Domain (Session (..), SessionStatus (..)) +import Shomei.Session.Store + ( SessionStore, + findSessionById, + listSessionsForUser, + revokeAllUserSessions, + revokeSession, + ) +import Shomei.Time.Store (Clock, now) + +-- | Suspend an active user and kill their sessions. +-- +-- Their outstanding /access/ tokens still ride out their short TTL under the default +-- @sessionCheckMode = VerifyTokenOnly@. A deployment that cannot tolerate that window sets +-- @VerifyTokenAndSession@: the HTTP auth handler then re-reads the session on every request +-- through 'Shomei.Session.Authentication.Workflow.verifyToken', and the next request is refused with +-- @401 session_revoked@, at the cost of one session lookup per authenticated request. The refresh +-- path is closed immediately either way, so under the default the blast radius is one access-token +-- lifetime. +suspendUser :: + (UserStore :> es, SessionStore :> es, AuthEventPublisher :> es, Clock :> es) => + -- | the acting administrator + UserId -> + -- | the target + UserId -> + Eff es (Either AuthError ()) +suspendUser actingAdmin target = + transition target [UserActive] UserSuspended \ts -> do + revokeAllUserSessions target ts + publishAuthEvent (Event.UserSuspended (Event.UserSuspendedData target (Just actingAdmin) ts)) + +-- | Return a suspended user to service. Their sessions stay revoked; they log in again. +reinstateUser :: + (UserStore :> es, SessionStore :> es, AuthEventPublisher :> es, Clock :> es) => + UserId -> + UserId -> + Eff es (Either AuthError ()) +reinstateUser actingAdmin target = + transition target [UserSuspended] UserActive \ts -> + publishAuthEvent (Event.UserReinstated (Event.UserReinstatedData target (Just actingAdmin) ts)) + +-- | Soft-delete a user and kill their sessions. Reachable from either live status. +deleteUser :: + (UserStore :> es, SessionStore :> es, AuthEventPublisher :> es, Clock :> es) => + UserId -> + UserId -> + Eff es (Either AuthError ()) +deleteUser actingAdmin target = + transition target [UserActive, UserSuspended] UserDeleted \ts -> do + revokeAllUserSessions target ts + publishAuthEvent (Event.UserDeleted (Event.UserDeletedData target (Just actingAdmin) ts)) + +-- | Look the target up, check it is in one of @allowed@, move it to @newStatus@, and run +-- @after@. The shared skeleton of the three lifecycle transitions. +transition :: + (UserStore :> es, Clock :> es) => + UserId -> + [UserStatus] -> + UserStatus -> + (UTCTime -> Eff es ()) -> + Eff es (Either AuthError ()) +transition target allowed newStatus after = do + mUser <- findUserById target + case mUser of + Nothing -> pure (Left UserNotFound) + Just user + | user.status `notElem` allowed -> pure (Left InvalidUserStatus) + | otherwise -> do + ts <- now + won <- updateUserStatus target allowed newStatus ts + if won + then after ts >> pure (Right ()) + else pure (Left InvalidUserStatus) + +-- | Revoke every /active/ session of a user, returning how many were revoked. +-- +-- Already-revoked and expired sessions are skipped rather than re-revoked, so the count is the +-- number of sessions this call actually ended and the audit trail carries no duplicate +-- revocations for a session that was already dead. +revokeUserSessions :: + (SessionStore :> es, AuthEventPublisher :> es, Clock :> es) => + UserId -> + UserId -> + Eff es (Either AuthError Int) +revokeUserSessions actingAdmin target = do + sessions <- listSessionsForUser target + ts <- now + let active = [s | s <- sessions, s.status == SessionActive] + forM_ active \s -> do + revokeSession s.sessionId ts + publishAuthEvent (Event.SessionRevoked (Event.SessionRevokedData s.sessionId (Just actingAdmin) ts)) + pure (Right (length active)) + +-- | Revoke one session by id, whoever owns it. +revokeOneSession :: + (SessionStore :> es, AuthEventPublisher :> es, Clock :> es) => + UserId -> + SessionId -> + Eff es (Either AuthError ()) +revokeOneSession actingAdmin sid = do + mSession <- findSessionById sid + case mSession of + Nothing -> pure (Left SessionNotFound) + Just _ -> do + ts <- now + revokeSession sid ts + publishAuthEvent (Event.SessionRevoked (Event.SessionRevokedData sid (Just actingAdmin) ts)) + pure (Right ()) diff --git a/src/Shomei/Account/Credential/Domain.hs b/src/Shomei/Account/Credential/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Credential/Domain.hs @@ -0,0 +1,23 @@ +-- | The password credential entity: the binding of a login id + password hash to a user. +module Shomei.Account.Credential.Domain + ( Credential (..), + ) +where + +import Shomei.Account.Email.Domain (Email) +import Shomei.Account.LoginId.Domain (LoginId) +import Shomei.Account.Password.Domain (PasswordHash) +import Shomei.Id (CredentialId, UserId) +import Shomei.Prelude + +data Credential = PasswordCredential + { credentialId :: !CredentialId, + userId :: !UserId, + loginId :: !LoginId, + email :: !(Maybe Email), + passwordHash :: !PasswordHash, + createdAt :: !UTCTime, + updatedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/Account/Credential/Store.hs b/src/Shomei/Account/Credential/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Credential/Store.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The credential-store port: persisting and looking up password credentials. +module Shomei.Account.Credential.Store + ( CredentialStore (..), + createPasswordCredential, + findPasswordCredentialByLoginId, + findPasswordCredentialByEmail, + updatePasswordHash, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Account.Credential.Domain (Credential) +import Shomei.Account.Email.Domain (Email) +import Shomei.Account.LoginId.Domain (LoginId) +import Shomei.Account.Password.Domain (PasswordHash) +import Shomei.Id (UserId) + +data CredentialStore :: Effect where + -- | Create a password credential. The principal is the login id; email is optional + -- metadata retained for the reset-by-email path. + CreatePasswordCredential :: UserId -> LoginId -> Maybe Email -> PasswordHash -> CredentialStore m Credential + -- | Resolve a credential by its principal login identifier (the login lookup). + FindPasswordCredentialByLoginId :: LoginId -> CredentialStore m (Maybe Credential) + -- | Resolve a credential by email; retained for the reset-by-email path. + FindPasswordCredentialByEmail :: Email -> CredentialStore m (Maybe Credential) + UpdatePasswordHash :: UserId -> PasswordHash -> CredentialStore m () + +type instance DispatchOf CredentialStore = Dynamic + +createPasswordCredential :: (CredentialStore :> es) => UserId -> LoginId -> Maybe Email -> PasswordHash -> Eff es Credential +createPasswordCredential uid lid mEmail h = send (CreatePasswordCredential uid lid mEmail h) + +findPasswordCredentialByLoginId :: (CredentialStore :> es) => LoginId -> Eff es (Maybe Credential) +findPasswordCredentialByLoginId = send . FindPasswordCredentialByLoginId + +findPasswordCredentialByEmail :: (CredentialStore :> es) => Email -> Eff es (Maybe Credential) +findPasswordCredentialByEmail = send . FindPasswordCredentialByEmail + +updatePasswordHash :: (CredentialStore :> es) => UserId -> PasswordHash -> Eff es () +updatePasswordHash uid h = send (UpdatePasswordHash uid h) diff --git a/src/Shomei/Account/Email/Domain.hs b/src/Shomei/Account/Email/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Email/Domain.hs @@ -0,0 +1,37 @@ +-- | Normalized email addresses. +-- +-- The raw 'Email' constructor is not exported: the only way to build one is 'mkEmail', +-- which trims whitespace, lowercases the address, and rejects malformed input. This +-- makes invalid emails unrepresentable outside this module. +module Shomei.Account.Email.Domain + ( Email, + mkEmail, + emailText, + ) +where + +import Data.Text qualified as Text +import Shomei.Error (AuthError (..)) +import Shomei.Prelude + +newtype Email = Email Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +emailText :: Email -> Text +emailText (Email t) = t + +-- | Trim whitespace; lowercase the whole address (initial impl); reject invalid shape. +-- Does NOT collapse gmail dots or plus-addressing. +mkEmail :: Text -> Either AuthError Email +mkEmail raw = + let t = Text.toLower (Text.strip raw) + in if isValidShape t then Right (Email t) else Left InvalidEmail + where + isValidShape t = case Text.splitOn "@" t of + [local, domain] -> + not (Text.null local) + && not (Text.null domain) + && Text.isInfixOf "." domain + && not (Text.isInfixOf " " t) + _ -> False diff --git a/src/Shomei/Account/Lifecycle/Workflow.hs b/src/Shomei/Account/Lifecycle/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Lifecycle/Workflow.hs @@ -0,0 +1,277 @@ +-- | Account lifecycle workflows for email verification and password management. +module Shomei.Account.Lifecycle.Workflow + ( RequestEmailVerification (..), + ConfirmEmailVerification (..), + RequestPasswordReset (..), + ConfirmPasswordReset (..), + ChangePassword (..), + requestEmailVerification, + confirmEmailVerification, + requestPasswordReset, + confirmPasswordReset, + changePassword, + ) +where + +import Data.Time (addUTCTime) +import Effectful (Eff, (:>)) +import Effectful.Error.Static (runErrorNoCallStack, throwError) +import Shomei.Account.Credential.Domain (Credential (..)) +import Shomei.Account.Credential.Store (CredentialStore, findPasswordCredentialByLoginId) +import Shomei.Account.Email.Domain (Email, emailText) +import Shomei.Account.LoginId.Domain (loginIdText) +import Shomei.Account.Notification.Domain (Notification (..)) +import Shomei.Account.Notification.Store (Notifier, sendNotification) +import Shomei.Account.OneTimeToken.Domain (OneTimeToken (..), OneTimeTokenHash (..), OneTimeTokenStatus (..)) +import Shomei.Account.Password.Breach.Store (PasswordBreachChecker) +import Shomei.Account.Password.Breach.Workflow (enforceBreachPolicy) +import Shomei.Account.Password.Domain (PasswordContext (..), PlainPassword, validatePassword) +import Shomei.Account.Password.Hash.Store (PasswordHasher, hashPassword, verifyPassword, verifyPasswordDummy) +import Shomei.Account.PasswordReset.Domain (NewPasswordResetToken (..), PersistedPasswordResetToken (..)) +import Shomei.Account.PasswordReset.Store + ( PasswordResetTokenStore, + createPasswordResetToken, + findPasswordResetTokenByHash, + ) +import Shomei.Account.User.Domain (User (..), UserStatus (UserActive)) +import Shomei.Account.User.Store (UserStore, findUserByEmail, findUserById, markUserEmailVerified) +import Shomei.Account.Verification.Domain (NewVerificationToken (..), PersistedVerificationToken (..)) +import Shomei.Account.Verification.Store + ( VerificationTokenStore, + createVerificationToken, + findVerificationTokenByHash, + markVerificationTokenConsumed, + revokeUserVerificationTokens, + ) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Config (NotifierConfig (..), ShomeiConfig (..)) +import Shomei.Error (AuthError (..)) +import Shomei.Id (UserId) +import Shomei.Prelude +import Shomei.Session.Command (ProofContext, proofContextFor) +import Shomei.Session.LoginAttempt.Domain (AttemptFactor (FactorPasswordChange)) +import Shomei.Session.LoginAttempt.Store (LoginAttemptStore) +import Shomei.Session.LoginAttempt.Workflow (AbuseGate (..), guardAbuse, recordProofFailure, recordProofSuccess) +import Shomei.Session.RefreshToken.Domain (RefreshToken (..), RefreshTokenHash (..)) +import Shomei.Session.Token.Generator (TokenGen, generateOpaqueToken, hashRefreshToken) +import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork, completePasswordChange, completePasswordReset) +import Shomei.Time.Store (Clock, now) + +newtype RequestEmailVerification = RequestEmailVerification {email :: Email} + deriving stock (Generic, Show) + +newtype ConfirmEmailVerification = ConfirmEmailVerification {token :: OneTimeToken} + deriving stock (Generic, Show) + +newtype RequestPasswordReset = RequestPasswordReset {email :: Email} + deriving stock (Generic, Show) + +data ConfirmPasswordReset = ConfirmPasswordReset + { token :: !OneTimeToken, + newPassword :: !PlainPassword + } + deriving stock (Generic, Show) + +data ChangePassword = ChangePassword + { userId :: !UserId, + currentPassword :: !PlainPassword, + newPassword :: !PlainPassword + } + deriving stock (Generic, Show) + +requestEmailVerification :: + ( UserStore :> es, + VerificationTokenStore :> es, + Notifier :> es, + AuthEventPublisher :> es, + Clock :> es, + TokenGen :> es + ) => + ShomeiConfig -> + RequestEmailVerification -> + Eff es (Either AuthError ()) +requestEmailVerification cfg cmd = do + ts <- now + mUser <- findUserByEmail cmd.email + forM_ mUser \user -> + forM_ user.email \email -> + when (user.status == UserActive && isNothing user.emailVerifiedAt) do + let expires = addUTCTime cfg.notifierConfig.verificationTokenTTL ts + (raw, h) <- generateOneTimeToken + _ <- + createVerificationToken + NewVerificationToken + { userId = user.userId, + tokenHash = h, + createdAt = ts, + expiresAt = expires + } + sendNotification (EmailVerificationRequested email raw expires) + publishAuthEvent (Event.EmailVerificationRequested (Event.EmailVerificationRequestedData user.userId email ts)) + pure (Right ()) + +confirmEmailVerification :: + ( VerificationTokenStore :> es, + UserStore :> es, + AuthEventPublisher :> es, + Clock :> es, + TokenGen :> es + ) => + ShomeiConfig -> + ConfirmEmailVerification -> + Eff es (Either AuthError ()) +confirmEmailVerification _cfg cmd = runErrorNoCallStack do + ts <- now + h <- hashOneTimeToken cmd.token + tok <- maybe (throwError VerificationTokenInvalid) pure =<< findVerificationTokenByHash h + either throwError pure (ensureUsableVerification tok ts) + user <- maybe (throwError VerificationTokenInvalid) pure =<< findUserById tok.userId + -- A verification token only ever exists for an account that had an email; a missing + -- email here means the token cannot belong to a verifiable account. + email <- maybe (throwError VerificationTokenInvalid) pure user.email + when (isJust user.emailVerifiedAt) (throwError EmailAlreadyVerified) + -- Consume before acting: the compare-and-swap is the linearization point, so of two + -- concurrent confirmations of one token exactly one proceeds. The loser sees precisely what + -- a stale-token presenter sees. + won <- markVerificationTokenConsumed tok.verificationTokenId ts + unless won (throwError VerificationTokenInvalid) + markUserEmailVerified user.userId ts + revokeUserVerificationTokens user.userId ts + publishAuthEvent (Event.EmailVerified (Event.EmailVerifiedData user.userId email ts)) + +requestPasswordReset :: + ( UserStore :> es, + PasswordResetTokenStore :> es, + Notifier :> es, + AuthEventPublisher :> es, + Clock :> es, + TokenGen :> es + ) => + ShomeiConfig -> + RequestPasswordReset -> + Eff es (Either AuthError ()) +requestPasswordReset cfg cmd = do + ts <- now + mUser <- findUserByEmail cmd.email + forM_ mUser \user -> + forM_ user.email \email -> + when (user.status == UserActive) do + let expires = addUTCTime cfg.notifierConfig.passwordResetTokenTTL ts + (raw, h) <- generateOneTimeToken + _ <- + createPasswordResetToken + NewPasswordResetToken + { userId = user.userId, + tokenHash = h, + createdAt = ts, + expiresAt = expires + } + sendNotification (PasswordResetRequested email raw expires) + publishAuthEvent (Event.PasswordResetRequested (Event.PasswordResetRequestedData user.userId email ts)) + pure (Right ()) + +confirmPasswordReset :: + ( UserStore :> es, + PasswordResetTokenStore :> es, + PasswordHasher :> es, + PasswordBreachChecker :> es, + AuthUnitOfWork :> es, + Clock :> es, + TokenGen :> es + ) => + ShomeiConfig -> + ConfirmPasswordReset -> + Eff es (Either AuthError ()) +confirmPasswordReset cfg cmd = runErrorNoCallStack do + ts <- now + h <- hashOneTimeToken cmd.token + tok <- maybe (throwError PasswordResetTokenInvalid) pure =<< findPasswordResetTokenByHash h + either throwError pure (ensureUsableReset tok ts) + user <- maybe (throwError PasswordResetTokenInvalid) pure =<< findUserById tok.userId + let pwContext = + PasswordContext + { contextEmail = emailText <$> user.email, + contextDisplayName = user.displayName + } + either (throwError . WeakPassword) pure (validatePassword cfg.passwordPolicy pwContext cmd.newPassword) + enforceBreachPolicy cfg.passwordPolicy cmd.newPassword + newHash <- hashPassword cmd.newPassword + -- Consume before acting, but after validating the new password: the compare-and-swap is the + -- linearization point (exactly one of two concurrent confirmations proceeds), while a + -- pure-read policy check ahead of it cannot widen the race and spares the user's token when + -- the new password is merely too weak. + won <- + completePasswordReset + tok.passwordResetTokenId + tok.userId + newHash + ts + [Event.PasswordResetCompleted (Event.PasswordResetCompletedData tok.userId ts)] + unless won (throwError PasswordResetTokenInvalid) + +changePassword :: + ( UserStore :> es, + CredentialStore :> es, + PasswordHasher :> es, + PasswordBreachChecker :> es, + AuthUnitOfWork :> es, + AuthEventPublisher :> es, + LoginAttemptStore :> es, + Clock :> es + ) => + ShomeiConfig -> + ProofContext -> + ChangePassword -> + Eff es (Either AuthError ()) +changePassword cfg pctx cmd = runErrorNoCallStack do + user <- maybe (throwError InvalidCredentials) pure =<< findUserById cmd.userId + ts <- now + let ctx = proofContextFor pctx (loginIdText user.loginId) + gate <- guardAbuse cfg.rateLimitConfig ctx ts + when gate.locked do + verifyPasswordDummy cmd.currentPassword + throwError InvalidCredentials + let pwContext = + PasswordContext + { contextEmail = emailText <$> user.email, + contextDisplayName = user.displayName + } + either (throwError . WeakPassword) pure (validatePassword cfg.passwordPolicy pwContext cmd.newPassword) + enforceBreachPolicy cfg.passwordPolicy cmd.newPassword + cred <- maybe (throwError InvalidCredentials) pure =<< findPasswordCredentialByLoginId user.loginId + ok <- verifyPassword cmd.currentPassword cred.passwordHash + unless ok do + recordProofFailure cfg.rateLimitConfig ctx FactorPasswordChange ts + publishAuthEvent (Event.PasswordChangeFailed (Event.PasswordChangeFailedData user.userId ts)) + throwError InvalidCredentials + recordProofSuccess ctx FactorPasswordChange gate.standingLockout ts + newHash <- hashPassword cmd.newPassword + completePasswordChange + user.userId + newHash + ts + [Event.PasswordChanged (Event.PasswordChangedData user.userId ts)] + +generateOneTimeToken :: (TokenGen :> es) => Eff es (OneTimeToken, OneTimeTokenHash) +generateOneTimeToken = do + raw@(RefreshToken t) <- generateOpaqueToken + RefreshTokenHash h <- hashRefreshToken raw + pure (OneTimeToken t, OneTimeTokenHash h) + +hashOneTimeToken :: (TokenGen :> es) => OneTimeToken -> Eff es OneTimeTokenHash +hashOneTimeToken (OneTimeToken t) = do + RefreshTokenHash h <- hashRefreshToken (RefreshToken t) + pure (OneTimeTokenHash h) + +ensureUsableVerification :: PersistedVerificationToken -> UTCTime -> Either AuthError () +ensureUsableVerification tok ts = + if tok.status == OneTimeTokenActive && tok.expiresAt > ts + then Right () + else Left VerificationTokenInvalid + +ensureUsableReset :: PersistedPasswordResetToken -> UTCTime -> Either AuthError () +ensureUsableReset tok ts = + if tok.status == OneTimeTokenActive && tok.expiresAt > ts + then Right () + else Left PasswordResetTokenInvalid diff --git a/src/Shomei/Account/LoginId/Domain.hs b/src/Shomei/Account/LoginId/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/LoginId/Domain.hs @@ -0,0 +1,40 @@ +-- | Normalized login identifiers — the principal of an account. +-- +-- A 'LoginId' is a free-form, case-insensitive, unique handle: it may be a username, +-- an agent id like @agent-4815162342@, or an email-shaped identifier +-- address. Unlike 'Shomei.Account.Email.Domain.Email' it does NOT require an @\@@ or a dot — +-- that is the whole point: a principal need not be an email. +-- +-- The raw 'LoginId' constructor is not exported: the only way to build one is +-- 'mkLoginId', which trims whitespace, lowercases the handle, and rejects the empty +-- string or any value containing internal whitespace. This makes invalid identifiers +-- unrepresentable outside this module, mirroring 'Shomei.Account.Email.Domain'. +module Shomei.Account.LoginId.Domain + ( LoginId, + mkLoginId, + loginIdText, + ) +where + +import Data.Char (isSpace) +import Data.Text qualified as Text +import Shomei.Error (AuthError (..)) +import Shomei.Prelude + +newtype LoginId = LoginId Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +-- | Project the normalized identifier text. +loginIdText :: LoginId -> Text +loginIdText (LoginId t) = t + +-- | Trim leading/trailing whitespace; lowercase the handle (case-insensitive +-- principal); reject the empty string and any value containing internal whitespace. +-- Does NOT require an @\@@ or a dot — a username principal is valid. +mkLoginId :: Text -> Either AuthError LoginId +mkLoginId raw = + let t = Text.toLower (Text.strip raw) + in if Text.null t || Text.any isSpace t + then Left InvalidLoginId + else Right (LoginId t) diff --git a/src/Shomei/Account/Notification/Domain.hs b/src/Shomei/Account/Notification/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Notification/Domain.hs @@ -0,0 +1,23 @@ +-- | Notifications emitted by account lifecycle workflows. +module Shomei.Account.Notification.Domain + ( Notification (..), + ) +where + +import Shomei.Account.Email.Domain (Email) +import Shomei.Account.OneTimeToken.Domain (OneTimeToken) +import Shomei.Prelude + +data Notification + = EmailVerificationRequested + { email :: !Email, + token :: !OneTimeToken, + expiresAt :: !UTCTime + } + | PasswordResetRequested + { email :: !Email, + token :: !OneTimeToken, + expiresAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/Account/Notification/Store.hs b/src/Shomei/Account/Notification/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Notification/Store.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Notification-sending effect for account lifecycle messages. +module Shomei.Account.Notification.Store + ( Notifier (..), + sendNotification, + ) +where + +import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Account.Notification.Domain (Notification) + +data Notifier :: Effect where + SendNotification :: Notification -> Notifier m () + +type instance DispatchOf Notifier = Dynamic + +sendNotification :: (Notifier :> es) => Notification -> Eff es () +sendNotification = send . SendNotification diff --git a/src/Shomei/Account/OneTimeToken/Domain.hs b/src/Shomei/Account/OneTimeToken/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/OneTimeToken/Domain.hs @@ -0,0 +1,33 @@ +-- | Shared opaque single-use token types for account lifecycle flows. +module Shomei.Account.OneTimeToken.Domain + ( OneTimeToken (..), + OneTimeTokenHash (..), + OneTimeTokenStatus (..), + oneTimeTokenText, + oneTimeTokenHashText, + ) +where + +import Shomei.Prelude + +newtype OneTimeToken = OneTimeToken Text + deriving stock (Generic) + deriving newtype (Eq, Show, FromJSON, ToJSON) + +newtype OneTimeTokenHash = OneTimeTokenHash Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +data OneTimeTokenStatus + = OneTimeTokenActive + | OneTimeTokenConsumed + | OneTimeTokenRevoked + | OneTimeTokenExpired + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +oneTimeTokenText :: OneTimeToken -> Text +oneTimeTokenText (OneTimeToken t) = t + +oneTimeTokenHashText :: OneTimeTokenHash -> Text +oneTimeTokenHashText (OneTimeTokenHash t) = t diff --git a/src/Shomei/Account/Password/Breach/Store.hs b/src/Shomei/Account/Password/Breach/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Password/Breach/Store.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The password-breach-checker port: decide whether a password appears in a known public +-- breach. Implemented in production by a HIBP k-anonymity range query (EP-3) and in tests by an +-- in-memory fake. Kept separate from the pure 'Shomei.Account.Password.Domain.validatePassword' because +-- the production check performs IO. +module Shomei.Account.Password.Breach.Store + ( PasswordBreachChecker (..), + BreachResult (..), + checkPasswordBreached, + + -- * Pure helpers (shared by the production interpreter and tests) + sha1PrefixSuffix, + parseHibpResponse, + ) +where + +import Crypto.Hash (SHA1 (..), hashWith) +import Data.ByteArray.Encoding (Base (Base16), convertToBase) +import Data.ByteString (ByteString) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import Data.Text.Read qualified as TR +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Account.Password.Domain (PlainPassword (..)) +import Shomei.Prelude + +-- | The outcome of a breach check; the third state lets policy choose fail-open vs fail-closed. +data BreachResult + = NotBreached + | Breached + | BreachCheckUnavailable + deriving stock (Eq, Show) + +data PasswordBreachChecker :: Effect where + CheckPasswordBreached :: PlainPassword -> PasswordBreachChecker m BreachResult + +type instance DispatchOf PasswordBreachChecker = Dynamic + +checkPasswordBreached :: (PasswordBreachChecker :> es) => PlainPassword -> Eff es BreachResult +checkPasswordBreached = send . CheckPasswordBreached + +-- | Uppercase hex SHA-1 of the UTF-8 password, split into the 5-char k-anonymity prefix and +-- the 35-char suffix. @sha1PrefixSuffix "password" == ("5BAA6", "1E4C9B93F3F0682250B6CF8331B7EE68FD8")@. +-- Only the prefix is ever sent to HIBP; the full hash never leaves the process. +sha1PrefixSuffix :: PlainPassword -> (Text, Text) +sha1PrefixSuffix (PlainPassword pw) = + let digest = hashWith SHA1 (TE.encodeUtf8 pw) + hex = Text.toUpper (TE.decodeUtf8 (convertToBase Base16 digest :: ByteString)) + in (Text.take 5 hex, Text.drop 5 hex) + +-- | Given a HIBP range response body and our 35-char suffix, return whether any line matches +-- our suffix (case-insensitive) with a count > 0. Padding lines (count 0) are ignored. Lines may +-- use CRLF; the trailing @\\r@ is stripped before splitting. +parseHibpResponse :: Text -> Text -> Bool +parseHibpResponse body suffix = + let wantUpper = Text.toUpper suffix + matches line = + case Text.splitOn ":" (Text.dropWhileEnd (== '\r') line) of + [s, c] -> Text.toUpper s == wantUpper && countPositive c + _ -> False + in any matches (Text.lines body) + where + countPositive c = case TR.decimal (Text.strip c) of + Right (n, "") -> n > (0 :: Integer) + _ -> False diff --git a/src/Shomei/Account/Password/Breach/Workflow.hs b/src/Shomei/Account/Password/Breach/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Password/Breach/Workflow.hs @@ -0,0 +1,33 @@ +-- | EP-3: the effectful breach-policy guard, appended to every password-accepting workflow +-- after the pure 'Shomei.Account.Password.Domain.validatePassword' step. Honors the EP-1 policy flags: +-- no-op when disabled; rejects breached passwords; on an unreachable checker, fails open or +-- closed per 'breachCheckFailClosed'. +module Shomei.Account.Password.Breach.Workflow (enforceBreachPolicy) where + +import Effectful (Eff, (:>)) +import Effectful.Error.Static (Error, throwError) +import Shomei.Account.Password.Breach.Store (BreachResult (..), PasswordBreachChecker, checkPasswordBreached) +import Shomei.Account.Password.Domain (PasswordPolicy (..), PlainPassword) +import Shomei.Error (AuthError (..), PasswordPolicyViolation (..)) + +-- | Run the opt-in breach check for a password. A no-op unless @breachCheckEnabled@ is set. +-- A 'Breached' result always rejects; an unreachable checker rejects only under +-- @breachCheckFailClosed@ (the default is fail-open). The 'Error AuthError' effect is supplied +-- by each workflow's enclosing 'runErrorNoCallStack', so the guard is callable from inside the +-- workflow @do@ blocks. +enforceBreachPolicy :: + (PasswordBreachChecker :> es, Error AuthError :> es) => + PasswordPolicy -> + PlainPassword -> + Eff es () +enforceBreachPolicy policy pw + | not policy.breachCheckEnabled = pure () + | otherwise = do + r <- checkPasswordBreached pw + case r of + NotBreached -> pure () + Breached -> throwError (WeakPassword PasswordBreached) + BreachCheckUnavailable -> + if policy.breachCheckFailClosed + then throwError (WeakPassword PasswordBreached) + else pure () diff --git a/src/Shomei/Account/Password/Common/Domain.hs b/src/Shomei/Account/Password/Common/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Password/Common/Domain.hs @@ -0,0 +1,43 @@ +-- | The bundled common-password dictionary and the membership check. +-- +-- The dictionary is embedded at COMPILE time from @data/common-passwords.txt@ via +-- Template Haskell ('embedStringFile'), parsed once into a 'Set' of normalized entries +-- (a top-level CAF), and queried by 'isCommonPassword'. Matching is case-insensitive +-- exact membership: the input is trimmed and lowercased, then looked up in the set. It is +-- NOT a substring scan. +module Shomei.Account.Password.Common.Domain + ( isCommonPassword, + commonPasswordCount, + ) +where + +import Data.FileEmbed (embedStringFile, makeRelativeToProject) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Shomei.Prelude + +-- | The raw embedded file contents (compile-time splice, path anchored at the package dir). +rawDictionary :: Text +rawDictionary = $(makeRelativeToProject "data/common-passwords.txt" >>= embedStringFile) + +-- | The dictionary as a set of normalized entries. Blank lines and lines beginning +-- with @#@ (comments / the operator note) are ignored. Built once as a CAF. +commonPasswords :: Set Text +commonPasswords = + Set.fromList + [ normalized + | line <- Text.lines rawDictionary, + let normalized = Text.toLower (Text.strip line), + not (Text.null normalized), + not ("#" `Text.isPrefixOf` Text.strip line) + ] + +-- | Number of dictionary entries (used by tests to assert the set is non-empty). +commonPasswordCount :: Int +commonPasswordCount = Set.size commonPasswords + +-- | Is the given password a known common password? Case-insensitive exact membership: +-- the input is trimmed and lowercased before lookup. +isCommonPassword :: Text -> Bool +isCommonPassword pw = Text.toLower (Text.strip pw) `Set.member` commonPasswords diff --git a/src/Shomei/Account/Password/Domain.hs b/src/Shomei/Account/Password/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Password/Domain.hs @@ -0,0 +1,94 @@ +-- | Password types and the pure password-policy validator. +-- +-- 'PlainPassword' is the user-supplied secret. It has a redacting 'Show' instance and +-- deliberately no JSON instances, so it is never logged, serialized, or persisted. +-- 'PasswordHash' is the opaque hash produced by the 'Shomei.Account.Password.Hash.Store' port +-- (Argon2id in production, EP-3). +module Shomei.Account.Password.Domain + ( PlainPassword (..), + PasswordHash (..), + PasswordPolicy (..), + PasswordContext (..), + emptyPasswordContext, + defaultPasswordPolicy, + validatePassword, + ) +where + +import Data.Text qualified as Text +import Shomei.Account.Password.Common.Domain (isCommonPassword) +import Shomei.Error (PasswordPolicyViolation (..)) +import Shomei.Prelude + +-- | Never logged, serialized, or persisted: redacting 'Show', no 'FromJSON'/'ToJSON'. +newtype PlainPassword = PlainPassword Text + deriving stock (Generic) + +instance Show PlainPassword where + show _ = "PlainPassword " + +newtype PasswordHash = PasswordHash Text + deriving stock (Generic) + deriving newtype (Eq, Show, FromJSON, ToJSON) + +data PasswordPolicy = PasswordPolicy + { minLength :: !Int, + maxLength :: !Int, + rejectCommonPasswords :: !Bool, -- consumed by EP-2 (docs/plans/21-...) + rejectContextualPasswords :: !Bool, -- consumed by EP-2 (docs/plans/21-...) + breachCheckEnabled :: !Bool, -- consumed by EP-3 (docs/plans/22-...) + breachCheckFailClosed :: !Bool, -- consumed by EP-3 (docs/plans/22-...) + breachCheckTimeoutMs :: !Int -- consumed by EP-3 (docs/plans/22-...) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +defaultPasswordPolicy :: PasswordPolicy +defaultPasswordPolicy = + PasswordPolicy + { minLength = 12, + maxLength = 256, + rejectCommonPasswords = True, + rejectContextualPasswords = True, + breachCheckEnabled = False, + breachCheckFailClosed = False, + breachCheckTimeoutMs = 1000 + } + +-- | The identity context a password is checked against (for the contextual check). +data PasswordContext = PasswordContext + { -- | the user's email address (raw text), if known + contextEmail :: !(Maybe Text), + -- | the user's display name, if any + contextDisplayName :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +-- | No identity context (length and common-password checks still apply). +emptyPasswordContext :: PasswordContext +emptyPasswordContext = PasswordContext {contextEmail = Nothing, contextDisplayName = Nothing} + +-- | Validate a password against the policy and the user's identity context. Check order: +-- length (cheap) first, then the common-password dictionary (if 'rejectCommonPasswords'), +-- then the contextual identity check (if 'rejectContextualPasswords'). +validatePassword :: + PasswordPolicy -> PasswordContext -> PlainPassword -> Either PasswordPolicyViolation () +validatePassword policy context (PlainPassword pw) + | Text.length pw < policy.minLength = Left (PasswordTooShort policy.minLength) + | Text.length pw > policy.maxLength = Left (PasswordTooLong policy.maxLength) + | policy.rejectCommonPasswords && isCommonPassword pw = Left PasswordTooCommon + | policy.rejectContextualPasswords && resemblesIdentity context pw = Left PasswordResemblesIdentity + | otherwise = Right () + +-- | Does the password (trimmed, lowercased) exactly equal the user's email local-part, +-- full email, or display name (each trimmed, lowercased)? Exact equality only — no +-- substring rule, to avoid rejecting long passphrases that merely contain a short name. +resemblesIdentity :: PasswordContext -> Text -> Bool +resemblesIdentity ctx pw = + let p = Text.toLower (Text.strip pw) + norm = Text.toLower . Text.strip + emailCandidates = case ctx.contextEmail of + Nothing -> [] + Just e -> let e' = norm e in [e', Text.takeWhile (/= '@') e'] + nameCandidates = maybe [] (\n -> [norm n]) ctx.contextDisplayName + in not (Text.null p) && p `elem` (emailCandidates <> nameCandidates) diff --git a/src/Shomei/Account/Password/Hash/Store.hs b/src/Shomei/Account/Password/Hash/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Password/Hash/Store.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The password-hasher port: hashing and verifying passwords (Argon2id in production, +-- EP-3). +module Shomei.Account.Password.Hash.Store + ( PasswordHasher (..), + hashPassword, + verifyPassword, + verifyPasswordDummy, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Account.Password.Domain (PasswordHash, PlainPassword) + +data PasswordHasher :: Effect where + HashPassword :: PlainPassword -> PasswordHasher m PasswordHash + VerifyPassword :: PlainPassword -> PasswordHash -> PasswordHasher m Bool + -- | Perform exactly the work one 'VerifyPassword' costs, and discard the answer. + -- + -- This exists for the login timing oracle: a login that fails before it ever reaches a + -- stored hash (unknown account, suspended user) must be indistinguishable, by response + -- time, from one that fails on a wrong password. Such a path has no hash to verify, so it + -- burns an equivalent amount of hashing work instead. + -- + -- It is a port operation rather than "verify against some constant hash" because only the + -- interpreter knows the cost parameters in force. An Argon2 verification costs whatever the + -- parameters embedded in the /stored/ hash say, so a hardcoded constant would drift out of + -- step the moment an operator tuned the parameters — a login miss would cost 102 ms while a + -- hit cost 19 ms, which is the very oracle this closes. + VerifyPasswordDummy :: PlainPassword -> PasswordHasher m () + +type instance DispatchOf PasswordHasher = Dynamic + +hashPassword :: (PasswordHasher :> es) => PlainPassword -> Eff es PasswordHash +hashPassword = send . HashPassword + +verifyPassword :: (PasswordHasher :> es) => PlainPassword -> PasswordHash -> Eff es Bool +verifyPassword p h = send (VerifyPassword p h) + +-- | Burn one verification's worth of hashing work; see 'VerifyPasswordDummy'. +verifyPasswordDummy :: (PasswordHasher :> es) => PlainPassword -> Eff es () +verifyPasswordDummy = send . VerifyPasswordDummy diff --git a/src/Shomei/Account/PasswordReset/Domain.hs b/src/Shomei/Account/PasswordReset/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/PasswordReset/Domain.hs @@ -0,0 +1,32 @@ +-- | Password-reset token rows. +module Shomei.Account.PasswordReset.Domain + ( PersistedPasswordResetToken (..), + NewPasswordResetToken (..), + ) +where + +import Shomei.Account.OneTimeToken.Domain (OneTimeTokenHash, OneTimeTokenStatus) +import Shomei.Id (PasswordResetTokenId, UserId) +import Shomei.Prelude + +data PersistedPasswordResetToken = PersistedPasswordResetToken + { passwordResetTokenId :: !PasswordResetTokenId, + userId :: !UserId, + tokenHash :: !OneTimeTokenHash, + status :: !OneTimeTokenStatus, + createdAt :: !UTCTime, + expiresAt :: !UTCTime, + consumedAt :: !(Maybe UTCTime), + revokedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data NewPasswordResetToken = NewPasswordResetToken + { userId :: !UserId, + tokenHash :: !OneTimeTokenHash, + createdAt :: !UTCTime, + expiresAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/Account/PasswordReset/Store.hs b/src/Shomei/Account/PasswordReset/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/PasswordReset/Store.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Store effect for password-reset tokens. +module Shomei.Account.PasswordReset.Store + ( PasswordResetTokenStore (..), + createPasswordResetToken, + findPasswordResetTokenByHash, + markPasswordResetTokenConsumed, + revokeUserPasswordResetTokens, + ) +where + +import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Account.OneTimeToken.Domain (OneTimeTokenHash) +import Shomei.Account.PasswordReset.Domain (NewPasswordResetToken, PersistedPasswordResetToken) +import Shomei.Id (PasswordResetTokenId, UserId) +import Shomei.Prelude + +data PasswordResetTokenStore :: Effect where + CreatePasswordResetToken :: NewPasswordResetToken -> PasswordResetTokenStore m PersistedPasswordResetToken + FindPasswordResetTokenByHash :: OneTimeTokenHash -> PasswordResetTokenStore m (Maybe PersistedPasswordResetToken) + -- | Transition a token @active → consumed@ as one atomic compare-and-swap. 'True' means + -- this call performed the transition; 'False' means it was already spent or revoked. + MarkPasswordResetTokenConsumed :: PasswordResetTokenId -> UTCTime -> PasswordResetTokenStore m Bool + RevokeUserPasswordResetTokens :: UserId -> UTCTime -> PasswordResetTokenStore m () + +type instance DispatchOf PasswordResetTokenStore = Dynamic + +createPasswordResetToken :: (PasswordResetTokenStore :> es) => NewPasswordResetToken -> Eff es PersistedPasswordResetToken +createPasswordResetToken = send . CreatePasswordResetToken + +findPasswordResetTokenByHash :: (PasswordResetTokenStore :> es) => OneTimeTokenHash -> Eff es (Maybe PersistedPasswordResetToken) +findPasswordResetTokenByHash = send . FindPasswordResetTokenByHash + +markPasswordResetTokenConsumed :: (PasswordResetTokenStore :> es) => PasswordResetTokenId -> UTCTime -> Eff es Bool +markPasswordResetTokenConsumed i t = send (MarkPasswordResetTokenConsumed i t) + +revokeUserPasswordResetTokens :: (PasswordResetTokenStore :> es) => UserId -> UTCTime -> Eff es () +revokeUserPasswordResetTokens i t = send (RevokeUserPasswordResetTokens i t) diff --git a/src/Shomei/Account/User/Domain.hs b/src/Shomei/Account/User/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/User/Domain.hs @@ -0,0 +1,37 @@ +-- | The user entity and its lifecycle status. +module Shomei.Account.User.Domain + ( UserStatus (..), + User (..), + NewUser (..), + ) +where + +import Shomei.Account.Email.Domain (Email) +import Shomei.Account.LoginId.Domain (LoginId) +import Shomei.Id (UserId) +import Shomei.Prelude + +data UserStatus = UserActive | UserSuspended | UserDeleted + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data User = User + { userId :: !UserId, + loginId :: !LoginId, + email :: !(Maybe Email), + displayName :: !(Maybe Text), + status :: !UserStatus, + emailVerifiedAt :: !(Maybe UTCTime), + createdAt :: !UTCTime, + updatedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data NewUser = NewUser + { loginId :: !LoginId, + email :: !(Maybe Email), + displayName :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/Account/User/Store.hs b/src/Shomei/Account/User/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/User/Store.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The user-store port: persisting and looking up 'User' records. +module Shomei.Account.User.Store + ( UserStore (..), + createUser, + findUserById, + findUserByLoginId, + findUserByEmail, + updateUserStatus, + markUserEmailVerified, + + -- * Listing (EP-2) + UserCursor (..), + UserListQuery (..), + emptyUserListQuery, + maxUserLimit, + clampUserLimit, + listUsers, + ) +where + +import Data.Time (UTCTime) +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Account.Email.Domain (Email) +import Shomei.Account.LoginId.Domain (LoginId) +import Shomei.Account.User.Domain (NewUser, User, UserStatus) +import Shomei.Id (UserId) + +-- | A keyset-pagination cursor over @(created_at, user_id)@, newest first. Pointing at a row +-- rather than counting offsets means a page boundary cannot shift under concurrent signups. +data UserCursor = UserCursor + { cursorCreatedAt :: !UTCTime, + cursorUserId :: !UserId + } + deriving stock (Eq, Show) + +-- | Filters and pagination for 'ListUsers'. Deliberately its own type rather than a share with +-- 'Shomei.Audit.Reader.Store.AuditEventQuery': different port, different filters. +data UserListQuery = UserListQuery + { queryStatus :: !(Maybe UserStatus), + -- | Pass through 'clampUserLimit' before it reaches a database. + queryLimit :: !Int, + queryBefore :: !(Maybe UserCursor) + } + deriving stock (Eq, Show) + +-- | No filter, 50 rows, from the top. +emptyUserListQuery :: UserListQuery +emptyUserListQuery = UserListQuery Nothing 50 Nothing + +maxUserLimit :: Int +maxUserLimit = 1000 + +clampUserLimit :: Int -> Int +clampUserLimit n = max 1 (min maxUserLimit n) + +data UserStore :: Effect where + CreateUser :: NewUser -> UserStore m User + FindUserById :: UserId -> UserStore m (Maybe User) + -- | Look a user up by their principal login identifier. + FindUserByLoginId :: LoginId -> UserStore m (Maybe User) + -- | Look a user up by email. No longer the principal lookup, but retained for the + -- reset/verification flows a caller initiates /by typing an email/. + FindUserByEmail :: Email -> UserStore m (Maybe User) + -- | Change status only when the row is currently in one of the allowed states. 'False' + -- means the user was absent or another writer won the transition. + UpdateUserStatus :: UserId -> [UserStatus] -> UserStatus -> UTCTime -> UserStore m Bool + MarkUserEmailVerified :: UserId -> UTCTime -> UserStore m () + -- | Newest-first page of users, optionally filtered by status. Soft-deleted users are + -- included: the admin surface is honest about them. + ListUsers :: UserListQuery -> UserStore m [User] + +type instance DispatchOf UserStore = Dynamic + +createUser :: (UserStore :> es) => NewUser -> Eff es User +createUser = send . CreateUser + +findUserById :: (UserStore :> es) => UserId -> Eff es (Maybe User) +findUserById = send . FindUserById + +findUserByLoginId :: (UserStore :> es) => LoginId -> Eff es (Maybe User) +findUserByLoginId = send . FindUserByLoginId + +findUserByEmail :: (UserStore :> es) => Email -> Eff es (Maybe User) +findUserByEmail = send . FindUserByEmail + +updateUserStatus :: (UserStore :> es) => UserId -> [UserStatus] -> UserStatus -> UTCTime -> Eff es Bool +updateUserStatus uid allowed st ts = send (UpdateUserStatus uid allowed st ts) + +markUserEmailVerified :: (UserStore :> es) => UserId -> UTCTime -> Eff es () +markUserEmailVerified uid t = send (MarkUserEmailVerified uid t) + +listUsers :: (UserStore :> es) => UserListQuery -> Eff es [User] +listUsers = send . ListUsers diff --git a/src/Shomei/Account/Verification/Domain.hs b/src/Shomei/Account/Verification/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Verification/Domain.hs @@ -0,0 +1,32 @@ +-- | Email-verification token rows. +module Shomei.Account.Verification.Domain + ( PersistedVerificationToken (..), + NewVerificationToken (..), + ) +where + +import Shomei.Account.OneTimeToken.Domain (OneTimeTokenHash, OneTimeTokenStatus) +import Shomei.Id (UserId, VerificationTokenId) +import Shomei.Prelude + +data PersistedVerificationToken = PersistedVerificationToken + { verificationTokenId :: !VerificationTokenId, + userId :: !UserId, + tokenHash :: !OneTimeTokenHash, + status :: !OneTimeTokenStatus, + createdAt :: !UTCTime, + expiresAt :: !UTCTime, + consumedAt :: !(Maybe UTCTime), + revokedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data NewVerificationToken = NewVerificationToken + { userId :: !UserId, + tokenHash :: !OneTimeTokenHash, + createdAt :: !UTCTime, + expiresAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/Account/Verification/Store.hs b/src/Shomei/Account/Verification/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Verification/Store.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Store effect for email-verification tokens. +module Shomei.Account.Verification.Store + ( VerificationTokenStore (..), + createVerificationToken, + findVerificationTokenByHash, + markVerificationTokenConsumed, + revokeUserVerificationTokens, + ) +where + +import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Account.OneTimeToken.Domain (OneTimeTokenHash) +import Shomei.Account.Verification.Domain (NewVerificationToken, PersistedVerificationToken) +import Shomei.Id (UserId, VerificationTokenId) +import Shomei.Prelude + +data VerificationTokenStore :: Effect where + CreateVerificationToken :: NewVerificationToken -> VerificationTokenStore m PersistedVerificationToken + FindVerificationTokenByHash :: OneTimeTokenHash -> VerificationTokenStore m (Maybe PersistedVerificationToken) + -- | Transition a token @active → consumed@ as one atomic compare-and-swap. 'True' means + -- this call performed the transition; 'False' means it was already spent or revoked. + MarkVerificationTokenConsumed :: VerificationTokenId -> UTCTime -> VerificationTokenStore m Bool + RevokeUserVerificationTokens :: UserId -> UTCTime -> VerificationTokenStore m () + +type instance DispatchOf VerificationTokenStore = Dynamic + +createVerificationToken :: (VerificationTokenStore :> es) => NewVerificationToken -> Eff es PersistedVerificationToken +createVerificationToken = send . CreateVerificationToken + +findVerificationTokenByHash :: (VerificationTokenStore :> es) => OneTimeTokenHash -> Eff es (Maybe PersistedVerificationToken) +findVerificationTokenByHash = send . FindVerificationTokenByHash + +markVerificationTokenConsumed :: (VerificationTokenStore :> es) => VerificationTokenId -> UTCTime -> Eff es Bool +markVerificationTokenConsumed i t = send (MarkVerificationTokenConsumed i t) + +revokeUserVerificationTokens :: (VerificationTokenStore :> es) => UserId -> UTCTime -> Eff es () +revokeUserVerificationTokens i t = send (RevokeUserVerificationTokens i t) diff --git a/src/Shomei/Audit/Event/Codec.hs b/src/Shomei/Audit/Event/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Audit/Event/Codec.hs @@ -0,0 +1,196 @@ +-- | Reconstruct a typed 'AuthEvent' from the @(event_type, payload)@ columns the write +-- path stores in @shomei_auth_events@. +-- +-- The write interpreter ('Shomei.Audit.Publisher.Postgres.projectAuthEvent') stores only +-- the inner @*Data@ record as the JSONB @payload@ (via @toJSON d@), with the constructor +-- identity captured separately in the @event_type@ text column. A naive +-- @fromJSON payload :: Result AuthEvent@ therefore cannot work — the payload is not the +-- tagged sum. 'reconstructAuthEvent' dispatches on @event_type@ and decodes the payload into +-- the matching @*Data@ record, mirroring the write path's constructor-to-type mapping. It is +-- fully backward compatible with every row already in the table and requires no migration. +-- +-- The @*Data@ records derive @FromJSON@/@ToJSON@ with default options (they do NOT use +-- 'eventAesonOptions'), so the payload is decoded with the plain default instances — exactly +-- what was written. +module Shomei.Audit.Event.Codec + ( reconstructAuthEvent, + projectAuthEvent, + ) +where + +import Data.Aeson (Value) +import Data.Aeson qualified as Aeson +import Data.Text qualified as Text +import Data.UUID (UUID) +import Shomei.Audit.Event.Domain +import Shomei.Id (sessionIdToUUID, userIdToUUID) +import Shomei.Prelude + +-- | Reconstruct a typed event. The @event_type@ strings are the exact ones the writer +-- emits (see 'Shomei.Audit.Publisher.Postgres.projectAuthEvent'); keep the two in lockstep. +-- A 'Left' means either an unknown @event_type@ or a payload that does not decode into the +-- expected @*Data@ record. +reconstructAuthEvent :: Text -> Aeson.Value -> Either String AuthEvent +reconstructAuthEvent etype payload = case etype of + "user_registered" -> UserRegistered <$> parse payload + "login_succeeded" -> LoginSucceeded <$> parse payload + "login_failed" -> LoginFailed <$> parse payload + "session_started" -> SessionStarted <$> parse payload + "session_revoked" -> SessionRevoked <$> parse payload + "refresh_token_rotated" -> RefreshTokenRotated <$> parse payload + "refresh_token_reuse_detected" -> RefreshTokenReuseDetected <$> parse payload + "email_verification_requested" -> EmailVerificationRequested <$> parse payload + "email_verified" -> EmailVerified <$> parse payload + "password_reset_requested" -> PasswordResetRequested <$> parse payload + "password_reset_completed" -> PasswordResetCompleted <$> parse payload + "password_changed" -> PasswordChanged <$> parse payload + "password_change_failed" -> PasswordChangeFailed <$> parse payload + "user_suspended" -> UserSuspended <$> parse payload + "user_deleted" -> UserDeleted <$> parse payload + "user_reinstated" -> UserReinstated <$> parse payload + "account_locked" -> AccountLocked <$> parse payload + "login_throttled" -> LoginThrottled <$> parse payload + "passkey_registered" -> PasskeyRegistered <$> parse payload + "passkey_removed" -> PasskeyRemoved <$> parse payload + "mfa_challenged" -> MfaChallenged <$> parse payload + "mfa_succeeded" -> MfaSucceeded <$> parse payload + "mfa_failed" -> MfaFailed <$> parse payload + "totp_enrolled" -> TotpEnrolled <$> parse payload + "totp_removed" -> TotpRemoved <$> parse payload + "recovery_codes_generated" -> RecoveryCodesGenerated <$> parse payload + "recovery_code_used" -> RecoveryCodeUsed <$> parse payload + "impersonation_started" -> ImpersonationStarted <$> parse payload + "impersonation_stopped" -> ImpersonationStopped <$> parse payload + "impersonation_action_blocked" -> ImpersonationActionBlocked <$> parse payload + "service_on_behalf_issued" -> ServiceOnBehalfIssued <$> parse payload + "service_token_issued" -> ServiceTokenIssued <$> parse payload + "role_granted" -> RoleGranted <$> parse payload + "role_revoked" -> RoleRevoked <$> parse payload + "service_account_created" -> ServiceAccountCreated <$> parse payload + "service_account_secret_rotated" -> ServiceAccountSecretRotated <$> parse payload + "service_account_revoked" -> ServiceAccountRevoked <$> parse payload + "oauth_client_created" -> OAuthClientCreated <$> parse payload + "oauth_client_revoked" -> OAuthClientRevoked <$> parse payload + "oauth_code_issued" -> OAuthCodeIssued <$> parse payload + "oauth_code_replayed" -> OAuthCodeReplayed <$> parse payload + "notification_delivery_failed" -> NotificationDeliveryFailed <$> parse payload + other -> Left ("unknown event_type: " <> Text.unpack other) + where + parse :: (Aeson.FromJSON a) => Aeson.Value -> Either String a + parse v = case Aeson.fromJSON v of + Aeson.Success a -> Right a + Aeson.Error e -> Left e + +-- | Project an 'AuthEvent' to the envelope columns the audit trail stores: +-- @(user_id?, session_id?, event_type, payload, occurredAt)@, where @payload = toJSON@ of the +-- inner @*Data@ record. This is the inverse of 'reconstructAuthEvent' and the single source of +-- truth for the constructor→@event_type@ mapping; the PostgreSQL writer +-- ('Shomei.Audit.Publisher.Postgres') and the in-memory reader both use it, and the +-- round-trip spec pins @project → reconstruct@ for every constructor. (The writer adds a fresh +-- random @event_id@; that is not part of the projection.) +projectAuthEvent :: AuthEvent -> (Maybe UUID, Maybe UUID, Text, Value, UTCTime) +projectAuthEvent = \case + UserRegistered d@(UserRegisteredData uid _ _ occ) -> + (Just (userIdToUUID uid), Nothing, "user_registered", toJSON d, occ) + LoginSucceeded d@(LoginSucceededData uid sid occ) -> + (Just (userIdToUUID uid), Just (sessionIdToUUID sid), "login_succeeded", toJSON d, occ) + LoginFailed d -> + (userIdToUUID <$> d.userId, Nothing, "login_failed", toJSON d, d.occurredAt) + SessionStarted d@(SessionStartedData sid uid occ) -> + (Just (userIdToUUID uid), Just (sessionIdToUUID sid), "session_started", toJSON d, occ) + -- The @user_id@ column is the event's /subject/, not its actor: filtering @?user=@ by an + -- admin must not return the sessions they revoked for other people. 'SessionRevokedData' + -- names no subject (only the session), so the column stays NULL, as it always has; the + -- acting admin rides in the payload's @revokedBy@. + SessionRevoked d -> + (Nothing, Just (sessionIdToUUID d.sessionId), "session_revoked", toJSON d, d.occurredAt) + RefreshTokenRotated d@(RefreshTokenRotatedData sid _ occ) -> + (Nothing, Just (sessionIdToUUID sid), "refresh_token_rotated", toJSON d, occ) + RefreshTokenReuseDetected d@(RefreshTokenReuseDetectedData sid _ occ) -> + (Nothing, Just (sessionIdToUUID sid), "refresh_token_reuse_detected", toJSON d, occ) + EmailVerificationRequested d@(EmailVerificationRequestedData uid _ occ) -> + (Just (userIdToUUID uid), Nothing, "email_verification_requested", toJSON d, occ) + EmailVerified d@(EmailVerifiedData uid _ occ) -> + (Just (userIdToUUID uid), Nothing, "email_verified", toJSON d, occ) + PasswordResetRequested d@(PasswordResetRequestedData uid _ occ) -> + (Just (userIdToUUID uid), Nothing, "password_reset_requested", toJSON d, occ) + PasswordResetCompleted d@(PasswordResetCompletedData uid occ) -> + (Just (userIdToUUID uid), Nothing, "password_reset_completed", toJSON d, occ) + PasswordChanged d@(PasswordChangedData uid occ) -> + (Just (userIdToUUID uid), Nothing, "password_changed", toJSON d, occ) + PasswordChangeFailed d@(PasswordChangeFailedData uid occ) -> + (Just (userIdToUUID uid), Nothing, "password_change_failed", toJSON d, occ) + UserSuspended d -> + (Just (userIdToUUID d.userId), Nothing, "user_suspended", toJSON d, d.occurredAt) + UserDeleted d -> + (Just (userIdToUUID d.userId), Nothing, "user_deleted", toJSON d, d.occurredAt) + UserReinstated d -> + (Just (userIdToUUID d.userId), Nothing, "user_reinstated", toJSON d, d.occurredAt) + AccountLocked d@(AccountLockedData _ _ _ _ occ) -> + (Nothing, Nothing, "account_locked", toJSON d, occ) + LoginThrottled d@(LoginThrottledData _ _ occ) -> + (Nothing, Nothing, "login_throttled", toJSON d, occ) + PasskeyRegistered d@(PasskeyRegisteredData uid _ occ) -> + (Just (userIdToUUID uid), Nothing, "passkey_registered", toJSON d, occ) + PasskeyRemoved d@(PasskeyRemovedData uid _ occ) -> + (Just (userIdToUUID uid), Nothing, "passkey_removed", toJSON d, occ) + MfaChallenged d@(MfaChallengedData uid _ occ) -> + (Just (userIdToUUID uid), Nothing, "mfa_challenged", toJSON d, occ) + MfaSucceeded d@(MfaSucceededData uid sid occ) -> + (Just (userIdToUUID uid), Just (sessionIdToUUID sid), "mfa_succeeded", toJSON d, occ) + MfaFailed d@(MfaFailedData mUid _ occ) -> + (fmap userIdToUUID mUid, Nothing, "mfa_failed", toJSON d, occ) + -- The row's user_id is the affected user; these are all self-service factor-management events. + TotpEnrolled d@(TotpEnrolledData uid occ) -> + (Just (userIdToUUID uid), Nothing, "totp_enrolled", toJSON d, occ) + TotpRemoved d@(TotpRemovedData uid occ) -> + (Just (userIdToUUID uid), Nothing, "totp_removed", toJSON d, occ) + RecoveryCodesGenerated d@(RecoveryCodesGeneratedData uid _ occ) -> + (Just (userIdToUUID uid), Nothing, "recovery_codes_generated", toJSON d, occ) + RecoveryCodeUsed d@(RecoveryCodeUsedData uid occ) -> + (Just (userIdToUUID uid), Nothing, "recovery_code_used", toJSON d, occ) + -- For impersonation events the subject (customer) is the row's user_id; the actor + -- (operator) and reason/ticket live inside the JSONB payload. + ImpersonationStarted d -> + (Just (userIdToUUID d.subjectUserId), Just (sessionIdToUUID d.sessionId), "impersonation_started", toJSON d, d.occurredAt) + ImpersonationStopped d -> + (Just (userIdToUUID d.subjectUserId), Just (sessionIdToUUID d.sessionId), "impersonation_stopped", toJSON d, d.occurredAt) + ImpersonationActionBlocked d -> + (Just (userIdToUUID d.subjectUserId), Just (sessionIdToUUID d.sessionId), "impersonation_action_blocked", toJSON d, d.occurredAt) + -- Like the impersonation events, the row's user_id is the SUBJECT (the user acted for); the + -- acting service and its backing user live in the JSONB payload. So `?user=` returns the + -- on-behalf-of grants made against that user alongside their own sessions. + ServiceOnBehalfIssued d -> + (Just (userIdToUUID d.subjectUserId), Just (sessionIdToUUID d.sessionId), "service_on_behalf_issued", toJSON d, d.occurredAt) + ServiceTokenIssued d -> + (Just (userIdToUUID d.userId), Just (sessionIdToUUID d.sessionId), "service_token_issued", toJSON d, d.occurredAt) + -- The row's user_id is the grant's SUBJECT; the granting admin (when there is one) lives in + -- the JSONB payload, mirroring how the impersonation events name the subject. + RoleGranted d -> + (Just (userIdToUUID d.userId), Nothing, "role_granted", toJSON d, d.occurredAt) + RoleRevoked d -> + (Just (userIdToUUID d.userId), Nothing, "role_revoked", toJSON d, d.occurredAt) + -- The row's user_id is the account's BACKING user, so `?user=` returns the + -- account's lifecycle and the tokens it minted together. There is no session. + ServiceAccountCreated d -> + (Just (userIdToUUID d.userId), Nothing, "service_account_created", toJSON d, d.occurredAt) + ServiceAccountSecretRotated d -> + (Just (userIdToUUID d.userId), Nothing, "service_account_secret_rotated", toJSON d, d.occurredAt) + ServiceAccountRevoked d -> + (Just (userIdToUUID d.userId), Nothing, "service_account_revoked", toJSON d, d.occurredAt) + -- An OAuth client has no backing user row and is never a token subject, so both id columns + -- stay NULL. The client is identified inside the payload. + OAuthClientCreated d -> + (Nothing, Nothing, "oauth_client_created", toJSON d, d.occurredAt) + OAuthClientRevoked d -> + (Nothing, Nothing, "oauth_client_revoked", toJSON d, d.occurredAt) + -- The subject is the user who authorized; the client rides in the payload. There is no session + -- yet -- the exchange creates it. + OAuthCodeIssued d -> + (Just (userIdToUUID d.userId), Nothing, "oauth_code_issued", toJSON d, d.occurredAt) + OAuthCodeReplayed d -> + (Just (userIdToUUID d.userId), Just (sessionIdToUUID d.sessionId), "oauth_code_replayed", toJSON d, d.occurredAt) + -- A delivery failure names no principal (the recipient is an email address, not a user id) and + -- no session, so both id columns stay NULL; channel/type/recipient/error ride in the payload. + NotificationDeliveryFailed d -> + (Nothing, Nothing, "notification_delivery_failed", toJSON d, d.occurredAt) diff --git a/src/Shomei/Audit/Event/Domain.hs b/src/Shomei/Audit/Event/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Audit/Event/Domain.hs @@ -0,0 +1,552 @@ +-- | The audit / security event vocabulary. +-- +-- 'AuthEvent' is the sum of everything worth recording for audit and intrusion +-- detection. Each arm carries a @*Data@ record with the relevant identifiers and the +-- @occurredAt@ timestamp. The 'Shomei.Audit.Publisher.Store' port publishes them; in +-- the bootstrap EP-3 persists them to the @shomei_auth_events@ table. +-- +-- Note: several constructor names (e.g. 'SessionRevoked', 'RefreshTokenReuseDetected') +-- intentionally mirror 'Shomei.Error.AuthError' constructors and domain status +-- constructors. Consumers import this module qualified to disambiguate. +module Shomei.Audit.Event.Domain + ( AuthEvent (..), + UserRegisteredData (..), + LoginSucceededData (..), + LoginFailedData (..), + SessionStartedData (..), + SessionRevokedData (..), + RefreshTokenRotatedData (..), + RefreshTokenReuseDetectedData (..), + EmailVerificationRequestedData (..), + EmailVerifiedData (..), + PasswordResetRequestedData (..), + PasswordResetCompletedData (..), + PasswordChangedData (..), + PasswordChangeFailedData (..), + UserSuspendedData (..), + UserDeletedData (..), + UserReinstatedData (..), + AccountLockedData (..), + LoginThrottledData (..), + PasskeyRegisteredData (..), + PasskeyRemovedData (..), + MfaChallengedData (..), + MfaSucceededData (..), + MfaFailedData (..), + TotpEnrolledData (..), + TotpRemovedData (..), + RecoveryCodesGeneratedData (..), + RecoveryCodeUsedData (..), + ImpersonationStartedData (..), + ImpersonationStoppedData (..), + ImpersonationActionBlockedData (..), + ServiceOnBehalfIssuedData (..), + ServiceTokenIssuedData (..), + RoleGrantedData (..), + RoleRevokedData (..), + ServiceAccountCreatedData (..), + ServiceAccountSecretRotatedData (..), + ServiceAccountRevokedData (..), + OAuthClientCreatedData (..), + OAuthClientRevokedData (..), + OAuthCodeIssuedData (..), + OAuthCodeReplayedData (..), + NotificationDeliveryFailedData (..), + ) +where + +import Data.Set (Set) +import Shomei.Account.Email.Domain (Email) +import Shomei.Account.LoginId.Domain (LoginId) +import Shomei.Authorization.Claims.Domain (Role, Scope) +import Shomei.Config (ServiceAccountId) +import Shomei.Id (CeremonyId, PasskeyId, RefreshTokenId, SessionId, UserId) +import Shomei.Prelude +import Shomei.Session.LoginAttempt.Domain (AccountKey, ClientIp) + +data UserRegisteredData = UserRegisteredData + { userId :: !UserId, + loginId :: !LoginId, + email :: !(Maybe Email), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data LoginSucceededData = LoginSucceededData + { userId :: !UserId, + sessionId :: !SessionId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data LoginFailedData = LoginFailedData + { accountKey :: !(Maybe AccountKey), + userId :: !(Maybe UserId), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data SessionStartedData = SessionStartedData + { sessionId :: !SessionId, + userId :: !UserId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | @revokedBy@ names the admin who revoked the session through the EP-2 admin API; it is +-- 'Nothing' for the self-service revocations (logout, refresh-token reuse detection, stopping an +-- impersonation). A missing key in a historical row decodes as 'Nothing', which is what those +-- rows mean. +data SessionRevokedData = SessionRevokedData + { sessionId :: !SessionId, + revokedBy :: !(Maybe UserId), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data RefreshTokenRotatedData = RefreshTokenRotatedData + { sessionId :: !SessionId, + oldTokenId :: !RefreshTokenId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data RefreshTokenReuseDetectedData = RefreshTokenReuseDetectedData + { sessionId :: !SessionId, + refreshTokenId :: !RefreshTokenId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data EmailVerificationRequestedData = EmailVerificationRequestedData + { userId :: !UserId, + email :: !Email, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data EmailVerifiedData = EmailVerifiedData + { userId :: !UserId, + email :: !Email, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data PasswordResetRequestedData = PasswordResetRequestedData + { userId :: !UserId, + email :: !Email, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data PasswordResetCompletedData = PasswordResetCompletedData + { userId :: !UserId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data PasswordChangedData = PasswordChangedData + { userId :: !UserId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data PasswordChangeFailedData = PasswordChangeFailedData + { userId :: !UserId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | @actor@ is the administrator who performed the lifecycle change. It is a 'Maybe' because a +-- future non-HTTP caller (a CLI, a migration) may have no acting principal — not because the +-- admin API ever omits it. +data UserSuspendedData = UserSuspendedData + { userId :: !UserId, + actor :: !(Maybe UserId), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data UserDeletedData = UserDeletedData + { userId :: !UserId, + actor :: !(Maybe UserId), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A suspended user was returned to service. +data UserReinstatedData = UserReinstatedData + { userId :: !UserId, + actor :: !(Maybe UserId), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data AccountLockedData = AccountLockedData + { accountKey :: !AccountKey, + clientIp :: !ClientIp, + failedCount :: !Int, + lockedUntil :: !UTCTime, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data LoginThrottledData = LoginThrottledData + { clientIp :: !ClientIp, + failedCount :: !Int, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data PasskeyRegisteredData = PasskeyRegisteredData + { userId :: !UserId, + passkeyId :: !PasskeyId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data PasskeyRemovedData = PasskeyRemovedData + { userId :: !UserId, + passkeyId :: !PasskeyId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A password login succeeded for an account with a passkey, so a WebAuthn +-- second factor is now demanded (no session issued yet). 'ceremonyId' is the +-- consume-once pending-MFA handle the client completes at @\/v1\/auth\/mfa\/complete@. +data MfaChallengedData = MfaChallengedData + { userId :: !UserId, + ceremonyId :: !CeremonyId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | The WebAuthn second factor (or a passwordless passkey login) verified and a +-- session was issued. +data MfaSucceededData = MfaSucceededData + { userId :: !UserId, + sessionId :: !SessionId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A WebAuthn assertion failed verification at login/step-up. 'userId' is +-- 'Nothing' when the user could not be resolved (e.g. a passwordless assertion +-- naming an unknown credential). +data MfaFailedData = MfaFailedData + { userId :: !(Maybe UserId), + reason :: !Text, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A user activated a TOTP second factor (EP-7): a confirmed credential now exists. +data TotpEnrolledData = TotpEnrolledData + { userId :: !UserId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A user removed their TOTP second factor (EP-7). Removal proves possession of the factor +-- (a current code) or its fallback (a recovery code), and is blocked under a delegated token. +data TotpRemovedData = TotpRemovedData + { userId :: !UserId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A fresh set of recovery codes was generated (EP-7), invalidating any previous set. 'count' +-- is how many were issued; the codes themselves are never in the payload (only their hashes are +-- ever persisted, and not here). +data RecoveryCodesGeneratedData = RecoveryCodesGeneratedData + { userId :: !UserId, + count :: !Int, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A recovery code was spent to complete an MFA challenge (EP-7). Single-use: the code cannot +-- complete a second challenge. +data RecoveryCodeUsedData = RecoveryCodeUsedData + { userId :: !UserId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | An operator started impersonating a subject: a delegated session was minted. +-- Carries both identities, the required reason, the optional support ticket id, and +-- the client IP for the audit trail. +data ImpersonationStartedData = ImpersonationStartedData + { actorUserId :: !UserId, + subjectUserId :: !UserId, + sessionId :: !SessionId, + reason :: !Text, + ticketId :: !(Maybe Text), + clientIp :: !(Maybe Text), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | An operator stopped impersonating: the delegated session was revoked. +data ImpersonationStoppedData = ImpersonationStoppedData + { actorUserId :: !UserId, + subjectUserId :: !UserId, + sessionId :: !SessionId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A credential-changing action was refused because it arrived on a delegated token. +data ImpersonationActionBlockedData = ImpersonationActionBlockedData + { actorUserId :: !UserId, + subjectUserId :: !UserId, + sessionId :: !SessionId, + -- | e.g. @"password_change"@, @"passkey_register"@, @"passkey_remove"@ + action :: !Text, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | EP-6: a service account exchanged a user's access token for a narrowed, short-lived token that +-- acts on the user's behalf (RFC 8693 on-behalf-of). Carries the subject (the user, whose id is the +-- audit row's @user_id@ column), the actor (the service account's backing user, in @act@), the +-- delegated session, and the scopes actually granted after narrowing. The @token-exchange:subject@ +-- gate scope is never among them. +data ServiceOnBehalfIssuedData = ServiceOnBehalfIssuedData + { -- | the service account's TypeID text (@client_id@) that requested the exchange + serviceAccountId :: !Text, + -- | the service account's backing user, recorded in the issued token's @act@ + actorUserId :: !UserId, + -- | the user the token now represents (@sub@) + subjectUserId :: !UserId, + sessionId :: !SessionId, + scopes :: !(Set Scope), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data ServiceTokenIssuedData = ServiceTokenIssuedData + { userId :: !UserId, + sessionId :: !SessionId, + accountId :: !ServiceAccountId, + scopes :: !(Set Scope), + actorId :: !(Maybe UserId), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A role was granted to a user. 'grantedBy' is the acting admin, or 'Nothing' for a CLI +-- bootstrap grant and for a default role applied at signup (the "system" actor). 'expiresAt' +-- (EP-9) is the grant's expiry, 'Nothing' for a grant that does not expire; expiry is passive +-- (no @role_grant_expired@ event fires), so this payload is the audit trail's whole record of +-- the window. A historical row without the key decodes as 'Nothing' (a forever grant). +-- +-- Role /definitions/ and permission wiring are not audit events: they are rare, low-sensitivity +-- catalog metadata. Grants and revocations — the security-relevant facts — are. +data RoleGrantedData = RoleGrantedData + { userId :: !UserId, + role :: !Role, + grantedBy :: !(Maybe UserId), + expiresAt :: !(Maybe UTCTime), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A role grant was removed. 'revokedBy' is 'Nothing' for a CLI revocation. +data RoleRevokedData = RoleRevokedData + { userId :: !UserId, + role :: !Role, + revokedBy :: !(Maybe UserId), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A database-backed service account was created (EP-4). 'serviceAccountId' is the TypeID text, +-- equal to 'clientId'; both are recorded so a reader need not know they coincide. The secret is +-- never in the payload — only its SHA-256 digest is ever persisted, and not here. +-- +-- 'userId' is the account's backing @shomei_users@ row, and becomes the audit row's @user_id@ +-- column, so @?user=@ filtering finds an account's whole lifecycle alongside the tokens it minted. +data ServiceAccountCreatedData = ServiceAccountCreatedData + { serviceAccountId :: !Text, + clientId :: !Text, + userId :: !UserId, + displayName :: !Text, + allowedScopes :: !(Set Scope), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A service account's secret was replaced. The previous secret stops working immediately: +-- the model is single-secret, so an operator needing overlap creates a second account. +data ServiceAccountSecretRotatedData = ServiceAccountSecretRotatedData + { serviceAccountId :: !Text, + clientId :: !Text, + userId :: !UserId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A service account was revoked. Its row survives; every subsequent @client_credentials@ +-- request answers @invalid_client@, indistinguishable from a wrong secret. +data ServiceAccountRevokedData = ServiceAccountRevokedData + { serviceAccountId :: !Text, + clientId :: !Text, + userId :: !UserId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | An OAuth2 \/ OIDC client was registered (EP-5). The secret is never in the payload — only +-- its SHA-256 digest is ever persisted, and not here. A public client has no secret at all. +-- +-- Unlike a service account, an OAuth client has no backing user row, so these events carry no +-- @user_id@ and the audit row's @user_id@ column stays NULL: the client is not a principal, it +-- is a registered relying party. +data OAuthClientCreatedData = OAuthClientCreatedData + { oauthClientId :: !Text, + clientId :: !Text, + clientType :: !Text, + displayName :: !Text, + redirectUris :: ![Text], + allowedScopes :: !(Set Scope), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | An OAuth client was revoked. Its row survives; every subsequent authorize request answers +-- @400 invalid_request@ without redirecting, and every token exchange answers @invalid_client@. +data OAuthClientRevokedData = OAuthClientRevokedData + { oauthClientId :: !Text, + clientId :: !Text, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | An authorization code was issued to a client for a user (EP-5). The code itself is never in +-- the payload — not even its hash: a code lives 60 seconds and naming it here would put a +-- short-lived credential's identifier in a long-lived table. +-- +-- The row's @user_id@ is the subject the code was issued for, so @?user=@ finds the whole +-- authorization: the code, the session the exchange started, and the tokens it minted. +data OAuthCodeIssuedData = OAuthCodeIssuedData + { clientId :: !Text, + userId :: !UserId, + scopes :: !(Set Scope), + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A consumed authorization code was presented again while the row still named the session +-- minted by its first exchange. The raw code and its digest never enter the audit trail. +data OAuthCodeReplayedData = OAuthCodeReplayedData + { clientId :: !Text, + presentedBy :: !Text, + userId :: !UserId, + sessionId :: !SessionId, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A notifier interpreter (EP-8) failed to deliver a notification after exhausting its +-- attempts. The triggering HTTP request still succeeds (fire-and-forget); this event is the +-- operator's observability signal. It deliberately carries no session or user id — the row's +-- id columns stay NULL — and __never__ the one-time token: only the channel +-- (@"smtp"@/@"webhook"@), the notification type, the recipient address, and a truncated error. +data NotificationDeliveryFailedData = NotificationDeliveryFailedData + { channel :: !Text, + notificationType :: !Text, + recipient :: !Text, + errorText :: !Text, + occurredAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data AuthEvent + = UserRegistered UserRegisteredData + | LoginSucceeded LoginSucceededData + | LoginFailed LoginFailedData + | SessionStarted SessionStartedData + | SessionRevoked SessionRevokedData + | RefreshTokenRotated RefreshTokenRotatedData + | RefreshTokenReuseDetected RefreshTokenReuseDetectedData + | EmailVerificationRequested EmailVerificationRequestedData + | EmailVerified EmailVerifiedData + | PasswordResetRequested PasswordResetRequestedData + | PasswordResetCompleted PasswordResetCompletedData + | PasswordChanged PasswordChangedData + | PasswordChangeFailed PasswordChangeFailedData + | UserSuspended UserSuspendedData + | UserDeleted UserDeletedData + | UserReinstated UserReinstatedData + | AccountLocked AccountLockedData + | LoginThrottled LoginThrottledData + | PasskeyRegistered PasskeyRegisteredData + | PasskeyRemoved PasskeyRemovedData + | MfaChallenged MfaChallengedData + | MfaSucceeded MfaSucceededData + | MfaFailed MfaFailedData + | TotpEnrolled TotpEnrolledData + | TotpRemoved TotpRemovedData + | RecoveryCodesGenerated RecoveryCodesGeneratedData + | RecoveryCodeUsed RecoveryCodeUsedData + | ImpersonationStarted ImpersonationStartedData + | ImpersonationStopped ImpersonationStoppedData + | ImpersonationActionBlocked ImpersonationActionBlockedData + | ServiceOnBehalfIssued ServiceOnBehalfIssuedData + | ServiceTokenIssued ServiceTokenIssuedData + | RoleGranted RoleGrantedData + | RoleRevoked RoleRevokedData + | ServiceAccountCreated ServiceAccountCreatedData + | ServiceAccountSecretRotated ServiceAccountSecretRotatedData + | ServiceAccountRevoked ServiceAccountRevokedData + | OAuthClientCreated OAuthClientCreatedData + | OAuthClientRevoked OAuthClientRevokedData + | OAuthCodeIssued OAuthCodeIssuedData + | OAuthCodeReplayed OAuthCodeReplayedData + | NotificationDeliveryFailed NotificationDeliveryFailedData + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/Audit/Publisher/Store.hs b/src/Shomei/Audit/Publisher/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Audit/Publisher/Store.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The audit/security event-publisher port. EP-3 persists events to +-- @shomei_auth_events@. +module Shomei.Audit.Publisher.Store + ( AuthEventPublisher (..), + publishAuthEvent, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Audit.Event.Domain (AuthEvent) + +data AuthEventPublisher :: Effect where + PublishAuthEvent :: AuthEvent -> AuthEventPublisher m () + +type instance DispatchOf AuthEventPublisher = Dynamic + +publishAuthEvent :: (AuthEventPublisher :> es) => AuthEvent -> Eff es () +publishAuthEvent = send . PublishAuthEvent diff --git a/src/Shomei/Audit/Reader/Store.hs b/src/Shomei/Audit/Reader/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Audit/Reader/Store.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The audit-event *reader* port: the read counterpart to +-- 'Shomei.Audit.Publisher.Store'. It exposes filtered, keyset-paginated reads over the +-- append-only @shomei_auth_events@ table. The PostgreSQL interpreter lives in +-- @Shomei.Audit.Reader.Postgres@. +-- +-- A 'StoredAuthEvent' carries the raw @storedPayload :: Value@ rather than a reconstructed +-- 'Shomei.Audit.Event.Domain.AuthEvent'; reconstruction is the caller's choice via +-- 'Shomei.Audit.Event.Codec.reconstructAuthEvent'. This keeps the storage read decoupled from +-- the JSON shape: an unrecognized future @event_type@ still lists (with its raw payload) +-- instead of breaking the whole query. +module Shomei.Audit.Reader.Store + ( AuthEventReader (..), + AuditEventQuery (..), + AuditCursor (..), + StoredAuthEvent (..), + emptyAuditQuery, + maxAuditLimit, + clampLimit, + queryAuthEvents, + countAuthEvents, + ) +where + +import Data.Aeson (Value) +import Data.UUID (UUID) +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Prelude + +-- | A keyset-pagination cursor: the @(created_at, event_id)@ of the last row seen. +data AuditCursor = AuditCursor + { cursorCreatedAt :: !UTCTime, + cursorEventId :: !UUID + } + deriving stock (Eq, Show) + +-- | Filters for an audit-event query. An empty 'queryEventTypes' means "all types". +data AuditEventQuery = AuditEventQuery + { queryUserId :: !(Maybe UUID), + querySessionId :: !(Maybe UUID), + queryEventTypes :: ![Text], + -- | inclusive lower bound on created_at + querySince :: !(Maybe UTCTime), + -- | exclusive upper bound on created_at + queryUntil :: !(Maybe UTCTime), + -- | clamp with 'clampLimit' before use + queryLimit :: !Int, + queryBefore :: !(Maybe AuditCursor) + } + deriving stock (Eq, Show) + +-- | One row of the audit trail: the envelope columns plus the raw event payload. +data StoredAuthEvent = StoredAuthEvent + { storedEventId :: !UUID, + storedEventType :: !Text, + storedUserId :: !(Maybe UUID), + storedSessionId :: !(Maybe UUID), + storedCreatedAt :: !UTCTime, + storedPayload :: !Value + } + deriving stock (Eq, Show) + +emptyAuditQuery :: AuditEventQuery +emptyAuditQuery = AuditEventQuery Nothing Nothing [] Nothing Nothing 50 Nothing + +maxAuditLimit :: Int +maxAuditLimit = 1000 + +-- | Clamp a requested limit into @[1, maxAuditLimit]@. Both surfaces share this clamp. +clampLimit :: Int -> Int +clampLimit n = max 1 (min maxAuditLimit n) + +data AuthEventReader :: Effect where + QueryAuthEvents :: AuditEventQuery -> AuthEventReader m [StoredAuthEvent] + CountAuthEvents :: AuditEventQuery -> AuthEventReader m Int + +type instance DispatchOf AuthEventReader = Dynamic + +queryAuthEvents :: (AuthEventReader :> es) => AuditEventQuery -> Eff es [StoredAuthEvent] +queryAuthEvents = send . QueryAuthEvents + +countAuthEvents :: (AuthEventReader :> es) => AuditEventQuery -> Eff es Int +countAuthEvents = send . CountAuthEvents diff --git a/src/Shomei/Authorization/Claims/Domain.hs b/src/Shomei/Authorization/Claims/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Authorization/Claims/Domain.hs @@ -0,0 +1,91 @@ +-- | The claims embedded in an access token, plus the small newtypes that make the claim +-- fields type-safe. +module Shomei.Authorization.Claims.Domain + ( Issuer (..), + Audience (..), + Scope (..), + Role (..), + Permission (..), + AuthClaims (..), + reservedClaimKeys, + mkExtraClaims, + noExtraClaims, + ) +where + +import Data.Aeson (Object) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Set (Set) +import Shomei.Id (SessionId, UserId) +import Shomei.Prelude + +newtype Issuer = Issuer Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +newtype Audience = Audience Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +newtype Scope = Scope Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +newtype Role = Role Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +-- | A capability string carried in the @permissions@ claim, resolved at mint time from the +-- subject's roles (the @shomei_role_permissions@ table). Convention: @resource:verb@, e.g. +-- @projects:write@ — a documented convention, not enforced grammar. +newtype Permission = Permission Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +data AuthClaims = AuthClaims + { subject :: !UserId, + sessionId :: !SessionId, + issuer :: !Issuer, + audience :: !Audience, + issuedAt :: !UTCTime, + expiresAt :: !UTCTime, + -- | when the last credential was proven. Unlike 'issuedAt', this is preserved across token + -- refresh and is the clock for reauthentication gates. + authTime :: !UTCTime, + scopes :: !(Set Scope), + roles :: !(Set Role), + -- | the capabilities the subject's roles imply (EP-9), resolved at mint time from the + -- @shomei_role_permissions@ catalog and carried in the @permissions@ claim. Empty for + -- tokens minted before EP-9 (and for OAuth machine/delegation flows, which do + -- not go through role enrichment); a token with no @permissions@ claim verifies to the + -- empty set, exactly as @roles@ does. + permissions :: !(Set Permission), + -- | when this token is a delegated (impersonation) token, the real operator + -- acting on behalf of 'subject'; serialised as the @act@ JWT claim. 'Nothing' + -- for every ordinary login token. + actor :: !(Maybe UserId), + -- | additional top-level JWT claims a consuming service attaches (e.g. TAN's + -- @userId@, @userInfo@, @impersonated@, @clientAccountId@, or a service token's + -- @type@/@serviceInfo@). Empty ('noExtraClaims') for ordinary tokens, which then + -- serialise byte-identically to before this field existed. Keys that collide with + -- a standard claim are overridden by the standard claim at sign time. + extraClaims :: !Object + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | The registered and private claim keys Shōmei owns. The signer writes every +-- managed value after the extension bag, the verifier removes every managed value +-- from the recovered extension bag, and 'mkExtraClaims' drops every managed value +-- at construction. Adding a managed claim therefore starts by adding its name here. +reservedClaimKeys :: [Text] +reservedClaimKeys = ["iss", "sub", "aud", "iat", "exp", "nbf", "jti", "sid", "scopes", "roles", "permissions", "act", "auth_time"] + +-- | Build an extra-claims object, dropping any reserved key (see 'reservedClaimKeys'). +mkExtraClaims :: Object -> Object +mkExtraClaims = KeyMap.filterWithKey (\k _ -> Key.toText k `notElem` reservedClaimKeys) + +-- | The empty extra-claims object — the default for ordinary tokens. +noExtraClaims :: Object +noExtraClaims = KeyMap.empty diff --git a/src/Shomei/Authorization/Claims/Store.hs b/src/Shomei/Authorization/Claims/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Authorization/Claims/Store.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The host claims-enrichment hook: called at every user-session token mint with the subject +-- and the roles read from the 'Shomei.Authorization.Role.Store.RoleStore', returning a 'ClaimsDelta' +-- the core merges into the standard claims. +-- +-- This is the same shape as the 'Shomei.Account.Notification.Store' port: Shōmei decides /when/, the +-- embedding host decides /what/. A host supplies its own interpreter where it assembles +-- @Shomei.Servant.Seam.Env.runPorts@; the standalone server uses 'runClaimsEnricherNull'. +-- +-- The delta's extra-claims object is filtered through 'Shomei.Authorization.Claims.Domain.mkExtraClaims' +-- before it reaches the token, so a host — or a compromised host code path — can never +-- override a reserved claim (@iss@, @sub@, @aud@, @iat@, @exp@, @sid@, @scopes@, @roles@, +-- @permissions@, @act@ — the full list is 'Shomei.Authorization.Claims.Domain.reservedClaimKeys'). Returning a +-- /delta/ rather than letting the hook rewrite the whole 'Shomei.Authorization.Claims.Domain.AuthClaims' keeps +-- the standard claims tamper-proof by construction. +-- +-- __Do not mirror live authorization decisions into JWT claims through this hook.__ Claims are +-- minted once and are then static for the token's lifetime; a decision copied from a live +-- authorization system (e.g. a check against the en ReBAC engine — see +-- @docs\/plans\/47-en-integration-examples-and-guidance-for-the-recommended-authorization-layer.md@) +-- is stale the moment the underlying relationship changes, silently granting revoked access +-- until the token expires. This hook is for coarse, slow-moving hints — tenant ids, plan tiers, +-- extra scopes — not for per-resource permissions. Check fine-grained permissions live, in the +-- handler, against the authorization system. +module Shomei.Authorization.Claims.Store + ( ClaimsEnricher (..), + ClaimsDelta (..), + emptyClaimsDelta, + enrichClaims, + runClaimsEnricherNull, + runClaimsEnricherPure, + ) +where + +import Data.Aeson (Object) +import Data.Set (Set) +import Data.Set qualified as Set +import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (interpret_, send) +import Shomei.Authorization.Claims.Domain (Role, Scope, noExtraClaims) +import Shomei.Id (UserId) +import Shomei.Prelude + +-- | What a host adds to a freshly minted token's claims. The roles here are merged with (not +-- substituted for) the roles the 'Shomei.Authorization.Role.Store.RoleStore' reports. +data ClaimsDelta = ClaimsDelta + { extraRoles :: !(Set Role), + extraScopes :: !(Set Scope), + -- | reserved keys are dropped when this is merged; see 'Shomei.Authorization.Claims.Domain.mkExtraClaims' + extraClaims :: !Object + } + deriving stock (Generic, Eq, Show) + +emptyClaimsDelta :: ClaimsDelta +emptyClaimsDelta = + ClaimsDelta + { extraRoles = Set.empty, + extraScopes = Set.empty, + extraClaims = noExtraClaims + } + +data ClaimsEnricher :: Effect where + -- | @EnrichClaims subject rolesFromStore@ + EnrichClaims :: UserId -> Set Role -> ClaimsEnricher m ClaimsDelta + +type instance DispatchOf ClaimsEnricher = Dynamic + +enrichClaims :: (ClaimsEnricher :> es) => UserId -> Set Role -> Eff es ClaimsDelta +enrichClaims uid roles = send (EnrichClaims uid roles) + +-- | The default: no enrichment. The standalone server uses this. +runClaimsEnricherNull :: Eff (ClaimsEnricher : es) a -> Eff es a +runClaimsEnricherNull = runClaimsEnricherPure \_ _ -> emptyClaimsDelta + +-- | A pure hook for embedding hosts and tests: supply a function of the subject and its stored +-- roles. A host needing effects of its own writes its own @interpret_@ instead. +runClaimsEnricherPure :: + (UserId -> Set Role -> ClaimsDelta) -> + Eff (ClaimsEnricher : es) a -> + Eff es a +runClaimsEnricherPure f = interpret_ \case + EnrichClaims uid roles -> pure (f uid roles) diff --git a/src/Shomei/Authorization/Role/Store.hs b/src/Shomei/Authorization/Role/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Authorization/Role/Store.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The role port: the declared role catalog (the "registry", @shomei_roles@), the durable +-- "user has role" facts (@shomei_role_grants@), and the role→permission definitions +-- (@shomei_role_permissions@). +-- +-- Roles are flat: a grant is a @(user, role)@ pair with no project, organization, or resource +-- scope. A role implies a set of flat verb-noun /permissions/ (EP-9), resolved to the union +-- across a subject's roles at token mint. This is Shōmei's tier-1 authorization story — +-- self-contained, requiring no second system, and sufficient to gate Shōmei's own @\/admin@ +-- surface. Fine-grained, relationship-derived authorization ("editor of /this/ project", live +-- revocation, caveats) is deliberately out of scope; see @docs\/user\/security.md@ for the +-- two-tier boundary. +module Shomei.Authorization.Role.Store + ( RoleStore (..), + RoleDefinition (..), + defineRole, + listDefinedRoles, + grantRole, + revokeRole, + listRolesForUser, + allowPermission, + disallowPermission, + listPermissionsForRole, + permissionsForRoles, + ) +where + +import Data.Set (Set) +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Authorization.Claims.Domain (Permission, Role) +import Shomei.Id (UserId) +import Shomei.Prelude + +-- | One row of the role registry (the @shomei_roles@ table): a role an operator has declared +-- grantable, with an optional human description. +data RoleDefinition = RoleDefinition + { role :: !Role, + description :: !(Maybe Text), + createdAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + +data RoleStore :: Effect where + -- | Declare a role in the registry. Returns 'True' if newly defined, 'False' if it already + -- existed (idempotent; the description of an existing role is NOT updated). + DefineRole :: Role -> Maybe Text -> UTCTime -> RoleStore m Bool + -- | The full registry, sorted by role name. Deployments have few roles; no paging. + ListDefinedRoles :: RoleStore m [RoleDefinition] + -- | Record a grant, with an optional expiry ('Nothing' = does not expire). Returns 'True' when + -- state changed: a new grant, or an existing grant whose expiry differs (re-granting updates + -- the expiry — upsert). Callers publish the audit event only on 'True'. + GrantRole :: UserId -> Role -> Maybe UserId -> Maybe UTCTime -> UTCTime -> RoleStore m Bool + -- | Remove a grant. Returns 'True' if a grant was removed. + RevokeRole :: UserId -> Role -> RoleStore m Bool + -- | The subject's roles as of the given instant: grants whose @expires_at@ is at or before it + -- are excluded. Callers pass the mint timestamp. + ListRolesForUser :: UserId -> UTCTime -> RoleStore m (Set Role) + -- | Attach a permission to a role. 'True' = newly attached, 'False' = already present. + AllowPermission :: Role -> Permission -> UTCTime -> RoleStore m Bool + -- | Detach a permission from a role. 'True' = something was detached. + DisallowPermission :: Role -> Permission -> RoleStore m Bool + -- | The permissions attached to a single role, sorted. + ListPermissionsForRole :: Role -> RoleStore m (Set Permission) + -- | The union of permissions across a role set — one query, used by the mint path. + PermissionsForRoles :: Set Role -> RoleStore m (Set Permission) + +type instance DispatchOf RoleStore = Dynamic + +defineRole :: (RoleStore :> es) => Role -> Maybe Text -> UTCTime -> Eff es Bool +defineRole r desc ts = send (DefineRole r desc ts) + +listDefinedRoles :: (RoleStore :> es) => Eff es [RoleDefinition] +listDefinedRoles = send ListDefinedRoles + +grantRole :: (RoleStore :> es) => UserId -> Role -> Maybe UserId -> Maybe UTCTime -> UTCTime -> Eff es Bool +grantRole uid r by expiry ts = send (GrantRole uid r by expiry ts) + +revokeRole :: (RoleStore :> es) => UserId -> Role -> Eff es Bool +revokeRole uid r = send (RevokeRole uid r) + +listRolesForUser :: (RoleStore :> es) => UserId -> UTCTime -> Eff es (Set Role) +listRolesForUser uid asOf = send (ListRolesForUser uid asOf) + +allowPermission :: (RoleStore :> es) => Role -> Permission -> UTCTime -> Eff es Bool +allowPermission r p ts = send (AllowPermission r p ts) + +disallowPermission :: (RoleStore :> es) => Role -> Permission -> Eff es Bool +disallowPermission r p = send (DisallowPermission r p) + +listPermissionsForRole :: (RoleStore :> es) => Role -> Eff es (Set Permission) +listPermissionsForRole = send . ListPermissionsForRole + +permissionsForRoles :: (RoleStore :> es) => Set Role -> Eff es (Set Permission) +permissionsForRoles = send . PermissionsForRoles diff --git a/src/Shomei/Authorization/Role/Workflow.hs b/src/Shomei/Authorization/Role/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Authorization/Role/Workflow.hs @@ -0,0 +1,153 @@ +-- | The audited role-granting workflows: the single code path the @shomei-admin roles@ CLI and +-- (later) the admin HTTP API both drive, so a grant is recorded identically whichever entry +-- point performs it. +-- +-- 'grantRoleTo' refuses a role absent from the registry ('Shomei.Error.RoleNotDefined'), which +-- is what turns @roles grant --role adminn@ from a silent no-op grant into a loud failure. The +-- PostgreSQL foreign key on @shomei_role_grants.role@ enforces the same invariant one layer +-- down, for code that bypasses this workflow. +-- +-- These functions treat a 'Role' as opaque text and do NOT validate its /shape/. Trimming and +-- rejecting blank role names belongs to the boundary layers — the CLI parser and the HTTP +-- handlers — exactly as @mkEmail@ / @mkLoginId@ validate before a workflow ever runs. +module Shomei.Authorization.Role.Workflow + ( grantRoleTo, + revokeRoleFrom, + rolesOf, + applyDefaultRoles, + undefinedDefaultRoles, + ) +where + +import Data.Set (Set) +import Data.Set qualified as Set +import Effectful (Eff, (:>)) +import Shomei.Account.User.Store (UserStore, findUserById) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Authorization.Claims.Domain (Role) +import Shomei.Authorization.Role.Store + ( RoleDefinition (..), + RoleStore, + grantRole, + listDefinedRoles, + listRolesForUser, + revokeRole, + ) +import Shomei.Config (ShomeiConfig (..)) +import Shomei.Error (AuthError (..)) +import Shomei.Id (UserId) +import Shomei.Prelude +import Shomei.Time.Store (Clock, now) + +-- | Grant a role to a user, publishing 'Event.RoleGranted' only when the store reports a state +-- change (so re-running a grant does not spam the audit trail). +-- +-- The first argument is the granting actor: 'Nothing' for a CLI bootstrap grant, where no +-- authenticated admin principal exists yet. The second is an optional expiry (EP-9): 'Nothing' +-- grants the role indefinitely, @Just t@ makes the grant stop appearing in tokens minted at or +-- after @t@. Re-granting an already-held role whose expiry /differs/ updates the window (upsert) +-- and reports @True@; an identical re-grant reports @False@ and stays audit-silent. +-- +-- @Right True@ = state changed (newly granted, or expiry updated); @Right False@ = the user +-- already held the role with the same expiry. +grantRoleTo :: + ( UserStore :> es, + RoleStore :> es, + AuthEventPublisher :> es, + Clock :> es + ) => + Maybe UserId -> + Maybe UTCTime -> + UserId -> + Role -> + Eff es (Either AuthError Bool) +grantRoleTo actor expiry subject role = do + mUser <- findUserById subject + case mUser of + Nothing -> pure (Left UserNotFound) + Just _ -> do + defined <- definedRoleNames + if not (role `Set.member` defined) + then pure (Left (RoleNotDefined role)) + else do + ts <- now + changed <- grantRole subject role actor expiry ts + when changed do + publishAuthEvent (Event.RoleGranted (Event.RoleGrantedData subject role actor expiry ts)) + pure (Right changed) + +-- | Revoke a role from a user. No registry check: revoking an existing grant must always work, +-- whatever the registry says today. +-- +-- @Right True@ = a grant was removed; @Right False@ = there was nothing to revoke. +revokeRoleFrom :: + ( UserStore :> es, + RoleStore :> es, + AuthEventPublisher :> es, + Clock :> es + ) => + Maybe UserId -> + UserId -> + Role -> + Eff es (Either AuthError Bool) +revokeRoleFrom actor subject role = do + mUser <- findUserById subject + case mUser of + Nothing -> pure (Left UserNotFound) + Just _ -> do + ts <- now + changed <- revokeRole subject role + when changed do + publishAuthEvent (Event.RoleRevoked (Event.RoleRevokedData subject role actor ts)) + pure (Right changed) + +-- | The roles currently granted to a user (as of now: expired grants are excluded). +rolesOf :: + (UserStore :> es, RoleStore :> es, Clock :> es) => + UserId -> + Eff es (Either AuthError (Set Role)) +rolesOf subject = do + mUser <- findUserById subject + case mUser of + Nothing -> pure (Left UserNotFound) + Just _ -> do + ts <- now + Right <$> listRolesForUser subject ts + +-- | Grant every configured default role to a freshly created user. Called by +-- @Shomei.Session.Authentication.Workflow.signup@ immediately after @createUser@, so the first access token the new +-- user receives already carries them. Each application is audited as 'Event.RoleGranted' with +-- no acting admin, exactly like a CLI bootstrap grant. +-- +-- This deliberately skips the user-existence and registry checks 'grantRoleTo' performs: +-- @signup@ just created the user, and boot validated the roles against the registry (see +-- 'undefinedDefaultRoles'), which is append-only — so a boot-validated role cannot later vanish. +applyDefaultRoles :: + (RoleStore :> es, AuthEventPublisher :> es) => + ShomeiConfig -> + UserId -> + UTCTime -> + Eff es () +applyDefaultRoles cfg subject ts = + forM_ (Set.toList cfg.defaultRoles) \role -> do + changed <- grantRole subject role Nothing Nothing ts + when changed do + publishAuthEvent (Event.RoleGranted (Event.RoleGrantedData subject role Nothing Nothing ts)) + +-- | The configured 'defaultRoles' missing from the registry. A nonempty result means the config +-- names roles nothing will ever check, and the process should refuse to serve. +-- +-- The standalone server calls this at boot and exits naming the offending roles. An __embedding +-- host that sets @defaultRoles@ should call it wherever it assembles its ports__, for the same +-- reason: validating here rather than at each signup keeps the hot path free of catalog reads +-- and turns a config typo into an immediate startup failure instead of a stream of 500s. +undefinedDefaultRoles :: (RoleStore :> es) => ShomeiConfig -> Eff es (Set Role) +undefinedDefaultRoles cfg + | Set.null cfg.defaultRoles = pure Set.empty + | otherwise = do + defined <- definedRoleNames + pure (cfg.defaultRoles `Set.difference` defined) + +definedRoleNames :: (RoleStore :> es) => Eff es (Set Role) +definedRoleNames = Set.fromList . map (.role) <$> listDefinedRoles diff --git a/src/Shomei/Authorization/Scope/Domain.hs b/src/Shomei/Authorization/Scope/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Authorization/Scope/Domain.hs @@ -0,0 +1,35 @@ +-- | Scope values that Shōmei itself interprets as privilege gates. +module Shomei.Authorization.Scope.Domain + ( adminScope, + tokenExchangeSubjectScope, + privilegeScopes, + privilegeScopesIn, + ) +where + +import Data.Set (Set) +import Data.Set qualified as Set +import Shomei.Authorization.Claims.Domain (Scope (..)) +import Shomei.Config (ImpersonationConfig (..), ShomeiConfig (..)) + +-- | The scope carried by a service token that may administer Shōmei. +adminScope :: Scope +adminScope = Scope "shomei:admin" + +-- | The gate a service account must hold to exchange a user's token on behalf of that user. +tokenExchangeSubjectScope :: Scope +tokenExchangeSubjectScope = Scope "token-exchange:subject" + +-- | Scopes that confer authority to the bearer rather than naming an ordinary capability. +-- An OAuth client's allowed scopes are copied onto each authorizing user's token, so these scopes +-- may never be registered on a client. Service accounts remain their intended holders. +privilegeScopes :: ShomeiConfig -> Set Scope +privilegeScopes cfg = + Set.fromList + [ cfg.impersonationConfig.impersonateScope, + adminScope, + tokenExchangeSubjectScope + ] + +privilegeScopesIn :: ShomeiConfig -> Set Scope -> Set Scope +privilegeScopesIn cfg = Set.intersection (privilegeScopes cfg) diff --git a/src/Shomei/Config.hs b/src/Shomei/Config.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Config.hs @@ -0,0 +1,538 @@ +-- | The runtime configuration record (IP-5). +-- +-- 'ShomeiConfig' carries the issuer/audience, the access/refresh/session TTLs, the +-- password policy, the token transport, the signing-key config, and the session-check +-- mode. 'defaultShomeiConfig' supplies sane defaults given an issuer and audience. +module Shomei.Config + ( ShomeiConfig (..), + TokenTransport (..), + transportUsesCookies, + transportIncludesBodyTokens, + SameSitePolicy (..), + CookieConfig (..), + defaultCookieConfig, + normalizeOrigin, + SessionCheckMode (..), + SigningKeyConfig (..), + NotifierConfig (..), + NotifierTransport (..), + SmtpTlsMode (..), + SmtpConfig (..), + WebhookConfig (..), + RateLimitConfig (..), + ObservabilityConfig (..), + LogFormat (..), + WebAuthnConfig (..), + MfaConfig (..), + UserVerificationPolicy (..), + AttestationPolicy (..), + ImpersonationConfig (..), + ServiceAccountId (..), + MachineTokenConfig (..), + OAuthConfig (..), + TotpConfig (..), + defaultWebAuthnConfig, + defaultMfaConfig, + defaultImpersonationConfig, + defaultMachineTokenConfig, + defaultOAuthConfig, + defaultTotpConfig, + defaultShomeiConfig, + defaultAccessTokenTTL, + defaultRefreshTokenTTL, + defaultSessionTTL, + defaultVerificationTokenTTL, + defaultPasswordResetTokenTTL, + defaultRateLimitConfig, + defaultObservabilityConfig, + configSigningAlgorithm, + ) +where + +import Data.Char (isAlpha, isSpace) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time (NominalDiffTime) +import Shomei.Account.Password.Domain (PasswordPolicy, defaultPasswordPolicy) +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..), Role (..), Scope (..)) +import Shomei.Passkey.Domain (UserVerificationPolicy (..)) +import Shomei.Prelude +import Shomei.SigningKey.Domain (SigningAlgorithm, signingAlgorithmFromText) + +-- | How access and refresh tokens travel between Shōmei and its clients. +-- +-- 'BearerToken' (the default) puts them in the JSON body and reads them from +-- @Authorization: Bearer@; cookies are neither set nor accepted. 'HttpOnlyCookie' puts them +-- in @HttpOnly@ cookies and omits them from response bodies, so page JavaScript — and +-- therefore an XSS payload — can never read them. 'BearerAndCookie' does both, for clients +-- migrating between the two. +-- +-- Bearer credentials are accepted in every mode: a foreign page cannot set an +-- @Authorization@ header, and non-browser callers (services, CLIs, service tokens) need it. +data TokenTransport = BearerToken | HttpOnlyCookie | BearerAndCookie + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Whether the configured transport ever accepts or sets cookies. +transportUsesCookies :: TokenTransport -> Bool +transportUsesCookies = \case + BearerToken -> False + HttpOnlyCookie -> True + BearerAndCookie -> True + +-- | Whether response bodies still carry token values. False only in cookie-only mode, where +-- omitting them is the point: an XSS payload cannot exfiltrate what the body never contained. +transportIncludesBodyTokens :: TokenTransport -> Bool +transportIncludesBodyTokens = \case + BearerToken -> True + HttpOnlyCookie -> False + BearerAndCookie -> True + +-- | How browsers may carry Shōmei's cookies cross-site. Rendered into the @SameSite@ +-- attribute of every cookie Shōmei sets. +data SameSitePolicy = SameSiteStrict | SameSiteLax | SameSiteNone + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Cookie-transport and CSRF policy. Consulted only when 'tokenTransport' is +-- 'HttpOnlyCookie' or 'BearerAndCookie'. +data CookieConfig = CookieConfig + { -- | Mark cookies @Secure@ (HTTPS only). Default 'True'; browsers exempt @localhost@ from + -- the HTTPS requirement, so this is safe for development too. + secure :: !Bool, + -- | The @SameSite@ attribute. Default 'SameSiteLax', which already stops browsers + -- attaching these cookies to cross-site POSTs. + sameSite :: !SameSitePolicy, + -- | Origins allowed to make cookie-authenticated /mutating/ requests, compared exactly + -- against the @Origin@ header (@scheme://host[:port]@). The localhost default matches + -- 'defaultWebAuthnConfig' so the turnkey dev experience works; __production deployments + -- must set their real origins__. + allowedOrigins :: ![Text] + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +defaultCookieConfig :: CookieConfig +defaultCookieConfig = + CookieConfig + { secure = True, + sameSite = SameSiteLax, + allowedOrigins = ["http://localhost:8080"] + } + +-- | Normalize the exact browser-origin shape Shōmei compares at the CSRF boundary. +-- Origins have no path, query, or fragment; one presentation-only trailing slash is accepted. +normalizeOrigin :: Text -> Either Text Text +normalizeOrigin raw + | Text.null scheme + || not (Text.all isAlpha scheme) + || Text.null host + || Text.any invalidHostCharacter host = + Left invalidMessage + | otherwise = Right (Text.toLower normalized) + where + stripped = Text.strip raw + normalized = fromMaybe stripped (Text.stripSuffix "/" stripped) + (scheme, separatorAndHost) = Text.breakOn "://" normalized + host = fromMaybe "" (Text.stripPrefix "://" separatorAndHost) + invalidHostCharacter c = c `elem` ("/?#" :: String) || isSpace c + invalidMessage = raw <> " must be scheme://host[:port] with no path" + +data SessionCheckMode = VerifyTokenOnly | VerifyTokenAndSession + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data SigningKeyConfig = SigningKeyConfig + { algorithm :: !Text, + -- | Seconds between background reloads of the signing-key material (signer, verifier + -- key set, and published JWKS) from the database, so a key activation or revocation + -- reaches a running server. 0 disables the periodic reload; @SIGHUP@ still reloads. + refreshIntervalSeconds :: !Int, + -- | Seconds of tolerance granted to @exp@, @nbf@, and @iat@ by the JWT + -- verifier. Zero requires exact agreement between issuer and verifier clocks. + allowedClockSkewSeconds :: !Int + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Which built-in 'Shomei.Account.Notification.Store.Notifier' interpreter the standalone +-- server uses. +-- +-- Shōmei emits a 'Shomei.Account.Notification.Domain.Notification' (recipient, one-time link/token, +-- expiry) through the 'Notifier' effect. The standalone server can interpret that three ways: +-- +-- * 'LogNotifier' (the default) writes the link to the server log — ideal for development and +-- for operators who scrape logs. +-- +-- * 'SmtpNotifier' delivers a plain-text email through a __provider relay__ (see 'SmtpConfig'). +-- It is deliberately not a self-hosted mail server and does no direct-to-MX delivery; it +-- points at a provider's authenticated submission endpoint (SES, SendGrid, Resend, Postmark). +-- +-- * 'WebhookNotifier' POSTs the notification as signed JSON to a configured URL (see +-- 'WebhookConfig'), doubling as Shōmei's lightweight eventing hook. +-- +-- An in-memory interpreter serves the tests, and a host may always supply its own 'Notifier' +-- interpreter for a provider Shōmei does not ship. +data NotifierTransport = LogNotifier | SmtpNotifier | WebhookNotifier + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | SMTP connection security. Names the three ubiquitous modes; the conventional ports are 25, +-- 587, and 465 respectively (see 'SmtpConfig'). +-- +-- * 'SmtpPlain' — plaintext (no TLS). A lab/test sink only; never a production configuration. +-- * 'SmtpStartTls' — start plaintext, then @STARTTLS@ to upgrade before authenticating (587). +-- * 'SmtpImplicitTls' — TLS from the first byte (465). +data SmtpTlsMode = SmtpPlain | SmtpStartTls | SmtpImplicitTls + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Provider-relay SMTP settings (EP-8). This is a __relay client__ aimed at a provider's +-- authenticated submission endpoint, not a mail server. Relay credentials deliberately live +-- outside this public, printable configuration record; the standalone server carries them in +-- its runtime environment. +data SmtpConfig = SmtpConfig + { host :: !Text, + -- | conventional: 25 plaintext (lab only), 587 STARTTLS, 465 implicit-TLS + port :: !Int, + tlsMode :: !SmtpTlsMode, + -- | 'Nothing' = unauthenticated (lab sinks only) + username :: !(Maybe Text), + fromAddress :: !Text, + -- | per-attempt send timeout in seconds (default 10) + timeoutSeconds :: !Int + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Webhook-notifier settings (EP-8). The notification is POSTed as JSON and signed by the +-- server transport. The signing secret deliberately lives outside this public, printable +-- configuration record. +data WebhookConfig = WebhookConfig + { url :: !Text, + -- | per-attempt request timeout in seconds (default 5) + timeoutSeconds :: !Int, + -- | total delivery attempts, initial + retries (default 3) + maxAttempts :: !Int + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data NotifierConfig = NotifierConfig + { emailVerificationRequired :: !Bool, + verificationTokenTTL :: !NominalDiffTime, + passwordResetTokenTTL :: !NominalDiffTime, + notifierTransport :: !NotifierTransport, + publicBaseUrl :: !Text, + -- | When 'True' the 'LogNotifier' writes the full one-time link — including the raw + -- token — to the log. That is a development convenience only: anyone who can read the + -- log can then complete a password reset for the account. Default 'False' logs a + -- SHA-256 prefix of the token instead, which correlates with the stored token hash but + -- cannot be redeemed. + logRawTokens :: !Bool, + -- | present when 'notifierTransport' is 'SmtpNotifier'; boot validation guarantees it. + smtpConfig :: !(Maybe SmtpConfig), + -- | present when 'notifierTransport' is 'WebhookNotifier'; boot validation guarantees it. + webhookConfig :: !(Maybe WebhookConfig), + -- | when 'True', every notification is also written through the 'LogNotifier' in addition + -- to the selected transport — a staged-rollout aid. Default 'False'. Has no effect when the + -- transport is already 'LogNotifier'. + alsoLogNotifications :: !Bool + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | The abuse-protection policy (EP-2). Every field carries a default (see +-- 'defaultRateLimitConfig') so the record is append-only per IP-3. +data RateLimitConfig = RateLimitConfig + { -- | failures within 'lockoutWindow' before the account is locked (default 5) + maxFailedLoginsPerAccount :: !Int, + -- | failures within 'lockoutWindow' from one IP before that IP is throttled (default 20) + maxFailedLoginsPerIp :: !Int, + -- | rolling window over which failures are counted (default 15 min) + lockoutWindow :: !NominalDiffTime, + -- | how long an account stays locked once tripped (default 15 min) + lockoutDuration :: !NominalDiffTime, + -- | WAI token-bucket sustained rate per client IP (default 60) + perIpRequestsPerMinute :: !Int, + -- | WAI token-bucket capacity / burst per client IP (default 60) + perIpBurst :: !Int, + -- | master switch; False disables all EP-2 protections (default True) + rateLimitEnabled :: !Bool + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | How the per-request structured log line is rendered (EP-3 observability). +data LogFormat = LogJson | LogPlain + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Observability policy (EP-3). Every field carries a default (see +-- 'defaultObservabilityConfig') so the record stays append-only per IP-3. +data ObservabilityConfig = ObservabilityConfig + { -- | JSON (default) or plain text per-request log lines + logFormat :: !LogFormat, + -- | emit one structured log line per request (default True) + requestLoggingEnabled :: !Bool, + -- | serve @GET /metrics@ and record HTTP/domain metrics (default True) + metricsEnabled :: !Bool, + -- | how long warp waits for in-flight requests to drain on shutdown (default 30) + gracefulShutdownTimeoutSeconds :: !Int + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | WebAuthn / passkey policy (MasterPlan 3, IP-3). Carries the Relying Party +-- identity (the @rpId@ scope domain, the allowed @origins@, the human RP name) and +-- ceremony policy. Every field has a default (see 'defaultWebAuthnConfig') so the +-- record stays append-only per IP-3; the @shomei-webauthn@ interpreter reads this identity. +data AttestationPolicy = AttestationNone | AttestationDirect + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data WebAuthnConfig = WebAuthnConfig + { -- | the scope domain a passkey is bound to, e.g. @auth.example.com@ + rpId :: !Text, + -- | the human-readable Relying Party name shown by the authenticator + rpName :: !Text, + -- | allowed web origins, e.g. @https://auth.example.com@ + origins :: ![Text], + userVerification :: !UserVerificationPolicy, + attestation :: !AttestationPolicy, + -- | browser-facing ceremony timeout + ceremonyTimeout :: !NominalDiffTime, + -- | how long a begun ceremony's options blob stays valid server-side + pendingCeremonyTTL :: !NominalDiffTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Policy shared by every second-factor mechanism. +newtype MfaConfig = MfaConfig + { requireSecondFactor :: Bool + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Impersonation / delegated-token policy (token-exchange plan). Carries the +-- scope a caller must hold to start impersonation, the lifetime of the delegated +-- session/token, and how recently the caller must have authenticated. Every field +-- has a default (see 'defaultImpersonationConfig') so the record stays append-only. +data ImpersonationConfig = ImpersonationConfig + { -- | scope a caller must hold to start impersonation; default @impersonate:user@ + impersonateScope :: !Scope, + -- | lifetime of the delegated session/token; default 30 minutes + impersonationSessionTTL :: !NominalDiffTime, + -- | caller's own access token must have been issued within this window; default 5 minutes + actorFreshnessWindow :: !NominalDiffTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +newtype ServiceAccountId = ServiceAccountId Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +-- | Lifetime for refresh-less tokens minted by OAuth machine grants and token exchange. +newtype MachineTokenConfig = MachineTokenConfig + { machineTokenTTL :: NominalDiffTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | OIDC provider policy (EP-5). Every field has a default (see 'defaultOAuthConfig') so the +-- record stays append-only. +-- +-- The OIDC issuer is 'ShomeiConfig.issuer', not a field here: OIDC Core requires the discovery +-- document to live at @{issuer}\/.well-known\/openid-configuration@ and ID tokens to carry +-- @iss = issuer@, so the issuer /is/ the deployment's public base URL by construction. A second +-- "public base URL" field would be a second value that must agree with the first. When +-- 'oidcEnabled' is set, the standalone server validates at boot that the issuer parses as an +-- absolute @http(s)@ URL and refuses to start otherwise. +data OAuthConfig = OAuthConfig + { -- | master switch, default 'False': discovery and @\/oauth\/authorize@ answer 404 when off, + -- so deploying the code before enabling the provider is safe. A disabled provider must + -- not advertise itself. + oidcEnabled :: !Bool, + -- | the host's own login page, to which an unauthenticated @\/oauth\/authorize@ request is + -- redirected with the original authorize URL in a @return_to@ query parameter. Shōmei + -- ships no login UI and persists no pending-authorize state; the host logs the user in + -- and navigates back to @return_to@. 'Nothing' makes an unauthenticated authorize + -- request a 401 with an OAuth error body instead. + loginUrl :: !(Maybe Text), + -- | how long an issued authorization code stays exchangeable; default 60 seconds, per + -- OAuth 2.0 Security BCP ("a maximum lifetime of 10 minutes"; codes are single-use and + -- exchanged within seconds by every real client) + authorizationCodeTTL :: !NominalDiffTime, + -- | ID-token lifetime; default 15 minutes, matching 'defaultAccessTokenTTL' + idTokenTTL :: !NominalDiffTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | TOTP second-factor policy (EP-7). Every field has a default (see 'defaultTotpConfig') so +-- the record stays append-only. +-- +-- The AES-256-GCM encryption key for stored secrets is deliberately __not__ a field here: it +-- is a secret, loaded by the standalone server from @SHOMEI_TOTP_ENCRYPTION_KEY@ and carried +-- in the server @Env@, never in this 'Show'able / serializable record (the same treatment the +-- key-encryption key gets). +data TotpConfig = TotpConfig + { -- | master switch, default 'False': enrollment is refused and login never challenges for + -- TOTP when off, so deploying the code before enabling the factor is safe. + totpEnabled :: !Bool, + -- | how long an unconfirmed enrollment stays activatable before it is treated as absent + -- (and replaced on re-enroll); default 15 minutes. + enrollmentTTL :: !NominalDiffTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +defaultTotpConfig :: TotpConfig +defaultTotpConfig = + TotpConfig + { totpEnabled = False, + enrollmentTTL = 15 * 60 + } + +defaultOAuthConfig :: OAuthConfig +defaultOAuthConfig = + OAuthConfig + { oidcEnabled = False, + loginUrl = Nothing, + authorizationCodeTTL = 60, + idTokenTTL = defaultAccessTokenTTL + } + +defaultImpersonationConfig :: ImpersonationConfig +defaultImpersonationConfig = + ImpersonationConfig + { impersonateScope = Scope "impersonate:user", + impersonationSessionTTL = 30 * 60, + actorFreshnessWindow = 5 * 60 + } + +defaultMachineTokenConfig :: MachineTokenConfig +defaultMachineTokenConfig = MachineTokenConfig {machineTokenTTL = 5 * 60} + +defaultMfaConfig :: MfaConfig +defaultMfaConfig = MfaConfig {requireSecondFactor = True} + +defaultWebAuthnConfig :: WebAuthnConfig +defaultWebAuthnConfig = + WebAuthnConfig + { rpId = "localhost", + rpName = "Shōmei", + origins = ["http://localhost:8080"], + userVerification = UVPreferred, + attestation = AttestationNone, + ceremonyTimeout = 300, + pendingCeremonyTTL = 300 + } + +data ShomeiConfig = ShomeiConfig + { issuer :: !Issuer, + audience :: !Audience, + accessTokenTTL :: !NominalDiffTime, + refreshTokenTTL :: !NominalDiffTime, + sessionTTL :: !NominalDiffTime, + passwordPolicy :: !PasswordPolicy, + tokenTransport :: !TokenTransport, + signingKeyConfig :: !SigningKeyConfig, + sessionCheckMode :: !SessionCheckMode, + notifierConfig :: !NotifierConfig, + rateLimitConfig :: !RateLimitConfig, + observabilityConfig :: !ObservabilityConfig, + webauthnConfig :: !WebAuthnConfig, + mfaConfig :: !MfaConfig, + impersonationConfig :: !ImpersonationConfig, + machineTokenConfig :: !MachineTokenConfig, + oauthConfig :: !OAuthConfig, + totpConfig :: !TotpConfig, + cookieConfig :: !CookieConfig, + -- | roles granted to every user created through @Shomei.Session.Authentication.Workflow.signup@ (the HTTP signup + -- route and @shomei-admin users create@ alike), applied before the first token is minted + -- so it already carries them. Empty by default. + -- + -- Every name here must exist in the @shomei_roles@ registry. The standalone server + -- validates this at boot (see @Shomei.Authorization.Role.Workflow.undefinedDefaultRoles@) and refuses + -- to start otherwise; embedding hosts should call the same check where they assemble + -- their ports. + defaultRoles :: !(Set Role) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +defaultAccessTokenTTL, defaultRefreshTokenTTL, defaultSessionTTL :: NominalDiffTime +defaultAccessTokenTTL = 15 * 60 -- 15 minutes +defaultRefreshTokenTTL = 30 * 24 * 60 * 60 -- 30 days +defaultSessionTTL = 30 * 24 * 60 * 60 -- 30 days + +defaultVerificationTokenTTL, defaultPasswordResetTokenTTL :: NominalDiffTime +defaultVerificationTokenTTL = 24 * 60 * 60 -- 24 hours +defaultPasswordResetTokenTTL = 60 * 60 -- 1 hour + +defaultRateLimitConfig :: RateLimitConfig +defaultRateLimitConfig = + RateLimitConfig + { maxFailedLoginsPerAccount = 5, + maxFailedLoginsPerIp = 20, + lockoutWindow = 15 * 60, + lockoutDuration = 15 * 60, + perIpRequestsPerMinute = 60, + perIpBurst = 60, + rateLimitEnabled = True + } + +defaultObservabilityConfig :: ObservabilityConfig +defaultObservabilityConfig = + ObservabilityConfig + { logFormat = LogJson, + requestLoggingEnabled = True, + metricsEnabled = True, + gracefulShutdownTimeoutSeconds = 30 + } + +-- | Parse the signing algorithm for newly generated keys. A hand-built embedding configuration +-- can contain arbitrary text, so callers must treat a parse failure as a boot error rather than +-- silently changing the trust root to another algorithm. +configSigningAlgorithm :: ShomeiConfig -> Either Text SigningAlgorithm +configSigningAlgorithm cfg = signingAlgorithmFromText cfg.signingKeyConfig.algorithm + +defaultShomeiConfig :: Issuer -> Audience -> ShomeiConfig +defaultShomeiConfig iss aud = + ShomeiConfig + { issuer = iss, + audience = aud, + accessTokenTTL = defaultAccessTokenTTL, + refreshTokenTTL = defaultRefreshTokenTTL, + sessionTTL = defaultSessionTTL, + passwordPolicy = defaultPasswordPolicy, + tokenTransport = BearerToken, + signingKeyConfig = SigningKeyConfig {algorithm = "ES256", refreshIntervalSeconds = 60, allowedClockSkewSeconds = 30}, + sessionCheckMode = VerifyTokenOnly, + notifierConfig = + NotifierConfig + { emailVerificationRequired = False, + verificationTokenTTL = defaultVerificationTokenTTL, + passwordResetTokenTTL = defaultPasswordResetTokenTTL, + notifierTransport = LogNotifier, + publicBaseUrl = "http://localhost:8080", + logRawTokens = False, + smtpConfig = Nothing, + webhookConfig = Nothing, + alsoLogNotifications = False + }, + rateLimitConfig = defaultRateLimitConfig, + observabilityConfig = defaultObservabilityConfig, + webauthnConfig = defaultWebAuthnConfig, + mfaConfig = defaultMfaConfig, + impersonationConfig = defaultImpersonationConfig, + machineTokenConfig = defaultMachineTokenConfig, + oauthConfig = defaultOAuthConfig, + totpConfig = defaultTotpConfig, + cookieConfig = defaultCookieConfig, + defaultRoles = Set.empty + } diff --git a/src/Shomei/Delegation/Workflow.hs b/src/Shomei/Delegation/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Delegation/Workflow.hs @@ -0,0 +1,204 @@ +-- | The impersonation token-exchange workflow. +-- +-- 'startImpersonation' mints a short-lived __delegated session__ for a target customer +-- on behalf of an authorized operator: a brand-new session row whose @actor@ is the +-- operator, a signed access token carrying both identities (@sub@ = customer, @act@ = +-- operator), and __no refresh token__ so the delegated session cannot be silently +-- renewed and dies at its TTL. 'stopImpersonation' revokes that session. +-- +-- Unlike 'Shomei.Session.Workflow.issueSession', this workflow deliberately does NOT +-- create a refresh token and does NOT publish 'LoginSucceeded'/'SessionStarted'; it +-- publishes 'ImpersonationStarted'/'ImpersonationStopped' instead. Who-may-impersonate-whom +-- policy lives in the embedding service, not here (see the plan's Decision Log). +module Shomei.Delegation.Workflow + ( StartImpersonation (..), + startImpersonation, + stopImpersonation, + DelegatedMint (..), + mintDelegatedToken, + ) +where + +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Time (NominalDiffTime, addUTCTime) +import Effectful (Eff, (:>)) +import Effectful.Error.Static (runErrorNoCallStack, throwError) +import Shomei.Account.User.Domain (User (..), UserStatus (UserActive)) +import Shomei.Account.User.Store (UserStore, findUserById) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Authorization.Claims.Domain (AuthClaims (..), Scope, noExtraClaims) +import Shomei.Config (ImpersonationConfig (..), ShomeiConfig (..)) +import Shomei.Error (AuthError (..)) +import Shomei.Id (UserId) +import Shomei.Prelude +import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (DelegatedSession)) +import Shomei.Session.Store (SessionStore, createSession, revokeSession) +import Shomei.Session.Token.Domain (AccessToken) +import Shomei.Session.Workflow (requireLiveSession) +import Shomei.SigningKey.Signer (TokenSigner, signAccessToken) +import Shomei.Time.Store (Clock, now) + +-- | Command to start impersonating a target on behalf of the verified caller. +data StartImpersonation = StartImpersonation + { -- | the caller's verified token contents (carries scopes + authTime + subject) + actorClaims :: !AuthClaims, + targetUserId :: !UserId, + reason :: !Text, + ticketId :: !(Maybe Text), + clientIp :: !(Maybe Text) + } + deriving stock (Generic, Show) + +-- | Exchange the caller's token for a short-lived delegated session + access token +-- for 'targetUserId'. Enforces scope, freshness, live-session, active-operator, self, and +-- target-active checks; mints +-- a refresh-less session; and audits the start. Returns the new 'Session' and signed +-- 'AccessToken'. +startImpersonation :: + ( UserStore :> es, + SessionStore :> es, + TokenSigner :> es, + AuthEventPublisher :> es, + Clock :> es + ) => + ShomeiConfig -> + StartImpersonation -> + Eff es (Either AuthError (Session, AccessToken)) +startImpersonation cfg cmd = runErrorNoCallStack do + let imp = cfg.impersonationConfig + caller = cmd.actorClaims + ts <- now + -- Scope check: the caller must hold the configured impersonation scope. + unless (imp.impersonateScope `Set.member` caller.scopes) (throwError ImpersonationForbidden) + -- Freshness check: the caller must have recently proven a credential; refresh does not count. + when (ts > addUTCTime imp.actorFreshnessWindow caller.authTime) (throwError ImpersonationForbidden) + -- The operator's credential must still be backed by a live session, regardless of the host's + -- ordinary route-authentication mode. + _ <- either (const (throwError ImpersonationForbidden)) pure =<< requireLiveSession ts caller.sessionId + -- A suspended or otherwise inactive operator cannot mint fresh authority from an old token. + operator <- maybe (throwError ImpersonationForbidden) pure =<< findUserById caller.subject + unless (operator.status == UserActive) (throwError ImpersonationForbidden) + -- Self check: an operator may not impersonate themselves. + when (cmd.targetUserId == caller.subject) (throwError ImpersonationTargetInvalid) + -- Target check: the target must exist and be active. + target <- maybe (throwError ImpersonationTargetInvalid) pure =<< findUserById cmd.targetUserId + unless (target.status == UserActive) (throwError ImpersonationTargetInvalid) + -- Mint a dedicated, refresh-less, short-lived delegated session through the shared core. Empty + -- scopes: an impersonation token carries the operator's authority to /be/ the customer, not a + -- narrowed scope set (that is on-behalf-of's job). + (session, access) <- + mintDelegatedToken + cfg + ts + DelegatedMint + { subjectUserId = cmd.targetUserId, + actorUserId = caller.subject, + scopes = Set.empty, + ttl = imp.impersonationSessionTTL + } + publishAuthEvent + ( Event.ImpersonationStarted + Event.ImpersonationStartedData + { actorUserId = caller.subject, + subjectUserId = cmd.targetUserId, + sessionId = session.sessionId, + reason = cmd.reason, + ticketId = cmd.ticketId, + clientIp = cmd.clientIp, + occurredAt = ts + } + ) + pure (session, access) + +-- | The inputs to the shared delegated-token core: who the token represents, who is acting, the +-- scopes it carries, and how long it lives. Everything policy — the scope\/freshness\/target +-- guards, the audit event — lives in the /caller/ ('startImpersonation' for impersonation, +-- 'Shomei.OAuth.TokenExchange.Workflow.exchangeToken' for on-behalf-of); this record is only the mint. +data DelegatedMint = DelegatedMint + { -- | the token's @sub@ + subjectUserId :: !UserId, + -- | the token's @act@ + actorUserId :: !UserId, + -- | empty for impersonation; the narrowed set for service on-behalf-of + scopes :: !(Set Scope), + ttl :: !NominalDiffTime + } + deriving stock (Generic, Show) + +-- | Mint a dedicated, __refresh-less__, short-lived delegated session and its signed access token: +-- a fresh session row whose @actor@ is 'actorUserId', and a token carrying both identities (@sub@ = +-- 'subjectUserId', @act@ = 'actorUserId') plus 'scopes'. No refresh token, no @LoginSucceeded@\/ +-- @SessionStarted@ events — the delegated session cannot be silently renewed and dies at its TTL. +-- +-- This is the single mint both delegation flows share, so the standards-based token-exchange grant +-- and the bespoke @\/auth\/impersonate@ endpoint cannot drift in session shape or claim contents. +-- The audit event is the caller's responsibility, because impersonation and on-behalf-of publish +-- different events. +mintDelegatedToken :: + ( SessionStore :> es, + TokenSigner :> es + ) => + ShomeiConfig -> + UTCTime -> + DelegatedMint -> + Eff es (Session, AccessToken) +mintDelegatedToken cfg ts mint = do + let expires = addUTCTime mint.ttl ts + session <- + createSession + NewSession + { userId = mint.subjectUserId, + createdAt = ts, + expiresAt = expires, + actor = Just mint.actorUserId, + oauthClientId = Nothing, + kind = DelegatedSession, + grantedScopes = Set.empty, + authenticatedAt = ts + } + let claims = + AuthClaims + { subject = mint.subjectUserId, + sessionId = session.sessionId, + issuer = cfg.issuer, + audience = cfg.audience, + issuedAt = ts, + expiresAt = expires, + authTime = ts, + scopes = mint.scopes, + roles = Set.empty, + -- A delegated token carries negotiated scopes, not role-derived permissions (EP-9): + -- it does not go through claims enrichment, so its permissions set is always empty. + permissions = Set.empty, + actor = Just mint.actorUserId, + extraClaims = noExtraClaims + } + access <- signAccessToken claims + pure (session, access) + +-- | Stop impersonating: revoke the delegated session named by the presented token's +-- claims and audit the stop. The claims must carry an @act@ actor (i.e. be a delegated +-- token); an ordinary token is rejected with 'ImpersonationTargetInvalid'. Revoking the +-- session is sufficient to end it because the delegated session has no refresh token. +stopImpersonation :: + ( SessionStore :> es, + AuthEventPublisher :> es, + Clock :> es + ) => + AuthClaims -> + Eff es (Either AuthError ()) +stopImpersonation claims = runErrorNoCallStack do + actorId <- maybe (throwError ImpersonationTargetInvalid) pure claims.actor + ts <- now + revokeSession claims.sessionId ts + publishAuthEvent + ( Event.ImpersonationStopped + Event.ImpersonationStoppedData + { actorUserId = actorId, + subjectUserId = claims.subject, + sessionId = claims.sessionId, + occurredAt = ts + } + ) diff --git a/src/Shomei/Error.hs b/src/Shomei/Error.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Error.hs @@ -0,0 +1,176 @@ +-- | The error vocabulary of the authentication core. +-- +-- 'AuthError' is the single error type returned by every workflow. 'TokenError' is the +-- narrower set of JWT-verification failures (interpreted by EP-4's verifier and wrapped +-- in 'TokenInvalid'). 'PasswordPolicyViolation' is the reason a password failed the +-- policy check. +module Shomei.Error + ( AuthDependency (..), + AuthError (..), + TokenError (..), + PasswordPolicyViolation (..), + ) +where + +import Shomei.Authorization.Claims.Domain (Role) +import Shomei.Passkey.Ceremony.Port (WebAuthnError) +import Shomei.Prelude + +data PasswordPolicyViolation + = -- | minimum length required + PasswordTooShort Int + | -- | maximum length allowed + PasswordTooLong Int + | -- | the password appears in the bundled common-password dictionary + PasswordTooCommon + | PasswordMissingRequiredClass Text + | -- | the password is essentially the user's own identity (email local-part, + -- full email, or display name) + PasswordResemblesIdentity + | -- | the password appears in a known public breach (HIBP). EP-3. + PasswordBreached + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data TokenError + = TokenMalformed + | TokenSignatureInvalid + | -- | The protected JWT header omitted @kid@ or named no published key. + TokenKeyNotFound !(Maybe Text) + | TokenExpired + | TokenIssuerInvalid + | TokenAudienceInvalid + | TokenOtherError Text + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A required external dependency whose availability is part of an operation's +-- typed outcome. Extend this closed vocabulary only when another dependency has +-- an intentional operation-level availability contract. +data AuthDependency + = PostgreSQL + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data AuthError + = InvalidEmail + | -- | The supplied login identifier was empty or contained internal whitespace. + InvalidLoginId + | WeakPassword PasswordPolicyViolation + | EmailAlreadyRegistered + | -- | A user already exists with the requested login identifier (the principal + -- collision check; the generic counterpart to 'EmailAlreadyRegistered'). + LoginIdAlreadyRegistered + | InvalidCredentials + | UserNotActive + | SessionNotFound + | SessionExpired + | SessionRevoked + | RefreshTokenInvalid + | RefreshTokenExpired + | RefreshTokenReuseDetected + | VerificationTokenInvalid + | PasswordResetTokenInvalid + | EmailAlreadyVerified + | -- | Token issuance was refused because runtime configuration requires a verified email + -- and the account's email is present but unverified. Maps to 403. + -- + -- Deliberately distinct from 'InvalidCredentials': every path that can raise it has + -- already proven control of the account (a correct password, a valid refresh token, or + -- a verified passkey assertion), so naming the reason leaks no existence information — + -- while a generic 401 would strand a legitimate user with no idea they must click the + -- verification link. + EmailNotVerified + | -- | INTERNAL audit signal raised when a login hits a locked account; the HTTP layer + -- maps it to the SAME generic 401 as 'InvalidCredentials' so a locked account is + -- indistinguishable from a wrong password. (The 'Shomei.Session.Authentication.Workflow.login' workflow itself + -- returns 'InvalidCredentials' for the locked case so even a direct core caller cannot + -- distinguish; 'AccountLocked' exists for completeness and future internal use.) + AccountLocked + | -- | The per-IP failure throttle tripped; the HTTP layer maps it to 429. + TooManyRequests + | TokenInvalid TokenError + | -- | A WebAuthn registration verification failed (bad attestation, origin/challenge + -- mismatch, or malformed credential JSON). The HTTP layer maps this to 400. + WebAuthnCeremonyError WebAuthnError + | -- | No passkey with the given id is owned by the requesting user. Maps to 404. + PasskeyNotFound + | -- | The pending ceremony was missing, already consumed, or expired. Maps to 404. + PendingCeremonyNotFound + | -- | A WebAuthn login/step-up assertion failed verification (bad signature, clone + -- counter, user-not-present, or a credential not owned by the expected user). The + -- HTTP layer maps this to a generic 401 so nothing about the failure leaks. + MfaAssertionInvalid + | -- | EP-7: TOTP enrollment was attempted while @totpConfig.totpEnabled@ is off. Maps to 403. + TotpDisabled + | -- | EP-7: TOTP enrollment was attempted while a /confirmed/ credential already exists; + -- removal (a separate, proof-gated step) must come first. Maps to 409. + TotpAlreadyEnrolled + | -- | EP-7: no unconfirmed, unexpired TOTP enrollment exists to verify (or it has lapsed). + -- Maps to 404. + TotpEnrollmentNotFound + | -- | EP-7: a presented TOTP code did not verify (wrong code, outside the window, or a + -- replayed counter). Maps to a generic 401 so nothing about the failure leaks. + TotpCodeInvalid + | -- | EP-7: a presented recovery code was unknown or already spent. Maps to a generic 401. + RecoveryCodeInvalid + | -- | The caller may not start impersonation: they lack the @impersonate:user@ scope + -- or their own access token is older than the freshness window. Maps to 403. + ImpersonationForbidden + | -- | The impersonation target is missing, not active, or is the caller themselves. + -- Maps to 400. + ImpersonationTargetInvalid + | -- | A credential-changing action was attempted under a delegated (impersonation) + -- token. Maps to 403. + ImpersonationActionBlocked + | -- | EP-4: @client_credentials@ authentication failed at @POST \/oauth\/token@. Raised for an + -- unknown @client_id@, a wrong secret, a revoked account, and an inactive backing user + -- alike — a revoked credential must be indistinguishable from a wrong one, and account + -- existence must not leak to an unauthenticated caller. + -- + -- The OAuth handler renders this as RFC 6749 §5.2 @invalid_client@ (HTTP 401), NOT through + -- the problem-details envelope; see "Shomei.Servant.OAuth". + OAuthClientInvalid + | -- | EP-4: the @scope@ parameter was present but empty, or requested scopes outside the + -- account's @allowed_scopes@. Rendered as RFC 6749 @invalid_scope@ (HTTP 400). + OAuthScopeInvalid + | -- | EP-6 (RFC 8693 token exchange): the presented @subject_token@ or @actor_token@ failed + -- verification, named an inactive\/absent user, or was itself a delegated token (chained + -- exchanges are refused). Rendered as RFC 6749 @invalid_grant@ (HTTP 400) at + -- @POST \/oauth\/token@; like the other OAuth errors it never reaches the problem envelope. + OAuthGrantInvalid + | -- | EP-6 (RFC 8693 token exchange): the request was structurally wrong for the exchange grant — + -- an unsupported @requested_token_type@, or a @subject_token_type@\/@actor_token_type@ + -- combination that names neither exchange mode. Rendered as RFC 6749 @invalid_request@ (HTTP + -- 400); never reaches the problem envelope. + OAuthRequestMalformed + | -- | The named user does not exist. Raised by the role grant/revoke workflows, which + -- resolve the subject before touching the grant table. Maps to 404. + -- + -- Deliberately NOT used by any authentication path: 'InvalidCredentials' stays the single + -- generic answer there, so account existence is never disclosed to an unauthenticated + -- caller. This constructor is only reachable from already-authorized admin surfaces. + UserNotFound + | -- | A grant named a role absent from the @shomei_roles@ registry. Maps to 422: the request + -- was well-formed but names a role the deployment never declared. Guards against + -- @roles grant --role adminn@ silently minting a role no gate will ever check. + RoleNotDefined Role + | -- | The target is not in a state that permits the requested lifecycle transition — + -- suspending an already-suspended user, reinstating one who was never suspended, deleting a + -- deleted one. Maps to 409. + -- + -- Deliberately not silently idempotent: two administrators acting on one incident must be + -- able to tell which of them changed the state. + InvalidUserStatus + | -- | An admin asked Shōmei to email the target (a password reset) and the target has no + -- address. Maps to 409. + -- + -- A real 409 leaks nothing here, unlike on the public reset endpoint: the caller is an + -- authorized admin who named a user id, not a stranger probing an email. + UserHasNoEmail + | -- | A required dependency could not execute an operation. Public adapters must + -- render this without exposing driver messages, SQL, or connection details. + DependencyUnavailable !AuthDependency + | InternalAuthError Text + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/Id.hs b/src/Shomei/Id.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Id.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Typed, self-describing identifiers for Shōmei domain entities. +-- +-- Each identifier is an 'mmzk-typeid' 'KindID' — a UUIDv7 with a type-level prefix +-- (@user_…@, @session_…@, @refresh_token_…@, @credential_…@). Because the prefix is a +-- type-level 'Symbol', 'UserId' and 'SessionId' are distinct types that cannot be +-- confused. The underlying UUID is stored as a native @uuid@ column in PostgreSQL +-- (EP-3) via 'userIdToUUID' / 'userIdFromUUID' (= 'getUUID' / 'decorateKindID'). +-- +-- The orphan 'FromHttpApiData' / 'ToHttpApiData' instances are required by EP-5's +-- Servant @Capture@s; @mmzk-typeid@ ships JSON instances but not these, and +-- @http-api-data@ is a pure dependency so it is acceptable in the transport-agnostic +-- core. +module Shomei.Id + ( UserId, + SessionId, + RefreshTokenId, + VerificationTokenId, + PasswordResetTokenId, + CredentialId, + PasskeyId, + CeremonyId, + ServiceAccountDbId, + OAuthClientId, + TotpCredentialId, + RecoveryCodeId, + LoginAttemptId, + genUserId, + genSessionId, + genRefreshTokenId, + genVerificationTokenId, + genPasswordResetTokenId, + genCredentialId, + genPasskeyId, + genCeremonyId, + genServiceAccountDbId, + genOAuthClientId, + genTotpCredentialId, + genRecoveryCodeId, + genLoginAttemptId, + idText, + parseId, + userIdToUUID, + userIdFromUUID, + sessionIdToUUID, + sessionIdFromUUID, + refreshTokenIdToUUID, + refreshTokenIdFromUUID, + verificationTokenIdToUUID, + verificationTokenIdFromUUID, + passwordResetTokenIdToUUID, + passwordResetTokenIdFromUUID, + credentialIdToUUID, + credentialIdFromUUID, + passkeyIdToUUID, + passkeyIdFromUUID, + ceremonyIdToUUID, + ceremonyIdFromUUID, + serviceAccountDbIdToUUID, + serviceAccountDbIdFromUUID, + oauthClientIdToUUID, + oauthClientIdFromUUID, + totpCredentialIdToUUID, + totpCredentialIdFromUUID, + recoveryCodeIdToUUID, + recoveryCodeIdFromUUID, + loginAttemptIdToUUID, + loginAttemptIdFromUUID, + ) +where + +import Data.KindID.Class (ToPrefix (..), ValidPrefix) +import Data.KindID.V7 (KindID, decorateKindID, getUUID) +import Data.KindID.V7 qualified as KindID +import Data.Text qualified as Text +import Data.UUID (UUID) +import Shomei.Prelude +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) + +type UserId = KindID "user" + +type SessionId = KindID "session" + +type RefreshTokenId = KindID "refresh_token" + +type VerificationTokenId = KindID "verification_token" + +type PasswordResetTokenId = KindID "password_reset_token" + +type CredentialId = KindID "credential" + +type PasskeyId = KindID "passkey" + +type CeremonyId = KindID "webauthn_ceremony" + +-- | A database-backed service account (EP-4). The @Db@ suffix distinguishes it from the +-- config-side 'Shomei.Config.ServiceAccountId', a newtype over 'Text' naming an account +-- declared in static configuration; the two lifecycles coexist during the deprecation window. +-- +-- Its TypeID text rendering is the OAuth2 @client_id@, so a @client_id@ is a public, +-- copy-pasteable identifier and never a secret. +type ServiceAccountDbId = KindID "svcacct" + +-- | An OAuth2 \/ OIDC client (EP-5): a relying party that drives the authorization-code flow. +-- +-- Its TypeID text rendering is the OAuth2 @client_id@, exactly as 'ServiceAccountDbId'\'s is. +-- The two are distinct types because they name distinct things: a service account /is/ a token +-- subject (it has a backing user row), while an OAuth client only ever acts /for/ one. +type OAuthClientId = KindID "oauthclient" + +-- | A user's TOTP (RFC 6238) credential (EP-7). One per user (@UNIQUE (user_id)@); the id +-- names the row, not a token subject. +type TotpCredentialId = KindID "totp" + +-- | A single-use MFA recovery code (EP-7). The id names the row; the code itself is stored +-- only as a hash. +type RecoveryCodeId = KindID "recovery" + +-- | One persisted credential-proof attempt. The id lets a provisional failure be converted to +-- success without inserting a second row. +type LoginAttemptId = KindID "loginattempt" + +genUserId :: (MonadIO m) => m UserId +genUserId = KindID.genKindID @"user" + +genSessionId :: (MonadIO m) => m SessionId +genSessionId = KindID.genKindID @"session" + +genRefreshTokenId :: (MonadIO m) => m RefreshTokenId +genRefreshTokenId = KindID.genKindID @"refresh_token" + +genVerificationTokenId :: (MonadIO m) => m VerificationTokenId +genVerificationTokenId = KindID.genKindID @"verification_token" + +genPasswordResetTokenId :: (MonadIO m) => m PasswordResetTokenId +genPasswordResetTokenId = KindID.genKindID @"password_reset_token" + +genCredentialId :: (MonadIO m) => m CredentialId +genCredentialId = KindID.genKindID @"credential" + +genPasskeyId :: (MonadIO m) => m PasskeyId +genPasskeyId = KindID.genKindID @"passkey" + +genCeremonyId :: (MonadIO m) => m CeremonyId +genCeremonyId = KindID.genKindID @"webauthn_ceremony" + +genServiceAccountDbId :: (MonadIO m) => m ServiceAccountDbId +genServiceAccountDbId = KindID.genKindID @"svcacct" + +genOAuthClientId :: (MonadIO m) => m OAuthClientId +genOAuthClientId = KindID.genKindID @"oauthclient" + +genTotpCredentialId :: (MonadIO m) => m TotpCredentialId +genTotpCredentialId = KindID.genKindID @"totp" + +genRecoveryCodeId :: (MonadIO m) => m RecoveryCodeId +genRecoveryCodeId = KindID.genKindID @"recovery" + +genLoginAttemptId :: (MonadIO m) => m LoginAttemptId +genLoginAttemptId = KindID.genKindID @"loginattempt" + +idText :: (ToPrefix p, ValidPrefix (PrefixSymbol p)) => KindID p -> Text +idText = KindID.toText + +parseId :: forall p. (ToPrefix p, ValidPrefix (PrefixSymbol p)) => Text -> Either Text (KindID p) +parseId t = case KindID.parseText @p t of + Left e -> Left (Text.pack (show e)) + Right k -> Right k + +userIdToUUID :: UserId -> UUID +userIdToUUID = getUUID + +userIdFromUUID :: UUID -> UserId +userIdFromUUID = decorateKindID + +sessionIdToUUID :: SessionId -> UUID +sessionIdToUUID = getUUID + +sessionIdFromUUID :: UUID -> SessionId +sessionIdFromUUID = decorateKindID + +refreshTokenIdToUUID :: RefreshTokenId -> UUID +refreshTokenIdToUUID = getUUID + +refreshTokenIdFromUUID :: UUID -> RefreshTokenId +refreshTokenIdFromUUID = decorateKindID + +verificationTokenIdToUUID :: VerificationTokenId -> UUID +verificationTokenIdToUUID = getUUID + +verificationTokenIdFromUUID :: UUID -> VerificationTokenId +verificationTokenIdFromUUID = decorateKindID + +passwordResetTokenIdToUUID :: PasswordResetTokenId -> UUID +passwordResetTokenIdToUUID = getUUID + +passwordResetTokenIdFromUUID :: UUID -> PasswordResetTokenId +passwordResetTokenIdFromUUID = decorateKindID + +credentialIdToUUID :: CredentialId -> UUID +credentialIdToUUID = getUUID + +credentialIdFromUUID :: UUID -> CredentialId +credentialIdFromUUID = decorateKindID + +passkeyIdToUUID :: PasskeyId -> UUID +passkeyIdToUUID = getUUID + +passkeyIdFromUUID :: UUID -> PasskeyId +passkeyIdFromUUID = decorateKindID + +ceremonyIdToUUID :: CeremonyId -> UUID +ceremonyIdToUUID = getUUID + +ceremonyIdFromUUID :: UUID -> CeremonyId +ceremonyIdFromUUID = decorateKindID + +serviceAccountDbIdToUUID :: ServiceAccountDbId -> UUID +serviceAccountDbIdToUUID = getUUID + +serviceAccountDbIdFromUUID :: UUID -> ServiceAccountDbId +serviceAccountDbIdFromUUID = decorateKindID + +oauthClientIdToUUID :: OAuthClientId -> UUID +oauthClientIdToUUID = getUUID + +oauthClientIdFromUUID :: UUID -> OAuthClientId +oauthClientIdFromUUID = decorateKindID + +totpCredentialIdToUUID :: TotpCredentialId -> UUID +totpCredentialIdToUUID = getUUID + +totpCredentialIdFromUUID :: UUID -> TotpCredentialId +totpCredentialIdFromUUID = decorateKindID + +recoveryCodeIdToUUID :: RecoveryCodeId -> UUID +recoveryCodeIdToUUID = getUUID + +recoveryCodeIdFromUUID :: UUID -> RecoveryCodeId +recoveryCodeIdFromUUID = decorateKindID + +loginAttemptIdToUUID :: LoginAttemptId -> UUID +loginAttemptIdToUUID = getUUID + +loginAttemptIdFromUUID :: UUID -> LoginAttemptId +loginAttemptIdFromUUID = decorateKindID + +instance (ToPrefix p, ValidPrefix (PrefixSymbol p)) => FromHttpApiData (KindID p) where + parseUrlPiece = parseId + +instance (ToPrefix p, ValidPrefix (PrefixSymbol p)) => ToHttpApiData (KindID p) where + toUrlPiece = idText diff --git a/src/Shomei/Mfa/RecoveryCode/Store.hs b/src/Shomei/Mfa/RecoveryCode/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/RecoveryCode/Store.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Store effect for single-use MFA recovery codes (EP-7). +-- +-- Codes are stored only as hashes. 'ConsumeRecoveryCode' is a compare-and-set — it stamps +-- @used_at@ exactly once, so a double-spend is impossible even under concurrent requests — +-- returning 'True' iff this caller was the one that spent an unused matching code. +-- 'ReplaceRecoveryCodes' deletes the user's existing set and inserts a new one in a single +-- transaction (regeneration invalidates the old codes). +module Shomei.Mfa.RecoveryCode.Store + ( RecoveryCodeStore (..), + replaceRecoveryCodes, + consumeRecoveryCode, + countUnusedRecoveryCodes, + ) +where + +import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Id (UserId) +import Shomei.Mfa.Totp.Domain (NewRecoveryCode) +import Shomei.Prelude + +data RecoveryCodeStore :: Effect where + -- | Atomically replace the user's whole recovery-code set (delete existing, insert new). + ReplaceRecoveryCodes :: UserId -> [NewRecoveryCode] -> RecoveryCodeStore m () + -- | Compare-and-set: spend an unused code whose hash matches. 'True' iff a row was consumed. + ConsumeRecoveryCode :: UserId -> Text -> UTCTime -> RecoveryCodeStore m Bool + CountUnusedRecoveryCodes :: UserId -> RecoveryCodeStore m Int + +type instance DispatchOf RecoveryCodeStore = Dynamic + +replaceRecoveryCodes :: (RecoveryCodeStore :> es) => UserId -> [NewRecoveryCode] -> Eff es () +replaceRecoveryCodes u cs = send (ReplaceRecoveryCodes u cs) + +consumeRecoveryCode :: (RecoveryCodeStore :> es) => UserId -> Text -> UTCTime -> Eff es Bool +consumeRecoveryCode u h t = send (ConsumeRecoveryCode u h t) + +countUnusedRecoveryCodes :: (RecoveryCodeStore :> es) => UserId -> Eff es Int +countUnusedRecoveryCodes = send . CountUnusedRecoveryCodes diff --git a/src/Shomei/Mfa/Totp/Algorithm.hs b/src/Shomei/Mfa/Totp/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/Totp/Algorithm.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DataKinds #-} + +-- | A pure, I/O-free RFC 6238 TOTP primitive, pinned by the RFC's own test vectors. +-- +-- TOTP is HOTP (RFC 4226) applied to time. Let @K@ be a shared secret (20 raw bytes +-- here), @X = 30@ seconds. The time-step counter is @C = floor(unixTime / X)@. The code +-- is @DT(HMAC-SHA1(K, C))@ where @DT@ is RFC 4226 dynamic truncation, taken @mod 10^digits@ +-- and zero-padded. Production fixes @digits = 6@; the vectors in "Shomei.TotpSpec" pin +-- the RFC 6238 Appendix B 8-digit outputs, so 'totpCode' takes @digits@ as a parameter. +-- +-- Base32 comes from @ram@'s 'Data.ByteArray.Encoding' ('Base32' is RFC 4648, uppercase); +-- a 20-byte secret encodes to exactly 32 characters with no padding, so no @base32@ +-- package is needed (see the plan's Decision Log). +module Shomei.Mfa.Totp.Algorithm + ( TotpSecret (..), + totpPeriod, + totpCode, + totpCounter, + verifyTotp, + secretToBase32, + base32ToSecret, + otpauthUri, + ) +where + +import Crypto.Hash.Algorithms (SHA1) +import Crypto.MAC.HMAC (HMAC, hmac) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.ByteArray qualified as BA +import Data.ByteArray.Encoding (Base (Base32), convertFromBase, convertToBase) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Int (Int64) +import Data.List (find) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Word (Word32) +import Shomei.Prelude + +-- | A raw TOTP shared secret: 20 random bytes. The 'Show' instance redacts it — a secret +-- printed to a log or a trace is a secret leaked — and 'Eq' is constant-time. +newtype TotpSecret = TotpSecret ByteString + +instance Show TotpSecret where + show _ = "TotpSecret " + +instance Eq TotpSecret where + TotpSecret a == TotpSecret b = BA.constEq a b + +-- | The TOTP time step, in seconds. Fixed at 30 — the value every mainstream +-- authenticator app assumes (Google Authenticator historically ignores @period@ URI +-- overrides), so it is deliberately not configurable. +totpPeriod :: Int64 +totpPeriod = 30 + +-- | The RFC 6238 time-step counter for an instant: @floor(unixSeconds / 30)@. +totpCounter :: UTCTime -> Int64 +totpCounter t = floor (utcTimeToPOSIXSeconds t) `div` totpPeriod + +-- | Serialize a counter as an 8-byte big-endian integer (RFC 4226 message). +counterBytes :: Int64 -> ByteString +counterBytes c = BS.pack [fromIntegral (c `shiftR` (8 * i)) | i <- [7, 6 .. 0]] + +-- | @totpCode digits secret counter@: HMAC-SHA1 over the counter, RFC 4226 dynamic +-- truncation, reduced @mod 10^digits@ and rendered as exactly @digits@ digits with +-- leading zeros. Production uses @digits = 6@; the RFC vectors use 8. +totpCode :: Int -> TotpSecret -> Int64 -> Text +totpCode digits (TotpSecret key) counter = + let h = BA.convert (hmac key (counterBytes counter) :: HMAC SHA1) :: ByteString + -- low 4 bits of the last byte give the truncation offset (0..15) + offset = fromIntegral (BS.index h 19 .&. 0x0f) :: Int + binCode :: Word32 + binCode = + ((fromIntegral (BS.index h offset) .&. 0x7f) `shiftL` 24) + .|. (fromIntegral (BS.index h (offset + 1)) `shiftL` 16) + .|. (fromIntegral (BS.index h (offset + 2)) `shiftL` 8) + .|. fromIntegral (BS.index h (offset + 3)) + value = binCode `mod` (10 ^ digits) + in Text.justifyRight digits '0' (Text.pack (show value)) + +-- | @verifyTotp secret lastUsedCounter now presented@: try the counters +-- @[c-1, c, c+1]@ (a ±1 step acceptance window, tolerating ~30 s of clock skew each way) +-- and return @Just acceptedCounter@ for the first that both matches the presented +-- 6-digit code AND is strictly greater than @lastUsedCounter@ (a 'Nothing' bound accepts +-- any counter). The strictly-greater rule is RFC 6238 §5.2 replay defense: a verified code +-- is never accepted twice. Code comparison is constant-time. +verifyTotp :: TotpSecret -> Maybe Int64 -> UTCTime -> Text -> Maybe Int64 +verifyTotp secret lastUsed now presented = + find matches [c - 1, c, c + 1] + where + c = totpCounter now + matches ctr = + maybe True (ctr >) lastUsed + && BA.constEq (TE.encodeUtf8 (totpCode 6 secret ctr)) (TE.encodeUtf8 presented) + +-- | RFC 4648 Base32 (uppercase, unpadded for a 20-byte secret) — the form authenticator +-- apps expect for the shared secret. +secretToBase32 :: TotpSecret -> Text +secretToBase32 (TotpSecret k) = TE.decodeUtf8 (convertToBase Base32 k) + +-- | Inverse of 'secretToBase32'; used by tests to prove the round-trip. +base32ToSecret :: Text -> Either String TotpSecret +base32ToSecret t = + TotpSecret <$> (convertFromBase Base32 (TE.encodeUtf8 t) :: Either String ByteString) + +-- | The enrollment URI authenticator apps scan: +-- @otpauth:\/\/totp\/{issuer}:{account}?secret={BASE32(K)}&issuer={issuer}@. Callers pass +-- label-safe @issuerLabel@ and @accountLabel@ (the workflow sanitizes them). +otpauthUri :: Text -> Text -> TotpSecret -> Text +otpauthUri issuerLabel accountLabel secret = + "otpauth://totp/" + <> issuerLabel + <> ":" + <> accountLabel + <> "?secret=" + <> secretToBase32 secret + <> "&issuer=" + <> issuerLabel diff --git a/src/Shomei/Mfa/Totp/Domain.hs b/src/Shomei/Mfa/Totp/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/Totp/Domain.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DataKinds #-} + +-- | Domain types for the EP-7 TOTP credential and recovery-code stores. +-- +-- A 'TotpCredential' carries the /raw/ 'TotpSecret' (Decision Log: encryption lives at the +-- PostgreSQL interpreter boundary, never in the workflows or the port). These types are +-- persisted through native columns (@bytea@ for the encrypted secret, @text@ for a recovery +-- code hash), not JSON, so — unlike 'Shomei.Passkey.Domain' — they carry no aeson instances; +-- the raw 'TotpSecret' has no JSON representation by design. +module Shomei.Mfa.Totp.Domain + ( NewTotpCredential (..), + TotpCredential (..), + NewRecoveryCode (..), + RecoveryCode (..), + isTotpConfirmed, + ) +where + +import Data.Int (Int64) +import Shomei.Id (RecoveryCodeId, TotpCredentialId, UserId) +import Shomei.Mfa.Totp.Algorithm (TotpSecret) +import Shomei.Prelude + +-- | A freshly generated (unconfirmed) TOTP enrollment, ready for the store to persist. +data NewTotpCredential = NewTotpCredential + { totpCredentialId :: !TotpCredentialId, + userId :: !UserId, + secret :: !TotpSecret, + createdAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + +-- | A persisted TOTP credential. @confirmedAt = Nothing@ marks an enrollment that has not yet +-- been activated with a first valid code; @lastUsedCounter@ is the replay-defense high-water +-- mark (RFC 6238 §5.2), 'Nothing' until the first acceptance. +data TotpCredential = TotpCredential + { totpCredentialId :: !TotpCredentialId, + userId :: !UserId, + secret :: !TotpSecret, + lastUsedCounter :: !(Maybe Int64), + confirmedAt :: !(Maybe UTCTime), + createdAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + +-- | One recovery code to persist: only its hash is stored (the plaintext is shown to the user +-- once and never again). +data NewRecoveryCode = NewRecoveryCode + { recoveryCodeId :: !RecoveryCodeId, + codeHash :: !Text, + createdAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + +-- | A persisted recovery code. @usedAt = Nothing@ marks it still spendable; consumption is a +-- compare-and-set that stamps @usedAt@ exactly once. +data RecoveryCode = RecoveryCode + { recoveryCodeId :: !RecoveryCodeId, + userId :: !UserId, + codeHash :: !Text, + createdAt :: !UTCTime, + usedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) + +-- | Whether a credential has been activated with a first valid code. A 'DuplicateRecordFields' +-- record's @.confirmedAt@ dot access is ambiguous at call sites that do not fix the type, so +-- this named predicate is the canonical read. +isTotpConfirmed :: TotpCredential -> Bool +isTotpConfirmed TotpCredential {confirmedAt} = isJust confirmedAt diff --git a/src/Shomei/Mfa/Totp/Store.hs b/src/Shomei/Mfa/Totp/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/Totp/Store.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Store effect for a user's TOTP (RFC 6238) credential (EP-7). +-- +-- One credential per user (@UNIQUE (user_id)@). The port speaks in /raw/ 'TotpSecret's; the +-- PostgreSQL interpreter encrypts on the way in and decrypts on the way out (AES-256-GCM), +-- while the in-memory interpreter holds the raw bytes. 'UpsertTotpEnrollment' replaces an +-- existing /unconfirmed/ enrollment (re-scanning the QR); refusing to overwrite a /confirmed/ +-- credential is the workflow's job, not the store's. +module Shomei.Mfa.Totp.Store + ( TotpCredentialStore (..), + upsertTotpEnrollment, + findTotpByUser, + confirmTotp, + setTotpLastUsedCounter, + deleteTotpByUser, + ) +where + +import Data.Int (Int64) +import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Id (TotpCredentialId, UserId) +import Shomei.Mfa.Totp.Domain (NewTotpCredential, TotpCredential) +import Shomei.Prelude + +data TotpCredentialStore :: Effect where + -- | Insert the enrollment, replacing any existing (unconfirmed) row for the user. + UpsertTotpEnrollment :: NewTotpCredential -> TotpCredentialStore m TotpCredential + FindTotpByUser :: UserId -> TotpCredentialStore m (Maybe TotpCredential) + -- | Mark the credential confirmed (activated) at the given time. + ConfirmTotp :: TotpCredentialId -> UTCTime -> TotpCredentialStore m () + -- | Advance the replay-defense high-water counter only when the supplied value is newer. + -- 'False' means another request already accepted this counter (or a later one). + SetTotpLastUsedCounter :: TotpCredentialId -> Int64 -> TotpCredentialStore m Bool + DeleteTotpByUser :: UserId -> TotpCredentialStore m () + +type instance DispatchOf TotpCredentialStore = Dynamic + +upsertTotpEnrollment :: (TotpCredentialStore :> es) => NewTotpCredential -> Eff es TotpCredential +upsertTotpEnrollment = send . UpsertTotpEnrollment + +findTotpByUser :: (TotpCredentialStore :> es) => UserId -> Eff es (Maybe TotpCredential) +findTotpByUser = send . FindTotpByUser + +confirmTotp :: (TotpCredentialStore :> es) => TotpCredentialId -> UTCTime -> Eff es () +confirmTotp i t = send (ConfirmTotp i t) + +setTotpLastUsedCounter :: (TotpCredentialStore :> es) => TotpCredentialId -> Int64 -> Eff es Bool +setTotpLastUsedCounter i c = send (SetTotpLastUsedCounter i c) + +deleteTotpByUser :: (TotpCredentialStore :> es) => UserId -> Eff es () +deleteTotpByUser = send . DeleteTotpByUser diff --git a/src/Shomei/Mfa/Totp/Workflow.hs b/src/Shomei/Mfa/Totp/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/Totp/Workflow.hs @@ -0,0 +1,254 @@ +-- | The TOTP enrollment / removal and recovery-code generation workflows (EP-7). +-- +-- These are the caller-facing counterparts to 'Shomei.Mfa.Workflow', which completes a login +-- with a TOTP or recovery-code factor. Enrollment is two-step: 'enrollTotp' mints a secret (shown +-- once) and 'verifyTotpEnrollment' activates it with a first valid code. 'removeTotp' downgrades +-- the factor, gated on proof of possession. 'regenerateRecoveryCodes' issues a fresh single-use +-- set, invalidating any previous one. +-- +-- The recovery-code hash is centralized in 'recoveryCodeHash' so this module and +-- 'Shomei.Mfa.Workflow' (which consumes codes) cannot drift on normalization. +module Shomei.Mfa.Totp.Workflow + ( TotpEnrollment (..), + TotpRemovalProof (..), + enrollTotp, + verifyTotpEnrollment, + removeTotp, + regenerateRecoveryCodes, + recoveryCodeSetSize, + recoveryCodeHash, + ) +where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Int (Int64) +import Data.Text qualified as Text +import Data.Time (addUTCTime) +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (runErrorNoCallStack, throwError) +import Shomei.Account.LoginId.Domain (loginIdText) +import Shomei.Account.User.Domain (User (..)) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Authorization.Claims.Domain (Issuer (..)) +import Shomei.Config (ShomeiConfig (..), TotpConfig (..)) +import Shomei.Error (AuthError (..)) +import Shomei.Id (TotpCredentialId, genRecoveryCodeId, genTotpCredentialId) +import Shomei.Mfa.RecoveryCode.Store (RecoveryCodeStore, consumeRecoveryCode, replaceRecoveryCodes) +import Shomei.Mfa.Totp.Algorithm (TotpSecret (..), secretToBase32, verifyTotp) +import Shomei.Mfa.Totp.Algorithm qualified as Totp +import Shomei.Mfa.Totp.Domain (NewRecoveryCode (..), NewTotpCredential (..), TotpCredential (..)) +import Shomei.Mfa.Totp.Store + ( TotpCredentialStore, + confirmTotp, + deleteTotpByUser, + findTotpByUser, + setTotpLastUsedCounter, + upsertTotpEnrollment, + ) +import Shomei.Prelude +import Shomei.ServiceAccount.Secret (sha256Hex) +import Shomei.Session.Command (ProofContext, proofContextFor) +import Shomei.Session.LoginAttempt.Domain (AttemptFactor (..)) +import Shomei.Session.LoginAttempt.Store (LoginAttemptStore) +import Shomei.Session.LoginAttempt.Workflow (AbuseGate (..), guardAbuse, recordProofFailure, recordProofSuccess) +import Shomei.Session.Token.Generator (TokenGen, generateRandomBytes) +import Shomei.Time.Store (Clock, now) + +-- | The one-time enrollment payload: the Base32 secret to type/scan and the @otpauth://@ URI. +data TotpEnrollment = TotpEnrollment + { secretBase32 :: !Text, + otpauthUri :: !Text + } + deriving stock (Generic, Eq, Show) + +-- | Proof presented to remove the TOTP factor: a currently valid code, or an unused recovery code. +data TotpRemovalProof + = RemoveWithCode Text + | RemoveWithRecoveryCode Text + deriving stock (Generic, Eq, Show) + +-- | Ten codes per generated set — the de-facto industry shape. +recoveryCodeSetSize :: Int +recoveryCodeSetSize = 10 + +-- | The stored hash of a recovery code: normalize (strip the dash, casefold) then SHA-256 hex. +-- The single definition both the generator here and the consumer in 'Shomei.Mfa.Workflow' use. +recoveryCodeHash :: Text -> Text +recoveryCodeHash = sha256Hex . Text.toLower . Text.filter (/= '-') + +-- Field accessors (DuplicateRecordFields make @value.field@ unreliable). +tcId :: TotpCredential -> TotpCredentialId +tcId TotpCredential {totpCredentialId} = totpCredentialId + +-- | Enroll (start) TOTP: mint a fresh 20-byte secret and persist it unconfirmed, replacing any +-- prior unconfirmed enrollment. Refuses when TOTP is disabled or a /confirmed/ credential +-- already exists (remove it first). The secret is returned once, never retrievable again; the +-- 'Event.TotpEnrolled' audit event fires only on confirmation ('verifyTotpEnrollment'). +enrollTotp :: + (TotpCredentialStore :> es, TokenGen :> es, Clock :> es, IOE :> es) => + ShomeiConfig -> + User -> + Eff es (Either AuthError TotpEnrollment) +enrollTotp cfg user = runErrorNoCallStack do + unless (totpEnabled (totpConfig cfg)) (throwError TotpDisabled) + ts <- now + let User {userId = uid} = user + existing <- findTotpByUser uid + when (maybe False confirmed existing) (throwError TotpAlreadyEnrolled) + secretBytes <- generateRandomBytes 20 + let secret = TotpSecret secretBytes + tcid <- genTotpCredentialId + _ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = uid, secret, createdAt = ts} + pure + TotpEnrollment + { secretBase32 = secretToBase32 secret, + otpauthUri = Totp.otpauthUri (issuerLabel cfg) (accountLabel user) secret + } + +-- | Activate a pending enrollment with a first valid code. Loads the unconfirmed, unexpired +-- enrollment (else 'TotpEnrollmentNotFound'), verifies the code (with no replay bound — this is +-- the first use), and on success confirms it and consumes that code's counter. A wrong code +-- publishes 'MfaFailed' and returns 'TotpCodeInvalid'. +verifyTotpEnrollment :: + (TotpCredentialStore :> es, AuthEventPublisher :> es, Clock :> es) => + ShomeiConfig -> + User -> + Text -> + Eff es (Either AuthError ()) +verifyTotpEnrollment cfg user code = runErrorNoCallStack do + unless (totpEnabled (totpConfig cfg)) (throwError TotpDisabled) + ts <- now + let User {userId = uid} = user + existing <- findTotpByUser uid + cred <- case existing of + Just c | not (confirmed c), not (enrollmentExpired cfg ts c) -> pure c + _ -> throwError TotpEnrollmentNotFound + case verifyTotp (secretOf cred) Nothing ts code of + Just accepted -> do + confirmTotp (tcId cred) ts + won <- setTotpLastUsedCounter (tcId cred) accepted + unless won do + publishAuthEvent (Event.MfaFailed (Event.MfaFailedData (Just uid) "totp_replayed" ts)) + throwError TotpCodeInvalid + publishAuthEvent (Event.TotpEnrolled (Event.TotpEnrolledData uid ts)) + Nothing -> do + publishAuthEvent (Event.MfaFailed (Event.MfaFailedData (Just uid) "totp_invalid" ts)) + throwError TotpCodeInvalid + +-- | Remove the TOTP factor, gated on proof of possession: a currently valid code, or an unused +-- recovery code (which is consumed). Refuses when no credential exists ('TotpEnrollmentNotFound') +-- or the proof fails ('TotpCodeInvalid' / 'RecoveryCodeInvalid'). Publishes 'Event.TotpRemoved'. +removeTotp :: + ( TotpCredentialStore :> es, + RecoveryCodeStore :> es, + AuthEventPublisher :> es, + LoginAttemptStore :> es, + Clock :> es + ) => + ShomeiConfig -> + ProofContext -> + User -> + TotpRemovalProof -> + Eff es (Either AuthError ()) +removeTotp cfg pctx user proof = runErrorNoCallStack do + ts <- now + let User {userId = uid} = user + ctx = proofContextFor pctx (loginIdText user.loginId) + factor = case proof of + RemoveWithCode _ -> FactorTotp + RemoveWithRecoveryCode _ -> FactorRecoveryCode + proofError = case proof of + RemoveWithCode _ -> TotpCodeInvalid + RemoveWithRecoveryCode _ -> RecoveryCodeInvalid + gate <- guardAbuse cfg.rateLimitConfig ctx ts + when gate.locked do + publishAuthEvent (Event.MfaFailed (Event.MfaFailedData (Just uid) "account_locked" ts)) + throwError proofError + cred <- maybe (throwError TotpEnrollmentNotFound) pure =<< findTotpByUser uid + case proof of + RemoveWithCode code -> + case verifyTotp (secretOf cred) (lastUsedOf cred) ts code of + Just accepted -> do + won <- setTotpLastUsedCounter (tcId cred) accepted + unless won do + recordProofFailure cfg.rateLimitConfig ctx FactorTotp ts + publishAuthEvent (Event.MfaFailed (Event.MfaFailedData (Just uid) "totp_replayed" ts)) + throwError TotpCodeInvalid + Nothing -> do + recordProofFailure cfg.rateLimitConfig ctx FactorTotp ts + publishAuthEvent (Event.MfaFailed (Event.MfaFailedData (Just uid) "totp_invalid" ts)) + throwError TotpCodeInvalid + RemoveWithRecoveryCode rc -> do + ok <- consumeRecoveryCode uid (recoveryCodeHash rc) ts + if ok + then publishAuthEvent (Event.RecoveryCodeUsed (Event.RecoveryCodeUsedData uid ts)) + else do + recordProofFailure cfg.rateLimitConfig ctx FactorRecoveryCode ts + publishAuthEvent (Event.MfaFailed (Event.MfaFailedData (Just uid) "recovery_invalid" ts)) + throwError RecoveryCodeInvalid + recordProofSuccess ctx factor gate.standingLockout ts + deleteTotpByUser uid + publishAuthEvent (Event.TotpRemoved (Event.TotpRemovedData uid ts)) + +-- | Generate a fresh set of 'recoveryCodeSetSize' single-use codes, replacing any previous set, +-- and return the plaintext codes (shown once). Codes back up passkey-only users too, so this is +-- allowed whether or not TOTP is enrolled. +regenerateRecoveryCodes :: + (RecoveryCodeStore :> es, TokenGen :> es, AuthEventPublisher :> es, Clock :> es, IOE :> es) => + ShomeiConfig -> + User -> + Eff es (Either AuthError [Text]) +regenerateRecoveryCodes _cfg user = runErrorNoCallStack do + ts <- now + let User {userId = uid} = user + codes <- forM [1 .. recoveryCodeSetSize] \_ -> formatRecoveryCode <$> generateRandomBytes 10 + ids <- forM [1 .. recoveryCodeSetSize] \_ -> genRecoveryCodeId + let rows = + zipWith + (\rid code -> NewRecoveryCode {recoveryCodeId = rid, codeHash = recoveryCodeHash code, createdAt = ts}) + ids + codes + replaceRecoveryCodes uid rows + publishAuthEvent (Event.RecoveryCodesGenerated (Event.RecoveryCodesGeneratedData uid recoveryCodeSetSize ts)) + pure codes + +-- Helpers -------------------------------------------------------------------- + +confirmed :: TotpCredential -> Bool +confirmed TotpCredential {confirmedAt} = isJust confirmedAt + +secretOf :: TotpCredential -> TotpSecret +secretOf TotpCredential {secret} = secret + +lastUsedOf :: TotpCredential -> Maybe Int64 +lastUsedOf TotpCredential {lastUsedCounter} = lastUsedCounter + +-- | An unconfirmed enrollment older than @totpConfig.enrollmentTTL@ is treated as absent. +enrollmentExpired :: ShomeiConfig -> UTCTime -> TotpCredential -> Bool +enrollmentExpired cfg ts TotpCredential {createdAt} = + addUTCTime (enrollmentTTL (totpConfig cfg)) createdAt <= ts + +-- | The issuer label for the @otpauth://@ URI, made label-safe (@:@ and @/@ break the URI). +issuerLabel :: ShomeiConfig -> Text +issuerLabel cfg = case cfg.issuer of + Issuer t -> labelSafe t + +-- | The account label: the user's login identifier, made label-safe. +accountLabel :: User -> Text +accountLabel User {loginId} = labelSafe (loginIdText loginId) + +labelSafe :: Text -> Text +labelSafe = Text.map (\c -> if c == ':' || c == '/' then '_' else c) + +-- | Format 10 random bytes as a @XXXXX-XXXXX@ code over the Crockford Base32 alphabet (no +-- ambiguous characters for codes users type by hand). +formatRecoveryCode :: ByteString -> Text +formatRecoveryCode bytes = + let chars = [Text.index crockford (fromIntegral b `mod` 32) | b <- BS.unpack bytes] + (a, b) = splitAt 5 chars + in Text.pack a <> "-" <> Text.pack b + +crockford :: Text +crockford = "0123456789ABCDEFGHJKMNPQRSTVWXYZ" diff --git a/src/Shomei/Mfa/Workflow.hs b/src/Shomei/Mfa/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/Workflow.hs @@ -0,0 +1,430 @@ +-- | The second-factor (MFA step-up) and passwordless passkey login workflows (EP-4). +-- +-- 'prepareMfaChallenge' is the step-up branch of 'Shomei.Session.Authentication.Workflow.login': after a correct +-- password for an account that has a second factor (and MFA is required), it begins a WebAuthn +-- authentication ceremony restricted to the user's credentials, stashes it consume-once, and +-- returns the ceremony id + browser options WITHOUT issuing a token. 'completeMfa' finishes +-- that step-up: it consumes the pending ceremony, verifies the browser's assertion against the +-- user's stored passkey, and mints the session/tokens. 'beginPasswordlessLogin' / +-- 'completePasswordlessLogin' authenticate with the passkey ALONE (no password): begin emits +-- options for a discoverable credential, complete resolves the account from the asserted +-- credential id, verifies, and mints tokens. +-- +-- All token-minting paths share 'Shomei.Session.Workflow.issueSession' so the tail never +-- drifts. The EP-1 passkey/ceremony records are read via plain record-pattern matching, not +-- @value.field@ dot syntax, because @OverloadedRecordDot@/@HasField@ is unreliable for those +-- @DuplicateRecordFields@ records (a MasterPlan-3 discovery). +module Shomei.Mfa.Workflow + ( prepareMfaChallenge, + completeMfa, + MfaCompletion (..), + beginPasswordlessLogin, + completePasswordlessLogin, + ) +where + +import Data.Aeson (Value, object) +import Data.Aeson.Types (parseMaybe, withObject, (.:)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Time (addUTCTime) +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error, runErrorNoCallStack, throwError) +import Shomei.Account.LoginId.Domain (loginIdText) +import Shomei.Account.User.Domain (User (..), UserStatus (UserActive)) +import Shomei.Account.User.Store (UserStore, findUserById) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Authorization.Claims.Store (ClaimsEnricher) +import Shomei.Authorization.Role.Store (RoleStore) +import Shomei.Config (ShomeiConfig (..), UserVerificationPolicy (UVRequired), WebAuthnConfig (..)) +import Shomei.Error (AuthError (..)) +import Shomei.Id (CeremonyId, UserId, genCeremonyId) +import Shomei.Mfa.RecoveryCode.Store (RecoveryCodeStore, consumeRecoveryCode, countUnusedRecoveryCodes) +import Shomei.Mfa.Totp.Algorithm (verifyTotp) +import Shomei.Mfa.Totp.Domain (TotpCredential (..)) +import Shomei.Mfa.Totp.Store (TotpCredentialStore, findTotpByUser, setTotpLastUsedCounter) +import Shomei.Mfa.Totp.Workflow (recoveryCodeHash) +import Shomei.Passkey.Ceremony.Port + ( BeginCeremony (..), + StoredCredentialForVerify (..), + VerifiedAuthentication (..), + WebAuthnCeremony, + beginAuthenticationCeremony, + completeAuthenticationCeremony, + ) +import Shomei.Passkey.Ceremony.Store (PendingCeremonyStore, putPendingCeremony, takePendingCeremony) +import Shomei.Passkey.Domain + ( CeremonyKind (AuthenticationCeremony), + PasskeyCredential (..), + PendingCeremony (..), + WebAuthnCredentialId (..), + b64urlEncode, + ) +import Shomei.Passkey.Store + ( PasskeyStore, + findPasskeyByCredentialId, + findPasskeysByUser, + updatePasskeySignCounter, + ) +import Shomei.Prelude +import Shomei.Session.Command (ProofContext, proofContextFor) +import Shomei.Session.LoginAttempt.Domain (AttemptFactor (..)) +import Shomei.Session.LoginAttempt.Store (LoginAttemptStore) +import Shomei.Session.LoginAttempt.Workflow (AbuseGate (..), guardAbuse, recordProofFailure, recordProofSuccess) +import Shomei.Session.Token.Domain (TokenPair) +import Shomei.Session.Token.Generator (TokenGen) +import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork) +import Shomei.Session.Workflow (ensureEmailVerified, issueSession) +import Shomei.SigningKey.Signer (TokenSigner) +import Shomei.Time.Store (Clock, now) + +-- | How a client completes an MFA challenge. Exactly one arm is populated by the HTTP layer's +-- 'Shomei.Mfa.Dto.MfaCompleteRequest' decoder: 'MfaPasskey' is a WebAuthn assertion, +-- 'MfaTotp' a six-digit code, 'MfaRecoveryCode' a single-use recovery code. +data MfaCompletion + = MfaPasskey Value + | MfaTotp Text + | MfaRecoveryCode Text + deriving stock (Generic, Eq, Show) + +-- Field accessors for the TOTP credential (DuplicateRecordFields make @value.field@ unreliable). +totpConfirmed :: TotpCredential -> Bool +totpConfirmed TotpCredential {confirmedAt} = isJust confirmedAt + +-- | The step-up branch of 'Shomei.Session.Authentication.Workflow.login'. Begins a WebAuthn authentication +-- ceremony whose @allowCredentials@ is restricted to this user's enrolled passkeys, stashes +-- the consume-once pending ceremony (bound to the user, expiring after the configured TTL), +-- publishes 'MfaChallenged', and returns the ceremony id + the browser-facing options. NO +-- token is issued: the caller returns this as the @mfa_required@ outcome. +prepareMfaChallenge :: + ( PasskeyStore :> es, + PendingCeremonyStore :> es, + WebAuthnCeremony :> es, + TotpCredentialStore :> es, + RecoveryCodeStore :> es, + AuthEventPublisher :> es, + IOE :> es + ) => + ShomeiConfig -> + User -> + UTCTime -> + Eff es (CeremonyId, Value, [Text]) +prepareMfaChallenge cfg user ts = do + let User {userId = uid} = user + creds <- findPasskeysByUser uid + mTotp <- findTotpByUser uid + unusedRecovery <- countUnusedRecoveryCodes uid + let hasPasskey = not (null creds) + hasTotp = maybe False totpConfirmed mTotp + methods = + ["passkey" | hasPasskey] + <> ["totp" | hasTotp] + <> ["recovery_code" | unusedRecovery > 0] + -- Passkey-holders get a real WebAuthn ceremony (options carry the challenge); a TOTP-only + -- user gets an empty options object and no ceremony call — the empty @optionsBlob@ is what + -- 'completeMfa' checks to refuse a passkey assertion for a challenge that never began one. + (optionsJson, optionsBlob) <- + if hasPasskey + then do + let allowIds = map (\PasskeyCredential {credentialId} -> credentialId) creds + BeginCeremony {optionsJson, optionsBlob} <- + beginAuthenticationCeremony (userVerification (webauthnConfig cfg)) allowIds + pure (optionsJson, optionsBlob) + else pure (object [], BS.empty) + cid <- genCeremonyId + putPendingCeremony + PendingCeremony + { ceremonyId = cid, + userId = Just uid, + kind = AuthenticationCeremony, + optionsBlob = optionsBlob, + createdAt = ts, + expiresAt = addUTCTime (pendingCeremonyTTL (webauthnConfig cfg)) ts + } + publishAuthEvent (Event.MfaChallenged (Event.MfaChallengedData uid cid ts)) + pure (cid, optionsJson, methods) + +-- | Finish a password-then-passkey step-up. The client posts the ceremony id from the +-- 'MfaRequired' challenge plus the browser's signed assertion. We consume the pending ceremony +-- (rejecting a missing/expired/consumed/non-authentication/no-user ceremony with a 404-mapped +-- 'PendingCeremonyNotFound'), verify the assertion against the user's stored passkey, confirm +-- the asserted credential is owned by that user, bump the sign counter, publish 'MfaSucceeded', +-- and mint tokens via the shared 'issueSession'. A verification failure publishes 'MfaFailed' +-- and returns 'MfaAssertionInvalid'. +completeMfa :: + ( UserStore :> es, + AuthUnitOfWork :> es, + PasskeyStore :> es, + PendingCeremonyStore :> es, + WebAuthnCeremony :> es, + TotpCredentialStore :> es, + RecoveryCodeStore :> es, + TokenSigner :> es, + RoleStore :> es, + ClaimsEnricher :> es, + AuthEventPublisher :> es, + LoginAttemptStore :> es, + Clock :> es, + TokenGen :> es + ) => + ShomeiConfig -> + ProofContext -> + CeremonyId -> + MfaCompletion -> + Eff es (Either AuthError (User, TokenPair)) +completeMfa cfg pctx ceremonyId completion = runErrorNoCallStack do + ts <- now + PendingCeremony {kind, userId = mUid, optionsBlob} <- + maybe (throwError PendingCeremonyNotFound) pure =<< takePendingCeremony ceremonyId ts + when (kind /= AuthenticationCeremony) (throwError PendingCeremonyNotFound) + uid <- maybe (throwError PendingCeremonyNotFound) pure mUid + user <- maybe (throwError InvalidCredentials) pure =<< findUserById uid + let User {status = userStatus} = user + when (userStatus /= UserActive) (throwError UserNotActive) + -- 'login' already gates before handing out a ceremony id, so this rarely fires; it keeps + -- the guarantee local to every path that can issue a token. + either throwError pure (ensureEmailVerified cfg user) + let ctx = proofContextFor pctx (loginIdText user.loginId) + factor = completionFactor completion + failure = recordProofFailure cfg.rateLimitConfig ctx factor ts + gate <- guardAbuse cfg.rateLimitConfig ctx ts + when gate.locked do + publishAuthEvent (Event.MfaFailed (Event.MfaFailedData (Just uid) "account_locked" ts)) + throwError (completionError completion) + -- Each arm proves the factor (spending the consume-once ceremony on any outcome); all three + -- converge on the shared 'issueSession' tail. + case completion of + MfaPasskey assertion -> do + -- The ceremony must have begun a WebAuthn challenge; a TOTP-only user's empty blob cannot + -- carry an assertion, so refuse it rather than let the ceremony interpreter fail obscurely. + when (BS.null optionsBlob) (failMfa failure (Just uid) "no passkey ceremony was begun") + (passkey, verified) <- verifyAssertion failure (Just uid) optionsBlob assertion + let PasskeyCredential {userId = pkUid, passkeyId} = passkey + VerifiedAuthentication {newSignCounter} = verified + when (pkUid /= uid) (failMfa failure (Just uid) "credential not owned by user") + won <- updatePasskeySignCounter passkeyId newSignCounter ts + unless won (failMfa failure (Just uid) "signature counter replayed") + MfaTotp code -> completeTotp failure uid ts code + MfaRecoveryCode code -> completeRecovery failure uid ts code + recordProofSuccess ctx factor gate.standingLockout ts + (sid, pair) <- issueSession cfg user ts + publishAuthEvent (Event.MfaSucceeded (Event.MfaSucceededData uid sid ts)) + pure (user, pair) + +-- | Verify a presented TOTP code against the user's /confirmed/ credential and persist the +-- accepted counter (RFC 6238 replay defense). Any failure — no credential, unconfirmed, wrong +-- code, replayed counter — publishes 'MfaFailed' and throws 'TotpCodeInvalid'. +completeTotp :: + (TotpCredentialStore :> es, AuthEventPublisher :> es, Error AuthError :> es) => + Eff es () -> + UserId -> + UTCTime -> + Text -> + Eff es () +completeTotp onFailure uid ts code = do + mtc <- findTotpByUser uid + case mtc of + Just TotpCredential {totpCredentialId, secret, lastUsedCounter, confirmedAt} + | isJust confirmedAt -> + case verifyTotp secret lastUsedCounter ts code of + Just accepted -> do + won <- setTotpLastUsedCounter totpCredentialId accepted + unless won (failTyped onFailure (Just uid) "totp_replayed" TotpCodeInvalid ts) + Nothing -> failTyped onFailure (Just uid) "totp_invalid" TotpCodeInvalid ts + _ -> failTyped onFailure (Just uid) "totp_invalid" TotpCodeInvalid ts + +-- | Spend a recovery code to complete the challenge: normalize (strip the dash, casefold), hash, +-- and consume via the store's compare-and-set. Success publishes 'RecoveryCodeUsed'; a miss +-- publishes 'MfaFailed' and throws 'RecoveryCodeInvalid'. +completeRecovery :: + (RecoveryCodeStore :> es, AuthEventPublisher :> es, Error AuthError :> es) => + Eff es () -> + UserId -> + UTCTime -> + Text -> + Eff es () +completeRecovery onFailure uid ts code = do + ok <- consumeRecoveryCode uid (recoveryCodeHash code) ts + if ok + then publishAuthEvent (Event.RecoveryCodeUsed (Event.RecoveryCodeUsedData uid ts)) + else failTyped onFailure (Just uid) "recovery_invalid" RecoveryCodeInvalid ts + +-- | Publish 'MfaFailed' with the reason (recorded only in the audit event) and abort with a +-- specific typed error. Unlike 'failMfa' (which always throws the generic 'MfaAssertionInvalid'), +-- this lets the TOTP and recovery arms surface their own machine codes. +failTyped :: + (AuthEventPublisher :> es, Error AuthError :> es) => + Eff es () -> + Maybe UserId -> + Text -> + AuthError -> + UTCTime -> + Eff es a +failTyped onFailure mUid reason err ts = do + onFailure + publishAuthEvent (Event.MfaFailed (Event.MfaFailedData mUid reason ts)) + throwError err + +-- | Begin a passwordless login: emit authentication options with NO @allowCredentials@ so +-- the browser offers its discoverable passkeys, stash the pending ceremony with no user +-- attached, and hand the client the ceremony id + options. +beginPasswordlessLogin :: + ( PendingCeremonyStore :> es, + WebAuthnCeremony :> es, + Clock :> es, + IOE :> es + ) => + ShomeiConfig -> + Eff es (Either AuthError (CeremonyId, Value)) +beginPasswordlessLogin cfg = runErrorNoCallStack do + ts <- now + BeginCeremony {optionsJson, optionsBlob} <- beginAuthenticationCeremony UVRequired [] + cid <- genCeremonyId + putPendingCeremony + PendingCeremony + { ceremonyId = cid, + userId = Nothing, + kind = AuthenticationCeremony, + optionsBlob = optionsBlob, + createdAt = ts, + expiresAt = addUTCTime (pendingCeremonyTTL (webauthnConfig cfg)) ts + } + pure (cid, optionsJson) + +-- | Finish a passwordless login: consume the pending ceremony, resolve the user from the +-- asserted credential id (via 'findPasskeyByCredentialId', whose result carries the owning +-- user), verify, bump the counter, publish 'MfaSucceeded', and mint tokens. +completePasswordlessLogin :: + ( UserStore :> es, + AuthUnitOfWork :> es, + PasskeyStore :> es, + PendingCeremonyStore :> es, + WebAuthnCeremony :> es, + TokenSigner :> es, + RoleStore :> es, + ClaimsEnricher :> es, + AuthEventPublisher :> es, + LoginAttemptStore :> es, + Clock :> es, + TokenGen :> es + ) => + ShomeiConfig -> + ProofContext -> + CeremonyId -> + Value -> + Eff es (Either AuthError (User, TokenPair)) +completePasswordlessLogin cfg pctx ceremonyId assertion = runErrorNoCallStack do + ts <- now + PendingCeremony {kind, optionsBlob} <- + maybe (throwError PendingCeremonyNotFound) pure =<< takePendingCeremony ceremonyId ts + when (kind /= AuthenticationCeremony) (throwError PendingCeremonyNotFound) + let failureCtx = proofContextFor pctx (assertionAccountKey assertion) + failure = recordProofFailure cfg.rateLimitConfig failureCtx FactorPasskey ts + failureGate <- guardAbuse cfg.rateLimitConfig failureCtx ts + when failureGate.locked do + publishAuthEvent (Event.MfaFailed (Event.MfaFailedData Nothing "account_locked" ts)) + throwError MfaAssertionInvalid + (passkey, verified) <- verifyAssertion failure Nothing optionsBlob assertion + let PasskeyCredential {userId = pkUid, passkeyId} = passkey + VerifiedAuthentication {newSignCounter} = verified + user <- maybe (throwError InvalidCredentials) pure =<< findUserById pkUid + let User {status = userStatus} = user + when (userStatus /= UserActive) (throwError UserNotActive) + -- The assertion is already verified above, so the account's existence is not in question. + either throwError pure (ensureEmailVerified cfg user) + let ctx = proofContextFor pctx (loginIdText user.loginId) + gate <- guardAbuse cfg.rateLimitConfig ctx ts + when gate.locked do + publishAuthEvent (Event.MfaFailed (Event.MfaFailedData (Just pkUid) "account_locked" ts)) + throwError MfaAssertionInvalid + won <- updatePasskeySignCounter passkeyId newSignCounter ts + unless won (failMfa failure (Just pkUid) "signature counter replayed") + recordProofSuccess ctx FactorPasskey gate.standingLockout ts + (sid, pair) <- issueSession cfg user ts + publishAuthEvent (Event.MfaSucceeded (Event.MfaSucceededData pkUid sid ts)) + pure (user, pair) + +-- | Verify a WebAuthn assertion against the stored passkey it names. Reads the credential +-- id from the assertion JSON (the lookup key — the cryptographic verification still happens in +-- the ceremony interpreter), looks the passkey up to build the verifier input, and calls +-- 'completeAuthenticationCeremony'. On a decode/verify failure, a clone-counter warning, or a +-- missing credential, publishes 'MfaFailed' and throws 'MfaAssertionInvalid'. Returns the +-- looked-up passkey (so callers can read its owning user) alongside the verified result. +verifyAssertion :: + ( PasskeyStore :> es, + WebAuthnCeremony :> es, + AuthEventPublisher :> es, + Clock :> es, + Error AuthError :> es + ) => + Eff es () -> + Maybe UserId -> + ByteString -> + Value -> + Eff es (PasskeyCredential, VerifiedAuthentication) +verifyAssertion onFailure mUid blob assertion = do + cid <- maybe (failMfa onFailure mUid "missing credential id") pure (assertionCredentialId assertion) + passkey <- maybe (failMfa onFailure mUid "unknown credential") pure =<< findPasskeyByCredentialId cid + let PasskeyCredential {credentialId, userHandle, publicKey, signCounter, transports} = passkey + stored = + StoredCredentialForVerify + { credentialId, + userHandle, + publicKey, + signCounter, + transports + } + res <- completeAuthenticationCeremony blob stored assertion + case res of + Left _ -> failMfa onFailure mUid "assertion verification failed" + Right verified -> + let VerifiedAuthentication {cloneWarning} = verified + in if cloneWarning + then failMfa onFailure mUid "signature counter clone warning" + else pure (passkey, verified) + +-- | Publish 'MfaFailed' and abort with the generic 'MfaAssertionInvalid'. The reason is +-- recorded in the audit event only; the HTTP body the caller eventually returns stays generic. +failMfa :: + (AuthEventPublisher :> es, Clock :> es, Error AuthError :> es) => + Eff es () -> + Maybe UserId -> + Text -> + Eff es a +failMfa onFailure mUid reason = do + ts <- now + onFailure + publishAuthEvent (Event.MfaFailed (Event.MfaFailedData mUid reason ts)) + throwError MfaAssertionInvalid + +-- | Read the credential id out of the browser's assertion JSON, the key used to look the +-- stored passkey up. The deterministic fake interpreter uses @"credentialId"@; a real +-- @webauthn-json@ assertion uses @"rawId"@ (or @"id"@). All three are base64url text decoded +-- by 'WebAuthnCredentialId''s 'FromJSON'. This is the one place the core peeks into the +-- assertion JSON, and only for a lookup key — the cryptographic verification is entirely in the +-- ceremony interpreter. +assertionCredentialId :: Value -> Maybe WebAuthnCredentialId +assertionCredentialId v = + parseField "credentialId" <|> parseField "rawId" <|> parseField "id" + where + parseField k = parseMaybe (withObject "assertion" (\o -> o .: k)) v + +completionFactor :: MfaCompletion -> AttemptFactor +completionFactor = \case + MfaPasskey _ -> FactorPasskey + MfaTotp _ -> FactorTotp + MfaRecoveryCode _ -> FactorRecoveryCode + +completionError :: MfaCompletion -> AuthError +completionError = \case + MfaPasskey _ -> MfaAssertionInvalid + MfaTotp _ -> TotpCodeInvalid + MfaRecoveryCode _ -> RecoveryCodeInvalid + +-- | A passwordless failure has no resolved login id yet. Hash the presented credential id as +-- the account key (or a fixed miss key if it cannot be decoded) while the IP budget remains shared. +assertionAccountKey :: Value -> Text +assertionAccountKey assertion = case assertionCredentialId assertion of + Just (WebAuthnCredentialId bytes) -> b64urlEncode bytes + Nothing -> "unknown-credential" diff --git a/src/Shomei/OAuth/AuthorizationCode/Domain.hs b/src/Shomei/OAuth/AuthorizationCode/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/AuthorizationCode/Domain.hs @@ -0,0 +1,63 @@ +-- | The OAuth2 authorization code (EP-5): the single-use bearer of an authorize request's +-- decisions, carried through the user's browser to the client and redeemed at the token endpoint. +-- +-- The code itself is never stored — only 'codeHash', its SHA-256 hex digest (see +-- 'Shomei.ServiceAccount.Secret.sha256Hex'). A database leak therefore leaks no usable codes, +-- exactly as for refresh tokens. +-- +-- Every field below is a binding the exchange re-checks. A code is not a capability to mint /any/ +-- token: it is a capability to mint /this/ token, for this user, to this client, at this redirect +-- URI, with proof of the PKCE verifier that produced 'codeChallenge'. +module Shomei.OAuth.AuthorizationCode.Domain + ( AuthorizationCode (..), + NewAuthorizationCode (..), + ) +where + +import Data.Set (Set) +import Shomei.Authorization.Claims.Domain (Scope) +import Shomei.Id (SessionId, UserId) +import Shomei.Prelude + +data AuthorizationCode = AuthorizationCode + { -- | SHA-256 hex of the opaque code; the primary key + codeHash :: !Text, + -- | the only client that may exchange this code + clientId :: !Text, + -- | the exchange must present this URI verbatim + redirectUri :: !Text, + userId :: !UserId, + scopes :: !(Set Scope), + -- | echoed verbatim into the ID token when present (OIDC Core §2) + nonce :: !(Maybe Text), + -- | the PKCE S256 challenge (RFC 7636). 'Nothing' only for a confidential client that sent + -- none; a public client is refused at authorize without one. + codeChallenge :: !(Maybe Text), + -- | when the user authenticated — the authorizing access token's @iat@ — for the ID token's + -- @auth_time@ claim + authTime :: !UTCTime, + createdAt :: !UTCTime, + expiresAt :: !UTCTime, + -- | stamped by the atomic consume. A code with this set has already been redeemed. + consumedAt :: !(Maybe UTCTime), + -- | the session minted by the successful exchange, bound immediately afterwards so a replay + -- can revoke the first exchange's result without changing the wire error. + sessionId :: !(Maybe SessionId) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data NewAuthorizationCode = NewAuthorizationCode + { codeHash :: !Text, + clientId :: !Text, + redirectUri :: !Text, + userId :: !UserId, + scopes :: !(Set Scope), + nonce :: !(Maybe Text), + codeChallenge :: !(Maybe Text), + authTime :: !UTCTime, + createdAt :: !UTCTime, + expiresAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/OAuth/AuthorizationCode/Store.hs b/src/Shomei/OAuth/AuthorizationCode/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/AuthorizationCode/Store.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The authorization-code port (EP-5): the @shomei_oauth_authorization_codes@ table between +-- @GET \/oauth\/authorize@ and the @authorization_code@ grant at @POST \/oauth\/token@. +-- +-- A dedicated table rather than a reuse of the one-time-token stores or 'PendingCeremonyStore': +-- a code binds a client, a redirect URI, a PKCE challenge, a user, a scope set, a nonce, and an +-- auth time, none of which those single-purpose tables carry, and consumption must return all of +-- it atomically. The consume-once /discipline/ is copied from +-- 'Shomei.Passkey.Ceremony.Store.TakePendingCeremony'. +module Shomei.OAuth.AuthorizationCode.Store + ( OAuthCodeStore (..), + putAuthorizationCode, + consumeAuthorizationCode, + bindAuthorizationCodeSession, + findConsumedAuthorizationCode, + deleteExpiredAuthorizationCodes, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Id (SessionId) +import Shomei.OAuth.AuthorizationCode.Domain (AuthorizationCode, NewAuthorizationCode) +import Shomei.Prelude + +data OAuthCodeStore :: Effect where + PutAuthorizationCode :: NewAuthorizationCode -> OAuthCodeStore m () + -- | Redeem a code by its SHA-256 hex digest, atomically and at most once. + -- + -- Returns the row only if it was unconsumed /and/ unexpired at the given time, and stamps + -- @consumed_at@ in the same statement — so of two racing exchanges of one code, exactly one + -- gets a 'Just'. A miss (unknown, already consumed, or expired) is 'Nothing', and the caller + -- must answer @invalid_grant@ for all three without distinguishing them. + ConsumeAuthorizationCode :: Text -> UTCTime -> OAuthCodeStore m (Maybe AuthorizationCode) + -- | Attach the session minted by a successful exchange to its already-consumed code row. + BindAuthorizationCodeSession :: Text -> SessionId -> OAuthCodeStore m () + -- | Find a still-live consumed row. Keeping this distinct from consume preserves the atomic + -- one-winner operation while letting a replay find the first exchange's result. + FindConsumedAuthorizationCode :: Text -> UTCTime -> OAuthCodeStore m (Maybe AuthorizationCode) + -- | Delete codes that expired before the given time. Consumed rows are kept until they expire + -- too, so a replay within the code's lifetime still finds a consumed row rather than nothing. + DeleteExpiredAuthorizationCodes :: UTCTime -> OAuthCodeStore m () + +type instance DispatchOf OAuthCodeStore = Dynamic + +putAuthorizationCode :: (OAuthCodeStore :> es) => NewAuthorizationCode -> Eff es () +putAuthorizationCode = send . PutAuthorizationCode + +consumeAuthorizationCode :: (OAuthCodeStore :> es) => Text -> UTCTime -> Eff es (Maybe AuthorizationCode) +consumeAuthorizationCode h t = send (ConsumeAuthorizationCode h t) + +bindAuthorizationCodeSession :: (OAuthCodeStore :> es) => Text -> SessionId -> Eff es () +bindAuthorizationCodeSession h sid = send (BindAuthorizationCodeSession h sid) + +findConsumedAuthorizationCode :: (OAuthCodeStore :> es) => Text -> UTCTime -> Eff es (Maybe AuthorizationCode) +findConsumedAuthorizationCode h t = send (FindConsumedAuthorizationCode h t) + +deleteExpiredAuthorizationCodes :: (OAuthCodeStore :> es) => UTCTime -> Eff es () +deleteExpiredAuthorizationCodes = send . DeleteExpiredAuthorizationCodes diff --git a/src/Shomei/OAuth/Authorize/Workflow.hs b/src/Shomei/OAuth/Authorize/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/Authorize/Workflow.hs @@ -0,0 +1,225 @@ +-- | The authorization-code issuing half of the OAuth2 authorization-code grant (RFC 6749 §4.1), +-- behind @GET \/oauth\/authorize@. +-- +-- The caller (the HTTP layer) has already done the two things this workflow cannot: it resolved +-- the @client_id@ to an active 'OAuthClient', and it checked the presented @redirect_uri@ against +-- that client's registered list by exact string equality. Those two checks decide whether an error +-- may be /redirected/ at all, which is an HTTP-shape decision — see the two validation regimes in +-- "Shomei.OAuth.Handler". Everything else — PKCE policy, scope policy, minting and storing the +-- code, auditing it — is here. +-- +-- __Errors here are not 'Shomei.Error.AuthError'.__ Parameter-policy errors become an @error=@ +-- parameter on a redirect back to the client (RFC 6749 §4.1.2.1). 'AuthorizeLoginRequired' is +-- instead interpreted by the HTTP layer as an unauthenticated or non-interactive caller and is +-- never sent to the client's redirect URI. +module Shomei.OAuth.Authorize.Workflow + ( AuthorizeParams (..), + AuthorizeRefusal (..), + AuthorizeError (..), + authorizeErrorCode, + authorizeErrorDescription, + IssuedCode (..), + authorize, + isValidS256Challenge, + ) +where + +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import Data.Generics.Labels () +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time (addUTCTime) +import Effectful (Eff, (:>)) +import Effectful.Error.Static (runErrorNoCallStack, throwError) +import Shomei.Audit.Event.Domain qualified as Event +-- Imported WITHOUT (..): 'OAuthClient' shares @clientId@ / @status@ / @createdAt@ with several +-- other domain records, which would defeat @OverloadedRecordDot@. Every field is read through a +-- generic-lens label, as 'Shomei.ServiceAccount.ClientCredentials.Workflow' does for 'ServiceAccount'. + +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Authorization.Claims.Domain (AuthClaims (..), Scope (..)) +import Shomei.Authorization.Scope.Domain (privilegeScopes, privilegeScopesIn) +import Shomei.Config (ShomeiConfig) +import Shomei.OAuth.AuthorizationCode.Domain (NewAuthorizationCode (..)) +import Shomei.OAuth.AuthorizationCode.Store (OAuthCodeStore, putAuthorizationCode) +import Shomei.OAuth.Client.Domain (ClientType (..), OAuthClient) +import Shomei.Prelude +import Shomei.ServiceAccount.Secret (sha256Hex) +import Shomei.Session.Domain (SessionKind (InteractiveSession)) +import Shomei.Session.RefreshToken.Domain (RefreshToken (..)) +import Shomei.Session.Store (SessionStore) +import Shomei.Session.Token.Generator (TokenGen, generateOpaqueToken) +import Shomei.Session.Workflow (requireLiveSession) +import Shomei.Time.Store (Clock, now) + +-- | The authorize request's parameters, after the HTTP layer has validated @client_id@ and +-- @redirect_uri@ (which is why 'redirectUri' is a 'Text' and not a 'Maybe'). +data AuthorizeParams = AuthorizeParams + { responseType :: !(Maybe Text), + redirectUri :: !Text, + -- | the raw space-delimited @scope@ parameter; 'Nothing' when absent + scope :: !(Maybe Text), + -- | opaque, echoed back on both the success and the error redirect + state :: !(Maybe Text), + nonce :: !(Maybe Text), + codeChallenge :: !(Maybe Text), + codeChallengeMethod :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +-- | Why an otherwise-verifying credential may not authorize a client. +data AuthorizeRefusal + = -- | The token carries @act@, or its session was established by a machine or delegation. + NonInteractiveCredential + | -- | The token's session is missing, revoked, or past its absolute expiry. + SessionNotLive + deriving stock (Generic, Eq, Show) + +-- | The authorization policy outcomes. Parameter-policy errors redirect to the validated client; +-- 'AuthorizeLoginRequired' is handled without such a redirect by the HTTP layer. +data AuthorizeError + = -- | @response_type@ was absent or not @code@ + UnsupportedResponseType + | -- | a PKCE policy violation; the text names it + AuthorizeInvalidRequest !Text + | -- | the requested scope is empty or exceeds the client's allow-list + AuthorizeInvalidScope + | -- | the caller is not a live interactive end-user login + AuthorizeLoginRequired !AuthorizeRefusal + deriving stock (Generic, Eq, Show) + +authorizeErrorCode :: AuthorizeError -> Text +authorizeErrorCode = \case + UnsupportedResponseType -> "unsupported_response_type" + AuthorizeInvalidRequest _ -> "invalid_request" + AuthorizeInvalidScope -> "invalid_scope" + AuthorizeLoginRequired _ -> "login_required" + +authorizeErrorDescription :: AuthorizeError -> Text +authorizeErrorDescription = \case + UnsupportedResponseType -> "response_type must be code" + AuthorizeInvalidRequest what -> what + AuthorizeInvalidScope -> "the requested scope is empty or exceeds what this client may request" + AuthorizeLoginRequired NonInteractiveCredential -> "an interactive login session is required to authorize a client" + AuthorizeLoginRequired SessionNotLive -> "the session is no longer valid" + +-- | What the browser is redirected back with. +data IssuedCode = IssuedCode + { -- | the opaque code; only its SHA-256 digest was stored + code :: !Text, + -- | echoed verbatim from the request + state :: !(Maybe Text), + grantedScopes :: !(Set Scope) + } + deriving stock (Generic, Eq, Show) + +-- | Is this a well-formed PKCE S256 challenge (RFC 7636 §4.2)? +-- +-- @BASE64URL-ENCODE(SHA256(verifier))@ without padding is always exactly 43 characters of the +-- base64url alphabet. Checking the shape at authorize means a client that sent a padded, hex, or +-- truncated challenge learns so immediately, rather than at the exchange as a bare +-- @invalid_grant@ it cannot debug. +isValidS256Challenge :: Text -> Bool +isValidS256Challenge t = + Text.length t == 43 && Text.all isBase64UrlChar t + where + isBase64UrlChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '-' || c == '_' + +-- | Enforce the request's policy, then mint, store, and audit a single-use code. +-- +-- Steps, in order: +-- +-- 1. @response_type@ must be exactly @code@. +-- 2. PKCE: a public client MUST supply a @code_challenge@ (with no secret it has no other +-- binding between this request and the exchange). Whenever a challenge is supplied, its +-- method must be @S256@ and its shape must be right. +-- 3. Scope: an absent @scope@ grants the client's whole allow-list; a present one must name a +-- non-empty subset of it. +-- 4. Mint a high-entropy opaque code, store only its SHA-256 digest along with every binding the +-- exchange will re-check, and publish 'Event.OAuthCodeIssued'. +-- +-- @auth_time@ is copied from the authorizing token: the moment the user actually proved a +-- credential, which is what OIDC's claim means — not its refresh time or this request time. +authorize :: + ( OAuthCodeStore :> es, + TokenGen :> es, + AuthEventPublisher :> es, + Clock :> es, + SessionStore :> es + ) => + ShomeiConfig -> + OAuthClient -> + AuthClaims -> + AuthorizeParams -> + Eff es (Either AuthorizeError IssuedCode) +authorize cfg client claims params = runErrorNoCallStack do + -- A code becomes a fresh, refreshable, fully enriched session. Only a token that is itself a + -- live interactive login may mint one, regardless of the deployment's sessionCheckMode. + when (isJust claims.actor) (throwError (AuthorizeLoginRequired NonInteractiveCredential)) + ts <- now + session <- + either (const (throwError (AuthorizeLoginRequired SessionNotLive))) pure + =<< requireLiveSession ts claims.sessionId + unless ((session ^. #kind) == InteractiveSession) $ + throwError (AuthorizeLoginRequired NonInteractiveCredential) + unless (params.responseType == Just "code") (throwError UnsupportedResponseType) + challenge <- resolvePkce + granted <- resolveScopes + -- The refresh-token generator is the codebase's single CSPRNG opaque-token source (32 bytes, + -- base64url). A code is the same kind of secret with a shorter life. + RefreshToken code <- generateOpaqueToken + putAuthorizationCode + NewAuthorizationCode + { codeHash = sha256Hex code, + clientId = client ^. #clientId, + redirectUri = params.redirectUri, + userId = claims.subject, + scopes = granted, + nonce = params.nonce, + codeChallenge = challenge, + authTime = claims.authTime, + createdAt = ts, + expiresAt = addUTCTime (cfg ^. #oauthConfig . #authorizationCodeTTL) ts + } + publishAuthEvent + ( Event.OAuthCodeIssued + Event.OAuthCodeIssuedData + { clientId = client ^. #clientId, + userId = claims.subject, + scopes = granted, + occurredAt = ts + } + ) + pure IssuedCode {code, state = params.state, grantedScopes = granted} + where + resolvePkce = case (params.codeChallenge, params.codeChallengeMethod) of + (Nothing, _) + -- A confidential client authenticates with its secret at the exchange, so PKCE is + -- optional for it. A public client has nothing else, so PKCE is its only defense against + -- a stolen code. + | (client ^. #clientType) == PublicClient -> + throwError (AuthorizeInvalidRequest "code_challenge is required for a public client") + | otherwise -> pure Nothing + (Just c, method) -> do + -- RFC 7636 §4.3 defaults an absent method to `plain`, which this provider does not + -- accept. Requiring it to be spelled out means a client cannot land on `plain` silently. + unless (method == Just "S256") $ + throwError (AuthorizeInvalidRequest "code_challenge_method must be S256") + unless (isValidS256Challenge c) $ + throwError (AuthorizeInvalidRequest "code_challenge must be 43 characters of unpadded base64url") + pure (Just c) + + -- An absent `scope` takes a server-defined default (RFC 6749 §3.3); "everything this client is + -- registered for" is the least surprising one. A present `scope` must be a non-empty subset: + -- `scope=` is a malformed request, not a request for nothing. + resolveScopes = case fmap (Set.fromList . map Scope . Text.words) params.scope of + Nothing -> do + let granted = (client ^. #allowedScopes) `Set.difference` privilegeScopes cfg + when (Set.null granted) (throwError AuthorizeInvalidScope) + pure granted + Just requested -> do + when (Set.null requested) (throwError AuthorizeInvalidScope) + unless (requested `Set.isSubsetOf` (client ^. #allowedScopes)) (throwError AuthorizeInvalidScope) + unless (Set.null (privilegeScopesIn cfg requested)) (throwError AuthorizeInvalidScope) + pure requested diff --git a/src/Shomei/OAuth/Client/Domain.hs b/src/Shomei/OAuth/Client/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/Client/Domain.hs @@ -0,0 +1,82 @@ +-- | The OAuth2 \/ OIDC client entity (EP-5): a relying party registered by an operator, which +-- drives the authorization-code flow at @GET \/oauth\/authorize@ and exchanges its code at +-- @POST \/oauth\/token@. +-- +-- Distinct from 'Shomei.ServiceAccount.Domain.ServiceAccount', EP-4's machine credential. A +-- service account authenticates /as itself/ and has a backing @shomei_users@ row, because its +-- token's @sub@ is that user. An OAuth client authenticates only to prove /which client/ is +-- exchanging a code; the token it receives belongs to whichever user authenticated at authorize. +-- So an OAuth client is never a token subject and has no user row. +-- +-- 'secretHash' is a lowercase 64-char SHA-256 hex digest — the same format the service accounts +-- use, so 'Shomei.ServiceAccount.Secret.verifyServiceSecret' verifies both — and is 'Nothing' for +-- exactly the 'PublicClient's. +module Shomei.OAuth.Client.Domain + ( ClientType (..), + OAuthClientStatus (..), + OAuthClient (..), + NewOAuthClient (..), + isRegisteredRedirectUri, + ) +where + +import Data.Set (Set) +import Shomei.Authorization.Claims.Domain (Scope) +import Shomei.Id (OAuthClientId) +import Shomei.Prelude + +-- | A 'ConfidentialClient' can keep a secret (a server-side web app); a 'PublicClient' cannot +-- (a browser SPA, a native or CLI app). PKCE is mandatory for the latter: with no secret, the +-- code challenge is its only binding between the authorize and token requests. +data ClientType = ConfidentialClient | PublicClient + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A revoked client keeps its row: audit events naming it must still resolve, and its +-- @client_id@ must never be recycled. +data OAuthClientStatus = OAuthClientActive | OAuthClientRevoked + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data OAuthClient = OAuthClient + { oauthClientId :: !OAuthClientId, + -- | the TypeID text rendering of 'oauthClientId'; the OAuth2 @client_id@. Public. + clientId :: !Text, + -- | 'Nothing' for exactly a 'PublicClient' + secretHash :: !(Maybe Text), + clientType :: !ClientType, + displayName :: !Text, + -- | absolute URIs, matched by exact string equality (see 'isRegisteredRedirectUri') + redirectUris :: ![Text], + -- | the ceiling on what an authorize request may ask for + allowedScopes :: !(Set Scope), + status :: !OAuthClientStatus, + createdAt :: !UTCTime, + revokedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data NewOAuthClient = NewOAuthClient + { oauthClientId :: !OAuthClientId, + clientId :: !Text, + secretHash :: !(Maybe Text), + clientType :: !ClientType, + displayName :: !Text, + redirectUris :: ![Text], + allowedScopes :: !(Set Scope), + createdAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Is this the client's redirect URI? +-- +-- Exact string equality, deliberately: no prefix matching, no wildcard, no normalization. A +-- redirect target the operator did not register must never receive a redirect, because +-- @\/oauth\/authorize@ would then be an open redirector — an attacker registers +-- @https:\/\/app.example.com\/cb@, requests @https:\/\/app.example.com\/cb\/..\/..\/@ or +-- @https:\/\/app.example.com.evil.test\/cb@, and harvests authorization codes. Comparing the +-- bytes the operator wrote down is the only rule with no edge cases. +isRegisteredRedirectUri :: OAuthClient -> Text -> Bool +isRegisteredRedirectUri client uri = uri `elem` client.redirectUris diff --git a/src/Shomei/OAuth/Client/Store.hs b/src/Shomei/OAuth/Client/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/Client/Store.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The OAuth-client port (EP-5): the @shomei_oauth_clients@ table behind the +-- authorization-code flow. +-- +-- Lookup is by @client_id@ (the public TypeID text), because that is what an OAuth client +-- presents at @\/oauth\/authorize@ and @\/oauth\/token@. Mutations are by 'OAuthClientId', +-- because that is what an administrator holds after a create or a list. This mirrors +-- "Shomei.ServiceAccount.Store" exactly. +module Shomei.OAuth.Client.Store + ( OAuthClientStore (..), + createOAuthClient, + findOAuthClientByClientId, + listOAuthClients, + revokeOAuthClient, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Id (OAuthClientId) +import Shomei.OAuth.Client.Domain (NewOAuthClient, OAuthClient) +import Shomei.Prelude + +data OAuthClientStore :: Effect where + CreateOAuthClient :: NewOAuthClient -> OAuthClientStore m OAuthClient + -- | The authorize- and token-time lookup. Returns revoked clients too: refusing a revoked + -- client is the workflow's job, and at the token endpoint the refusal must be + -- indistinguishable from a wrong secret. + FindOAuthClientByClientId :: Text -> OAuthClientStore m (Maybe OAuthClient) + -- | The whole table, newest first. Deployments have few OAuth clients; no paging. + ListOAuthClients :: OAuthClientStore m [OAuthClient] + RevokeOAuthClient :: OAuthClientId -> UTCTime -> OAuthClientStore m () + +type instance DispatchOf OAuthClientStore = Dynamic + +createOAuthClient :: (OAuthClientStore :> es) => NewOAuthClient -> Eff es OAuthClient +createOAuthClient = send . CreateOAuthClient + +findOAuthClientByClientId :: (OAuthClientStore :> es) => Text -> Eff es (Maybe OAuthClient) +findOAuthClientByClientId = send . FindOAuthClientByClientId + +listOAuthClients :: (OAuthClientStore :> es) => Eff es [OAuthClient] +listOAuthClients = send ListOAuthClients + +revokeOAuthClient :: (OAuthClientStore :> es) => OAuthClientId -> UTCTime -> Eff es () +revokeOAuthClient cid t = send (RevokeOAuthClient cid t) diff --git a/src/Shomei/OAuth/Client/Workflow.hs b/src/Shomei/OAuth/Client/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/Client/Workflow.hs @@ -0,0 +1,33 @@ +-- | Registration policy for OAuth clients. +module Shomei.OAuth.Client.Workflow + ( ClientRegistrationError (..), + registerOAuthClient, + ) +where + +import Data.Set (Set) +import Data.Set qualified as Set +import Effectful (Eff, (:>)) +import Shomei.Authorization.Claims.Domain (Scope) +import Shomei.Authorization.Scope.Domain (privilegeScopesIn) +import Shomei.Config (ShomeiConfig) +import Shomei.OAuth.Client.Domain (NewOAuthClient (..), OAuthClient) +import Shomei.OAuth.Client.Store (OAuthClientStore, createOAuthClient) +import Shomei.Prelude + +data ClientRegistrationError = PrivilegeScopesRefused (Set Scope) + deriving stock (Generic, Eq, Show) + +-- | Register an OAuth client only when its allow-list cannot confer a Shōmei privilege gate on +-- every user who authorizes through it. The store remains policy-free for migrations and tests; +-- this workflow is the application registration seam. +registerOAuthClient :: + (OAuthClientStore :> es) => + ShomeiConfig -> + NewOAuthClient -> + Eff es (Either ClientRegistrationError OAuthClient) +registerOAuthClient cfg newClient = + let refused = privilegeScopesIn cfg newClient.allowedScopes + in if Set.null refused + then Right <$> createOAuthClient newClient + else pure (Left (PrivilegeScopesRefused refused)) diff --git a/src/Shomei/OAuth/IdToken/Domain.hs b/src/Shomei/OAuth/IdToken/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/IdToken/Domain.hs @@ -0,0 +1,38 @@ +-- | The OIDC ID token's claims (OIDC Core §2), signed by 'Shomei.SigningKey.Signer.signIdToken'. +-- +-- An ID token is __not__ an access token. It is a statement /to the client/ that a particular user +-- authenticated at a particular time, and its @aud@ is the @client_id@ — not the API audience. +-- Presenting one as a bearer credential must never work, which is why it carries no @sid@, no +-- scopes, no roles, and no permissions, and why 'Shomei.SigningKey.Verifier' will refuse it (its +-- @aud@ does not match the configured audience). +module Shomei.OAuth.IdToken.Domain + ( IdTokenClaims (..), + IdToken (..), + ) +where + +import Shomei.Authorization.Claims.Domain (Issuer) +import Shomei.Id (UserId) +import Shomei.Prelude + +-- | A signed OIDC ID token (a compact JWS), beside 'Shomei.Session.Token.Domain.AccessToken'. +newtype IdToken = IdToken Text + deriving stock (Generic) + deriving newtype (Eq, Show, FromJSON, ToJSON) + +data IdTokenClaims = IdTokenClaims + { issuer :: !Issuer, + subject :: !UserId, + -- | the @client_id@ the code was issued to; the ID token is addressed to it alone + audience :: !Text, + issuedAt :: !UTCTime, + expiresAt :: !UTCTime, + -- | echoed verbatim from the authorize request when one was sent. The client compares it to + -- the value it generated, which is what stops an attacker replaying someone else's ID + -- token into the client's session. + nonce :: !(Maybe Text), + -- | when the user actually authenticated (the authorizing access token's @iat@), as a JSON + -- number of Unix seconds on the wire + authTime :: !UTCTime + } + deriving stock (Generic, Eq, Show) diff --git a/src/Shomei/OAuth/Revocation/Domain.hs b/src/Shomei/OAuth/Revocation/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/Revocation/Domain.hs @@ -0,0 +1,35 @@ +-- | Ownership policy for RFC 7009 token revocation. +module Shomei.OAuth.Revocation.Domain + ( RevocationCaller (..), + mayRevokeSession, + ) +where + +import Data.Set qualified as Set +import Shomei.Authorization.Scope.Domain (adminScope) +import Shomei.Prelude +import Shomei.ServiceAccount.Domain (ServiceAccount) +import Shomei.ServiceAccount.Domain qualified as ServiceAccount +import Shomei.Session.Domain (Session) +import Shomei.Session.Domain qualified as Session + +-- | The authenticated principal presenting a token to the revocation endpoint. +data RevocationCaller + = RevokingOAuthClient !Text + | RevokingServiceAccount !ServiceAccount + deriving stock (Generic, Eq, Show) + +-- | RFC 7009 §2.1: may this caller revoke this session? +-- +-- OAuth clients own only sessions minted under their @client_id@. A service account owns machine +-- and delegated sessions in which its backing user is the subject or actor. The documented +-- @shomei:admin@ principal is the explicit global escape hatch. +mayRevokeSession :: RevocationCaller -> Session -> Bool +mayRevokeSession (RevokingOAuthClient callerClientId) Session.Session {oauthClientId} = + oauthClientId == Just callerClientId +mayRevokeSession + (RevokingServiceAccount ServiceAccount.ServiceAccount {userId = callerUserId, allowedScopes}) + Session.Session {userId = subjectUserId, actor} = + adminScope `Set.member` allowedScopes + || callerUserId == subjectUserId + || actor == Just callerUserId diff --git a/src/Shomei/OAuth/TokenExchange/Workflow.hs b/src/Shomei/OAuth/TokenExchange/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/TokenExchange/Workflow.hs @@ -0,0 +1,285 @@ +-- | RFC 8693 (OAuth 2.0 Token Exchange) as a third grant on @POST \/oauth\/token@ (EP-6). +-- +-- Token exchange generalizes the two delegated-token stories Shōmei already tells into one +-- standard grant. Both modes issue a __delegation-shaped__ token — @sub@ names the represented +-- party, @act@ names who is wielding it — through the single shared mint +-- 'Shomei.Delegation.Workflow.mintDelegatedToken', so the standards path and the bespoke +-- @\/auth\/impersonate@ endpoint cannot drift. +-- +-- * __Impersonation mode__ — an operator holding the @impersonate:user@ scope exchanges a bare +-- user id (@subject_token_type = urn:shomei:params:oauth:token-type:user-id@) plus their own +-- access token as the @actor_token@, for a token that /is/ that user. This reuses +-- 'Shomei.Delegation.Workflow.startImpersonation' verbatim, so the scope gate, freshness +-- gate, self\/active-target checks, refresh-less session, and @impersonation_started@ audit +-- event are literally the same code as the bespoke endpoint. +-- +-- * __Service on-behalf-of mode__ — a service account (EP-4) authenticates as the OAuth client of +-- the request and presents a user's access token as the @subject_token@. It receives a +-- narrowed, short-lived token carrying the user's @sub@ and the service's identity in @act@, so +-- user identity propagates across service hops. Gated behind the dedicated +-- @token-exchange:subject@ scope on the account, which is never itself copied into an issued +-- token (that would let exchanged tokens perform further exchanges). +-- +-- __Errors here are 'AuthError', but never reach the problem envelope.__ The @POST \/oauth\/token@ +-- dispatcher renders them in the RFC 6749 §5.2 shape (see "Shomei.Servant.OAuth"): 'OAuthGrantInvalid' +-- → @invalid_grant@, 'OAuthScopeInvalid' → @invalid_scope@, 'OAuthRequestMalformed' → +-- @invalid_request@, 'OAuthClientInvalid' → @invalid_client@, and the impersonation guards +-- ('ImpersonationForbidden'\/'ImpersonationTargetInvalid') collapse to @invalid_grant@ so a stock +-- caller learns nothing of Shōmei's impersonation policy internals. +-- +-- __Chained exchanges are refused outright.__ A token already carrying @act@ (any delegated token, +-- from either mode) is rejected as a subject or actor token, so delegation chains cannot form. This +-- is simpler to reason about than nesting prior @act@ claims, and is revisitable later. +module Shomei.OAuth.TokenExchange.Workflow + ( ExchangeRequest (..), + ExchangedToken (..), + exchangeToken, + userIdTokenType, + accessTokenType, + tokenExchangeSubjectScope, + ) +where + +import Data.Generics.Labels () +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Time (NominalDiffTime) +import Effectful (Eff, (:>)) +import Effectful.Error.Static (Error, runErrorNoCallStack, throwError) +import Shomei.Account.User.Domain (User, UserStatus (UserActive)) +import Shomei.Account.User.Store (UserStore, findUserById) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Authorization.Claims.Domain (AuthClaims (..), Scope (..)) +import Shomei.Authorization.Scope.Domain (tokenExchangeSubjectScope) +import Shomei.Config (ImpersonationConfig (..), MachineTokenConfig (..), SessionCheckMode (VerifyTokenAndSession), ShomeiConfig (..)) +import Shomei.Delegation.Workflow + ( DelegatedMint (..), + StartImpersonation (..), + mintDelegatedToken, + startImpersonation, + ) +import Shomei.Error (AuthError (..)) +import Shomei.Id (SessionId, UserId, parseId) +import Shomei.Prelude +import Shomei.ServiceAccount.Domain (ServiceAccount, ServiceAccountStatus (ServiceAccountActive)) +import Shomei.Session.Authentication.Workflow qualified as Authentication +import Shomei.Session.Store (SessionStore) +import Shomei.Session.Token.Domain (AccessToken (..)) +import Shomei.SigningKey.Signer (TokenSigner) +import Shomei.SigningKey.Verifier (TokenVerifier) +import Shomei.Time.Store (Clock, now) + +-- | The Shōmei-defined token type URN for "a bare user id" — the impersonation-mode +-- @subject_token@. A support operator holds no token of the customer's; the customer's identity is +-- known only by id, so a provider URN for the id itself is the RFC-sanctioned escape hatch. +userIdTokenType :: Text +userIdTokenType = "urn:shomei:params:oauth:token-type:user-id" + +-- | The standard RFC 8693 access-token type URN. +accessTokenType :: Text +accessTokenType = "urn:ietf:params:oauth:token-type:access_token" + +-- | A parsed RFC 8693 token-exchange request. The dispatcher in "Shomei.OAuth.Handler" reads the +-- form parameters and performs client authentication (setting 'authenticatedService'); this +-- workflow performs all of the policy. +data ExchangeRequest = ExchangeRequest + { subjectToken :: !Text, + subjectTokenType :: !Text, + actorToken :: !(Maybe Text), + actorTokenType :: !(Maybe Text), + requestedScopes :: !(Maybe (Set Scope)), + requestedTokenType :: !(Maybe Text), + reason :: !(Maybe Text), + ticketId :: !(Maybe Text), + clientIp :: !(Maybe Text), + -- | 'Nothing' = the caller did not client-authenticate (impersonation mode authenticates through + -- the actor token instead); 'Just' = EP-4 client authentication already succeeded, so this is + -- an on-behalf-of request from that service account. + authenticatedService :: !(Maybe ServiceAccount) + } + deriving stock (Generic, Show) + +-- | The result of a successful exchange: the signed access token, its lifetime, the scopes it +-- carries (empty for impersonation), and the delegated session's id. +data ExchangedToken = ExchangedToken + { accessToken :: !AccessToken, + expiresIn :: !NominalDiffTime, + grantedScopes :: !(Set Scope), + sessionId :: !SessionId + } + deriving stock (Generic, Show) + +-- | Run a token-exchange request in whichever mode its parameters select. +exchangeToken :: + ( UserStore :> es, + SessionStore :> es, + TokenSigner :> es, + TokenVerifier :> es, + AuthEventPublisher :> es, + Clock :> es + ) => + ShomeiConfig -> + ExchangeRequest -> + Eff es (Either AuthError ExchangedToken) +exchangeToken cfg req = runErrorNoCallStack do + -- We only ever issue access tokens: any other requested_token_type is malformed for this grant. + case req.requestedTokenType of + Nothing -> pure () + Just t | t == accessTokenType -> pure () + Just _ -> throwError OAuthRequestMalformed + case (req.subjectTokenType == userIdTokenType, req.subjectTokenType == accessTokenType, req.authenticatedService) of + -- Impersonation: a user-id subject and no client authentication. + (True, _, Nothing) -> impersonationMode cfg req + -- On-behalf-of: an access-token subject presented by an authenticated service account. + (_, True, Just svc) -> onBehalfOfMode cfg req svc + -- Every other combination — a client-authenticated user-id subject, an unauthenticated + -- access-token subject, an unknown subject type — is a request that names neither mode. + _ -> throwError OAuthRequestMalformed + +-- | Impersonation mode. Delegates to 'startImpersonation' so the guards, session shape, and audit +-- event are exactly the bespoke endpoint's. +impersonationMode :: + ( UserStore :> es, + SessionStore :> es, + TokenSigner :> es, + TokenVerifier :> es, + AuthEventPublisher :> es, + Clock :> es, + Error AuthError :> es + ) => + ShomeiConfig -> + ExchangeRequest -> + Eff es ExchangedToken +impersonationMode cfg req = do + -- The operator's credential travels as the actor token; it is required, and must be an access + -- token. Its absence or a wrong actor_token_type is a malformed request, not a bad grant. + rawActor <- maybe (throwError OAuthRequestMalformed) pure req.actorToken + case req.actorTokenType of + Just t | t == accessTokenType -> pure () + _ -> throwError OAuthRequestMalformed + actorClaims <- verifyToken rawActor + -- No chained exchanges: a delegated token may not itself act as the operator. + when (isJust actorClaims.actor) (throwError OAuthGrantInvalid) + targetUserId <- parseSubjectUserId req.subjectToken + (session, access) <- + either throwError pure + =<< startImpersonation + cfg + StartImpersonation + { actorClaims, + targetUserId, + reason = fromMaybe "token_exchange" req.reason, + ticketId = req.ticketId, + clientIp = req.clientIp + } + pure + ExchangedToken + { accessToken = access, + expiresIn = cfg.impersonationConfig.impersonationSessionTTL, + grantedScopes = Set.empty, + sessionId = session ^. #sessionId + } + +-- | Service on-behalf-of mode. The authenticated service acts /for/ the subject token's user. +onBehalfOfMode :: + ( UserStore :> es, + SessionStore :> es, + TokenSigner :> es, + TokenVerifier :> es, + AuthEventPublisher :> es, + Clock :> es, + Error AuthError :> es + ) => + ShomeiConfig -> + ExchangeRequest -> + ServiceAccount -> + Eff es ExchangedToken +onBehalfOfMode cfg req svc = do + -- The account must be active and must hold the gate scope. A revoked account, or one without the + -- gate, learns only that it may not do this — never anything about the subject token. + unless (svc ^. #status == ServiceAccountActive) (throwError OAuthClientInvalid) + let allowed = svc ^. #allowedScopes + unless (tokenExchangeSubjectScope `Set.member` allowed) (throwError OAuthScopeInvalid) + subjectClaims <- verifyToken req.subjectToken + -- No chained exchanges: a delegated token cannot be re-exchanged. + when (isJust subjectClaims.actor) (throwError OAuthGrantInvalid) + requireActiveUser subjectClaims.subject + -- The service's backing user must be active too, or it cannot mint on anyone's behalf. + requireActiveUser (svc ^. #userId) + granted <- narrowScopes req.requestedScopes allowed subjectClaims.scopes + ts <- now + (session, access) <- + mintDelegatedToken + cfg + ts + DelegatedMint + { subjectUserId = subjectClaims.subject, + actorUserId = svc ^. #userId, + scopes = granted, + ttl = cfg.machineTokenConfig.machineTokenTTL + } + let sid = session ^. #sessionId + publishAuthEvent + ( Event.ServiceOnBehalfIssued + Event.ServiceOnBehalfIssuedData + { serviceAccountId = svc ^. #clientId, + actorUserId = svc ^. #userId, + subjectUserId = subjectClaims.subject, + sessionId = sid, + scopes = granted, + occurredAt = ts + } + ) + pure + ExchangedToken + { accessToken = access, + expiresIn = cfg.machineTokenConfig.machineTokenTTL, + grantedScopes = granted, + sessionId = sid + } + +-- | Scope narrowing for on-behalf-of (per the plan's Decision Log): +-- +-- * requested defaults to the account's allowed scopes minus the gate scope when @scope@ is absent; +-- * the granted set is @requested ∩ (allowed \\ gate)@ — the service can never confer a scope it +-- does not hold, and the gate scope is never carried; +-- * when the subject token carries a __non-empty__ scope set, the granted set must be within it +-- (@granted ⊆ subject.scopes@), else 'OAuthScopeInvalid'. An empty subject scope set — today's +-- interactive user tokens — imposes no bound (an unscoped session is not "no authority"); +-- * an empty granted set is 'OAuthScopeInvalid'. +narrowScopes :: + (Error AuthError :> es) => + Maybe (Set Scope) -> + Set Scope -> + Set Scope -> + Eff es (Set Scope) +narrowScopes mRequested allowed subjectScopes = do + let ceiling_ = Set.delete tokenExchangeSubjectScope allowed + requested = fromMaybe ceiling_ mRequested + granted = Set.intersection requested ceiling_ + when (Set.null granted) (throwError OAuthScopeInvalid) + unless (Set.null subjectScopes || granted `Set.isSubsetOf` subjectScopes) (throwError OAuthScopeInvalid) + pure granted + +-- | Verify a presented compact token back into its claims, or fail the whole exchange with +-- @invalid_grant@ — a subject or actor token that will not validate is a bad grant, and every +-- reason it might fail is indistinguishable on the wire. +verifyToken :: + (TokenVerifier :> es, SessionStore :> es, Clock :> es, Error AuthError :> es) => + Text -> + Eff es AuthClaims +verifyToken raw = + either (const (throwError OAuthGrantInvalid)) pure + =<< Authentication.verifyTokenWith VerifyTokenAndSession (AccessToken raw) + +-- | Parse the impersonation-mode @subject_token@: a bare user id. A garbage id is an invalid grant. +parseSubjectUserId :: (Error AuthError :> es) => Text -> Eff es UserId +parseSubjectUserId raw = either (const (throwError OAuthGrantInvalid)) pure (parseId raw) + +-- | Require a user to exist and be active, else 'OAuthGrantInvalid'. Used for both the subject and +-- the service's backing user: neither an absent nor an inactive user can be represented or act. +requireActiveUser :: (UserStore :> es, Error AuthError :> es) => UserId -> Eff es () +requireActiveUser uid = do + user <- maybe (throwError OAuthGrantInvalid) pure =<< findUserById uid + unless ((user :: User) ^. #status == UserActive) (throwError OAuthGrantInvalid) diff --git a/src/Shomei/OAuth/TokenGrant/Workflow.hs b/src/Shomei/OAuth/TokenGrant/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/TokenGrant/Workflow.hs @@ -0,0 +1,322 @@ +-- | The two grants EP-5 adds to @POST \/oauth\/token@: @authorization_code@ (RFC 6749 §4.1.3, +-- with PKCE per RFC 7636) and @refresh_token@ (§6), both authenticated as an OAuth client. +-- +-- __Errors here are not 'Shomei.Error.AuthError'.__ They become RFC 6749 §5.2 error objects at the +-- token endpoint, never problem documents, so a dedicated type keeps them out of the problem +-- catalog — which describes only what the application envelope can carry. (This mirrors +-- "Shomei.OAuth.Authorize.Workflow".) +-- +-- __Rotation and reuse detection are not reimplemented here.__ 'refreshViaOAuth' adds one check — +-- that the session was minted by /this/ client — and then delegates to 'Shomei.Session.Authentication.Workflow.refresh', +-- the most security-sensitive machinery in the repository. Forking its invariants for OAuth +-- clients would be the single most likely way to break them. +module Shomei.OAuth.TokenGrant.Workflow + ( TokenGrantError (..), + grantErrorCode, + grantErrorDescription, + ExchangeAuthorizationCode (..), + RefreshViaOAuth (..), + ExchangedTokens (..), + exchangeAuthorizationCode, + refreshViaOAuth, + pkceChallengeFor, + ) +where + +import Crypto.Hash (SHA256 (..), hashWith) +import Data.Bifunctor (first) +import Data.ByteArray qualified as BA +import Data.ByteArray.Encoding (Base (Base64URLUnpadded), convertToBase) +import Data.ByteString (ByteString) +import Data.Generics.Labels () +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import Data.Time (addUTCTime) +import Effectful (Eff, (:>)) +import Effectful.Error.Static (Error, runErrorNoCallStack, throwError) +-- Imported WITHOUT (..): both share field names with 'Shomei.Account.User.Domain.User', which would defeat +-- @OverloadedRecordDot@. Read through generic-lens labels. + +import Shomei.Account.User.Domain (UserStatus (UserActive)) +import Shomei.Account.User.Store (UserStore, findUserById) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Authorization.Claims.Domain (AuthClaims, Scope (..)) +import Shomei.Authorization.Claims.Store (ClaimsEnricher) +import Shomei.Authorization.Role.Store (RoleStore) +import Shomei.Config (ShomeiConfig) +import Shomei.Error (AuthError) +import Shomei.Id (SessionId) +import Shomei.OAuth.AuthorizationCode.Domain (AuthorizationCode) +import Shomei.OAuth.AuthorizationCode.Store (OAuthCodeStore, bindAuthorizationCodeSession, consumeAuthorizationCode, findConsumedAuthorizationCode) +import Shomei.OAuth.Client.Domain (ClientType (..), OAuthClient, OAuthClientStatus (..)) +import Shomei.OAuth.Client.Store (OAuthClientStore, findOAuthClientByClientId) +import Shomei.OAuth.IdToken.Domain (IdToken, IdTokenClaims (..)) +import Shomei.Prelude +import Shomei.ServiceAccount.Secret (sha256Hex, verifyServiceSecret) +import Shomei.Session.Authentication.Workflow qualified as Wf +import Shomei.Session.Command (RefreshCommand (..), RefreshOrigin (OAuthClientRefresh)) +import Shomei.Session.RefreshToken.Domain (RefreshToken) +import Shomei.Session.RefreshToken.Store (RefreshTokenStore, findRefreshTokenByHash, revokeSessionRefreshTokens) +import Shomei.Session.Store (SessionStore, findSessionById) +import Shomei.Session.Store qualified as SessionStore +import Shomei.Session.Token.Domain (TokenPair) +import Shomei.Session.Token.Generator (TokenGen, hashRefreshToken) +import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork) +import Shomei.Session.Workflow (SessionOptions (..), ensureEmailVerified, issueSessionWith) +import Shomei.SigningKey.Signer (TokenSigner, signIdToken) +import Shomei.Time.Store (Clock, now) + +-- | The RFC 6749 §5.2 error codes these grants produce. +data TokenGrantError + = -- | client authentication failed: unknown client, revoked client, wrong secret, a secret sent + -- by a public client, or a secret withheld by a confidential one. Never says which. + GrantInvalidClient + | -- | the presented grant is invalid, expired, revoked, or not this client's. The text is for a + -- human reading a log, never for the caller to branch on. + GrantInvalidGrant !Text + | GrantInvalidRequest !Text + deriving stock (Generic, Eq, Show) + +grantErrorCode :: TokenGrantError -> Text +grantErrorCode = \case + GrantInvalidClient -> "invalid_client" + GrantInvalidGrant _ -> "invalid_grant" + GrantInvalidRequest _ -> "invalid_request" + +grantErrorDescription :: TokenGrantError -> Text +grantErrorDescription = \case + GrantInvalidClient -> "client authentication failed" + -- One description for every invalid_grant, so a caller cannot tell a replayed code from an + -- expired one from someone else's. The specific text stays server-side. + GrantInvalidGrant _ -> "the provided grant is invalid, expired, or was issued to another client" + GrantInvalidRequest what -> what + +data ExchangeAuthorizationCode = ExchangeAuthorizationCode + { clientId :: !Text, + -- | 'Nothing' for a public client, which has none + clientSecret :: !(Maybe Text), + code :: !Text, + redirectUri :: !Text, + codeVerifier :: !(Maybe Text) + } + deriving stock (Generic, Eq, Show) + +data RefreshViaOAuth = RefreshViaOAuth + { clientId :: !Text, + clientSecret :: !(Maybe Text), + refreshToken :: !RefreshToken + } + deriving stock (Generic, Eq, Show) + +data ExchangedTokens = ExchangedTokens + { tokens :: !TokenPair, + grantedScopes :: !(Set Scope), + -- | present exactly when the granted scopes include @openid@ + idToken :: !(Maybe IdToken), + sessionId :: !SessionId + } + deriving stock (Generic, Show) + +-- | @BASE64URL-ENCODE(SHA256(ASCII(verifier)))@, unpadded (RFC 7636 §4.6). +-- +-- Exported because a test that drives the real flow must produce a challenge the same way a client +-- does, and reimplementing it in the test would let both drift together. +pkceChallengeFor :: Text -> Text +pkceChallengeFor verifier = + TE.decodeUtf8 (convertToBase Base64URLUnpadded (hashWith SHA256 (TE.encodeUtf8 verifier)) :: ByteString) + +-- | RFC 6749 §4.1.3: authenticate the client, redeem the code, verify PKCE, mint the session. +-- +-- Every check that could distinguish one failure from another answers the same @invalid_grant@: +-- a code that never existed, one already redeemed, one that expired, one issued to a different +-- client, one presented with a different @redirect_uri@, and one whose PKCE verifier does not +-- match are indistinguishable on the wire. The code is consumed __before__ any of those checks +-- that could fail, so a wrong-client or wrong-PKCE attempt still burns it: an attacker who steals a +-- code cannot grind at it. +exchangeAuthorizationCode :: + ( OAuthClientStore :> es, + OAuthCodeStore :> es, + UserStore :> es, + AuthUnitOfWork :> es, + TokenSigner :> es, + TokenGen :> es, + RoleStore :> es, + ClaimsEnricher :> es, + SessionStore :> es, + RefreshTokenStore :> es, + AuthEventPublisher :> es, + Clock :> es + ) => + ShomeiConfig -> + ExchangeAuthorizationCode -> + Eff es (Either TokenGrantError ExchangedTokens) +exchangeAuthorizationCode cfg cmd = runErrorNoCallStack do + _client <- authenticateClient (cmd ^. #clientId) (cmd ^. #clientSecret) + ts <- now + let presentedHash = sha256Hex (cmd ^. #code) + consumed <- consumeAuthorizationCode presentedHash ts + row <- case consumed of + Just fresh -> pure fresh + Nothing -> do + replay <- findConsumedAuthorizationCode presentedHash ts + forM_ replay \used -> + forM_ (used ^. #sessionId) \sid -> do + SessionStore.revokeSession sid ts + revokeSessionRefreshTokens sid ts + publishAuthEvent + ( Event.OAuthCodeReplayed + Event.OAuthCodeReplayedData + { clientId = used ^. #clientId, + presentedBy = cmd ^. #clientId, + userId = used ^. #userId, + sessionId = sid, + occurredAt = ts + } + ) + throwError (GrantInvalidGrant "no such code, already consumed, or expired") + -- The code was minted for one client at one redirect URI; both are re-checked here because the + -- code travelled through the user's browser and anything in that path could have altered them. + unless (row ^. #clientId == cmd ^. #clientId) $ + throwError (GrantInvalidGrant "the code was issued to a different client") + unless (row ^. #redirectUri == cmd ^. #redirectUri) $ + throwError (GrantInvalidGrant "redirect_uri does not match the authorize request") + verifyPkce row + user <- do + u <- maybe (throwError (GrantInvalidGrant "the code's user no longer exists")) pure =<< findUserById (row ^. #userId) + unless ((u ^. #status) == UserActive) (throwError (GrantInvalidGrant "the code's user is not active")) + either (const (throwError (GrantInvalidGrant "the code's user has not verified their email"))) pure (ensureEmailVerified cfg u) + pure u + let granted = row ^. #scopes + (sid, pair, claims) <- + issueSessionWith + cfg + SessionOptions {oauthClientId = Just (cmd ^. #clientId), extraScopes = granted} + user + ts + bindAuthorizationCodeSession (row ^. #codeHash) sid + idToken <- + if Scope "openid" `Set.member` granted + then Just <$> signIdTokenFor cfg cmd row claims ts + else pure Nothing + pure ExchangedTokens {tokens = pair, grantedScopes = granted, idToken, sessionId = sid} + where + -- If the code carries a challenge, a matching verifier is mandatory. If it does not (a + -- confidential client that skipped PKCE), a supplied verifier is ignored rather than treated + -- as an error: the client has proven itself with its secret. + verifyPkce row = case row ^. #codeChallenge of + Nothing -> pure () + Just expected -> do + verifier <- maybe (throwError (GrantInvalidGrant "code_verifier is required")) pure (cmd ^. #codeVerifier) + let actual = pkceChallengeFor verifier + unless (TE.encodeUtf8 expected `BA.constEq` TE.encodeUtf8 actual) $ + throwError (GrantInvalidGrant "code_verifier does not match the stored code_challenge") + +-- | The ID token (OIDC Core §2) for a freshly exchanged code. +-- +-- @sub@ comes from the claims 'issueSessionWith' just signed, not from a second store read, so an +-- ID token can never name a different subject than the access token issued beside it. @nonce@ and +-- @auth_time@ come from the authorize request, carried across in the code row. +signIdTokenFor :: + (TokenSigner :> es) => + ShomeiConfig -> + ExchangeAuthorizationCode -> + AuthorizationCode -> + AuthClaims -> + UTCTime -> + Eff es IdToken +signIdTokenFor cfg cmd row claims ts = + signIdToken + IdTokenClaims + { issuer = cfg ^. #issuer, + subject = claims ^. #subject, + audience = cmd ^. #clientId, + issuedAt = ts, + expiresAt = addUTCTime (cfg ^. #oauthConfig . #idTokenTTL) ts, + nonce = row ^. #nonce, + authTime = row ^. #authTime + } + +-- | RFC 6749 §6, with client binding. +-- +-- The session must have been minted by this same client through the authorization-code grant. A +-- session with no @oauth_client_id@ — every password login, passkey login, impersonation, and +-- service-account session — cannot be refreshed here at all: it is refreshed at the endpoint that +-- created it. +-- +-- The binding is checked /before/ delegating, and a mismatch does not run reuse detection. That is +-- deliberate: otherwise any client could revoke another client's whole token family for a user +-- simply by presenting a refresh token it had somehow observed, turning reuse detection into a +-- denial-of-service tool. +refreshViaOAuth :: + ( OAuthClientStore :> es, + SessionStore :> es, + RefreshTokenStore :> es, + AuthUnitOfWork :> es, + UserStore :> es, + TokenSigner :> es, + RoleStore :> es, + ClaimsEnricher :> es, + Clock :> es, + TokenGen :> es + ) => + ShomeiConfig -> + RefreshViaOAuth -> + Eff es (Either TokenGrantError Wf.Refreshed) +refreshViaOAuth cfg cmd = do + outcome <- runErrorNoCallStack do + _client <- authenticateClient (cmd ^. #clientId) (cmd ^. #clientSecret) + session <- resolveSession + unless ((session ^. #oauthClientId) == Just (cmd ^. #clientId)) $ + throwError (GrantInvalidGrant "the refresh token was not issued to this client") + case outcome of + Left e -> pure (Left e) + -- Everything past here -- rotation, the used-token reuse path, revoked/expired terminal + -- states -- is the existing + -- workflow's, unchanged. Its 'AuthError's collapse to one `invalid_grant`, because a caller + -- must not learn from the token endpoint whether a token was expired, revoked, or reused. + Right () -> do + result <- + Wf.refreshFrom + (OAuthClientRefresh (cmd ^. #clientId)) + cfg + RefreshCommand {refreshToken = cmd ^. #refreshToken} + pure (first (GrantInvalidGrant . tshow) result) + where + tshow :: AuthError -> Text + tshow = Text.pack . show + + -- Look the token up to reach its session and check the binding. This costs two reads the + -- delegated 'Wf.refresh' repeats; the alternative is threading the binding into 'refresh' + -- itself and coupling the bespoke endpoint to OAuth. + resolveSession = do + tokHash <- hashRefreshToken (cmd ^. #refreshToken) + tok <- maybe (throwError (GrantInvalidGrant "unknown refresh token")) pure =<< findRefreshTokenByHash tokHash + maybe (throwError (GrantInvalidGrant "the refresh token's session is gone")) pure + =<< findSessionById (tok ^. #sessionId) + +-- | RFC 6749 §2.3: a confidential client proves itself with its secret; a public client has none. +-- +-- Every failure is the single 'GrantInvalidClient'. A caller learns neither that a @client_id@ +-- exists, nor that it is revoked, nor that it is of the other type. +-- +-- The secret is verified before the status is checked, so a revoked client and an active one with +-- a wrong secret cost the same work — the same ordering 'Shomei.ServiceAccount.ClientCredentials.Workflow' uses. +authenticateClient :: + (OAuthClientStore :> es, Error TokenGrantError :> es) => + Text -> + Maybe Text -> + Eff es OAuthClient +authenticateClient clientId mSecret = do + client <- maybe (throwError GrantInvalidClient) pure =<< findOAuthClientByClientId clientId + case (client ^. #clientType, client ^. #secretHash, mSecret) of + (ConfidentialClient, Just expected, Just presented) -> + unless (verifyServiceSecret expected presented) (throwError GrantInvalidClient) + -- A public client that presents a secret is not "a public client being generous": it is a + -- request Shōmei cannot honor, because there is nothing to check the secret against. + (PublicClient, Nothing, Nothing) -> pure () + _ -> throwError GrantInvalidClient + unless ((client ^. #status) == OAuthClientActive) (throwError GrantInvalidClient) + pure client diff --git a/src/Shomei/Passkey/Ceremony/Port.hs b/src/Shomei/Passkey/Ceremony/Port.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Passkey/Ceremony/Port.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The WebAuthn ceremony port (MasterPlan 3, IP-1). +-- +-- A passkey is a public-key credential a browser creates with +-- @navigator.credentials.create()@ and proves possession of with +-- @navigator.credentials.get()@. Each exchange is a /ceremony/ with a /begin/ step +-- (the server emits options carrying a random challenge) and a /complete/ step (the +-- server verifies the browser's signed response). +-- +-- This port lets 'Shomei.Session.Authentication.Workflow' code orchestrate those ceremonies without +-- @shomei-core@ ever importing the heavy @webauthn@ library: its operations cross the +-- package boundary using only aeson 'Value' (the browser-facing @webauthn-json@ +-- payloads, already a core dependency) plus the 'Shomei.Passkey.Domain' domain types. +-- The real interpreter (@runWebAuthnCeremonyLibrary@ in @shomei-webauthn@) does the +-- encode/decode/verify against the library; a deterministic fake +-- ('Shomei.Test.InMemory.runWebAuthnCeremonyFake') drives tests without cryptography. +module Shomei.Passkey.Ceremony.Port + ( WebAuthnCeremony (..), + WebAuthnError (..), + CredentialUserInfo (..), + BeginCeremony (..), + StoredCredentialForVerify (..), + VerifiedRegistration (..), + VerifiedAuthentication (..), + beginRegistrationCeremony, + completeRegistrationCeremony, + beginAuthenticationCeremony, + completeAuthenticationCeremony, + ) +where + +import Data.Aeson (Value) +import Data.ByteString (ByteString) +import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Passkey.Domain + ( PublicKeyBytes, + SignatureCounter, + UserHandle, + UserVerificationPolicy, + WebAuthnCredentialId, + ) +import Shomei.Prelude + +-- | The verification failure modes, mapped from the library's +-- RegistrationError/AuthenticationError families to a small stable closed set. +data WebAuthnError + = WebAuthnDecodeError Text + | WebAuthnChallengeMismatch + | WebAuthnOriginMismatch + | WebAuthnRpIdMismatch + | WebAuthnUserNotPresent + | WebAuthnUserNotVerified + | WebAuthnSignatureInvalid + | WebAuthnCounterCloned + | WebAuthnOtherError Text + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | The user identity baked into a registration's options. +data CredentialUserInfo = CredentialUserInfo + { userHandle :: !UserHandle, + accountName :: !Text, + displayName :: !Text + } + deriving stock (Generic, Eq, Show) + +-- | The two outputs of a begin step: the JSON for the browser and the opaque +-- blob for PendingCeremonyStore (EP-2). +data BeginCeremony = BeginCeremony + { optionsJson :: !Value, + optionsBlob :: !ByteString + } + deriving stock (Generic, Eq, Show) + +-- | The stored fields the authentication verify step needs (EP-4 reads them +-- from PasskeyStore and hands them here). +data StoredCredentialForVerify = StoredCredentialForVerify + { credentialId :: !WebAuthnCredentialId, + userHandle :: !UserHandle, + publicKey :: !PublicKeyBytes, + signCounter :: !SignatureCounter, + transports :: ![Text] + } + deriving stock (Generic, Eq, Show) + +data VerifiedRegistration = VerifiedRegistration + { credentialId :: !WebAuthnCredentialId, + userHandle :: !UserHandle, + publicKey :: !PublicKeyBytes, + signCounter :: !SignatureCounter, + transports :: ![Text] + } + deriving stock (Generic, Eq, Show) + +data VerifiedAuthentication = VerifiedAuthentication + { credentialId :: !WebAuthnCredentialId, + newSignCounter :: !SignatureCounter, + cloneWarning :: !Bool + } + deriving stock (Generic, Eq, Show) + +data WebAuthnCeremony :: Effect where + -- 2nd arg = excludeCredentials (ids already enrolled for this user). + BeginRegistrationCeremony :: + CredentialUserInfo -> [WebAuthnCredentialId] -> WebAuthnCeremony m BeginCeremony + -- optionsBlob, then the browser's credential JSON. + CompleteRegistrationCeremony :: + ByteString -> Value -> WebAuthnCeremony m (Either WebAuthnError VerifiedRegistration) + -- User-verification policy, then allowCredentials ([] = passwordless discovery). + BeginAuthenticationCeremony :: + UserVerificationPolicy -> [WebAuthnCredentialId] -> WebAuthnCeremony m BeginCeremony + CompleteAuthenticationCeremony :: + ByteString -> + StoredCredentialForVerify -> + Value -> + WebAuthnCeremony m (Either WebAuthnError VerifiedAuthentication) + +type instance DispatchOf WebAuthnCeremony = Dynamic + +beginRegistrationCeremony :: + (WebAuthnCeremony :> es) => CredentialUserInfo -> [WebAuthnCredentialId] -> Eff es BeginCeremony +beginRegistrationCeremony u xs = send (BeginRegistrationCeremony u xs) + +completeRegistrationCeremony :: + (WebAuthnCeremony :> es) => ByteString -> Value -> Eff es (Either WebAuthnError VerifiedRegistration) +completeRegistrationCeremony b v = send (CompleteRegistrationCeremony b v) + +beginAuthenticationCeremony :: + (WebAuthnCeremony :> es) => UserVerificationPolicy -> [WebAuthnCredentialId] -> Eff es BeginCeremony +beginAuthenticationCeremony uv ids = send (BeginAuthenticationCeremony uv ids) + +completeAuthenticationCeremony :: + (WebAuthnCeremony :> es) => + ByteString -> StoredCredentialForVerify -> Value -> Eff es (Either WebAuthnError VerifiedAuthentication) +completeAuthenticationCeremony b c v = send (CompleteAuthenticationCeremony b c v) diff --git a/src/Shomei/Passkey/Ceremony/Store.hs b/src/Shomei/Passkey/Ceremony/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Passkey/Ceremony/Store.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Store effect for short-lived pending WebAuthn ceremony state. +-- +-- Between a ceremony's "begin" and "complete" halves the server must remember the +-- challenge and the serialized options blob it issued. This port persists that state +-- keyed by a 'CeremonyId' and consumes it exactly once. +-- +-- 'TakePendingCeremony' is the security heart: it is __consume-once__. It removes the +-- row and returns it only if the ceremony is present AND not yet expired +-- (@expiresAt > now@); it returns 'Nothing' if the ceremony is absent OR expired. The +-- @now@ 'UTCTime' is supplied by the caller (read from the 'Shomei.Time.Store' port). +-- An expired ceremony is still removed from the store when taken, so a stale row cannot +-- linger and be retried. Untaken rows are removed by the batched maintenance sweeper. +-- +-- The ceremony domain type is owned by EP-1 ('Shomei.Passkey.Domain'); this module only +-- references it. EP-2 supplies the in-memory and PostgreSQL interpreters. +module Shomei.Passkey.Ceremony.Store + ( PendingCeremonyStore (..), + putPendingCeremony, + takePendingCeremony, + ) +where + +import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Id (CeremonyId) +import Shomei.Passkey.Domain (PendingCeremony) +import Shomei.Prelude + +data PendingCeremonyStore :: Effect where + PutPendingCeremony :: PendingCeremony -> PendingCeremonyStore m () + -- | Consume-once: remove the row and return it iff present AND @expiresAt > now@; + -- otherwise return 'Nothing' (removing an expired row too). @now@ is the second arg. + TakePendingCeremony :: CeremonyId -> UTCTime -> PendingCeremonyStore m (Maybe PendingCeremony) + +type instance DispatchOf PendingCeremonyStore = Dynamic + +putPendingCeremony :: (PendingCeremonyStore :> es) => PendingCeremony -> Eff es () +putPendingCeremony = send . PutPendingCeremony + +takePendingCeremony :: (PendingCeremonyStore :> es) => CeremonyId -> UTCTime -> Eff es (Maybe PendingCeremony) +takePendingCeremony c t = send (TakePendingCeremony c t) diff --git a/src/Shomei/Passkey/Domain.hs b/src/Shomei/Passkey/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Passkey/Domain.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DataKinds #-} + +-- | Passkey (WebAuthn credential) domain types (MasterPlan 3, EP-1). +-- +-- These are pure data with no @webauthn@ dependency — the heavy library lives only in +-- the @shomei-webauthn@ package, and the 'Shomei.Passkey.Ceremony.Port' port crosses +-- the package boundary using aeson 'Data.Aeson.Value' plus the types defined here. Later +-- plans persist them: EP-2 stores 'PasskeyCredential' and 'PendingCeremony', EP-3's +-- enrollment workflow produces 'NewPasskeyCredential', and EP-4's login reads them back. +-- +-- The three @ByteString@ newtypes ('WebAuthnCredentialId', 'UserHandle', +-- 'PublicKeyBytes') are opaque authenticator bytes. aeson has no default 'ByteString' +-- JSON instance, so each carries hand-written instances encoding the bytes as +-- base64url-without-padding 'Text' via 'b64urlEncode' / 'b64urlDecode' (the same +-- encoding the rest of the codebase uses). These JSON instances matter because the +-- deterministic fake ceremony interpreter and the EP-3/EP-4 workflows move these values +-- around as JSON; PostgreSQL persistence (EP-2) uses native @bytea@, not JSON. +module Shomei.Passkey.Domain + ( UserVerificationPolicy (..), + WebAuthnCredentialId (..), + UserHandle (..), + PublicKeyBytes (..), + SignatureCounter (..), + NewPasskeyCredential (..), + PasskeyCredential (..), + CeremonyKind (..), + PendingCeremony (..), + + -- * base64url helpers (reused by EP-2..EP-4) + b64urlEncode, + b64urlDecode, + ) +where + +import Data.Base64.Types (extractBase64) +import Data.ByteString (ByteString) +import Data.ByteString.Base64.URL qualified as B64U +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import Data.Word (Word32) +import Shomei.Id (CeremonyId, PasskeyId, UserId) +import Shomei.Prelude + +-- | Per-ceremony WebAuthn user-verification policy. Kept in the pure passkey domain so the +-- ceremony port can choose a policy without depending on the aggregate runtime configuration. +data UserVerificationPolicy = UVRequired | UVPreferred | UVDiscouraged + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | base64url-without-padding encode strict bytes to text. +b64urlEncode :: ByteString -> Text +b64urlEncode = extractBase64 . B64U.encodeBase64Unpadded + +-- | Decode base64url-without-padding text back to strict bytes. +b64urlDecode :: Text -> Either String ByteString +b64urlDecode = either (Left . Text.unpack) Right . B64U.decodeBase64UnpaddedUntyped . TE.encodeUtf8 + +-- | The authenticator-assigned credential id (stored as bytea). Opaque bytes. +newtype WebAuthnCredentialId = WebAuthnCredentialId ByteString + deriving stock (Generic, Eq, Show) + +instance ToJSON WebAuthnCredentialId where + toJSON (WebAuthnCredentialId bs) = toJSON (b64urlEncode bs) + +instance FromJSON WebAuthnCredentialId where + parseJSON v = WebAuthnCredentialId <$> (parseJSON v >>= either fail pure . b64urlDecode) + +-- | The RP-assigned per-user handle (random bytes the authenticator returns at login). +newtype UserHandle = UserHandle ByteString + deriving stock (Generic, Eq, Show) + +instance ToJSON UserHandle where + toJSON (UserHandle bs) = toJSON (b64urlEncode bs) + +instance FromJSON UserHandle where + parseJSON v = UserHandle <$> (parseJSON v >>= either fail pure . b64urlDecode) + +-- | The COSE public-key bytes exactly as the webauthn library serializes them. +newtype PublicKeyBytes = PublicKeyBytes ByteString + deriving stock (Generic, Eq, Show) + +instance ToJSON PublicKeyBytes where + toJSON (PublicKeyBytes bs) = toJSON (b64urlEncode bs) + +instance FromJSON PublicKeyBytes where + parseJSON v = PublicKeyBytes <$> (parseJSON v >>= either fail pure . b64urlDecode) + +-- | The authenticator's signature counter (clone-detection aid). +newtype SignatureCounter = SignatureCounter Word32 + deriving stock (Generic, Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- | A freshly verified registration, ready for EP-2's store to persist. +data NewPasskeyCredential = NewPasskeyCredential + { userId :: !UserId, + credentialId :: !WebAuthnCredentialId, + userHandle :: !UserHandle, + publicKey :: !PublicKeyBytes, + signCounter :: !SignatureCounter, + transports :: ![Text], + label :: !(Maybe Text), + createdAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A persisted passkey (EP-2 reads/writes this; EP-1 only defines it). +data PasskeyCredential = PasskeyCredential + { passkeyId :: !PasskeyId, + userId :: !UserId, + credentialId :: !WebAuthnCredentialId, + userHandle :: !UserHandle, + publicKey :: !PublicKeyBytes, + signCounter :: !SignatureCounter, + transports :: ![Text], + label :: !(Maybe Text), + createdAt :: !UTCTime, + lastUsedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Which ceremony a pending blob belongs to. +data CeremonyKind = RegistrationCeremony | AuthenticationCeremony + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | The short-lived challenge/options state (EP-1 defines; EP-2 persists). +data PendingCeremony = PendingCeremony + { ceremonyId :: !CeremonyId, + userId :: !(Maybe UserId), + kind :: !CeremonyKind, + optionsBlob :: !ByteString, + createdAt :: !UTCTime, + expiresAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) diff --git a/src/Shomei/Passkey/Store.hs b/src/Shomei/Passkey/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Passkey/Store.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Store effect for registered passkeys (WebAuthn public-key credentials). +-- +-- A passkey is the public half of a WebAuthn credential that an authenticator +-- created during a registration ceremony. This port persists those credentials and +-- offers the three lookups the workflows need: by owning user (enrollment listing), +-- by the authenticator-assigned credential id (the assertion key the browser returns), +-- and by the per-user 'UserHandle' (passwordless discovery in EP-4). It also bumps the +-- clone-detection signature counter, counts a user's passkeys, and deletes one. +-- +-- The credential domain types are owned by EP-1 ('Shomei.Passkey.Domain'); this module +-- only references them. EP-2 supplies the in-memory and PostgreSQL interpreters. +module Shomei.Passkey.Store + ( PasskeyStore (..), + createPasskey, + findPasskeysByUser, + findPasskeyByCredentialId, + findPasskeysByUserHandle, + updatePasskeySignCounter, + deletePasskey, + countPasskeysByUser, + ) +where + +import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Id (PasskeyId, UserId) +import Shomei.Passkey.Domain + ( NewPasskeyCredential, + PasskeyCredential, + SignatureCounter, + UserHandle, + WebAuthnCredentialId, + ) +import Shomei.Prelude + +data PasskeyStore :: Effect where + CreatePasskey :: NewPasskeyCredential -> PasskeyStore m PasskeyCredential + FindPasskeysByUser :: UserId -> PasskeyStore m [PasskeyCredential] + FindPasskeyByCredentialId :: WebAuthnCredentialId -> PasskeyStore m (Maybe PasskeyCredential) + FindPasskeysByUserHandle :: UserHandle -> PasskeyStore m [PasskeyCredential] + -- | Compare-and-swap the signature counter and @last_used_at@. 'False' means replay. A + -- counterless authenticator's zero-to-zero update is accepted, matching WebAuthn clone checks. + UpdatePasskeySignCounter :: PasskeyId -> SignatureCounter -> UTCTime -> PasskeyStore m Bool + -- | Delete only when both the owning user and the passkey id match (a user action). + DeletePasskey :: UserId -> PasskeyId -> PasskeyStore m () + CountPasskeysByUser :: UserId -> PasskeyStore m Int + +type instance DispatchOf PasskeyStore = Dynamic + +createPasskey :: (PasskeyStore :> es) => NewPasskeyCredential -> Eff es PasskeyCredential +createPasskey = send . CreatePasskey + +findPasskeysByUser :: (PasskeyStore :> es) => UserId -> Eff es [PasskeyCredential] +findPasskeysByUser = send . FindPasskeysByUser + +findPasskeyByCredentialId :: (PasskeyStore :> es) => WebAuthnCredentialId -> Eff es (Maybe PasskeyCredential) +findPasskeyByCredentialId = send . FindPasskeyByCredentialId + +findPasskeysByUserHandle :: (PasskeyStore :> es) => UserHandle -> Eff es [PasskeyCredential] +findPasskeysByUserHandle = send . FindPasskeysByUserHandle + +updatePasskeySignCounter :: (PasskeyStore :> es) => PasskeyId -> SignatureCounter -> UTCTime -> Eff es Bool +updatePasskeySignCounter i c t = send (UpdatePasskeySignCounter i c t) + +deletePasskey :: (PasskeyStore :> es) => UserId -> PasskeyId -> Eff es () +deletePasskey u p = send (DeletePasskey u p) + +countPasskeysByUser :: (PasskeyStore :> es) => UserId -> Eff es Int +countPasskeysByUser = send . CountPasskeysByUser diff --git a/src/Shomei/Passkey/Workflow.hs b/src/Shomei/Passkey/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Passkey/Workflow.hs @@ -0,0 +1,168 @@ +-- | Authenticated passkey enrollment and management workflows (MasterPlan 3, EP-3). +-- +-- A "passkey" is a stored public-key credential. These workflows let an already-authenticated +-- user begin a WebAuthn registration ceremony, complete it (verifying the browser's answer and +-- storing the public key), list their passkeys, and remove one. They are written purely against +-- port effects, so the same code runs over the in-memory test interpreters and the real +-- PostgreSQL + @shomei-webauthn@ interpreters. Login (the assertion ceremony) is EP-4, not here. +-- +-- The ceremony types ('CredentialUserInfo', 'BeginCeremony', 'VerifiedRegistration') and the +-- ceremony effect live in 'Shomei.Passkey.Ceremony.Port' (EP-1); the stored passkey/pending +-- types in 'Shomei.Passkey.Domain' (EP-1); the two stores in 'Shomei.Passkey.Store' / +-- 'Shomei.Passkey.Ceremony.Store' (EP-2). OverloadedRecordDot is unreliable for those EP-1 +-- records (a MasterPlan-3 discovery), so they are read via plain record-pattern matching. +module Shomei.Passkey.Workflow + ( beginPasskeyRegistration, + completePasskeyRegistration, + listPasskeys, + removePasskey, + ) +where + +import Data.Aeson (Value) +import Data.ByteString.Lazy qualified as BSL +import Data.Text qualified as Text +import Data.Time (addUTCTime) +import Data.UUID qualified as UUID +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (runErrorNoCallStack, throwError) +import Shomei.Account.Email.Domain (emailText) +import Shomei.Account.LoginId.Domain (loginIdText) +import Shomei.Account.User.Domain (User (..)) +import Shomei.Account.User.Store (UserStore, findUserById) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Config (ShomeiConfig (..), WebAuthnConfig (..)) +import Shomei.Error (AuthError (..)) +import Shomei.Id (CeremonyId, PasskeyId, UserId, genCeremonyId, userIdToUUID) +import Shomei.Passkey.Ceremony.Port + ( BeginCeremony (..), + CredentialUserInfo (..), + VerifiedRegistration (..), + WebAuthnCeremony, + beginRegistrationCeremony, + completeRegistrationCeremony, + ) +import Shomei.Passkey.Ceremony.Store (PendingCeremonyStore, putPendingCeremony, takePendingCeremony) +import Shomei.Passkey.Domain + ( CeremonyKind (RegistrationCeremony), + NewPasskeyCredential (..), + PasskeyCredential (..), + PendingCeremony (..), + UserHandle (..), + ) +import Shomei.Passkey.Store (PasskeyStore, createPasskey, deletePasskey, findPasskeysByUser) +import Shomei.Prelude +import Shomei.Time.Store (Clock, now) + +-- | Derive a stable WebAuthn user handle from the Shōmei user id: the 16 bytes of the +-- user's UUID. All of a user's passkeys therefore share one handle, so a passwordless login +-- (EP-4) can resolve the user from the handle alone. We deliberately do not use a random +-- handle (see the MasterPlan Decision Log). +userHandleForUser :: UserId -> UserHandle +userHandleForUser uid = UserHandle (BSL.toStrict (UUID.toByteString (userIdToUUID uid))) + +-- | Collapse a blank label to 'Nothing' (mirrors @mkDisplayName@ in the handlers). +normalizeLabel :: Text -> Maybe Text +normalizeLabel t + | Text.null (Text.strip t) = Nothing + | otherwise = Just (Text.strip t) + +beginPasskeyRegistration :: + ( UserStore :> es, + PasskeyStore :> es, + PendingCeremonyStore :> es, + WebAuthnCeremony :> es, + Clock :> es, + IOE :> es + ) => + ShomeiConfig -> + UserId -> + Eff es (Either AuthError (CeremonyId, Value)) +beginPasskeyRegistration cfg uid = runErrorNoCallStack do + ts <- now + user <- maybe (throwError InvalidCredentials) pure =<< findUserById uid + existing <- findPasskeysByUser uid + -- The human-readable label shown in the browser's passkey UI: prefer the email when + -- present, otherwise fall back to the login identifier (the user handle itself is + -- always derived from the user id, so it is unaffected by a missing email). + let accountLabel = maybe (loginIdText user.loginId) emailText user.email + info = + CredentialUserInfo + { userHandle = userHandleForUser uid, + accountName = accountLabel, + displayName = fromMaybe accountLabel user.displayName + } + excludeIds = map (\PasskeyCredential {credentialId} -> credentialId) existing + BeginCeremony {optionsJson, optionsBlob} <- beginRegistrationCeremony info excludeIds + ceremonyId <- genCeremonyId + putPendingCeremony + PendingCeremony + { ceremonyId = ceremonyId, + userId = Just uid, + kind = RegistrationCeremony, + optionsBlob = optionsBlob, + createdAt = ts, + expiresAt = addUTCTime (pendingCeremonyTTL (webauthnConfig cfg)) ts + } + pure (ceremonyId, optionsJson) + +completePasskeyRegistration :: + ( PasskeyStore :> es, + PendingCeremonyStore :> es, + WebAuthnCeremony :> es, + AuthEventPublisher :> es, + Clock :> es + ) => + ShomeiConfig -> + UserId -> + CeremonyId -> + Value -> + Maybe Text -> + Eff es (Either AuthError PasskeyCredential) +completePasskeyRegistration _cfg uid ceremonyId credentialJson mLabel = runErrorNoCallStack do + ts <- now + PendingCeremony {kind, userId = pendingUid, optionsBlob} <- + maybe (throwError PendingCeremonyNotFound) pure =<< takePendingCeremony ceremonyId ts + -- Reject a ceremony that is not a registration, or that was begun for a different user. + when (kind /= RegistrationCeremony) (throwError PendingCeremonyNotFound) + when (pendingUid /= Just uid) (throwError PendingCeremonyNotFound) + VerifiedRegistration {credentialId, userHandle, publicKey, signCounter, transports} <- + either (throwError . WebAuthnCeremonyError) pure + =<< completeRegistrationCeremony optionsBlob credentialJson + passkey <- + createPasskey + NewPasskeyCredential + { userId = uid, + credentialId, + userHandle, + publicKey, + signCounter, + transports, + label = normalizeLabel =<< mLabel, + createdAt = ts + } + let PasskeyCredential {passkeyId} = passkey + publishAuthEvent (Event.PasskeyRegistered (Event.PasskeyRegisteredData uid passkeyId ts)) + pure passkey + +listPasskeys :: + (PasskeyStore :> es) => + UserId -> + Eff es [PasskeyCredential] +listPasskeys = findPasskeysByUser + +removePasskey :: + ( PasskeyStore :> es, + AuthEventPublisher :> es, + Clock :> es + ) => + UserId -> + PasskeyId -> + Eff es (Either AuthError ()) +removePasskey uid pid = runErrorNoCallStack do + ts <- now + owned <- findPasskeysByUser uid + unless (any (\PasskeyCredential {passkeyId} -> passkeyId == pid) owned) (throwError PasskeyNotFound) + deletePasskey uid pid + publishAuthEvent (Event.PasskeyRemoved (Event.PasskeyRemovedData uid pid ts)) diff --git a/src/Shomei/Prelude.hs b/src/Shomei/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Prelude.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE PackageImports #-} + +-- | Shōmei shared prelude. Import this module in every Shōmei module instead of +-- importing 'Prelude' directly. Every import here uses PackageImports to pin the +-- originating package and avoid ambiguity when multiple packages re-export the same +-- name. +-- +-- Usage: +-- +-- > import Shomei.Prelude +-- +-- Do NOT add @import "base" Prelude@ after this; GHC2024 hides the default Prelude +-- when you write a custom one. +module Shomei.Prelude + ( module X, + module Control.Lens, + eventAesonOptions, + ) +where + +import "aeson" Data.Aeson as X + ( FromJSON, + Options (..), + SumEncoding (..), + ToJSON, + camelTo2, + defaultOptions, + fromJSON, + genericParseJSON, + genericToEncoding, + genericToJSON, + parseJSON, + toEncoding, + toJSON, + ) +import "base" Control.Applicative as X ((<|>)) +import "base" Control.Monad as X + ( forM, + forM_, + guard, + unless, + void, + when, + ) +import "base" Control.Monad.IO.Class as X (MonadIO, liftIO) +import "base" Data.List.NonEmpty as X (NonEmpty (..)) +import "base" Data.Maybe as X + ( fromMaybe, + isJust, + isNothing, + mapMaybe, + ) +import "base" Data.Proxy as X (Proxy (..)) +import "base" GHC.Generics as X (Generic) +import "lens" Control.Lens +import "text" Data.Text as X (Text) +import "time" Data.Time as X (UTCTime, getCurrentTime) + +-- | Aeson 'Options' for event types: tagged objects with snake_case constructor +-- names and always-tagged single constructors. +-- +-- Example: @data MyEvent = UserCreated { ... }@ serialises as +-- @{ "type": "user_created", "data": { ... } }@. +eventAesonOptions :: Options +eventAesonOptions = + defaultOptions + { sumEncoding = TaggedObject "type" "data", + constructorTagModifier = camelTo2 '_', + tagSingleConstructors = True + } diff --git a/src/Shomei/ServiceAccount/ClientCredentials/Workflow.hs b/src/Shomei/ServiceAccount/ClientCredentials/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/ServiceAccount/ClientCredentials/Workflow.hs @@ -0,0 +1,145 @@ +-- | The OAuth2 @client_credentials@ grant (RFC 6749 §4.4) over database-backed service accounts. +-- +-- A machine client authenticates as itself with a @client_id@ and a secret, and receives an +-- access token for its own identity — no user interaction, and deliberately no refresh token: +-- the credential dies at its TTL and the client simply asks again. +-- +-- A database-backed account is enabled by existing in active state and revoked by changing that +-- state. Its refresh-less token ages according to 'MachineTokenConfig'. +module Shomei.ServiceAccount.ClientCredentials.Workflow + ( ClientCredentialsGrant (..), + GrantedToken (..), + grantClientCredentials, + ) +where + +import Data.Generics.Labels () +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Time (NominalDiffTime, addUTCTime) +import Effectful (Eff, (:>)) +import Effectful.Error.Static (runErrorNoCallStack, throwError) +-- Imported WITHOUT (..): 'ServiceAccount' shares the field names @userId@ and @status@ with +-- 'Shomei.Account.User.Domain.User', and bringing both record's fields into scope defeats +-- @OverloadedRecordDot@'s 'HasField' resolution (a MasterPlan-3 discovery). Every field below is +-- read through a generic-lens label instead, exactly as 'Shomei.ServiceAccount.Secret' does. + +import Shomei.Account.User.Domain (UserStatus (UserActive)) +import Shomei.Account.User.Store (UserStore, findUserById) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Authorization.Claims.Domain (Scope) +import Shomei.Config (MachineTokenConfig (..), ServiceAccountId (..), ShomeiConfig (..)) +import Shomei.Error (AuthError (..)) +import Shomei.Id (SessionId) +import Shomei.Prelude +import Shomei.ServiceAccount.Domain (ServiceAccount, ServiceAccountStatus (..)) +import Shomei.ServiceAccount.Secret (verifyServiceSecret) +import Shomei.ServiceAccount.Store (ServiceAccountStore, findServiceAccountByClientId) +import Shomei.Session.Domain (NewSession (..), SessionKind (MachineSession)) +import Shomei.Session.Store (SessionStore, createSession) +import Shomei.Session.Token.Domain (AccessToken) +import Shomei.Session.Workflow (buildClaims) +import Shomei.SigningKey.Signer (TokenSigner, signAccessToken) +import Shomei.Time.Store (Clock, now) + +data ClientCredentialsGrant = ClientCredentialsGrant + { clientId :: !Text, + clientSecret :: !Text, + -- | 'Nothing' means the @scope@ parameter was absent from the request, which RFC 6749 §3.3 + -- lets the server answer with a default. @Just@ an empty set means the caller sent + -- @scope=@, which is a malformed request, not a request for nothing. + requestedScopes :: !(Maybe (Set Scope)) + } + deriving stock (Generic, Eq, Show) + +data GrantedToken = GrantedToken + { accessToken :: !AccessToken, + expiresIn :: !NominalDiffTime, + -- | echoed back to the client, so it never has to guess what it was actually given + grantedScopes :: !(Set Scope), + sessionId :: !SessionId + } + deriving stock (Generic, Eq, Show) + +-- | Authenticate a database-backed service account and mint its access token. +-- +-- Every authentication failure — unknown @client_id@, wrong secret, revoked account, missing or +-- inactive backing user — returns the single 'OAuthClientInvalid'. A caller must not be able to +-- tell a revoked credential from a mistyped one, nor learn that a @client_id@ exists. +grantClientCredentials :: + ( ServiceAccountStore :> es, + UserStore :> es, + SessionStore :> es, + TokenSigner :> es, + AuthEventPublisher :> es, + Clock :> es + ) => + ShomeiConfig -> + ClientCredentialsGrant -> + Eff es (Either AuthError GrantedToken) +grantClientCredentials cfg cmd = runErrorNoCallStack do + account <- maybe (throwError OAuthClientInvalid) pure =<< findServiceAccountByClientId (cmd ^. #clientId) + -- Verify the secret before checking status, so a revoked account and an active one with a + -- wrong secret cost the same work. + unless (verifyServiceSecret (account ^. #secretHash) (cmd ^. #clientSecret)) (throwError OAuthClientInvalid) + unless ((account ^. #status) == ServiceAccountActive) (throwError OAuthClientInvalid) + granted <- resolveScopes account + serviceUser <- do + user <- maybe (throwError OAuthClientInvalid) pure =<< findUserById (account ^. #userId) + unless ((user ^. #status) == UserActive) (throwError OAuthClientInvalid) + pure user + ts <- now + let ttl = cfg ^. #machineTokenConfig . #machineTokenTTL + expires = addUTCTime ttl ts + -- A refresh-less session: no NewRefreshToken is ever created for it, so the credential cannot + -- outlive its TTL. Machine clients re-authenticate instead of refreshing. + session <- + createSession + NewSession + { userId = serviceUser ^. #userId, + createdAt = ts, + expiresAt = expires, + actor = Nothing, + oauthClientId = Nothing, + kind = MachineSession, + grantedScopes = Set.empty, + authenticatedAt = ts + } + let claims = + (buildClaims cfg (serviceUser ^. #userId) (session ^. #sessionId) ts) + & #expiresAt + .~ expires + & #scopes + .~ granted + access <- signAccessToken claims + publishAuthEvent + ( Event.ServiceTokenIssued + Event.ServiceTokenIssuedData + { userId = serviceUser ^. #userId, + sessionId = session ^. #sessionId, + -- The wire shape is unchanged: 'ServiceAccountId' is a newtype over 'Text', and the + -- database-backed account's public name is its client id. + accountId = ServiceAccountId (account ^. #clientId), + scopes = granted, + actorId = Nothing, + occurredAt = ts + } + ) + pure + GrantedToken + { accessToken = access, + expiresIn = ttl, + grantedScopes = granted, + sessionId = session ^. #sessionId + } + where + -- RFC 6749 §3.3: an absent `scope` may take a server-defined default. "Everything this + -- account is allowed" is the least surprising default for a machine credential. A present + -- `scope` must name a non-empty subset of the allow-list. + resolveScopes account = case cmd ^. #requestedScopes of + Nothing -> pure (account ^. #allowedScopes) + Just requested -> do + when (Set.null requested) (throwError OAuthScopeInvalid) + unless (requested `Set.isSubsetOf` (account ^. #allowedScopes)) (throwError OAuthScopeInvalid) + pure requested diff --git a/src/Shomei/ServiceAccount/Domain.hs b/src/Shomei/ServiceAccount/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/ServiceAccount/Domain.hs @@ -0,0 +1,54 @@ +-- | The service-account entity (EP-4): a machine credential an operator creates, rotates, and +-- revokes at runtime, authenticating at @POST \/oauth\/token@ with the OAuth2 +-- @client_credentials@ grant. +-- +-- 'secretHash' is a lowercase 64-character SHA-256 hex digest verified in constant time by +-- 'Shomei.ServiceAccount.Secret.verifyServiceSecret'. +module Shomei.ServiceAccount.Domain + ( ServiceAccountStatus (..), + ServiceAccount (..), + NewServiceAccount (..), + ) +where + +import Data.Set (Set) +import Shomei.Authorization.Claims.Domain (Scope) +import Shomei.Id (ServiceAccountDbId, UserId) +import Shomei.Prelude + +-- | A revoked account keeps its row: audit events naming it must still resolve, and a revoked +-- credential must be refused, not forgotten. +data ServiceAccountStatus = ServiceAccountActive | ServiceAccountRevoked + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data ServiceAccount = ServiceAccount + { serviceAccountId :: !ServiceAccountDbId, + -- | the TypeID text rendering of 'serviceAccountId'; the OAuth2 @client_id@. Public. + clientId :: !Text, + -- | the @shomei_users@ row backing this account's sessions and claims @sub@ + userId :: !UserId, + secretHash :: !Text, + displayName :: !Text, + -- | the ceiling on what a token from this account may carry. A @client_credentials@ + -- request with no @scope@ parameter is granted all of them. + allowedScopes :: !(Set Scope), + status :: !ServiceAccountStatus, + createdAt :: !UTCTime, + rotatedAt :: !(Maybe UTCTime), + revokedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data NewServiceAccount = NewServiceAccount + { serviceAccountId :: !ServiceAccountDbId, + clientId :: !Text, + userId :: !UserId, + secretHash :: !Text, + displayName :: !Text, + allowedScopes :: !(Set Scope), + createdAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/ServiceAccount/Secret.hs b/src/Shomei/ServiceAccount/Secret.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/ServiceAccount/Secret.hs @@ -0,0 +1,26 @@ +-- | Hashing and constant-time verification for service-account client secrets. +module Shomei.ServiceAccount.Secret + ( sha256Hex, + verifyServiceSecret, + ) +where + +import Crypto.Hash (SHA256 (..), hashWith) +import Data.ByteArray qualified as BA +import Data.ByteArray.Encoding (Base (Base16), convertToBase) +import Data.ByteString (ByteString) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import Shomei.Prelude + +-- | Constant-time check of a presented secret against a stored lowercase SHA-256 hex digest. +verifyServiceSecret :: Text -> Text -> Bool +verifyServiceSecret expectedHash presentedSecret = + let expected = TE.encodeUtf8 (Text.toLower expectedHash) + actual = TE.encodeUtf8 (sha256Hex presentedSecret) + in expected `BA.constEq` actual + +sha256Hex :: Text -> Text +sha256Hex secret = + let digest = hashWith SHA256 (TE.encodeUtf8 secret) + in Text.toLower (TE.decodeUtf8 (convertToBase Base16 digest :: ByteString)) diff --git a/src/Shomei/ServiceAccount/Store.hs b/src/Shomei/ServiceAccount/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/ServiceAccount/Store.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The service-account port (EP-4): the @shomei_service_accounts@ table behind the OAuth2 +-- @client_credentials@ grant. +-- +-- Lookup is by @client_id@ (the public TypeID text), because that is what an OAuth2 client +-- presents. Mutations are by 'ServiceAccountDbId', because that is what an administrator holds +-- after a create or a list. +module Shomei.ServiceAccount.Store + ( ServiceAccountStore (..), + createServiceAccount, + findServiceAccountByClientId, + listServiceAccounts, + rotateServiceAccountSecret, + revokeServiceAccount, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Id (ServiceAccountDbId) +import Shomei.Prelude +import Shomei.ServiceAccount.Domain (NewServiceAccount, ServiceAccount) + +data ServiceAccountStore :: Effect where + CreateServiceAccount :: NewServiceAccount -> ServiceAccountStore m ServiceAccount + -- | The authentication lookup. Returns revoked accounts too: refusing a revoked credential + -- is the workflow's job, and it must be indistinguishable from a wrong secret. + FindServiceAccountByClientId :: Text -> ServiceAccountStore m (Maybe ServiceAccount) + -- | The whole table, newest first. Deployments have few service accounts; no paging. + ListServiceAccounts :: ServiceAccountStore m [ServiceAccount] + -- | Replace the secret hash and stamp @rotated_at@. Takes the /new hash/, never a plaintext: + -- the secret is generated and shown once by the caller. + RotateServiceAccountSecret :: ServiceAccountDbId -> Text -> UTCTime -> ServiceAccountStore m () + RevokeServiceAccount :: ServiceAccountDbId -> UTCTime -> ServiceAccountStore m () + +type instance DispatchOf ServiceAccountStore = Dynamic + +createServiceAccount :: (ServiceAccountStore :> es) => NewServiceAccount -> Eff es ServiceAccount +createServiceAccount = send . CreateServiceAccount + +findServiceAccountByClientId :: (ServiceAccountStore :> es) => Text -> Eff es (Maybe ServiceAccount) +findServiceAccountByClientId = send . FindServiceAccountByClientId + +listServiceAccounts :: (ServiceAccountStore :> es) => Eff es [ServiceAccount] +listServiceAccounts = send ListServiceAccounts + +rotateServiceAccountSecret :: (ServiceAccountStore :> es) => ServiceAccountDbId -> Text -> UTCTime -> Eff es () +rotateServiceAccountSecret sid h t = send (RotateServiceAccountSecret sid h t) + +revokeServiceAccount :: (ServiceAccountStore :> es) => ServiceAccountDbId -> UTCTime -> Eff es () +revokeServiceAccount sid t = send (RevokeServiceAccount sid t) diff --git a/src/Shomei/Session/Authentication/Workflow.hs b/src/Shomei/Session/Authentication/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Authentication/Workflow.hs @@ -0,0 +1,492 @@ +-- | The authentication workflows, written purely against the port effects. +-- +-- These five functions are the behavioral heart of Shōmei: 'signup', 'login', 'refresh' +-- (rotation with reuse detection), 'logout', and 'verifyToken'. They contain the rules of +-- the system and no infrastructure — every external capability is a port effect, so the +-- same workflows run against the in-memory interpreter (tests, here) and the real +-- PostgreSQL + JWT interpreters (EP-3/EP-4/EP-6). +-- +-- 'signup' and 'login' use a local 'Effectful.Error.Static' 'Error' effect to +-- short-circuit on the first 'AuthError'; 'refresh'/'logout'/'verifyToken' return +-- @Either AuthError@ directly via explicit case analysis (the rotation logic reads more +-- clearly that way). The 'Shomei.Audit.Event.Domain' module is imported qualified and its values +-- are built positionally, because several of its constructors deliberately share names +-- with 'AuthError' constructors. +module Shomei.Session.Authentication.Workflow + ( signup, + login, + refresh, + refreshFrom, + logout, + verifyToken, + verifyTokenWith, + LoginResult (..), + MfaChallenge (..), + Refreshed (..), + issueSession, + ) +where + +import Data.Aeson (Value) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Time (addUTCTime) +import Effectful (Eff, IOE, (:>)) +import Effectful.Error.Static (Error, runErrorNoCallStack, throwError) +import Shomei.Account.Credential.Domain (Credential (..)) +import Shomei.Account.Credential.Store (CredentialStore, createPasswordCredential, findPasswordCredentialByLoginId) +import Shomei.Account.Email.Domain (emailText) +import Shomei.Account.Password.Breach.Store (PasswordBreachChecker) +import Shomei.Account.Password.Breach.Workflow (enforceBreachPolicy) +import Shomei.Account.Password.Domain (PasswordContext (..), validatePassword) +import Shomei.Account.Password.Hash.Store (PasswordHasher, hashPassword, verifyPassword, verifyPasswordDummy) +import Shomei.Account.User.Domain (NewUser (..), User (..), UserStatus (UserActive)) +import Shomei.Account.User.Store (UserStore, createUser, findUserByEmail, findUserById, findUserByLoginId) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Authorization.Claims.Domain (AuthClaims (..), Scope) +import Shomei.Authorization.Claims.Store (ClaimsEnricher) +import Shomei.Authorization.Role.Store (RoleStore) +import Shomei.Authorization.Role.Workflow (applyDefaultRoles) +import Shomei.Config (MfaConfig (..), NotifierConfig (..), RateLimitConfig (..), SessionCheckMode (..), ShomeiConfig (..)) +import Shomei.Error (AuthError (..)) +import Shomei.Id (CeremonyId, UserId) +import Shomei.Mfa.RecoveryCode.Store (RecoveryCodeStore) +import Shomei.Mfa.Totp.Domain (isTotpConfirmed) +import Shomei.Mfa.Totp.Store (TotpCredentialStore, findTotpByUser) +import Shomei.Mfa.Workflow (prepareMfaChallenge) +import Shomei.Passkey.Ceremony.Port (WebAuthnCeremony) +import Shomei.Passkey.Ceremony.Store (PendingCeremonyStore) +import Shomei.Passkey.Store (PasskeyStore, countPasskeysByUser) +import Shomei.Prelude +import Shomei.Session.Command (ClientContext (..), LoginCommand (..), LogoutCommand (..), RefreshCommand (..), RefreshOrigin (..), SignupCommand (..)) +import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (InteractiveSession), SessionStatus (SessionActive)) +import Shomei.Session.LoginAttempt.Domain (AccountLockout (..), AttemptFactor (FactorPassword), FailureOutcome (..)) +import Shomei.Session.LoginAttempt.Store (LoginAttemptStore, clearAccountLockout, convertLoginAttemptToSuccess, discardLoginAttempt) +import Shomei.Session.LoginAttempt.Workflow + ( guardIpBudget, + recordProofFailureOutcome, + ) +import Shomei.Session.RefreshToken.Domain (NewRefreshToken (..), PersistedRefreshToken (..)) +import Shomei.Session.RefreshToken.Domain qualified as RT +import Shomei.Session.RefreshToken.Store + ( RefreshTokenStore, + findRefreshTokenByHash, + ) +import Shomei.Session.Store (SessionStore, findSessionById) +import Shomei.Session.Token.Domain (AccessToken, TokenPair (..)) +import Shomei.Session.Token.Generator (TokenGen, generateOpaqueToken, hashRefreshToken) +import Shomei.Session.UnitOfWork.Store + ( AuthUnitOfWork, + NewSessionToken (..), + RotationOutcome (..), + persistNewSession, + revokeSessionWithTokens, + rotateRefreshToken, + ) +import Shomei.Session.Workflow (buildEnrichedClaims, ensureEmailVerified, issueSession, requireLiveSession) +import Shomei.SigningKey.Signer (TokenSigner, signAccessToken) +import Shomei.SigningKey.Verifier (TokenVerifier, verifyAccessToken) +import Shomei.Time.Store (Clock, now) + +-- | The step-up challenge handed back when an account with any enrolled second factor logs in +-- with the correct password and second-factor policy is on. 'ceremonyId' is the consume-once +-- pending-MFA handle the client echoes to 'Shomei.Mfa.Workflow.completeMfa'; 'options' is the +-- @navigator.credentials.get()@ options the browser runs (the empty object @{}@ for a TOTP-only +-- user, who has no WebAuthn ceremony); 'methods' advertises which factors can complete it +-- (@"passkey"@, @"totp"@, @"recovery_code"@). +data MfaChallenge = MfaChallenge + { ceremonyId :: !CeremonyId, + options :: !Value, + methods :: ![Text] + } + deriving stock (Generic, Eq, Show) + +-- | The outcome of 'login'. 'LoginComplete' contains the user and tokens and is returned +-- unchanged for accounts with no second factor or with the MFA policy off. 'MfaRequired' means the +-- password was correct but a second factor is now demanded; NO token is issued yet. +data LoginResult + = LoginComplete User TokenPair + | MfaRequired MfaChallenge + deriving stock (Generic, Eq, Show) + +signup :: + ( UserStore :> es, + CredentialStore :> es, + AuthUnitOfWork :> es, + PasswordHasher :> es, + PasswordBreachChecker :> es, + TokenSigner :> es, + RoleStore :> es, + ClaimsEnricher :> es, + AuthEventPublisher :> es, + -- 'applyDefaultRoles' audits each grant it makes. Note that this workflow's own + -- UserRegistered/SessionStarted events go through 'persistNewSession' (inside its + -- transaction); the publisher constraint is only for those default-role grants. + Clock :> es, + TokenGen :> es + ) => + ShomeiConfig -> + SignupCommand -> + Eff es (Either AuthError (User, TokenPair)) +signup cfg cmd = runErrorNoCallStack do + let pwContext = + PasswordContext + { contextEmail = emailText <$> cmd.email, + contextDisplayName = cmd.displayName + } + either (throwError . WeakPassword) pure (validatePassword cfg.passwordPolicy pwContext cmd.password) + enforceBreachPolicy cfg.passwordPolicy cmd.password + existing <- findUserByLoginId cmd.loginId + when (isJust existing) (throwError LoginIdAlreadyRegistered) + forM_ cmd.email \email -> do + existingByEmail <- findUserByEmail email + when (isJust existingByEmail) (throwError EmailAlreadyRegistered) + pwHash <- hashPassword cmd.password + ts <- now + user <- createUser NewUser {loginId = cmd.loginId, email = cmd.email, displayName = cmd.displayName} + _ <- createPasswordCredential user.userId cmd.loginId cmd.email pwHash + -- Before the session (and therefore before the first token is minted), so the very first + -- access token already carries the configured default roles. + applyDefaultRoles cfg user.userId ts + rawToken <- generateOpaqueToken + tokHash <- hashRefreshToken rawToken + -- Session row, refresh-token row, and both audit events in one transaction: a crash here + -- leaves the new user with no session rather than a session with no token. + (session, _token) <- + persistNewSession + NewSession + { userId = user.userId, + createdAt = ts, + expiresAt = addUTCTime cfg.sessionTTL ts, + actor = Nothing, + oauthClientId = Nothing, + kind = InteractiveSession, + grantedScopes = Set.empty, + authenticatedAt = ts + } + NewSessionToken + { tokenHash = tokHash, + createdAt = ts, + expiresAt = addUTCTime cfg.refreshTokenTTL ts + } + \sid -> + [ Event.UserRegistered (Event.UserRegisteredData user.userId cmd.loginId cmd.email ts), + Event.SessionStarted (Event.SessionStartedData sid user.userId ts) + ] + access <- signAccessToken =<< buildEnrichedClaims cfg user.userId session.sessionId ts + pure + ( user, + TokenPair {accessToken = access, refreshToken = rawToken, expiresIn = cfg.accessTokenTTL} + ) + +-- | Authenticate a login-id/password pair, with EP-2 abuse protection layered on the +-- existing generic-error contract. Before verifying the password the workflow consults the +-- per-IP failure budget and the per-account lockout state; every failure path records an +-- attempt and, once the per-account budget is exhausted within the window, locks the account +-- for the configured cooldown. To preserve the no-leak guarantee, a wrong password, an unknown +-- account, and a locked account all return the single generic 'InvalidCredentials'; only the +-- per-IP throttle returns the IP-keyed 'TooManyRequests' (which discloses nothing about which +-- accounts exist). A successful login records a success and clears the lockout. +-- +-- The caller supplies a 'ClientContext' carrying the request's source IP and the precomputed +-- hashed account key for the presented login identifier, so the core needs no crypto dependency +-- and the abuse store never holds a plaintext principal. +login :: + ( UserStore :> es, + CredentialStore :> es, + AuthUnitOfWork :> es, + PasswordHasher :> es, + TokenSigner :> es, + RoleStore :> es, + ClaimsEnricher :> es, + AuthEventPublisher :> es, + LoginAttemptStore :> es, + PasskeyStore :> es, + PendingCeremonyStore :> es, + WebAuthnCeremony :> es, + TotpCredentialStore :> es, + RecoveryCodeStore :> es, + Clock :> es, + TokenGen :> es, + IOE :> es + ) => + ShomeiConfig -> + ClientContext -> + LoginCommand -> + Eff es (Either AuthError LoginResult) +login cfg ctx cmd = runErrorNoCallStack do + ts <- now + let rl = cfg.rateLimitConfig + guardIpBudget rl ctx ts + -- Serialize this account key and reserve one failure-budget slot before any stored hash is + -- consulted. A correct password converts the provisional failure to success below. + outcome <- recordProofFailureOutcome rl ctx FactorPassword ts + let lockedBefore = maybe False (maybe False (> ts) . lockedUntil) outcome.priorLockout + -- A locked account is still charged one Argon2id verification. Returning before hashing made + -- lock state observable through response time even though the HTTP error stayed generic. + when lockedBefore do + verifyPasswordDummy cmd.password + failLogin rl outcome ctx Nothing ts + -- Every failure path below performs exactly one password-hashing operation. The paths that + -- never reach a stored hash call 'verifyPasswordDummy' instead, which burns an equivalent + -- amount of Argon2id work, so a miss cannot be told apart from a wrong password by response + -- time. + mCred <- findPasswordCredentialByLoginId cmd.loginId + cred <- maybe (failLoginTimed rl outcome ctx cmd ts) pure mCred + ok <- verifyPassword cmd.password cred.passwordHash + unless ok (failLogin rl outcome ctx (Just cred.userId) ts) + -- The password hash was already evaluated, so the missing-user and inactive-user branches do + -- not need a dummy hash. Keeping the user lookup after verification also leaves the common + -- wrong-password path at four database checkouts, including its audit event. + mUser <- findUserById cred.userId + user <- maybe (failLogin rl outcome ctx (Just cred.userId) ts) pure mUser + when (user.status /= UserActive) do + publishNewLock rl outcome ctx ts + publishAuthEvent (Event.LoginFailed (Event.LoginFailedData (Just ctx.accountKey) (Just user.userId) ts)) + throwError UserNotActive + -- Gate before the MFA branch, so an account with an unverified email is not even offered a + -- ceremony. The password was already proven correct here, so naming the reason discloses + -- nothing the caller does not know (see 'EmailNotVerified'). + either throwError pure (ensureEmailVerified cfg user) + -- A password that leads to MFA is not yet a successful login: recording success here would let + -- every password proof reset the counter immediately before another second-factor guess. + passkeyCount <- countPasskeysByUser user.userId + totpEnrolled <- maybe False isTotpConfirmed <$> findTotpByUser user.userId + let hasSecondFactor = passkeyCount > 0 || totpEnrolled + if requireSecondFactor (mfaConfig cfg) && hasSecondFactor + then do + (cid, optionsJson, methods) <- prepareMfaChallenge cfg user ts + -- A correct password that advances to MFA is neither a failed proof nor a fully + -- authenticated success. Remove its provisional row without resetting earlier failures. + discardLoginAttempt outcome.attemptId + when outcome.lockedNow (clearAccountLockout ctx.accountKey) + pure (MfaRequired MfaChallenge {ceremonyId = cid, options = optionsJson, methods = methods}) + else do + convertLoginAttemptToSuccess outcome.attemptId + when (outcome.lockedNow || isJust outcome.priorLockout) (clearAccountLockout ctx.accountKey) + (_sid, pair) <- issueSession cfg user ts + pure (LoginComplete user pair) + +-- | 'failLogin' preceded by a dummy Argon2id verification, for the login paths that fail +-- before ever reaching a stored password hash: an unknown login identifier, and a credential +-- row whose user row is missing. Without the dummy work these return in microseconds while a +-- wrong password costs ~100 ms, which enumerates accounts through the identical @401@. +failLoginTimed :: + ( AuthEventPublisher :> es, + PasswordHasher :> es, + Error AuthError :> es + ) => + RateLimitConfig -> + FailureOutcome -> + ClientContext -> + LoginCommand -> + UTCTime -> + Eff es a +failLoginTimed rl outcome ctx cmd ts = do + verifyPasswordDummy cmd.password + failLogin rl outcome ctx Nothing ts + +-- | The shared failure path for 'login': publish the lock transition reserved by the already +-- recorded provisional failure, publish 'LoginFailed', then throw the generic +-- 'InvalidCredentials'. Both the unknown-account branch and the wrong-password branch reach +-- this so they remain byte-for-byte identical at the boundary. +failLogin :: + ( AuthEventPublisher :> es, + Error AuthError :> es + ) => + RateLimitConfig -> + FailureOutcome -> + ClientContext -> + Maybe UserId -> + UTCTime -> + Eff es a +failLogin rl outcome ctx mUserId ts = do + publishNewLock rl outcome ctx ts + publishAuthEvent (Event.LoginFailed (Event.LoginFailedData (Just ctx.accountKey) mUserId ts)) + throwError InvalidCredentials + +publishNewLock :: + (AuthEventPublisher :> es) => + RateLimitConfig -> + FailureOutcome -> + ClientContext -> + UTCTime -> + Eff es () +publishNewLock rl outcome ctx ts = when outcome.lockedNow do + let deadline = addUTCTime rl.lockoutDuration ts + publishAuthEvent + (Event.AccountLocked (Event.AccountLockedData ctx.accountKey ctx.clientIp outcome.failures deadline ts)) + +data Refreshed = Refreshed + { tokens :: !TokenPair, + -- | the session's persisted OAuth grant; empty for sessions no OAuth client minted. + grantedScopes :: !(Set Scope) + } + deriving stock (Generic, Show) + +refresh :: + ( SessionStore :> es, + RefreshTokenStore :> es, + AuthUnitOfWork :> es, + -- only consulted when 'emailVerificationRequired' is enabled + UserStore :> es, + TokenSigner :> es, + RoleStore :> es, + ClaimsEnricher :> es, + Clock :> es, + TokenGen :> es + ) => + ShomeiConfig -> + RefreshCommand -> + Eff es (Either AuthError TokenPair) +refresh cfg cmd = fmap (.tokens) <$> refreshFrom BespokeRefresh cfg cmd + +refreshFrom :: + ( SessionStore :> es, + RefreshTokenStore :> es, + AuthUnitOfWork :> es, + UserStore :> es, + TokenSigner :> es, + RoleStore :> es, + ClaimsEnricher :> es, + Clock :> es, + TokenGen :> es + ) => + RefreshOrigin -> + ShomeiConfig -> + RefreshCommand -> + Eff es (Either AuthError Refreshed) +refreshFrom origin cfg cmd = do + ts <- now + tokHash <- hashRefreshToken cmd.refreshToken + mTok <- findRefreshTokenByHash tokHash + case mTok of + Nothing -> pure (Left RefreshTokenInvalid) + Just tok -> case tok.status of + RT.RefreshTokenUsed -> reuseDetected tok ts + RT.RefreshTokenRevoked -> pure (Left SessionRevoked) + RT.RefreshTokenExpired -> pure (Left RefreshTokenExpired) + RT.RefreshTokenActive -> do + mSession <- findSessionById tok.sessionId + case mSession of + Nothing -> pure (Left SessionNotFound) + Just s + | not (originMayRefresh origin s) -> pure (Left RefreshTokenInvalid) + -- The session's absolute deadline is checked before the presented token's own + -- expiry: rotation caps every child token at 's.expiresAt', so at the deadline + -- both are expired and 'SessionExpired' ("log in again") is the informative one. + | s.expiresAt <= ts -> pure (Left SessionExpired) + | s.status /= SessionActive -> pure (Left SessionRevoked) + | tok.expiresAt <= ts -> pure (Left RefreshTokenExpired) + | otherwise -> do + -- The emailVerificationRequired gate, before rotation: a silent renewal must + -- not keep an unverified account alive past its first access-token lifetime. + -- The user row is loaded ONLY when the flag is on — refresh otherwise never + -- touches the user table, and most deployments leave the flag off. + gate <- + if cfg.notifierConfig.emailVerificationRequired + then do + mUser <- findUserById s.userId + -- A session whose user row is gone is corrupt state; SessionNotFound is + -- the existing least-leaking fit. + pure (maybe (Left SessionNotFound) (ensureEmailVerified cfg) mUser) + else pure (Right ()) + case gate of + Left e -> pure (Left e) + Right () -> do + rawNew <- generateOpaqueToken + newHash <- hashRefreshToken rawNew + -- One transaction: the compare-and-swap that transitions this token + -- active → used, the insert of its replacement, and the rotation event. + -- Only the caller that wins the swap may rotate; losing the race means + -- someone else has already spent the token, which is indistinguishable + -- from theft — so take the reuse path. A conflict inserts nothing, and the + -- token is never re-read to "confirm" it. + outcome <- + rotateRefreshToken + tok.refreshTokenId + ts + NewRefreshToken + { sessionId = tok.sessionId, + tokenHash = newHash, + parentTokenId = Just tok.refreshTokenId, + createdAt = ts, + -- Never mint a token that outlives its session. + expiresAt = min (addUTCTime cfg.refreshTokenTTL ts) s.expiresAt + } + (Event.RefreshTokenRotated (Event.RefreshTokenRotatedData tok.sessionId tok.refreshTokenId ts)) + case outcome of + RotationConflict -> reuseDetected tok ts + Rotated _ -> do + -- Re-running the enrichment here is what makes a role change take + -- effect on refresh (the staleness contract in docs/user/security.md). + base <- buildEnrichedClaims cfg s.userId s.sessionId ts + let claims = base {scopes = base.scopes <> s.grantedScopes, authTime = s.authenticatedAt} + access <- signAccessToken claims + pure + ( Right + Refreshed + { tokens = TokenPair {accessToken = access, refreshToken = rawNew, expiresIn = cfg.accessTokenTTL}, + grantedScopes = s.grantedScopes + } + ) + where + reuseDetected tok ts = do + won <- + revokeSessionWithTokens + tok.sessionId + ts + [Event.RefreshTokenReuseDetected (Event.RefreshTokenReuseDetectedData tok.sessionId tok.refreshTokenId ts)] + pure (Left (if won then RefreshTokenReuseDetected else SessionRevoked)) + +originMayRefresh :: RefreshOrigin -> Session -> Bool +originMayRefresh BespokeRefresh session = isNothing session.oauthClientId +originMayRefresh (OAuthClientRefresh clientId) session = session.oauthClientId == Just clientId + +logout :: + ( SessionStore :> es, + AuthUnitOfWork :> es, + Clock :> es + ) => + ShomeiConfig -> + LogoutCommand -> + Eff es (Either AuthError ()) +logout _cfg cmd = do + ts <- now + let sid = cmd.sessionId + mSession <- findSessionById sid + case mSession of + Nothing -> pure (Left SessionNotFound) + Just _ -> do + -- Self-service logout: no administrator revoked this session. + _ <- + revokeSessionWithTokens + sid + ts + [Event.SessionRevoked (Event.SessionRevokedData sid Nothing ts)] + pure (Right ()) + +verifyToken :: + (TokenVerifier :> es, SessionStore :> es, Clock :> es) => + ShomeiConfig -> + AccessToken -> + Eff es (Either AuthError AuthClaims) +verifyToken cfg = verifyTokenWith cfg.sessionCheckMode + +-- | Verify a token under an explicit session-check policy. Privilege-minting callers use +-- 'VerifyTokenAndSession' even when ordinary route authentication remains stateless. +verifyTokenWith :: + (TokenVerifier :> es, SessionStore :> es, Clock :> es) => + SessionCheckMode -> + AccessToken -> + Eff es (Either AuthError AuthClaims) +verifyTokenWith mode token = do + result <- verifyAccessToken token + case result of + Left te -> pure (Left (TokenInvalid te)) + Right claims -> case mode of + VerifyTokenOnly -> pure (Right claims) + VerifyTokenAndSession -> do + ts <- now + fmap (const claims) <$> requireLiveSession ts claims.sessionId diff --git a/src/Shomei/Session/Command.hs b/src/Shomei/Session/Command.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Command.hs @@ -0,0 +1,74 @@ +-- | The commands that drive the auth workflows. +-- +-- The password-bearing commands ('SignupCommand', 'LoginCommand') carry a +-- 'PlainPassword', so they get a 'Show' only via the redacting 'PlainPassword' instance +-- and deliberately no JSON instances. EP-5's DTO layer maps HTTP requests to these. +module Shomei.Session.Command + ( SignupCommand (..), + LoginCommand (..), + RefreshCommand (..), + RefreshOrigin (..), + LogoutCommand (..), + ClientContext (..), + ProofContext (..), + proofContextFor, + ) +where + +import Shomei.Account.Email.Domain (Email) +import Shomei.Account.LoginId.Domain (LoginId) +import Shomei.Account.Password.Domain (PlainPassword) +import Shomei.Id (SessionId) +import Shomei.Prelude +import Shomei.Session.LoginAttempt.Domain (AccountKey, ClientIp) +import Shomei.Session.RefreshToken.Domain (RefreshToken) + +data SignupCommand = SignupCommand + { loginId :: !LoginId, + email :: !(Maybe Email), + password :: !PlainPassword, + displayName :: !(Maybe Text) + } + deriving stock (Generic, Show) + +data LoginCommand = LoginCommand + { loginId :: !LoginId, + password :: !PlainPassword + } + deriving stock (Generic, Show) + +newtype RefreshCommand = RefreshCommand {refreshToken :: RefreshToken} + deriving stock (Generic, Show) + +-- | Which endpoint is rotating. The bespoke endpoint has no client identity, so it may not +-- rotate a session an OAuth client minted; the OAuth grant may rotate only its own. +data RefreshOrigin = BespokeRefresh | OAuthClientRefresh Text + deriving stock (Generic, Eq, Show) + +newtype LogoutCommand = LogoutCommand {sessionId :: SessionId} + deriving stock (Generic, Show) + +-- | Per-request context the 'Shomei.Session.Authentication.Workflow.login' workflow needs for abuse protection: +-- the client's source IP (for the per-IP failure throttle) and the precomputed hashed account +-- key for the presented login identifier (so the core never needs a crypto dependency, and the +-- abuse store never holds a plaintext principal). +data ClientContext = ClientContext + { clientIp :: !ClientIp, + accountKey :: !AccountKey + } + deriving stock (Generic, Show) + +-- | Request data shared by credential-proof workflows whose account is discovered inside the +-- workflow. The opaque function hashes a normalized login identifier without pulling crypto into +-- @shomei-core@. +data ProofContext = ProofContext + { clientIp :: !ClientIp, + accountKeyOf :: !(Text -> AccountKey) + } + +proofContextFor :: ProofContext -> Text -> ClientContext +proofContextFor pctx principal = + ClientContext + { clientIp = pctx.clientIp, + accountKey = pctx.accountKeyOf principal + } diff --git a/src/Shomei/Session/Domain.hs b/src/Shomei/Session/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Domain.hs @@ -0,0 +1,76 @@ +-- | The session entity: a server-side record of an authenticated login, against which +-- refresh tokens are issued and (optionally) access tokens are checked. +module Shomei.Session.Domain + ( SessionStatus (..), + SessionKind (..), + Session (..), + NewSession (..), + ) +where + +import Data.Set (Set) +import Shomei.Authorization.Claims.Domain (Scope) +import Shomei.Id (SessionId, UserId) +import Shomei.Prelude + +data SessionStatus = SessionActive | SessionRevoked | SessionExpired + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | How a session was established. This provenance is selected by the minting path rather than +-- by a caller-supplied option, so privilege-minting operations can distinguish a human login +-- from a machine credential or a delegation. +data SessionKind + = -- | A human proved a credential, or exchanged a code authorized by such a session. + InteractiveSession + | -- | @client_credentials@: a service acting as itself, with no human involved. + MachineSession + | -- | Impersonation or RFC 8693 on-behalf-of: the token carries an @act@ claim. + DelegatedSession + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data Session = Session + { sessionId :: !SessionId, + userId :: !UserId, + status :: !SessionStatus, + createdAt :: !UTCTime, + expiresAt :: !UTCTime, + revokedAt :: !(Maybe UTCTime), + -- | for a delegated (impersonation) session, the operator acting on behalf + -- of 'userId'; 'Nothing' for every ordinary login session. + actor :: !(Maybe UserId), + -- | the OAuth2 @client_id@ that minted this session through the authorization-code grant + -- (EP-5); 'Nothing' for every other flow, including every session that predates the + -- column. It exists to bind refresh: a token issued through client A must not be + -- rotatable by client B at @\/oauth\/token@. The bespoke @\/v1\/auth\/refresh@ refuses it. + oauthClientId :: !(Maybe Text), + -- | how this session was established; see 'SessionKind'. + kind :: !SessionKind, + -- | the scopes the authorization-code grant granted, re-applied on every refresh so a + -- rotated access token keeps @openid@ and friends. Empty for every other flow and for + -- every row that predates the column. + grantedScopes :: !(Set Scope), + -- | when the last credential was proven; preserved across refresh and emitted as @auth_time@. + authenticatedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data NewSession = NewSession + { userId :: !UserId, + createdAt :: !UTCTime, + expiresAt :: !UTCTime, + -- | set to @Just operator@ when minting a delegated session; 'Nothing' otherwise. + actor :: !(Maybe UserId), + -- | set to @Just client_id@ by the authorization-code grant; 'Nothing' otherwise. + oauthClientId :: !(Maybe Text), + -- | how this session was established; see 'SessionKind'. + kind :: !SessionKind, + -- | the authorization-code grant's persisted scope set; empty for every other flow. + grantedScopes :: !(Set Scope), + -- | when the credential establishing this session was proven. + authenticatedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/Session/LoginAttempt/Domain.hs b/src/Shomei/Session/LoginAttempt/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/LoginAttempt/Domain.hs @@ -0,0 +1,95 @@ +-- | Domain types for brute-force protection: a log of login attempts (keyed by a hashed +-- account identifier and a client IP) and a per-account lockout record. The account key is a +-- hash, never the plaintext email, so the abuse store cannot become an enumeration oracle. +module Shomei.Session.LoginAttempt.Domain + ( LoginOutcome (..), + AttemptFactor (..), + AccountKey (..), + ClientIp (..), + LoginAttempt (..), + NewLoginAttempt (..), + AccountLockout (..), + LockPolicy (..), + FailureOutcome (..), + ) +where + +import Shomei.Id (LoginAttemptId) +import Shomei.Prelude + +-- | Whether an attempt succeeded or failed. (We log both; success clears the counter.) +data LoginOutcome = LoginSuccess | LoginFailure + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Which credential an attempt proved or failed to prove. All factors share one lockout. +data AttemptFactor + = FactorPassword + | FactorTotp + | FactorRecoveryCode + | FactorPasskey + | FactorPasswordChange + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | A SHA-256 (hex) of the normalized login identifier presented at login. Opaque key for counting. +newtype AccountKey = AccountKey Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +-- | The client's source IP as text (e.g. "203.0.113.7"). Source of the per-IP throttle. +newtype ClientIp = ClientIp Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +-- | A persisted login attempt (one row in @shomei_login_attempts@). +data LoginAttempt = LoginAttempt + { attemptId :: !LoginAttemptId, + accountKey :: !AccountKey, + clientIp :: !ClientIp, + outcome :: !LoginOutcome, + occurredAt :: !UTCTime, + factor :: !AttemptFactor + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | Input for recording an attempt (identical fields; no server-assigned columns). +data NewLoginAttempt = NewLoginAttempt + { accountKey :: !AccountKey, + clientIp :: !ClientIp, + outcome :: !LoginOutcome, + occurredAt :: !UTCTime, + factor :: !AttemptFactor + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | The lockout state for one account key (one row in @shomei_account_lockouts@). +data AccountLockout = AccountLockout + { accountKey :: !AccountKey, + failedCount :: !Int, + lockedUntil :: !(Maybe UTCTime), + updatedAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | What one atomic failure-recording operation may do after the windowed count reaches the +-- configured account threshold. +data LockPolicy = LockPolicy + { maxFailures :: !Int, + lockUntil :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | The account-key state immediately after a failure row was durably recorded. +data FailureOutcome = FailureOutcome + { attemptId :: !LoginAttemptId, + failures :: !Int, + priorLockout :: !(Maybe AccountLockout), + lockedNow :: !Bool + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/Session/LoginAttempt/Store.hs b/src/Shomei/Session/LoginAttempt/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/LoginAttempt/Store.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The login-attempt store effect: the durable state behind brute-force lockout and per-IP +-- login throttling. Counting is windowed (failures since a cutoff time); lockout is keyed by +-- the hashed account identifier. +module Shomei.Session.LoginAttempt.Store + ( LoginAttemptStore (..), + recordLoginFailure, + convertLoginAttemptToSuccess, + discardLoginAttempt, + countRecentFailuresByAccount, + countRecentFailuresByIp, + getAccountLockout, + setAccountLockout, + clearAccountLockout, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Id (LoginAttemptId) +import Shomei.Prelude +import Shomei.Session.LoginAttempt.Domain (AccountKey, AccountLockout, ClientIp, FailureOutcome, LockPolicy, NewLoginAttempt) + +data LoginAttemptStore :: Effect where + -- | Serialize on the account key, append a provisional failure, count it in the current + -- window, and optionally transition the account to locked in the same operation. + RecordLoginFailure :: NewLoginAttempt -> UTCTime -> Maybe LockPolicy -> LoginAttemptStore m FailureOutcome + -- | Convert a provisional failure to success without adding a second attempt row. + ConvertLoginAttemptToSuccess :: LoginAttemptId -> LoginAttemptStore m () + -- | Remove a provisional row after a correct password advances into an MFA challenge. It is + -- neither a failed proof nor a fully authenticated success, so it must affect neither budget. + DiscardLoginAttempt :: LoginAttemptId -> LoginAttemptStore m () + -- | Count failures for an account since the given cutoff (window start). + CountRecentFailuresByAccount :: AccountKey -> UTCTime -> LoginAttemptStore m Int + -- | Count failures from an IP since the given cutoff (window start). + CountRecentFailuresByIp :: ClientIp -> UTCTime -> LoginAttemptStore m Int + -- | Read the current lockout record for an account (if any). + GetAccountLockout :: AccountKey -> LoginAttemptStore m (Maybe AccountLockout) + -- | Upsert the lockout record (set failedCount / lockedUntil / updatedAt). + SetAccountLockout :: AccountLockout -> LoginAttemptStore m () + -- | Clear the lockout record for an account (on successful login). + ClearAccountLockout :: AccountKey -> LoginAttemptStore m () + +type instance DispatchOf LoginAttemptStore = Dynamic + +recordLoginFailure :: + (LoginAttemptStore :> es) => + NewLoginAttempt -> + UTCTime -> + Maybe LockPolicy -> + Eff es FailureOutcome +recordLoginFailure attempt cutoff policy = send (RecordLoginFailure attempt cutoff policy) + +convertLoginAttemptToSuccess :: (LoginAttemptStore :> es) => LoginAttemptId -> Eff es () +convertLoginAttemptToSuccess = send . ConvertLoginAttemptToSuccess + +discardLoginAttempt :: (LoginAttemptStore :> es) => LoginAttemptId -> Eff es () +discardLoginAttempt = send . DiscardLoginAttempt + +countRecentFailuresByAccount :: (LoginAttemptStore :> es) => AccountKey -> UTCTime -> Eff es Int +countRecentFailuresByAccount k t = send (CountRecentFailuresByAccount k t) + +countRecentFailuresByIp :: (LoginAttemptStore :> es) => ClientIp -> UTCTime -> Eff es Int +countRecentFailuresByIp ip t = send (CountRecentFailuresByIp ip t) + +getAccountLockout :: (LoginAttemptStore :> es) => AccountKey -> Eff es (Maybe AccountLockout) +getAccountLockout = send . GetAccountLockout + +setAccountLockout :: (LoginAttemptStore :> es) => AccountLockout -> Eff es () +setAccountLockout = send . SetAccountLockout + +clearAccountLockout :: (LoginAttemptStore :> es) => AccountKey -> Eff es () +clearAccountLockout = send . ClearAccountLockout diff --git a/src/Shomei/Session/LoginAttempt/Workflow.hs b/src/Shomei/Session/LoginAttempt/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/LoginAttempt/Workflow.hs @@ -0,0 +1,147 @@ +-- | Shared abuse-protection policy for every unauthenticated credential proof. +-- +-- Keeping the gate, failure accounting, and success reset here gives later workflows one seam to +-- reuse. EP-5 can make failure recording atomic by changing 'recordProofFailure' without finding +-- and rewriting every credential workflow again. +module Shomei.Session.LoginAttempt.Workflow + ( AbuseGate (..), + guardIpBudget, + guardAbuse, + recordProofFailureOutcome, + recordProofFailure, + recordProofSuccess, + ) +where + +import Data.Time (addUTCTime) +import Effectful (Eff, (:>)) +import Effectful.Error.Static (Error, throwError) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent) +import Shomei.Config (RateLimitConfig (..)) +import Shomei.Error (AuthError (TooManyRequests)) +import Shomei.Prelude +import Shomei.Session.Command (ClientContext (..)) +import Shomei.Session.LoginAttempt.Domain + ( AccountLockout (..), + AttemptFactor, + FailureOutcome (..), + LockPolicy (..), + LoginOutcome (..), + NewLoginAttempt (..), + ) +import Shomei.Session.LoginAttempt.Store + ( LoginAttemptStore, + clearAccountLockout, + convertLoginAttemptToSuccess, + countRecentFailuresByIp, + getAccountLockout, + recordLoginFailure, + ) + +-- | State read before a proof. A standing row may be expired; successful proof removes it. +data AbuseGate = AbuseGate + { standingLockout :: !(Maybe AccountLockout), + locked :: !Bool + } + deriving stock (Generic, Eq, Show) + +-- | Enforce the per-IP failure budget, then read account lockout state. This operation records +-- nothing so a throttled caller cannot extend its own throttle merely by retrying. +guardAbuse :: + (LoginAttemptStore :> es, AuthEventPublisher :> es, Error AuthError :> es) => + RateLimitConfig -> + ClientContext -> + UTCTime -> + Eff es AbuseGate +guardAbuse rl ctx ts + | not rl.rateLimitEnabled = pure (AbuseGate Nothing False) + | otherwise = do + guardIpBudget rl ctx ts + lockRow <- getAccountLockout ctx.accountKey + let isLocked = maybe False (maybe False (> ts) . (.lockedUntil)) lockRow + pure (AbuseGate lockRow isLocked) + +-- | Enforce only the per-IP failure budget. Password login uses this narrower gate because the +-- authoritative account lockout read is part of 'recordLoginFailure'; reading it beforehand +-- would recreate the read-then-write race that operation closes. +guardIpBudget :: + (LoginAttemptStore :> es, AuthEventPublisher :> es, Error AuthError :> es) => + RateLimitConfig -> + ClientContext -> + UTCTime -> + Eff es () +guardIpBudget rl ctx ts = when rl.rateLimitEnabled do + let cutoff = addUTCTime (negate rl.lockoutWindow) ts + ipFails <- countRecentFailuresByIp ctx.clientIp cutoff + when (ipFails >= rl.maxFailedLoginsPerIp) do + publishAuthEvent (Event.LoginThrottled (Event.LoginThrottledData ctx.clientIp ipFails ts)) + throwError TooManyRequests + +-- | Atomically record and count one provisional failure. The caller decides when the proof has +-- actually failed and therefore when a newly-created lock is eligible for audit publication. +recordProofFailureOutcome :: + (LoginAttemptStore :> es) => + RateLimitConfig -> + ClientContext -> + AttemptFactor -> + UTCTime -> + Eff es FailureOutcome +recordProofFailureOutcome rl ctx factor ts = do + let cutoff = addUTCTime (negate rl.lockoutWindow) ts + policy = + if rl.rateLimitEnabled + then Just (LockPolicy rl.maxFailedLoginsPerAccount (addUTCTime rl.lockoutDuration ts)) + else Nothing + result <- + recordLoginFailure + NewLoginAttempt + { accountKey = ctx.accountKey, + clientIp = ctx.clientIp, + outcome = LoginFailure, + occurredAt = ts, + factor + } + cutoff + policy + pure result + +-- | Record and count one failed credential proof. Every factor contributes to the same account +-- budget; the factor field exists for auditability, not separate budgets. +recordProofFailure :: + (LoginAttemptStore :> es, AuthEventPublisher :> es) => + RateLimitConfig -> + ClientContext -> + AttemptFactor -> + UTCTime -> + Eff es () +recordProofFailure rl ctx factor ts = do + result <- recordProofFailureOutcome rl ctx factor ts + when result.lockedNow do + let lockedUntil = addUTCTime rl.lockoutDuration ts + publishAuthEvent + (Event.AccountLocked (Event.AccountLockedData ctx.accountKey ctx.clientIp result.failures lockedUntil ts)) + +-- | Record a successful proof and clear a standing lockout row. The read-before-write guard avoids +-- an unnecessary delete on the overwhelmingly common no-lockout path. +recordProofSuccess :: + (LoginAttemptStore :> es) => + ClientContext -> + AttemptFactor -> + Maybe AccountLockout -> + UTCTime -> + Eff es () +recordProofSuccess ctx factor standing ts = do + provisional <- + recordLoginFailure + NewLoginAttempt + { accountKey = ctx.accountKey, + clientIp = ctx.clientIp, + outcome = LoginFailure, + occurredAt = ts, + factor + } + ts + Nothing + convertLoginAttemptToSuccess provisional.attemptId + when (isJust standing) (clearAccountLockout ctx.accountKey) diff --git a/src/Shomei/Session/RefreshToken/Domain.hs b/src/Shomei/Session/RefreshToken/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/RefreshToken/Domain.hs @@ -0,0 +1,63 @@ +-- | Refresh-token types. +-- +-- 'RefreshToken' is the opaque secret handed to the client. 'RefreshTokenHash' is what +-- is persisted (the server never stores the raw token). 'PersistedRefreshToken' is the +-- stored row, including the @parentTokenId@ link that forms a rotation /family/ — the +-- chain of tokens descended from one login. Reuse of a token already marked +-- 'RefreshTokenUsed' is treated as theft and revokes the session and its tokens; a token +-- deliberately marked 'RefreshTokenRevoked' reports that the session was revoked without a +-- theft response (see 'Shomei.Session.Authentication.Workflow.refresh'). +module Shomei.Session.RefreshToken.Domain + ( RefreshToken (..), + RefreshTokenHash (..), + RefreshTokenStatus (..), + PersistedRefreshToken (..), + NewRefreshToken (..), + ) +where + +import Shomei.Id (RefreshTokenId, SessionId) +import Shomei.Prelude + +newtype RefreshToken = RefreshToken Text + deriving stock (Generic) + deriving newtype (Eq) + +instance Show RefreshToken where + show _ = "RefreshToken " + +newtype RefreshTokenHash = RefreshTokenHash Text + deriving stock (Generic) + deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) + +data RefreshTokenStatus + = RefreshTokenActive + | RefreshTokenUsed + | RefreshTokenRevoked + | RefreshTokenExpired + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data PersistedRefreshToken = PersistedRefreshToken + { refreshTokenId :: !RefreshTokenId, + sessionId :: !SessionId, + tokenHash :: !RefreshTokenHash, + parentTokenId :: !(Maybe RefreshTokenId), + status :: !RefreshTokenStatus, + createdAt :: !UTCTime, + expiresAt :: !UTCTime, + usedAt :: !(Maybe UTCTime), + revokedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +data NewRefreshToken = NewRefreshToken + { sessionId :: !SessionId, + tokenHash :: !RefreshTokenHash, + parentTokenId :: !(Maybe RefreshTokenId), + createdAt :: !UTCTime, + expiresAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/Session/RefreshToken/Store.hs b/src/Shomei/Session/RefreshToken/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/RefreshToken/Store.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The refresh-token-store port: persisting and rotating refresh tokens, including standalone +-- family/session/user revocation operations. Authentication reuse detection uses the +-- session-scoped transactional unit of work; OAuth revocation still uses the family operation. +module Shomei.Session.RefreshToken.Store + ( RefreshTokenStore (..), + createRefreshToken, + findRefreshTokenByHash, + markRefreshTokenUsed, + revokeRefreshTokenFamily, + revokeSessionRefreshTokens, + revokeAllUserRefreshTokens, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Id (RefreshTokenId, SessionId, UserId) +import Shomei.Prelude +import Shomei.Session.RefreshToken.Domain (NewRefreshToken, PersistedRefreshToken, RefreshTokenHash) + +data RefreshTokenStore :: Effect where + CreateRefreshToken :: NewRefreshToken -> RefreshTokenStore m PersistedRefreshToken + FindRefreshTokenByHash :: RefreshTokenHash -> RefreshTokenStore m (Maybe PersistedRefreshToken) + -- | Transition a token @active → used@ as one atomic compare-and-swap. 'True' means this + -- call performed the transition; 'False' means the token was no longer @active@ — someone + -- else spent it first, which 'Shomei.Session.Authentication.Workflow.refresh' treats as reuse. + MarkRefreshTokenUsed :: RefreshTokenId -> UTCTime -> RefreshTokenStore m Bool + RevokeRefreshTokenFamily :: RefreshTokenId -> UTCTime -> RefreshTokenStore m () + RevokeSessionRefreshTokens :: SessionId -> UTCTime -> RefreshTokenStore m () + RevokeAllUserRefreshTokens :: UserId -> UTCTime -> RefreshTokenStore m () + +type instance DispatchOf RefreshTokenStore = Dynamic + +createRefreshToken :: (RefreshTokenStore :> es) => NewRefreshToken -> Eff es PersistedRefreshToken +createRefreshToken = send . CreateRefreshToken + +findRefreshTokenByHash :: (RefreshTokenStore :> es) => RefreshTokenHash -> Eff es (Maybe PersistedRefreshToken) +findRefreshTokenByHash = send . FindRefreshTokenByHash + +markRefreshTokenUsed :: (RefreshTokenStore :> es) => RefreshTokenId -> UTCTime -> Eff es Bool +markRefreshTokenUsed i t = send (MarkRefreshTokenUsed i t) + +revokeRefreshTokenFamily :: (RefreshTokenStore :> es) => RefreshTokenId -> UTCTime -> Eff es () +revokeRefreshTokenFamily i t = send (RevokeRefreshTokenFamily i t) + +revokeSessionRefreshTokens :: (RefreshTokenStore :> es) => SessionId -> UTCTime -> Eff es () +revokeSessionRefreshTokens s t = send (RevokeSessionRefreshTokens s t) + +revokeAllUserRefreshTokens :: (RefreshTokenStore :> es) => UserId -> UTCTime -> Eff es () +revokeAllUserRefreshTokens u t = send (RevokeAllUserRefreshTokens u t) diff --git a/src/Shomei/Session/Store.hs b/src/Shomei/Session/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Store.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The session-store port: persisting, looking up, and revoking sessions. +module Shomei.Session.Store + ( SessionStore (..), + createSession, + findSessionById, + revokeSession, + revokeAllUserSessions, + listSessionsForUser, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Id (SessionId, UserId) +import Shomei.Prelude +import Shomei.Session.Domain (NewSession, Session) + +data SessionStore :: Effect where + CreateSession :: NewSession -> SessionStore m Session + FindSessionById :: SessionId -> SessionStore m (Maybe Session) + RevokeSession :: SessionId -> UTCTime -> SessionStore m () + RevokeAllUserSessions :: UserId -> UTCTime -> SessionStore m () + -- | Every session ever created for a user, newest first, in every status. Unpaginated: + -- sessions per user are bounded small in practice (roughly one per device), unlike users + -- per deployment. + ListSessionsForUser :: UserId -> SessionStore m [Session] + +type instance DispatchOf SessionStore = Dynamic + +createSession :: (SessionStore :> es) => NewSession -> Eff es Session +createSession = send . CreateSession + +findSessionById :: (SessionStore :> es) => SessionId -> Eff es (Maybe Session) +findSessionById = send . FindSessionById + +revokeSession :: (SessionStore :> es) => SessionId -> UTCTime -> Eff es () +revokeSession sid t = send (RevokeSession sid t) + +revokeAllUserSessions :: (SessionStore :> es) => UserId -> UTCTime -> Eff es () +revokeAllUserSessions uid t = send (RevokeAllUserSessions uid t) + +listSessionsForUser :: (SessionStore :> es) => UserId -> Eff es [Session] +listSessionsForUser = send . ListSessionsForUser diff --git a/src/Shomei/Session/Token/Domain.hs b/src/Shomei/Session/Token/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Token/Domain.hs @@ -0,0 +1,28 @@ +-- | Access tokens and the token pair returned by the auth workflows. +-- +-- 'AccessToken' is the signed JWT (produced by the 'Shomei.SigningKey.Signer' port, +-- really signed by EP-4). 'TokenPair' bundles it with the opaque refresh token and the +-- access-token lifetime. +module Shomei.Session.Token.Domain + ( AccessToken (..), + TokenPair (..), + ) +where + +import Data.Time (NominalDiffTime) +import Shomei.Prelude +import Shomei.Session.RefreshToken.Domain (RefreshToken) + +newtype AccessToken = AccessToken Text + deriving stock (Generic) + deriving newtype (Eq) + +instance Show AccessToken where + show _ = "AccessToken " + +data TokenPair = TokenPair + { accessToken :: !AccessToken, + refreshToken :: !RefreshToken, + expiresIn :: !NominalDiffTime + } + deriving stock (Generic, Eq, Show) diff --git a/src/Shomei/Session/Token/Generator.hs b/src/Shomei/Session/Token/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Token/Generator.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The opaque-token-generation port: minting a fresh random refresh token and hashing +-- a refresh token for storage. Production (EP-3/EP-6) uses crypton @getRandomBytes 32@ +-- base64url-encoded plus SHA-256; the test interpreter is deterministic. +module Shomei.Session.Token.Generator + ( TokenGen (..), + generateOpaqueToken, + hashRefreshToken, + generateRandomBytes, + ) +where + +import Data.ByteString (ByteString) +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Session.RefreshToken.Domain (RefreshToken, RefreshTokenHash) + +data TokenGen :: Effect where + GenerateOpaqueToken :: TokenGen m RefreshToken + HashRefreshToken :: RefreshToken -> TokenGen m RefreshTokenHash + -- | @n@ cryptographically random bytes (EP-7: TOTP secrets and recovery codes). The test + -- interpreter is deterministic. + GenerateRandomBytes :: Int -> TokenGen m ByteString + +type instance DispatchOf TokenGen = Dynamic + +generateOpaqueToken :: (TokenGen :> es) => Eff es RefreshToken +generateOpaqueToken = send GenerateOpaqueToken + +hashRefreshToken :: (TokenGen :> es) => RefreshToken -> Eff es RefreshTokenHash +hashRefreshToken = send . HashRefreshToken + +generateRandomBytes :: (TokenGen :> es) => Int -> Eff es ByteString +generateRandomBytes = send . GenerateRandomBytes diff --git a/src/Shomei/Session/UnitOfWork/Store.hs b/src/Shomei/Session/UnitOfWork/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/UnitOfWork/Store.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The transactional unit-of-work port: the multi-table write tails that must be atomic. +-- +-- Every other store port in this package is one effect per table, and each of its operations +-- is one SQL statement in its own database round-trip. That is the right shape for reads and +-- for standalone writes, but it is wrong for the write /tails/ of the authentication +-- workflows, where several inserts must either all land or none of them do. Persisting a +-- session but not its refresh token leaves a row nothing can ever use; marking a refresh token +-- used but failing to insert its replacement logs the user out mid-rotation. +-- +-- This port names those tails as single operations. The PostgreSQL interpreter +-- (@Shomei.Session.UnitOfWork.Postgres@) runs each one inside a single @BEGIN … COMMIT@; the +-- in-memory interpreter ('Shomei.Test.InMemory') performs the equivalent update to its +-- mutable world in one atomic step. The per-table ports remain for reads, single-table writes, +-- and callers whose revocation scope or audit contract differs from these workflow tails. +module Shomei.Session.UnitOfWork.Store + ( AuthUnitOfWork (..), + NewSessionToken (..), + RotationOutcome (..), + persistNewSession, + rotateRefreshToken, + completePasswordReset, + completePasswordChange, + revokeSessionWithTokens, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Account.Password.Domain (PasswordHash) +import Shomei.Audit.Event.Domain (AuthEvent) +import Shomei.Id (PasswordResetTokenId, RefreshTokenId, SessionId, UserId) +import Shomei.Prelude +import Shomei.Session.Domain (NewSession, Session) +import Shomei.Session.RefreshToken.Domain (NewRefreshToken, PersistedRefreshToken, RefreshTokenHash) + +-- | The refresh-token half of a brand-new session, minus the session id. +-- +-- The session id is absent because the caller does not know it yet: it is generated inside the +-- interpreter, exactly as @CreateSession@ generates it today. The interpreter fills it in when +-- it builds the token row. +data NewSessionToken = NewSessionToken + { tokenHash :: !RefreshTokenHash, + createdAt :: !UTCTime, + expiresAt :: !UTCTime + } + deriving stock (Generic, Eq, Show) + +-- | The result of an atomic refresh-token rotation. +-- +-- 'RotationConflict' means the compare-and-swap that transitions the presented token +-- @active → used@ matched no row, i.e. some other request already spent it. That is +-- indistinguishable from a stolen token being replayed, so callers treat it as reuse. It is a +-- /signal/, not an error: the transaction simply did not rotate, and no replacement token was +-- inserted. Callers must never re-read the token to "confirm" this — the conflict is the +-- confirmation. +data RotationOutcome + = Rotated !PersistedRefreshToken + | RotationConflict + deriving stock (Generic, Eq, Show) + +data AuthUnitOfWork :: Effect where + -- | Insert a session, its first refresh token, and the audit events built from the + -- generated session id — atomically. Returns the persisted session and token. + -- + -- The events arrive as a function of the session id rather than as a list because the id is + -- generated inside the interpreter, yet the events must name it: signup publishes + -- @UserRegistered@ + @SessionStarted@, login and MFA completion publish @LoginSucceeded@ + + -- @SessionStarted@. The builder lets each caller author its own events in the workflow layer + -- while the interpreter supplies the id. + PersistNewSession :: + NewSession -> + NewSessionToken -> + (SessionId -> [AuthEvent]) -> + AuthUnitOfWork m (Session, PersistedRefreshToken) + -- | Mark the presented refresh token used, insert its replacement, and record the rotation + -- event — atomically. The 'UTCTime' is the @used_at@ stamp for the token being retired. + -- + -- Yields 'RotationConflict' without inserting anything when the presented token was no + -- longer active. + RotateRefreshToken :: + RefreshTokenId -> + UTCTime -> + NewRefreshToken -> + AuthEvent -> + AuthUnitOfWork m RotationOutcome + -- | Consume the reset token (CAS); then update the hash, revoke every session and refresh + -- token of the user, revoke the user's other outstanding reset tokens, and record the events + -- atomically. 'False' means the CAS lost and nothing was written. The caller computes the hash. + CompletePasswordReset :: + PasswordResetTokenId -> + UserId -> + PasswordHash -> + UTCTime -> + [AuthEvent] -> + AuthUnitOfWork m Bool + -- | Update the hash, revoke every session and refresh token, and record the events atomically. + CompletePasswordChange :: + UserId -> + PasswordHash -> + UTCTime -> + [AuthEvent] -> + AuthUnitOfWork m () + -- | CAS the session @active → revoked@; only on success revoke its refresh tokens and record + -- the events. 'False' means the session was already dead and nothing was written. + RevokeSessionWithTokens :: + SessionId -> + UTCTime -> + [AuthEvent] -> + AuthUnitOfWork m Bool + +type instance DispatchOf AuthUnitOfWork = Dynamic + +-- | Atomically persist a new session, its first refresh token, and the events naming it. +persistNewSession :: + (AuthUnitOfWork :> es) => + NewSession -> + NewSessionToken -> + (SessionId -> [AuthEvent]) -> + Eff es (Session, PersistedRefreshToken) +persistNewSession ns nst mkEvents = send (PersistNewSession ns nst mkEvents) + +-- | Atomically retire a refresh token and issue its replacement, or report a conflict. +rotateRefreshToken :: + (AuthUnitOfWork :> es) => + RefreshTokenId -> + UTCTime -> + NewRefreshToken -> + AuthEvent -> + Eff es RotationOutcome +rotateRefreshToken rid usedAt nrt ev = send (RotateRefreshToken rid usedAt nrt ev) + +-- | Atomically complete a password reset after the caller has computed and validated the hash. +completePasswordReset :: + (AuthUnitOfWork :> es) => + PasswordResetTokenId -> + UserId -> + PasswordHash -> + UTCTime -> + [AuthEvent] -> + Eff es Bool +completePasswordReset tid uid newHash ts events = + send (CompletePasswordReset tid uid newHash ts events) + +-- | Atomically complete a password change after the caller has computed and validated the hash. +completePasswordChange :: + (AuthUnitOfWork :> es) => + UserId -> + PasswordHash -> + UTCTime -> + [AuthEvent] -> + Eff es () +completePasswordChange uid newHash ts events = + send (CompletePasswordChange uid newHash ts events) + +-- | Atomically revoke an active session, its refresh tokens, and the supplied audit events. +revokeSessionWithTokens :: + (AuthUnitOfWork :> es) => + SessionId -> + UTCTime -> + [AuthEvent] -> + Eff es Bool +revokeSessionWithTokens sid ts events = send (RevokeSessionWithTokens sid ts events) diff --git a/src/Shomei/Session/Workflow.hs b/src/Shomei/Session/Workflow.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Workflow.hs @@ -0,0 +1,231 @@ +-- | The shared token-issuing tail of the authentication workflows. +-- +-- 'issueSession' mints a fresh session + refresh token + signed access token for an +-- already-authenticated user and publishes 'LoginSucceeded' + 'SessionStarted'. It is the +-- exact tail that 'Shomei.Session.Authentication.Workflow.login' (non-MFA path), 'Shomei.Mfa.Workflow.completeMfa', +-- and 'Shomei.Mfa.Workflow.completePasswordlessLogin' share, factored out so the call sites +-- cannot drift. 'buildClaims' assembles the access-token claims for a fresh session. +-- +-- This module is a leaf: it imports no passkey domain types, so it is free of the +-- @OverloadedRecordDot@/@HasField@ ambiguity that co-importing the passkey records triggers +-- (a MasterPlan-3 discovery). It exists as its own module to break the import cycle that +-- would otherwise form between 'Shomei.Session.Authentication.Workflow' (which calls 'issueSession') and +-- 'Shomei.Mfa.Workflow' (which also calls 'issueSession'). 'Shomei.Session.Authentication.Workflow' re-exports +-- 'issueSession' so the public interface remains @Shomei.Session.Authentication.Workflow.issueSession@. +module Shomei.Session.Workflow + ( buildClaims, + buildClaimsWith, + buildEnrichedClaims, + SessionOptions (..), + defaultSessionOptions, + issueSession, + issueSessionWith, + ensureEmailVerified, + requireLiveSession, + ) +where + +import Data.Aeson (Object) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Time (addUTCTime) +import Effectful (Eff, (:>)) +import Shomei.Account.User.Domain (User (..)) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Authorization.Claims.Domain (AuthClaims (..), Scope, mkExtraClaims, noExtraClaims) +import Shomei.Authorization.Claims.Store (ClaimsDelta (..), ClaimsEnricher, enrichClaims) +import Shomei.Authorization.Role.Store (RoleStore, listRolesForUser, permissionsForRoles) +import Shomei.Config (NotifierConfig (..), ShomeiConfig (..)) +import Shomei.Error (AuthError (..)) +import Shomei.Id (SessionId, UserId) +import Shomei.Prelude +import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (InteractiveSession), SessionStatus (SessionActive)) +import Shomei.Session.Store (SessionStore, findSessionById) +import Shomei.Session.Token.Domain (TokenPair (..)) +import Shomei.Session.Token.Generator (TokenGen, generateOpaqueToken, hashRefreshToken) +import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork, NewSessionToken (..), persistNewSession) +import Shomei.SigningKey.Signer (TokenSigner, signAccessToken) + +-- | The @emailVerificationRequired@ gate, called by every token-issuing path. +-- +-- Blocks only an account that /has/ an email which is unverified. An account with no email +-- is exempt: it can never complete verification, so gating it would permanently brick +-- login-id-only deployments that enable the flag for their email accounts. +-- +-- Pure 'Either' so callers in both the @Error@-effect and the explicit-@Either@ styles can +-- use it. +ensureEmailVerified :: ShomeiConfig -> User -> Either AuthError () +ensureEmailVerified cfg user + | cfg.notifierConfig.emailVerificationRequired + && isJust user.email + && isNothing user.emailVerifiedAt = + Left EmailNotVerified + | otherwise = Right () + +-- | Read a session and require it to be usable now. Privilege-minting workflows share this one +-- predicate so missing, expired, and revoked sessions cannot be interpreted differently. +requireLiveSession :: (SessionStore :> es) => UTCTime -> SessionId -> Eff es (Either AuthError Session) +requireLiveSession ts sid = do + mSession <- findSessionById sid + pure $ case mSession of + Nothing -> Left SessionNotFound + Just session + | session.expiresAt <= ts -> Left SessionExpired + | session.status /= SessionActive -> Left SessionRevoked + | otherwise -> Right session + +-- | The /base/ claims for a freshly-authenticated session: no scopes, no roles. The standard +-- workflows call 'buildEnrichedClaims', which fills those in from the role store and the host +-- hook. 'Shomei.ServiceAccount.Secret' uses this directly, because it sets @scopes@ itself from +-- the account's negotiated allow-list. +buildClaims :: ShomeiConfig -> UserId -> SessionId -> UTCTime -> AuthClaims +buildClaims cfg uid sid ts = + AuthClaims + { subject = uid, + sessionId = sid, + issuer = cfg.issuer, + audience = cfg.audience, + issuedAt = ts, + expiresAt = addUTCTime cfg.accessTokenTTL ts, + authTime = ts, + scopes = Set.empty, + roles = Set.empty, + permissions = Set.empty, + actor = Nothing, + extraClaims = noExtraClaims + } + +-- | Like 'buildClaims' but attaches a service-supplied custom-claims object (reserved +-- keys are dropped by 'mkExtraClaims'). A consuming service uses this to add its own +-- top-level JWT claims without modifying Shōmei; the standard workflows keep calling +-- 'buildClaims'. +buildClaimsWith :: ShomeiConfig -> Object -> UserId -> SessionId -> UTCTime -> AuthClaims +buildClaimsWith cfg extra uid sid ts = + (buildClaims cfg uid sid ts) {extraClaims = mkExtraClaims extra} + +-- | Build the access-token claims for a fresh user session: 'buildClaims' plus the roles the +-- 'RoleStore' holds for the subject, plus whatever the host's 'ClaimsEnricher' adds. +-- +-- This is the single claims-construction point for every user-session mint — signup, login, +-- MFA completion, passwordless login, and refresh all reach it. Anything that needs the same +-- claims (an OIDC ID token, a userinfo response, an exchanged token) must call this rather than +-- re-reading the stores itself, or the two will drift. +-- +-- The delta's extra claims run through 'mkExtraClaims', so the hook cannot forge a reserved +-- claim. Roles are the union of stored and hook-supplied ones; scopes come only from the hook +-- (Shōmei persists no scopes). Permissions (EP-9) are the union of the /effective/ role set's +-- catalog permissions — an enricher-added role brings its permissions with it — and cannot be +-- forged through @extraClaims@ ('permissions' is reserved). The stored roles are read as of the +-- mint instant, so an expired grant contributes neither its role nor its permissions. +buildEnrichedClaims :: + (RoleStore :> es, ClaimsEnricher :> es) => + ShomeiConfig -> + UserId -> + SessionId -> + UTCTime -> + Eff es AuthClaims +buildEnrichedClaims cfg uid sid ts = do + storeRoles <- listRolesForUser uid ts + delta <- enrichClaims uid storeRoles + let effectiveRoles = storeRoles <> delta.extraRoles + perms <- permissionsForRoles effectiveRoles + pure + (buildClaims cfg uid sid ts) + { roles = effectiveRoles, + scopes = delta.extraScopes, + permissions = perms, + extraClaims = mkExtraClaims delta.extraClaims + } + +-- | Mint a fresh session + refresh token + signed access token for an authenticated user, +-- publishing 'LoginSucceeded' and 'SessionStarted'. Returns the new session id alongside the +-- token pair so a caller (e.g. 'Shomei.Mfa.Workflow.completeMfa') can name the session in its +-- own audit event. The session id is fresh each call. +-- +-- The session row, the refresh-token row, and both audit events are written by a single +-- 'persistNewSession' — one database transaction, one round-trip — so a crash mid-tail cannot +-- leave a session without its token. Signing the access token is pure CPU work and stays +-- outside the transaction. The session id is generated inside the unit-of-work interpreter, +-- which is why the events are supplied as a function of it. +-- | What distinguishes one issuance from another. Everything here is 'mempty'-ish by default, so +-- 'issueSession' — the login\/MFA\/passwordless tail — behaves exactly as it did before EP-5. +data SessionOptions = SessionOptions + { -- | the OAuth2 @client_id@ that minted this session (EP-5's authorization-code grant), which + -- binds the session's refresh token to that client. 'Nothing' for every other flow. + oauthClientId :: !(Maybe Text), + -- | scopes the OAuth authorization-code grant granted, persisted on the session and added to + -- the minted access token beyond whatever the 'ClaimsEnricher' supplies. + extraScopes :: !(Set Scope) + } + deriving stock (Generic, Eq, Show) + +defaultSessionOptions :: SessionOptions +defaultSessionOptions = SessionOptions {oauthClientId = Nothing, extraScopes = Set.empty} + +issueSession :: + ( AuthUnitOfWork :> es, + TokenSigner :> es, + TokenGen :> es, + RoleStore :> es, + ClaimsEnricher :> es + ) => + ShomeiConfig -> + User -> + UTCTime -> + Eff es (SessionId, TokenPair) +issueSession cfg user ts = do + (sid, pair, _claims) <- issueSessionWith cfg defaultSessionOptions user ts + pure (sid, pair) + +-- | 'issueSession' with the OAuth-specific knobs, and returning the claims it signed. +-- +-- The claims come back because EP-5's authorization-code grant must build its __ID token__ from +-- the same 'buildEnrichedClaims' output as the access token, per this MasterPlan's claims +-- integration point — never by re-reading the role store in the HTTP layer. +issueSessionWith :: + ( AuthUnitOfWork :> es, + TokenSigner :> es, + TokenGen :> es, + RoleStore :> es, + ClaimsEnricher :> es + ) => + ShomeiConfig -> + SessionOptions -> + User -> + UTCTime -> + Eff es (SessionId, TokenPair, AuthClaims) +issueSessionWith cfg opts user ts = do + rawToken <- generateOpaqueToken + tokHash <- hashRefreshToken rawToken + (session, _token) <- + persistNewSession + NewSession + { userId = user.userId, + createdAt = ts, + expiresAt = addUTCTime cfg.sessionTTL ts, + actor = Nothing, + oauthClientId = opts.oauthClientId, + -- Every caller is an interactive login or a code exchange authorized by one. + kind = InteractiveSession, + grantedScopes = opts.extraScopes, + authenticatedAt = ts + } + NewSessionToken + { tokenHash = tokHash, + createdAt = ts, + expiresAt = addUTCTime cfg.refreshTokenTTL ts + } + \sid -> + [ Event.LoginSucceeded (Event.LoginSucceededData user.userId sid ts), + Event.SessionStarted (Event.SessionStartedData sid user.userId ts) + ] + base <- buildEnrichedClaims cfg user.userId session.sessionId ts + -- Union rather than replace: the host's 'ClaimsEnricher' scopes and the OAuth-granted scopes + -- are both things this principal legitimately holds on this token. + let claims = base {scopes = base.scopes <> opts.extraScopes} + access <- signAccessToken claims + pure + ( session.sessionId, + TokenPair {accessToken = access, refreshToken = rawToken, expiresIn = cfg.accessTokenTTL}, + claims + ) diff --git a/src/Shomei/SigningKey/Domain.hs b/src/Shomei/SigningKey/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Domain.hs @@ -0,0 +1,60 @@ +-- | The storage-agnostic signing-key record that crosses the +-- 'Shomei.SigningKey.Store' port (IP-4). +-- +-- To keep @shomei-core@ (and @shomei-postgres@) free of any @jose@ dependency, key +-- material crosses the port as opaque 'Text' (JWK JSON). Only @shomei-jwt@ (EP-4) +-- converts a 'StoredSigningKey' to/from a @jose@ @JWK@. +module Shomei.SigningKey.Domain + ( SigningKeyStatus (..), + SigningAlgorithm (..), + signingAlgorithmToText, + signingAlgorithmFromText, + StoredSigningKey (..), + ) +where + +import Data.Text qualified as Text +import Shomei.Prelude + +data SigningKeyStatus = KeyPending | KeyActive | KeyRetired | KeyRevoked + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +-- | The JWT signing algorithm a key uses. A closed enum kept in @shomei-core@ so +-- the in-memory decision is type-safe; the storage representation +-- ('StoredSigningKey.algorithm') and the config stay 'Text', and only @shomei-jwt@ +-- maps this enum to a @jose@ @Alg@. @ES256@ is ECDSA over P-256/SHA-256 (the +-- default); @RS256@ is RSASSA-PKCS1-v1_5 with SHA-256. +data SigningAlgorithm = ES256 | RS256 + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) + +signingAlgorithmToText :: SigningAlgorithm -> Text +signingAlgorithmToText ES256 = "ES256" +signingAlgorithmToText RS256 = "RS256" + +-- | Parse the stored algorithm text. Unknown values are an error rather than a +-- silent default, so a corrupt/forward-incompatible key is caught loudly. +signingAlgorithmFromText :: Text -> Either Text SigningAlgorithm +signingAlgorithmFromText t = case Text.strip t of + "ES256" -> Right ES256 + "RS256" -> Right RS256 + other -> Left ("unknown signing algorithm: " <> other) + +data StoredSigningKey = StoredSigningKey + { -- | the @kid@ + keyId :: !Text, + -- | e.g. @"ES256"@ + algorithm :: !Text, + -- | opaque JWK JSON; core never imports jose + publicKeyJwk :: !Text, + -- | opaque JWK JSON + privateKeyJwk :: !Text, + status :: !SigningKeyStatus, + createdAt :: !UTCTime, + activatedAt :: !(Maybe UTCTime), + retiredAt :: !(Maybe UTCTime), + revokedAt :: !(Maybe UTCTime) + } + deriving stock (Generic, Eq, Show) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Shomei/SigningKey/Signer.hs b/src/Shomei/SigningKey/Signer.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Signer.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The token-signer port: turning 'AuthClaims' into a signed 'AccessToken', and +-- 'IdTokenClaims' into a signed 'IdToken' (both real JWTs in @shomei-jwt@). +-- +-- ID-token signing is an operation here rather than a direct @jose@ call from the HTTP layer, +-- because every workflow-visible signing capability in this repo crosses this port: that is what +-- keeps the in-memory test fake able to stand in for the real signer, and what means an OIDC ID +-- token is signed with the same active key and @kid@ as an access token, with zero new JWKS or +-- key-rotation work. +module Shomei.SigningKey.Signer + ( TokenSigner (..), + signAccessToken, + signIdToken, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Authorization.Claims.Domain (AuthClaims) +import Shomei.OAuth.IdToken.Domain (IdToken, IdTokenClaims) +import Shomei.Session.Token.Domain (AccessToken) + +data TokenSigner :: Effect where + SignAccessToken :: AuthClaims -> TokenSigner m AccessToken + -- | EP-5. Signed with the same active key and @kid@ as an access token, so the ID token + -- verifies against the same published JWKS document. + SignIdToken :: IdTokenClaims -> TokenSigner m IdToken + +type instance DispatchOf TokenSigner = Dynamic + +signAccessToken :: (TokenSigner :> es) => AuthClaims -> Eff es AccessToken +signAccessToken = send . SignAccessToken + +signIdToken :: (TokenSigner :> es) => IdTokenClaims -> Eff es IdToken +signIdToken = send . SignIdToken diff --git a/src/Shomei/SigningKey/Store.hs b/src/Shomei/SigningKey/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Store.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The signing-key-store port (IP-4): persisting and listing 'StoredSigningKey' records. +-- Key material is opaque JWK JSON; this port never touches @jose@. +module Shomei.SigningKey.Store + ( SigningKeyStore (..), + listActiveSigningKeys, + listPublishableSigningKeys, + findSigningKeyByKid, + insertSigningKey, + updateSigningKeyStatus, + replaceActiveSigningKey, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Prelude +import Shomei.SigningKey.Domain (SigningKeyStatus, StoredSigningKey) + +data SigningKeyStore :: Effect where + ListActiveSigningKeys :: SigningKeyStore m [StoredSigningKey] + -- | Every key that belongs in the published JWKS and the verifier key set: + -- @active@ and @retired@ (they overlap during a rotation window). Excludes + -- @pending@ (not yet trusted) and @revoked@ (explicitly distrusted). + ListPublishableSigningKeys :: SigningKeyStore m [StoredSigningKey] + FindSigningKeyByKid :: Text -> SigningKeyStore m (Maybe StoredSigningKey) + InsertSigningKey :: StoredSigningKey -> SigningKeyStore m () + UpdateSigningKeyStatus :: Text -> SigningKeyStatus -> UTCTime -> SigningKeyStore m () + -- | In one transaction, retire every active key with @retired_at = t@, then insert the + -- given key (or promote the row with its @kid@) as active with @activated_at = t@. + ReplaceActiveSigningKey :: StoredSigningKey -> UTCTime -> SigningKeyStore m () + +type instance DispatchOf SigningKeyStore = Dynamic + +listActiveSigningKeys :: (SigningKeyStore :> es) => Eff es [StoredSigningKey] +listActiveSigningKeys = send ListActiveSigningKeys + +listPublishableSigningKeys :: (SigningKeyStore :> es) => Eff es [StoredSigningKey] +listPublishableSigningKeys = send ListPublishableSigningKeys + +findSigningKeyByKid :: (SigningKeyStore :> es) => Text -> Eff es (Maybe StoredSigningKey) +findSigningKeyByKid = send . FindSigningKeyByKid + +insertSigningKey :: (SigningKeyStore :> es) => StoredSigningKey -> Eff es () +insertSigningKey = send . InsertSigningKey + +updateSigningKeyStatus :: (SigningKeyStore :> es) => Text -> SigningKeyStatus -> UTCTime -> Eff es () +updateSigningKeyStatus kid st t = send (UpdateSigningKeyStatus kid st t) + +replaceActiveSigningKey :: (SigningKeyStore :> es) => StoredSigningKey -> UTCTime -> Eff es () +replaceActiveSigningKey key t = send (ReplaceActiveSigningKey key t) diff --git a/src/Shomei/SigningKey/Verifier.hs b/src/Shomei/SigningKey/Verifier.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Verifier.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The token-verifier port: validating a signed 'AccessToken' back into 'AuthClaims' +-- (real JWT/JWKS verification in EP-4). +module Shomei.SigningKey.Verifier + ( TokenVerifier (..), + verifyAccessToken, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Authorization.Claims.Domain (AuthClaims) +import Shomei.Error (TokenError) +import Shomei.Session.Token.Domain (AccessToken) + +data TokenVerifier :: Effect where + VerifyAccessToken :: AccessToken -> TokenVerifier m (Either TokenError AuthClaims) + +type instance DispatchOf TokenVerifier = Dynamic + +verifyAccessToken :: (TokenVerifier :> es) => AccessToken -> Eff es (Either TokenError AuthClaims) +verifyAccessToken = send . VerifyAccessToken diff --git a/src/Shomei/Test/InMemory.hs b/src/Shomei/Test/InMemory.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Test/InMemory.hs @@ -0,0 +1,1527 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +-- | A pure, in-memory interpreter for every Shōmei port, backing the EP-2 test suite. +-- +-- A single mutable 'World' (held in an 'IORef') holds the user/credential/session/ +-- refresh-token/signing-key stores plus the published-event log, a fixed test clock, and +-- a deterministic token counter. 'runInMemory' stacks an interpreter for every port over +-- 'IOE'. There is no database, JWT library, or network here: the +-- 'Shomei.Account.Password.Hash.Store' fake tags and compares plaintext, the +-- 'Shomei.Session.Token.Generator' fake emits @rt-0@, @rt-1@, … and the +-- 'Shomei.SigningKey.Signer'/'Shomei.SigningKey.Verifier' fakes round-trip 'AuthClaims' +-- through JSON. +module Shomei.Test.InMemory + ( World (..), + InMemoryPorts, + emptyWorld, + runInMemory, + runInMemoryWith, + + -- * Individual interpreters + + -- | Exported so an assembly can compose a /hybrid/ stack — e.g. these + -- in-memory store/support interpreters together with EP-4's real @jose@ + -- 'Shomei.SigningKey.Signer'/'Shomei.SigningKey.Verifier' interpreters — keeping + -- the same effect order as 'runInMemory'. ('Shomei.Servant''s end-to-end test + -- uses exactly that hybrid so signing/verification exercise real ES256.) + runUserStore, + runCredentialStore, + runSessionStore, + runRefreshTokenStore, + runRoleStore, + runAuthUnitOfWork, + runVerificationTokenStore, + runPasswordResetTokenStore, + runLoginAttemptStore, + runPasskeyStore, + runPendingCeremonyStore, + runServiceAccountStore, + runOAuthClientStore, + runOAuthCodeStore, + runTotpCredentialStore, + runRecoveryCodeStore, + runNotifier, + runClaimsEnricherNull, + runPasswordHasher, + runPasswordBreachCheckerFake, + runTokenSigner, + runTokenVerifier, + runAuthEventPublisher, + runAuthEventReader, + runSigningKeyStore, + runClock, + runTokenGen, + runWebAuthnCeremonyFake, + ) +where + +import Data.Aeson (Value, eitherDecode, eitherDecodeStrict', encode, object) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types (Parser, parseMaybe, withObject, (.:)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () +import Data.IORef (IORef, atomicModifyIORef', readIORef) +import Data.List (sortBy, sortOn) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (listToMaybe) +import Data.Ord (Down (..), comparing) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TLE +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.UUID qualified as UUID +import Effectful (Eff, IOE, runEff, (:>)) +import Effectful.Dispatch.Dynamic (interpret_) +import Shomei.Account.Credential.Domain (Credential (..)) +import Shomei.Account.Credential.Store (CredentialStore (..)) +import Shomei.Account.LoginId.Domain (LoginId) +import Shomei.Account.Notification.Domain (Notification) +import Shomei.Account.Notification.Store (Notifier (..)) +import Shomei.Account.OneTimeToken.Domain (OneTimeTokenHash, OneTimeTokenStatus (..)) +import Shomei.Account.Password.Breach.Store (BreachResult (..), PasswordBreachChecker (..)) +import Shomei.Account.Password.Domain (PasswordHash (..), PlainPassword (..)) +import Shomei.Account.Password.Hash.Store (PasswordHasher (..)) +import Shomei.Account.PasswordReset.Domain (NewPasswordResetToken (..), PersistedPasswordResetToken (..)) +import Shomei.Account.PasswordReset.Store (PasswordResetTokenStore (..)) +import Shomei.Account.User.Domain (NewUser (..), User (..), UserStatus (..)) +import Shomei.Account.User.Store (UserCursor (..), UserListQuery (..), UserStore (..), clampUserLimit) +import Shomei.Account.Verification.Domain (NewVerificationToken (..), PersistedVerificationToken (..)) +import Shomei.Account.Verification.Store (VerificationTokenStore (..)) +import Shomei.Audit.Event.Codec (projectAuthEvent) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Audit.Publisher.Store (AuthEventPublisher (..)) +import Shomei.Audit.Reader.Store + ( AuditCursor (..), + AuditEventQuery (..), + AuthEventReader (..), + StoredAuthEvent (..), + clampLimit, + ) +import Shomei.Authorization.Claims.Domain (AuthClaims, Issuer (..), Permission (..), Role (..)) +import Shomei.Authorization.Claims.Store (ClaimsDelta, ClaimsEnricher, emptyClaimsDelta, runClaimsEnricherNull, runClaimsEnricherPure) +import Shomei.Authorization.Role.Store (RoleDefinition (..), RoleStore (..)) +import Shomei.Error (TokenError (..)) +import Shomei.Id + ( CeremonyId, + LoginAttemptId, + OAuthClientId, + PasskeyId, + PasswordResetTokenId, + RecoveryCodeId, + RefreshTokenId, + ServiceAccountDbId, + SessionId, + TotpCredentialId, + UserId, + VerificationTokenId, + genCredentialId, + genLoginAttemptId, + genPasskeyId, + genPasswordResetTokenId, + genRefreshTokenId, + genSessionId, + genUserId, + genVerificationTokenId, + idText, + sessionIdToUUID, + userIdToUUID, + ) +import Shomei.Mfa.RecoveryCode.Store (RecoveryCodeStore (..)) +import Shomei.Mfa.Totp.Domain + ( NewRecoveryCode (..), + NewTotpCredential (..), + RecoveryCode (..), + TotpCredential (..), + ) +import Shomei.Mfa.Totp.Store (TotpCredentialStore (..)) +import Shomei.OAuth.AuthorizationCode.Domain + ( AuthorizationCode (..), + NewAuthorizationCode (..), + ) +import Shomei.OAuth.AuthorizationCode.Store (OAuthCodeStore (..)) +import Shomei.OAuth.Client.Domain + ( NewOAuthClient (..), + OAuthClient (..), + OAuthClientStatus (..), + ) +import Shomei.OAuth.Client.Store (OAuthClientStore (..)) +import Shomei.OAuth.IdToken.Domain (IdToken (..), IdTokenClaims (..)) +import Shomei.Passkey.Ceremony.Port + ( BeginCeremony (..), + StoredCredentialForVerify (..), + VerifiedAuthentication (..), + VerifiedRegistration (..), + WebAuthnCeremony (..), + WebAuthnError (..), + ) +import Shomei.Passkey.Ceremony.Store (PendingCeremonyStore (..)) +import Shomei.Passkey.Domain + ( NewPasskeyCredential (..), + PasskeyCredential (..), + PendingCeremony (..), + PublicKeyBytes, + SignatureCounter (..), + UserHandle, + WebAuthnCredentialId, + ) +import Shomei.Passkey.Store (PasskeyStore (..)) +import Shomei.Prelude +import Shomei.ServiceAccount.Domain + ( NewServiceAccount (..), + ServiceAccount (..), + ServiceAccountStatus (..), + ) +import Shomei.ServiceAccount.Store (ServiceAccountStore (..)) +import Shomei.Session.Domain (NewSession (..), Session (..), SessionStatus (..)) +import Shomei.Session.LoginAttempt.Domain + ( AccountKey, + AccountLockout (..), + FailureOutcome (..), + LockPolicy (..), + LoginAttempt (..), + LoginOutcome (..), + NewLoginAttempt (..), + ) +import Shomei.Session.LoginAttempt.Store (LoginAttemptStore (..)) +import Shomei.Session.RefreshToken.Domain + ( NewRefreshToken (..), + PersistedRefreshToken (..), + RefreshToken (..), + RefreshTokenHash (..), + RefreshTokenStatus (..), + ) +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 (..), NewSessionToken (..), RotationOutcome (..)) +import Shomei.SigningKey.Domain (SigningKeyStatus (..), StoredSigningKey (..)) +import Shomei.SigningKey.Signer (TokenSigner (..)) +import Shomei.SigningKey.Store (SigningKeyStore (..)) +import Shomei.SigningKey.Verifier (TokenVerifier (..)) +import Shomei.Time.Store (Clock (..)) + +-- | The whole mutable test world. +data World = World + { users :: !(Map UserId User), + credsByLoginId :: !(Map LoginId Credential), + sessions :: !(Map SessionId Session), + refreshTokens :: !(Map RefreshTokenId PersistedRefreshToken), + refreshByHash :: !(Map RefreshTokenHash RefreshTokenId), + verificationTokens :: !(Map VerificationTokenId PersistedVerificationToken), + verificationByHash :: !(Map OneTimeTokenHash VerificationTokenId), + passwordResetTokens :: !(Map PasswordResetTokenId PersistedPasswordResetToken), + passwordResetByHash :: !(Map OneTimeTokenHash PasswordResetTokenId), + signingKeys :: !(Map Text StoredSigningKey), + -- | the role registry, pre-seeded with @admin@ to mirror the migration's seed row so a + -- fresh in-memory world and a freshly migrated database agree + definedRoles :: !(Map Role RoleDefinition), + -- | durable @(user, role)@ grants, each with an optional expiry (@Nothing@ = forever), mirroring + -- @shomei_role_grants.expires_at@ (EP-9). Unlike PostgreSQL, this map enforces no foreign key + -- into 'definedRoles': the registry check lives in 'Shomei.Authorization.Role.Workflow.grantRoleTo', + -- which is the tested path. The database FK is defense in depth for code that bypasses + -- the workflow, and has no in-memory analogue. + roleGrants :: !(Map UserId (Map Role (Maybe UTCTime))), + -- | role→permission definitions (@shomei_role_permissions@, EP-9), resolved to a union at mint. + -- As with 'roleGrants', no FK into 'definedRoles' is enforced here. + rolePermissions :: !(Map Role (Set Permission)), + -- | newest-first append-only attempt log (EP-2 brute-force protection) + loginAttempts :: ![LoginAttempt], + accountLockouts :: !(Map AccountKey AccountLockout), + passkeys :: !(Map PasskeyId PasskeyCredential), + pendingCeremonies :: !(Map CeremonyId PendingCeremony), + -- | EP-4 database-backed service accounts, keyed by id. Unlike PostgreSQL this map + -- enforces no unique index on @clientId@; the id /is/ the client id's source, so a + -- collision is impossible by construction. + serviceAccounts :: !(Map ServiceAccountDbId ServiceAccount), + -- | EP-5 OAuth2/OIDC clients, keyed by id. As with 'serviceAccounts', @clientId@ is derived + -- from the id, so the database's unique index has no in-memory analogue to enforce. + oauthClients :: !(Map OAuthClientId OAuthClient), + -- | EP-5 single-use authorization codes, keyed by the code's SHA-256 hex digest exactly as + -- the PostgreSQL primary key is. Consumed rows stay, so a replay finds a consumed row. + oauthCodes :: !(Map Text AuthorizationCode), + -- | EP-7 TOTP credentials, keyed by user id (@UNIQUE (user_id)@). The in-memory interpreter + -- holds the /raw/ 'Shomei.Mfa.Totp.Algorithm.TotpSecret'; only the PostgreSQL boundary encrypts it. + totpCredentials :: !(Map UserId TotpCredential), + -- | EP-7 recovery codes, keyed by id. Consumed rows stay (with @usedAt@ set), so a replayed + -- code finds a spent row exactly as the database does. + recoveryCodes :: !(Map RecoveryCodeId RecoveryCode), + -- | newest-first + publishedEvents :: ![Event.AuthEvent], + -- | newest-first + sentNotifications :: ![Notification], + -- | fixed test time + clock :: !UTCTime, + -- | deterministic opaque tokens + tokenCounter :: !Int, + -- | deterministic WebAuthn ceremony challenges (fake interpreter) + ceremonyCounter :: !Int, + -- | EP-3: plaintexts the breach-checker fake treats as breached + breachedPasswords :: !(Set Text), + -- | EP-3: when False the fake returns 'BreachCheckUnavailable' (test seam for fail-open/closed) + breachCheckAvailable :: !Bool + } + deriving stock (Generic) + +emptyWorld :: UTCTime -> World +emptyWorld t = + World + { users = Map.empty, + credsByLoginId = Map.empty, + sessions = Map.empty, + refreshTokens = Map.empty, + refreshByHash = Map.empty, + verificationTokens = Map.empty, + verificationByHash = Map.empty, + passwordResetTokens = Map.empty, + passwordResetByHash = Map.empty, + signingKeys = Map.empty, + definedRoles = Map.singleton adminRole (RoleDefinition adminRole (Just adminRoleDescription) t), + roleGrants = Map.empty, + rolePermissions = Map.empty, + loginAttempts = [], + accountLockouts = Map.empty, + passkeys = Map.empty, + pendingCeremonies = Map.empty, + serviceAccounts = Map.empty, + oauthClients = Map.empty, + oauthCodes = Map.empty, + totpCredentials = Map.empty, + recoveryCodes = Map.empty, + publishedEvents = [], + sentNotifications = [], + clock = t, + tokenCounter = 0, + ceremonyCounter = 0, + breachedPasswords = Set.empty, + breachCheckAvailable = True + } + +-- | The role the @shomei_role_grants@ migration seeds into the registry, and its description. +-- Kept in lockstep with @shomei-migrations\/sql-migrations\/*-shomei-role-grants.sql@. +adminRole :: Role +adminRole = Role "admin" + +adminRoleDescription :: Text +adminRoleDescription = "Full access to the shomei /admin surface and admin CLI-equivalent HTTP routes" + +-- | Strict, /atomic/ world update. Every store shares one 'IORef' 'World', and the +-- concurrency regression tests run workflows from many green threads, so the plain +-- read-modify-write of 'Data.IORef.modifyIORef'' would silently drop updates. +-- 'atomicModifyIORef'' serializes them. +modifyWorld :: IORef World -> (World -> World) -> IO () +modifyWorld ref f = atomicModifyIORef' ref \w -> (f w, ()) + +-- | Atomic compare-and-swap over the world: inspect and transition in one uninterruptible +-- step, answering whether this caller performed the transition. The in-memory analogue of a +-- conditional @UPDATE … WHERE status = 'active' RETURNING@. +casWorld :: IORef World -> (World -> Maybe World) -> IO Bool +casWorld ref f = atomicModifyIORef' ref \w -> case f w of + Just w' -> (w', True) + Nothing -> (w, False) + +-- Token signer/verifier fakes: round-trip claims through JSON. + +renderClaims :: AuthClaims -> Text +renderClaims = TL.toStrict . TLE.decodeUtf8 . encode + +parseClaims :: Text -> Either TokenError AuthClaims +parseClaims t = case eitherDecode (TLE.encodeUtf8 (TL.fromStrict t)) of + Left _ -> Left TokenMalformed + Right c -> Right c + +-- | Walk to the root of a refresh-token family by following @parentTokenId@ links. +rootOf :: Map RefreshTokenId PersistedRefreshToken -> RefreshTokenId -> RefreshTokenId +rootOf m tid = case Map.lookup tid m of + Just t -> maybe tid (rootOf m) t.parentTokenId + Nothing -> tid + +runUserStore :: (IOE :> es) => IORef World -> Eff (UserStore : es) a -> Eff es a +runUserStore ref = interpret_ \case + CreateUser nu -> do + uid <- genUserId + w <- liftIO (readIORef ref) + let u = + User + { userId = uid, + loginId = nu.loginId, + email = nu.email, + displayName = nu.displayName, + status = UserActive, + emailVerifiedAt = Nothing, + createdAt = w.clock, + updatedAt = w.clock + } + liftIO (modifyWorld ref (#users %~ Map.insert uid u)) + pure u + FindUserById uid -> liftIO ((Map.lookup uid . (.users)) <$> readIORef ref) + FindUserByLoginId lid -> liftIO (findByLoginId lid <$> readIORef ref) + FindUserByEmail e -> liftIO (findByEmail e <$> readIORef ref) + UpdateUserStatus uid allowed st ts -> + liftIO + ( casWorld ref \w -> case Map.lookup uid w.users of + Just user + | user.status `elem` allowed -> + Just (w & #users %~ Map.insert uid (user & #status .~ st & #updatedAt .~ ts)) + _ -> Nothing + ) + MarkUserEmailVerified uid t -> + liftIO (modifyWorld ref (#users %~ Map.adjust (#emailVerifiedAt .~ Just t) uid)) + ListUsers q -> liftIO (page q . Map.elems . (.users) <$> readIORef ref) + where + findByLoginId lid w = listToMaybe [u | u <- Map.elems w.users, u.loginId == lid] + findByEmail e w = listToMaybe [u | u <- Map.elems w.users, u.email == Just e] + + -- The same newest-first keyset page the PostgreSQL statement produces, so the servant + -- suite's pagination walk exercises identical semantics against the in-memory world. + page q = + take (clampUserLimit q.queryLimit) + . filter (beforeCursor q.queryBefore) + . filter (matchesStatus q.queryStatus) + . sortOn (Down . userKey) + + userKey u = (u.createdAt, userIdToUUID u.userId) + matchesStatus mst u = maybe True (== u.status) mst + beforeCursor Nothing _ = True + beforeCursor (Just c) u = userKey u < (c.cursorCreatedAt, userIdToUUID c.cursorUserId) + +runCredentialStore :: (IOE :> es) => IORef World -> Eff (CredentialStore : es) a -> Eff es a +runCredentialStore ref = interpret_ \case + CreatePasswordCredential uid lid mEmail h -> do + cid <- genCredentialId + w <- liftIO (readIORef ref) + let c = + PasswordCredential + { credentialId = cid, + userId = uid, + loginId = lid, + email = mEmail, + passwordHash = h, + createdAt = w.clock, + updatedAt = w.clock + } + liftIO (modifyWorld ref (#credsByLoginId %~ Map.insert lid c)) + pure c + FindPasswordCredentialByLoginId lid -> + liftIO ((Map.lookup lid . (.credsByLoginId)) <$> readIORef ref) + -- Retained reset-by-email path: a scan over the credential values (mirrors the user + -- 'findByEmail' scan), matching the optional email metadata. + FindPasswordCredentialByEmail e -> + liftIO ((\w -> listToMaybe [c | c <- Map.elems w.credsByLoginId, c.email == Just e]) <$> readIORef ref) + UpdatePasswordHash uid h -> + liftIO + ( modifyWorld + ref + (#credsByLoginId %~ Map.map (\c -> if c.userId == uid then c & #passwordHash .~ h else c)) + ) + +runSessionStore :: (IOE :> es) => IORef World -> Eff (SessionStore : es) a -> Eff es a +runSessionStore ref = interpret_ \case + CreateSession ns -> do + sid <- genSessionId + let s = mkSession sid ns + liftIO (modifyWorld ref (#sessions %~ Map.insert sid s)) + pure s + FindSessionById sid -> liftIO ((Map.lookup sid . (.sessions)) <$> readIORef ref) + RevokeSession sid t -> + liftIO (modifyWorld ref (#sessions %~ Map.adjust (revoke t) sid)) + RevokeAllUserSessions uid t -> + liftIO + ( modifyWorld + ref + (#sessions %~ Map.map (\s -> if s.userId == uid then revoke t s else s)) + ) + ListSessionsForUser uid -> + liftIO (sessionsOf uid <$> readIORef ref) + where + revoke t s = s & #status .~ SessionRevoked & #revokedAt .~ Just t + sessionsOf uid w = + sortOn (Down . \s -> (s.createdAt, sessionIdToUUID s.sessionId)) [s | s <- Map.elems w.sessions, s.userId == uid] + +-- Build a fresh Session from a NewSession (kept separate to avoid a long inline record). +mkSession :: SessionId -> NewSession -> Session +mkSession sid ns = + Session + { sessionId = sid, + userId = ns.userId, + status = SessionActive, + createdAt = ns.createdAt, + expiresAt = ns.expiresAt, + revokedAt = Nothing, + actor = ns.actor, + oauthClientId = ns.oauthClientId, + kind = ns.kind, + grantedScopes = ns.grantedScopes, + authenticatedAt = ns.authenticatedAt + } + +runRefreshTokenStore :: (IOE :> es) => IORef World -> Eff (RefreshTokenStore : es) a -> Eff es a +runRefreshTokenStore ref = interpret_ \case + CreateRefreshToken nrt -> do + rid <- genRefreshTokenId + let prt = mkPersisted rid nrt + liftIO + ( modifyWorld + ref + ( (#refreshTokens %~ Map.insert rid prt) + . (#refreshByHash %~ Map.insert nrt.tokenHash rid) + ) + ) + pure prt + FindRefreshTokenByHash h -> + liftIO (lookupByHash h <$> readIORef ref) + MarkRefreshTokenUsed rid t -> + liftIO + ( casWorld ref \w -> case Map.lookup rid w.refreshTokens of + Just tok + | tok.status == RefreshTokenActive -> + Just (w & #refreshTokens %~ Map.adjust (markUsed t) rid) + _ -> Nothing + ) + RevokeRefreshTokenFamily rid t -> + liftIO (modifyWorld ref (revokeFamily rid t)) + RevokeSessionRefreshTokens sid t -> + liftIO + ( modifyWorld + ref + (#refreshTokens %~ Map.map (\tok -> if tok.sessionId == sid then revoke t tok else tok)) + ) + RevokeAllUserRefreshTokens uid t -> + liftIO + ( modifyWorld + ref + ( \w -> + w + & #refreshTokens + %~ Map.map + ( \tok -> + case Map.lookup tok.sessionId w.sessions of + Just s | s.userId == uid -> revoke t tok + _ -> tok + ) + ) + ) + where + markUsed t tok = tok & #status .~ RefreshTokenUsed & #usedAt .~ Just t + revoke t tok = tok & #status .~ RefreshTokenRevoked & #revokedAt .~ Just t + lookupByHash h w = do + rid <- Map.lookup h w.refreshByHash + Map.lookup rid w.refreshTokens + revokeFamily rid t w = + let m = w.refreshTokens + target = rootOf m rid + m' = Map.map (\tok -> if rootOf m tok.refreshTokenId == target then revoke t tok else tok) m + in w & #refreshTokens .~ m' + +mkPersisted :: RefreshTokenId -> NewRefreshToken -> PersistedRefreshToken +mkPersisted rid nrt = + PersistedRefreshToken + { refreshTokenId = rid, + sessionId = nrt.sessionId, + tokenHash = nrt.tokenHash, + parentTokenId = nrt.parentTokenId, + status = RefreshTokenActive, + createdAt = nrt.createdAt, + expiresAt = nrt.expiresAt, + usedAt = Nothing, + revokedAt = Nothing + } + +-- | In-memory interpreter for the role registry, grant table, and permission definitions. +-- +-- @DefineRole@, @GrantRole@, @AllowPermission@, and @DisallowPermission@ report whether they +-- changed anything, so a caller publishes an audit event only on a real state change. Re-defining +-- an existing role does not overwrite its description, matching the PostgreSQL @ON CONFLICT DO +-- NOTHING@; re-granting a role whose expiry differs updates the window (upsert) and reports a +-- change, matching the PostgreSQL @… IS DISTINCT FROM …@ guard; @ListRolesForUser@ filters +-- expired grants as of the supplied instant, exactly as the SQL @expires_at > $2@ does. +runRoleStore :: (IOE :> es) => IORef World -> Eff (RoleStore : es) a -> Eff es a +runRoleStore ref = interpret_ \case + DefineRole r desc ts -> + liftIO + ( casWorld ref \w -> + if Map.member r w.definedRoles + then Nothing + else Just (w & #definedRoles %~ Map.insert r (RoleDefinition r desc ts)) + ) + ListDefinedRoles -> + liftIO (Map.elems . (.definedRoles) <$> readIORef ref) + GrantRole uid r _by expiry _ts -> + liftIO + ( casWorld ref \w -> + let held = Map.findWithDefault Map.empty uid w.roleGrants + in -- Upsert: unchanged only when the role is already held with an identical expiry. + -- 'insertWith Map.union' is left-biased toward the new singleton, so a differing + -- expiry overwrites the old one — the in-memory analogue of the SQL upsert. + if Map.lookup r held == Just expiry + then Nothing + else Just (w & #roleGrants %~ Map.insertWith Map.union uid (Map.singleton r expiry)) + ) + RevokeRole uid r -> + liftIO + ( casWorld ref \w -> + if r `Map.member` Map.findWithDefault Map.empty uid w.roleGrants + then Just (w & #roleGrants %~ Map.adjust (Map.delete r) uid) + else Nothing + ) + ListRolesForUser uid asOf -> + liftIO (unexpired asOf . Map.findWithDefault Map.empty uid . (.roleGrants) <$> readIORef ref) + AllowPermission r p _ts -> + liftIO + ( casWorld ref \w -> + if p `Set.member` Map.findWithDefault Set.empty r w.rolePermissions + then Nothing + else Just (w & #rolePermissions %~ Map.insertWith Set.union r (Set.singleton p)) + ) + DisallowPermission r p -> + liftIO + ( casWorld ref \w -> + if p `Set.member` Map.findWithDefault Set.empty r w.rolePermissions + then Just (w & #rolePermissions %~ Map.adjust (Set.delete p) r) + else Nothing + ) + ListPermissionsForRole r -> + liftIO (Map.findWithDefault Set.empty r . (.rolePermissions) <$> readIORef ref) + PermissionsForRoles roles -> + liftIO ((\w -> foldMap (\r -> Map.findWithDefault Set.empty r w.rolePermissions) (Set.toList roles)) <$> readIORef ref) + where + -- Keep the roles whose grant has not expired as of the instant (Nothing = forever). + unexpired asOf = Map.keysSet . Map.filter (maybe True (> asOf)) + +-- | In-memory interpreter for the transactional unit-of-work port. +-- +-- Where the PostgreSQL interpreter wraps its statements in @BEGIN … COMMIT@, this one applies +-- the whole multi-table update in a single 'atomicModifyIORef'' step, which is the in-memory +-- equivalent: no other green thread can observe a session without its refresh token, and the +-- rotation's compare-and-swap and its inserts land together or not at all. The concurrency +-- regression tests run these workflows from many threads and depend on exactly that. +-- +-- 'publishedEvents' is newest-first, so a batch of events is prepended reversed: the last event +-- a workflow authors ends up at the head. +runAuthUnitOfWork :: (IOE :> es) => IORef World -> Eff (AuthUnitOfWork : es) a -> Eff es a +runAuthUnitOfWork ref = interpret_ \case + PersistNewSession ns nst mkEvents -> do + sid <- genSessionId + rid <- genRefreshTokenId + let session = mkSession sid ns + newToken = + NewRefreshToken + { sessionId = sid, + tokenHash = nst.tokenHash, + parentTokenId = Nothing, + createdAt = nst.createdAt, + expiresAt = nst.expiresAt + } + persisted = mkPersisted rid newToken + events = mkEvents sid + liftIO + ( modifyWorld + ref + ( (#sessions %~ Map.insert sid session) + . (#refreshTokens %~ Map.insert rid persisted) + . (#refreshByHash %~ Map.insert nst.tokenHash rid) + . (#publishedEvents %~ (reverse events <>)) + ) + ) + pure (session, persisted) + RotateRefreshToken presentedId usedAt newToken ev -> do + rid <- genRefreshTokenId + let persisted = mkPersisted rid newToken + liftIO + ( atomicModifyIORef' ref \w -> case Map.lookup presentedId w.refreshTokens of + Just tok + | tok.status == RefreshTokenActive -> + ( w + & #refreshTokens + %~ (Map.insert rid persisted . Map.adjust (markUsed usedAt) presentedId) + & #refreshByHash + %~ Map.insert newToken.tokenHash rid + & #publishedEvents + %~ (ev :), + Rotated persisted + ) + _ -> (w, RotationConflict) + ) + CompletePasswordReset tid uid newHash ts events -> + liftIO + ( atomicModifyIORef' ref \w -> case Map.lookup tid w.passwordResetTokens of + Just tok + | tok.status == OneTimeTokenActive -> + let userSessions = w.sessions + w' = + w + & #passwordResetTokens + %~ ( Map.map (revokeResetSibling uid tid ts) + . Map.adjust (consumeReset ts) tid + ) + & #credsByLoginId + %~ Map.map (replaceUserHash uid newHash) + & #sessions + %~ Map.map (revokeUserSession uid ts) + & #refreshTokens + %~ Map.map (revokeUserRefreshToken userSessions uid ts) + & #publishedEvents + %~ (reverse events <>) + in (w', True) + _ -> (w, False) + ) + CompletePasswordChange uid newHash ts events -> + liftIO + ( modifyWorld ref \w -> + let userSessions = w.sessions + in w + & #credsByLoginId + %~ Map.map (replaceUserHash uid newHash) + & #sessions + %~ Map.map (revokeUserSession uid ts) + & #refreshTokens + %~ Map.map (revokeUserRefreshToken userSessions uid ts) + & #publishedEvents + %~ (reverse events <>) + ) + RevokeSessionWithTokens sid ts events -> + liftIO + ( atomicModifyIORef' ref \w -> case Map.lookup sid w.sessions of + Just session + | session.status == SessionActive -> + ( w + & #sessions + %~ Map.adjust (revokeSessionAt ts) sid + & #refreshTokens + %~ Map.map (revokeSessionRefreshToken sid ts) + & #publishedEvents + %~ (reverse events <>), + True + ) + _ -> (w, False) + ) + where + markUsed t tok = tok & #status .~ RefreshTokenUsed & #usedAt .~ Just t + consumeReset t tok = tok & #status .~ OneTimeTokenConsumed & #consumedAt .~ Just t + revokeResetSibling uid consumedId t tok + | tok.userId == uid, + tok.passwordResetTokenId /= consumedId, + tok.status == OneTimeTokenActive = + tok & #status .~ OneTimeTokenRevoked & #revokedAt .~ Just t + | otherwise = tok + replaceUserHash uid h credential + | credential.userId == uid = credential & #passwordHash .~ h + | otherwise = credential + revokeUserSession uid t session + | session.userId == uid, + session.status == SessionActive = + revokeSessionAt t session + | otherwise = session + revokeSessionAt t session = session & #status .~ SessionRevoked & #revokedAt .~ Just t + revokeUserRefreshToken sessions uid t tok = + case Map.lookup tok.sessionId sessions of + Just session + | session.userId == uid -> revokeRefreshTokenAt t tok + _ -> tok + revokeSessionRefreshToken sid t tok + | tok.sessionId == sid = revokeRefreshTokenAt t tok + | otherwise = tok + revokeRefreshTokenAt t tok = tok & #status .~ RefreshTokenRevoked & #revokedAt .~ Just t + +runVerificationTokenStore :: (IOE :> es) => IORef World -> Eff (VerificationTokenStore : es) a -> Eff es a +runVerificationTokenStore ref = interpret_ \case + CreateVerificationToken nvt -> do + tid <- genVerificationTokenId + let tok = mkVerificationToken tid nvt + liftIO + ( modifyWorld + ref + ( (#verificationTokens %~ Map.insert tid tok) + . (#verificationByHash %~ Map.insert nvt.tokenHash tid) + ) + ) + pure tok + FindVerificationTokenByHash h -> + liftIO (lookupVerification h <$> readIORef ref) + MarkVerificationTokenConsumed tid t -> + liftIO + ( casWorld ref \w -> case Map.lookup tid w.verificationTokens of + Just tok + | tok.status == OneTimeTokenActive -> + Just (w & #verificationTokens %~ Map.adjust (consume t) tid) + _ -> Nothing + ) + RevokeUserVerificationTokens uid t -> + liftIO + ( modifyWorld + ref + (#verificationTokens %~ Map.map (\tok -> if tok.userId == uid && tok.status == OneTimeTokenActive then revoke t tok else tok)) + ) + where + lookupVerification h w = do + tid <- Map.lookup h w.verificationByHash + Map.lookup tid w.verificationTokens + consume t tok = tok & #status .~ OneTimeTokenConsumed & #consumedAt .~ Just t + revoke t tok = tok & #status .~ OneTimeTokenRevoked & #revokedAt .~ Just t + +mkVerificationToken :: VerificationTokenId -> NewVerificationToken -> PersistedVerificationToken +mkVerificationToken tid nvt = + PersistedVerificationToken + { verificationTokenId = tid, + userId = nvt.userId, + tokenHash = nvt.tokenHash, + status = OneTimeTokenActive, + createdAt = nvt.createdAt, + expiresAt = nvt.expiresAt, + consumedAt = Nothing, + revokedAt = Nothing + } + +runPasswordResetTokenStore :: (IOE :> es) => IORef World -> Eff (PasswordResetTokenStore : es) a -> Eff es a +runPasswordResetTokenStore ref = interpret_ \case + CreatePasswordResetToken nrt -> do + tid <- genPasswordResetTokenId + let tok = mkPasswordResetToken tid nrt + liftIO + ( modifyWorld + ref + ( (#passwordResetTokens %~ Map.insert tid tok) + . (#passwordResetByHash %~ Map.insert nrt.tokenHash tid) + ) + ) + pure tok + FindPasswordResetTokenByHash h -> + liftIO (lookupReset h <$> readIORef ref) + MarkPasswordResetTokenConsumed tid t -> + liftIO + ( casWorld ref \w -> case Map.lookup tid w.passwordResetTokens of + Just tok + | tok.status == OneTimeTokenActive -> + Just (w & #passwordResetTokens %~ Map.adjust (consume t) tid) + _ -> Nothing + ) + RevokeUserPasswordResetTokens uid t -> + liftIO + ( modifyWorld + ref + (#passwordResetTokens %~ Map.map (\tok -> if tok.userId == uid && tok.status == OneTimeTokenActive then revoke t tok else tok)) + ) + where + lookupReset h w = do + tid <- Map.lookup h w.passwordResetByHash + Map.lookup tid w.passwordResetTokens + consume t tok = tok & #status .~ OneTimeTokenConsumed & #consumedAt .~ Just t + revoke t tok = tok & #status .~ OneTimeTokenRevoked & #revokedAt .~ Just t + +mkPasswordResetToken :: PasswordResetTokenId -> NewPasswordResetToken -> PersistedPasswordResetToken +mkPasswordResetToken tid nrt = + PersistedPasswordResetToken + { passwordResetTokenId = tid, + userId = nrt.userId, + tokenHash = nrt.tokenHash, + status = OneTimeTokenActive, + createdAt = nrt.createdAt, + expiresAt = nrt.expiresAt, + consumedAt = Nothing, + revokedAt = Nothing + } + +runLoginAttemptStore :: (IOE :> es) => IORef World -> Eff (LoginAttemptStore : es) a -> Eff es a +runLoginAttemptStore ref = interpret_ \case + RecordLoginFailure na cutoff policy -> do + aid <- genLoginAttemptId + liftIO + ( atomicModifyIORef' ref \w -> + let attempted = w & #loginAttempts %~ (toAttempt aid na :) + failures = countAccountFailures na.accountKey cutoff attempted + prior = Map.lookup na.accountKey w.accountLockouts + stillLocked = maybe False (maybe False (> na.occurredAt) . (.lockedUntil)) prior + shouldLock = case policy of + Just p -> failures >= p.maxFailures && not stillLocked + Nothing -> False + next = case policy of + Just p + | shouldLock -> + attempted + & #accountLockouts + %~ Map.insert + na.accountKey + (AccountLockout na.accountKey failures (Just p.lockUntil) na.occurredAt) + _ -> attempted + result = + FailureOutcome + { attemptId = aid, + failures, + priorLockout = prior, + lockedNow = shouldLock + } + in (next, result) + ) + ConvertLoginAttemptToSuccess aid -> + liftIO (modifyWorld ref (#loginAttempts %~ fmap (convertAttempt aid))) + DiscardLoginAttempt aid -> + liftIO (modifyWorld ref (#loginAttempts %~ filter ((/= aid) . (.attemptId)))) + CountRecentFailuresByAccount k cutoff -> + liftIO (countAccountFailures k cutoff <$> readIORef ref) + CountRecentFailuresByIp ip cutoff -> + liftIO (countWith (\a -> a.clientIp == ip) cutoff <$> readIORef ref) + GetAccountLockout k -> + liftIO ((Map.lookup k . (.accountLockouts)) <$> readIORef ref) + SetAccountLockout lo -> + liftIO (modifyWorld ref (#accountLockouts %~ Map.insert lo.accountKey lo)) + ClearAccountLockout k -> + liftIO (modifyWorld ref (#accountLockouts %~ Map.delete k)) + where + toAttempt aid na = + LoginAttempt + { attemptId = aid, + accountKey = na.accountKey, + clientIp = na.clientIp, + outcome = na.outcome, + occurredAt = na.occurredAt, + factor = na.factor + } + convertAttempt :: LoginAttemptId -> LoginAttempt -> LoginAttempt + convertAttempt aid attempt@LoginAttempt {attemptId, accountKey, clientIp, occurredAt, factor} + | attemptId == aid = LoginAttempt {attemptId, accountKey, clientIp, outcome = LoginSuccess, occurredAt, factor} + | otherwise = attempt + -- Pure windowed failure count (used for the per-IP throttle). + countWith p cutoff w = + length + [ a | a <- w.loginAttempts, p a, a.outcome == LoginFailure, a.occurredAt >= cutoff + ] + -- Per-account failures within the window AND strictly after the most recent success, + -- so a successful login resets the account's brute-force progress (counter-reset-on-success) + -- while the window still bounds the lookback. + countAccountFailures k cutoff w = + let successes = + [ a.occurredAt | a <- w.loginAttempts, a.accountKey == k, a.outcome == LoginSuccess + ] + lastSuccess = if null successes then Nothing else Just (maximum successes) + afterSuccess a = maybe True (\ls -> a.occurredAt > ls) lastSuccess + in length + [ a + | a <- w.loginAttempts, + a.accountKey == k, + a.outcome == LoginFailure, + a.occurredAt >= cutoff, + afterSuccess a + ] + +-- | Field accessors for the EP-1 passkey records. 'OverloadedRecordDot' is unreliable +-- for these @DuplicateRecordFields@ records (MasterPlan 3 discovery), so read them with +-- plain record-pattern matching instead of @value.field@. +pkUserId :: PasskeyCredential -> UserId +pkUserId PasskeyCredential {userId} = userId + +pkCredentialId :: PasskeyCredential -> WebAuthnCredentialId +pkCredentialId PasskeyCredential {credentialId} = credentialId + +pkUserHandle :: PasskeyCredential -> UserHandle +pkUserHandle PasskeyCredential {userHandle} = userHandle + +pcCeremonyId :: PendingCeremony -> CeremonyId +pcCeremonyId PendingCeremony {ceremonyId} = ceremonyId + +pcExpiresAt :: PendingCeremony -> UTCTime +pcExpiresAt PendingCeremony {expiresAt} = expiresAt + +runPasskeyStore :: (IOE :> es) => IORef World -> Eff (PasskeyStore : es) a -> Eff es a +runPasskeyStore ref = interpret_ \case + CreatePasskey NewPasskeyCredential {userId, credentialId, userHandle, publicKey, signCounter, transports, label, createdAt} -> do + pid <- genPasskeyId + let pc = + PasskeyCredential + { passkeyId = pid, + userId, + credentialId, + userHandle, + publicKey, + signCounter, + transports, + label, + createdAt, + lastUsedAt = Nothing + } + liftIO (modifyWorld ref (#passkeys %~ Map.insert pid pc)) + pure pc + FindPasskeysByUser uid -> + liftIO ((\w -> [p | p <- Map.elems w.passkeys, pkUserId p == uid]) <$> readIORef ref) + FindPasskeyByCredentialId cid -> + liftIO ((\w -> listToMaybe [p | p <- Map.elems w.passkeys, pkCredentialId p == cid]) <$> readIORef ref) + FindPasskeysByUserHandle uh -> + liftIO ((\w -> [p | p <- Map.elems w.passkeys, pkUserHandle p == uh]) <$> readIORef ref) + UpdatePasskeySignCounter pid c@(SignatureCounter next) t -> + liftIO + ( casWorld ref \w -> case Map.lookup pid w.passkeys of + Just p@PasskeyCredential {signCounter = SignatureCounter current} + | current < next || (next == 0 && current == 0) -> + Just (w & #passkeys %~ Map.insert pid (p & #signCounter .~ c & #lastUsedAt .~ Just t)) + _ -> Nothing + ) + DeletePasskey uid pid -> + liftIO (modifyWorld ref (#passkeys %~ Map.update (\p -> if pkUserId p == uid then Nothing else Just p) pid)) + CountPasskeysByUser uid -> + liftIO ((\w -> length [p | p <- Map.elems w.passkeys, pkUserId p == uid]) <$> readIORef ref) + +runPendingCeremonyStore :: (IOE :> es) => IORef World -> Eff (PendingCeremonyStore : es) a -> Eff es a +runPendingCeremonyStore ref = interpret_ \case + PutPendingCeremony pc -> + liftIO (modifyWorld ref (#pendingCeremonies %~ Map.insert (pcCeremonyId pc) pc)) + TakePendingCeremony cid now' -> liftIO do + atomicModifyIORef' ref \w -> case Map.lookup cid w.pendingCeremonies of + Nothing -> (w, Nothing) + Just pc -> + -- Consume-once: remove the row regardless, so an expired take also clears the stale row; + -- return it only if it is still live. + (w & #pendingCeremonies %~ Map.delete cid, if pcExpiresAt pc > now' then Just pc else Nothing) + +-- | Field accessors for the EP-4 service-account records. Both 'ServiceAccount' and +-- 'NewServiceAccount' share field names with several other domain records, so read them with +-- plain record-pattern matching rather than @value.field@ (the same 'DuplicateRecordFields' +-- caution the passkey accessors above document). +saId :: ServiceAccount -> ServiceAccountDbId +saId ServiceAccount {serviceAccountId} = serviceAccountId + +saClientId :: ServiceAccount -> Text +saClientId ServiceAccount {clientId} = clientId + +saCreatedAt :: ServiceAccount -> UTCTime +saCreatedAt ServiceAccount {createdAt} = createdAt + +-- | In-memory interpreter for the EP-4 service-account store. +-- +-- 'RotateServiceAccountSecret' and 'RevokeServiceAccount' are silent no-ops on an unknown id, +-- matching the PostgreSQL @UPDATE … WHERE service_account_id = $1@ that affects zero rows: the +-- CLI resolves the account by client id before mutating, so an unknown id cannot arise from the +-- tested path. +runServiceAccountStore :: (IOE :> es) => IORef World -> Eff (ServiceAccountStore : es) a -> Eff es a +runServiceAccountStore ref = interpret_ \case + CreateServiceAccount NewServiceAccount {serviceAccountId, clientId, userId, secretHash, displayName, allowedScopes, createdAt} -> do + let sa = + ServiceAccount + { serviceAccountId, + clientId, + userId, + secretHash, + displayName, + allowedScopes, + status = ServiceAccountActive, + createdAt, + rotatedAt = Nothing, + revokedAt = Nothing + } + liftIO (modifyWorld ref (#serviceAccounts %~ Map.insert serviceAccountId sa)) + pure sa + FindServiceAccountByClientId cid -> + liftIO ((\w -> listToMaybe [sa | sa <- Map.elems w.serviceAccounts, saClientId sa == cid]) <$> readIORef ref) + ListServiceAccounts -> + liftIO (sortOn (Down . \sa -> (saCreatedAt sa, idText (saId sa))) . Map.elems . (.serviceAccounts) <$> readIORef ref) + RotateServiceAccountSecret sid h t -> + liftIO (modifyWorld ref (#serviceAccounts %~ Map.adjust (\sa -> sa & #secretHash .~ h & #rotatedAt .~ Just t) sid)) + RevokeServiceAccount sid t -> + liftIO + ( modifyWorld + ref + (#serviceAccounts %~ Map.adjust (\sa -> sa & #status .~ ServiceAccountRevoked & #revokedAt .~ Just t) sid) + ) + +-- | Field accessors for the EP-5 OAuth-client records, for the same 'DuplicateRecordFields' +-- reason as the service-account accessors above: 'OAuthClient' shares @clientId@, @status@, +-- @createdAt@, @displayName@, @secretHash@ and @revokedAt@ with 'ServiceAccount'. +ocId :: OAuthClient -> OAuthClientId +ocId OAuthClient {oauthClientId} = oauthClientId + +ocClientId :: OAuthClient -> Text +ocClientId OAuthClient {clientId} = clientId + +ocCreatedAt :: OAuthClient -> UTCTime +ocCreatedAt OAuthClient {createdAt} = createdAt + +-- | In-memory interpreter for the EP-5 OAuth-client store. +-- +-- 'RevokeOAuthClient' is a silent no-op on an unknown id, matching the PostgreSQL +-- @UPDATE … WHERE oauth_client_id = $1@ that affects zero rows. +runOAuthClientStore :: (IOE :> es) => IORef World -> Eff (OAuthClientStore : es) a -> Eff es a +runOAuthClientStore ref = interpret_ \case + CreateOAuthClient NewOAuthClient {oauthClientId, clientId, secretHash, clientType, displayName, redirectUris, allowedScopes, createdAt} -> do + let oc = + OAuthClient + { oauthClientId, + clientId, + secretHash, + clientType, + displayName, + redirectUris, + allowedScopes, + status = OAuthClientActive, + createdAt, + revokedAt = Nothing + } + liftIO (modifyWorld ref (#oauthClients %~ Map.insert oauthClientId oc)) + pure oc + FindOAuthClientByClientId cid -> + liftIO ((\w -> listToMaybe [oc | oc <- Map.elems w.oauthClients, ocClientId oc == cid]) <$> readIORef ref) + ListOAuthClients -> + liftIO (sortOn (Down . \oc -> (ocCreatedAt oc, idText (ocId oc))) . Map.elems . (.oauthClients) <$> readIORef ref) + RevokeOAuthClient cid t -> + liftIO + ( modifyWorld + ref + (#oauthClients %~ Map.adjust (\oc -> oc & #status .~ OAuthClientRevoked & #revokedAt .~ Just t) cid) + ) + +-- | Field accessors for the EP-5 authorization-code records ('AuthorizationCode' shares +-- @clientId@ / @createdAt@ / @expiresAt@ / @userId@ / @scopes@ with several other domain records). +acExpiresAt :: AuthorizationCode -> UTCTime +acExpiresAt AuthorizationCode {expiresAt} = expiresAt + +acConsumedAt :: AuthorizationCode -> Maybe UTCTime +acConsumedAt AuthorizationCode {consumedAt} = consumedAt + +-- | In-memory interpreter for the EP-5 authorization-code store. +-- +-- 'ConsumeAuthorizationCode' is a single 'modifyWorld', which 'atomicModifyIORef'' makes atomic — +-- the in-memory analogue of PostgreSQL's @UPDATE … WHERE consumed_at IS NULL … RETURNING@. Of two +-- racing consumes of one code, exactly one sees an unconsumed row. +runOAuthCodeStore :: (IOE :> es) => IORef World -> Eff (OAuthCodeStore : es) a -> Eff es a +runOAuthCodeStore ref = interpret_ \case + PutAuthorizationCode NewAuthorizationCode {codeHash, clientId, redirectUri, userId, scopes, nonce, codeChallenge, authTime, createdAt, expiresAt} -> do + let code = + AuthorizationCode + { codeHash, + clientId, + redirectUri, + userId, + scopes, + nonce, + codeChallenge, + authTime, + createdAt, + expiresAt, + consumedAt = Nothing, + sessionId = Nothing + } + liftIO (modifyWorld ref (#oauthCodes %~ Map.insert codeHash code)) + ConsumeAuthorizationCode h t -> + liftIO + ( atomicModifyIORef' ref \w -> + case Map.lookup h w.oauthCodes of + Just code + | isNothing (acConsumedAt code), + acExpiresAt code > t -> + -- Set through a generic-lens label: @consumedAt@ is shared with the one-time + -- token records, so a plain record update on it is ambiguous. + let consumed = code & #consumedAt .~ Just t + in (w {oauthCodes = Map.insert h consumed w.oauthCodes}, Just consumed) + -- Unknown, already consumed, or expired: one indistinguishable miss. + _ -> (w, Nothing) + ) + BindAuthorizationCodeSession h sid -> + liftIO + ( modifyWorld + ref + ( #oauthCodes + %~ Map.adjust + (\code -> if isJust (acConsumedAt code) then code & #sessionId .~ Just sid else code) + h + ) + ) + FindConsumedAuthorizationCode h t -> + liftIO do + code <- Map.lookup h . oauthCodes <$> readIORef ref + pure case code of + Just found + | isJust (acConsumedAt found), + acExpiresAt found > t -> + Just found + _ -> Nothing + DeleteExpiredAuthorizationCodes t -> + liftIO (modifyWorld ref (#oauthCodes %~ Map.filter (\c -> acExpiresAt c > t))) + +-- | Field accessors for the EP-7 TOTP records ('TotpCredential' shares @userId@ / @createdAt@ / +-- @secret@ with other domain records; the 'DuplicateRecordFields' caution applies). +tcId :: TotpCredential -> TotpCredentialId +tcId TotpCredential {totpCredentialId} = totpCredentialId + +-- | In-memory interpreter for the EP-7 TOTP credential store. +-- +-- Keyed by user id, so 'UpsertTotpEnrollment' replaces any existing (unconfirmed) row exactly as +-- the PostgreSQL @ON CONFLICT (user_id) DO UPDATE@ does. Raw secrets are held as-is; the +-- encryption boundary is PostgreSQL-only (Decision Log). +runTotpCredentialStore :: (IOE :> es) => IORef World -> Eff (TotpCredentialStore : es) a -> Eff es a +runTotpCredentialStore ref = interpret_ \case + UpsertTotpEnrollment NewTotpCredential {totpCredentialId, userId, secret, createdAt} -> do + let tc = + TotpCredential + { totpCredentialId, + userId, + secret, + lastUsedCounter = Nothing, + confirmedAt = Nothing, + createdAt + } + liftIO (modifyWorld ref (#totpCredentials %~ Map.insert userId tc)) + pure tc + FindTotpByUser uid -> + liftIO ((Map.lookup uid . (.totpCredentials)) <$> readIORef ref) + ConfirmTotp tcid t -> + liftIO (modifyWorld ref (#totpCredentials %~ Map.map (\c -> if tcId c == tcid then c & #confirmedAt .~ Just t else c))) + SetTotpLastUsedCounter tcid c -> + liftIO + ( casWorld ref \w -> + case listToMaybe [(uid, tc) | (uid, tc) <- Map.toList w.totpCredentials, tcId tc == tcid] of + Just (uid, tc@TotpCredential {lastUsedCounter}) + | maybe True (< c) lastUsedCounter -> + Just (w & #totpCredentials %~ Map.insert uid (tc & #lastUsedCounter .~ Just c)) + _ -> Nothing + ) + DeleteTotpByUser uid -> + liftIO (modifyWorld ref (#totpCredentials %~ Map.delete uid)) + +-- | Field accessors for the EP-7 recovery-code records. +rcId :: RecoveryCode -> RecoveryCodeId +rcId RecoveryCode {recoveryCodeId} = recoveryCodeId + +rcUserId :: RecoveryCode -> UserId +rcUserId RecoveryCode {userId} = userId + +rcCodeHash :: RecoveryCode -> Text +rcCodeHash RecoveryCode {codeHash} = codeHash + +rcUsedAt :: RecoveryCode -> Maybe UTCTime +rcUsedAt RecoveryCode {usedAt} = usedAt + +-- | In-memory interpreter for the EP-7 recovery-code store. +-- +-- 'ConsumeRecoveryCode' is a single 'casWorld' (atomic), the in-memory analogue of PostgreSQL's +-- @UPDATE … WHERE used_at IS NULL RETURNING@: of two racing consumes of one code, exactly one +-- sees it unused. 'ReplaceRecoveryCodes' drops the user's whole set and inserts the new one. +runRecoveryCodeStore :: (IOE :> es) => IORef World -> Eff (RecoveryCodeStore : es) a -> Eff es a +runRecoveryCodeStore ref = interpret_ \case + ReplaceRecoveryCodes uid newCodes -> liftIO do + let fresh = + [ ( nc.recoveryCodeId, + RecoveryCode + { recoveryCodeId = nc.recoveryCodeId, + userId = uid, + codeHash = nc.codeHash, + createdAt = nc.createdAt, + usedAt = Nothing + } + ) + | nc <- newCodes + ] + modifyWorld + ref + (#recoveryCodes %~ (\m -> Map.union (Map.fromList fresh) (Map.filter (\rc -> rcUserId rc /= uid) m))) + ConsumeRecoveryCode uid h t -> + liftIO + ( casWorld ref \w -> + case listToMaybe [rc | rc <- Map.elems w.recoveryCodes, rcUserId rc == uid, rcCodeHash rc == h, isNothing (rcUsedAt rc)] of + Just rc -> Just (w & #recoveryCodes %~ Map.adjust (#usedAt .~ Just t) (rcId rc)) + Nothing -> Nothing + ) + CountUnusedRecoveryCodes uid -> + liftIO ((\w -> length [rc | rc <- Map.elems w.recoveryCodes, rcUserId rc == uid, isNothing (rcUsedAt rc)]) <$> readIORef ref) + +runPasswordHasher :: IORef World -> Eff (PasswordHasher : es) a -> Eff es a +runPasswordHasher _ref = interpret_ \case + HashPassword (PlainPassword pw) -> pure (PasswordHash ("argon2-fake:" <> pw)) + VerifyPassword (PlainPassword pw) (PasswordHash h) -> pure (h == "argon2-fake:" <> pw) + -- The fake does no work, so there is none to burn. Only the real Argon2 interpreter needs + -- this operation to cost anything. + VerifyPasswordDummy _ -> pure () + +-- | EP-3 in-memory breach-checker fake: a password is 'Breached' iff its plaintext is in the +-- 'World''s @breachedPasswords@ set; when @breachCheckAvailable@ is False it returns +-- 'BreachCheckUnavailable' so tests can exercise the fail-open/fail-closed policy branches. +runPasswordBreachCheckerFake :: (IOE :> es) => IORef World -> Eff (PasswordBreachChecker : es) a -> Eff es a +runPasswordBreachCheckerFake ref = interpret_ \case + CheckPasswordBreached (PlainPassword pw) -> liftIO do + w <- readIORef ref + pure + if not w.breachCheckAvailable + then BreachCheckUnavailable + else if Set.member pw w.breachedPasswords then Breached else NotBreached + +runTokenSigner :: Eff (TokenSigner : es) a -> Eff es a +runTokenSigner = interpret_ \case + SignAccessToken claims -> pure (AccessToken (renderClaims claims)) + -- The fake ID token is the claims as JSON, as the fake access token is. It does not round-trip + -- through 'runTokenVerifier': nothing verifies an ID token server-side (the client does). + SignIdToken idc -> pure (IdToken (TL.toStrict (TLE.decodeUtf8 (encode (renderIdTokenClaims idc))))) + +-- | The fake ID token's payload: the same claim names the real @jose@ signer emits, so a test can +-- assert on them without a JWT library. +renderIdTokenClaims :: IdTokenClaims -> Value +renderIdTokenClaims idc = + object + ( [ ("iss", Aeson.String (issuerText idc.issuer)), + ("sub", Aeson.String (idText idc.subject)), + ("aud", Aeson.String idc.audience), + ("auth_time", Aeson.toJSON (floor (utcTimeToPOSIXSeconds idc.authTime) :: Integer)) + ] + <> foldMap (\n -> [("nonce", Aeson.String n)]) idc.nonce + ) + where + issuerText (Issuer t) = t + +runTokenVerifier :: Eff (TokenVerifier : es) a -> Eff es a +runTokenVerifier = interpret_ \case + VerifyAccessToken (AccessToken t) -> pure (parseClaims t) + +runAuthEventPublisher :: (IOE :> es) => IORef World -> Eff (AuthEventPublisher : es) a -> Eff es a +runAuthEventPublisher ref = interpret_ \case + PublishAuthEvent ev -> liftIO (modifyWorld ref (#publishedEvents %~ (ev :))) + +-- | In-memory mirror of 'Shomei.Audit.Reader.Postgres.runAuthEventReaderPostgres' over the +-- 'World''s @publishedEvents@ log. Each event is projected with the shared +-- 'Shomei.Audit.Event.Codec.projectAuthEvent' (the same mapping the writer uses) and assigned a +-- synthetic, insertion-ordered @event_id@ so the @(created_at, event_id)@ keyset is stable and +-- monotone with insertion. Filters, newest-first ordering, the @before@ cursor, and the limit +-- clamp all match the SQL interpreter; 'CountAuthEvents' applies the filters only (no +-- cursor/limit), as the SQL @COUNT@ does. +runAuthEventReader :: (IOE :> es) => IORef World -> Eff (AuthEventReader : es) a -> Eff es a +runAuthEventReader ref = interpret_ \case + QueryAuthEvents q -> liftIO (queryRows q <$> readIORef ref) + CountAuthEvents q -> liftIO (length . filterRows q . allRows <$> readIORef ref) + where + -- Oldest-first index → synthetic event_id, so a later insert sorts after an earlier one. + allRows :: World -> [StoredAuthEvent] + allRows w = zipWith toStored [0 ..] (reverse w.publishedEvents) + toStored :: Int -> Event.AuthEvent -> StoredAuthEvent + toStored i ev = + let (uid, sid, etype, payload, occ) = projectAuthEvent ev + in StoredAuthEvent + { storedEventId = UUID.fromWords 0 0 0 (fromIntegral i), + storedEventType = etype, + storedUserId = uid, + storedSessionId = sid, + storedCreatedAt = occ, + storedPayload = payload + } + filterRows :: AuditEventQuery -> [StoredAuthEvent] -> [StoredAuthEvent] + filterRows q = + filter \r -> + maybe True (\u -> r.storedUserId == Just u) q.queryUserId + && maybe True (\s -> r.storedSessionId == Just s) q.querySessionId + && (null q.queryEventTypes || r.storedEventType `elem` q.queryEventTypes) + && maybe True (\s -> r.storedCreatedAt >= s) q.querySince + && maybe True (\u -> r.storedCreatedAt < u) q.queryUntil + queryRows :: AuditEventQuery -> World -> [StoredAuthEvent] + queryRows q w = + let base = filterRows q (allRows w) + afterCursor = case q.queryBefore of + Nothing -> base + Just (AuditCursor t e) -> filter (\r -> (r.storedCreatedAt, r.storedEventId) < (t, e)) base + ordered = sortBy (comparing (Down . sortKey)) afterCursor + in take (clampLimit q.queryLimit) ordered + sortKey r = (r.storedCreatedAt, r.storedEventId) + +runNotifier :: (IOE :> es) => IORef World -> Eff (Notifier : es) a -> Eff es a +runNotifier ref = interpret_ \case + SendNotification n -> liftIO (modifyWorld ref (#sentNotifications %~ (n :))) + +runSigningKeyStore :: (IOE :> es) => IORef World -> Eff (SigningKeyStore : es) a -> Eff es a +runSigningKeyStore ref = interpret_ \case + ListActiveSigningKeys -> + liftIO (activeKeys <$> readIORef ref) + ListPublishableSigningKeys -> + liftIO (publishableKeys <$> readIORef ref) + FindSigningKeyByKid kid -> + liftIO ((Map.lookup kid . (.signingKeys)) <$> readIORef ref) + InsertSigningKey k -> + liftIO (modifyWorld ref (#signingKeys %~ Map.insert k.keyId k)) + UpdateSigningKeyStatus kid st t -> + liftIO (modifyWorld ref (#signingKeys %~ Map.adjust (stampStatus st t) kid)) + ReplaceActiveSigningKey key t -> + liftIO $ modifyWorld ref $ \w -> + let retired = Map.map (retireIfActive t) w.signingKeys + active = key {status = KeyActive, activatedAt = Just t} + in w {signingKeys = Map.insert active.keyId active retired} + where + activeKeys w = [k | k <- Map.elems w.signingKeys, k.status == KeyActive] + publishableKeys w = [k | k <- Map.elems w.signingKeys, k.status `elem` [KeyActive, KeyRetired]] + stampStatus :: SigningKeyStatus -> UTCTime -> StoredSigningKey -> StoredSigningKey + stampStatus st t key = + case st of + KeyActive -> key & #status .~ st & #activatedAt .~ Just t + KeyRetired -> key & #status .~ st & #retiredAt .~ Just t + KeyRevoked -> key & #status .~ st & #revokedAt .~ Just t + KeyPending -> key & #status .~ st + retireIfActive :: UTCTime -> StoredSigningKey -> StoredSigningKey + retireIfActive t key + | key.status == KeyActive = key & #status .~ KeyRetired & #retiredAt .~ Just t + | otherwise = key + +runClock :: (IOE :> es) => IORef World -> Eff (Clock : es) a -> Eff es a +runClock ref = interpret_ \case + Now -> liftIO ((.clock) <$> readIORef ref) + +runTokenGen :: (IOE :> es) => IORef World -> Eff (TokenGen : es) a -> Eff es a +runTokenGen ref = interpret_ \case + GenerateOpaqueToken -> liftIO do + n <- atomicModifyIORef' ref \w -> (w & #tokenCounter %~ (+ 1), w.tokenCounter) + pure (RefreshToken ("rt-" <> Text.pack (show n))) + HashRefreshToken (RefreshToken t) -> pure (RefreshTokenHash ("hash:" <> t)) + -- Deterministic pseudo-random bytes: varied within a call and distinct across calls (the + -- counter advances), so ten recovery codes drawn in a row differ. Never used for real secrecy. + GenerateRandomBytes n -> liftIO do + c <- atomicModifyIORef' ref \w -> (w & #tokenCounter %~ (+ 1), w.tokenCounter) + pure (BS.pack [fromIntegral ((c * 131 + i * 17 + 7) `mod` 256) | i <- [0 .. n - 1]]) + +-- | A deterministic, cryptography-free fake of 'WebAuthnCeremony' for tests +-- (EP-3/EP-4 drive their workflows through this without a real authenticator). +-- +-- The contract a test must follow: +-- +-- * A /begin/ step ('BeginRegistrationCeremony' / 'BeginAuthenticationCeremony') +-- returns a 'BeginCeremony' whose @optionsJson@ is the canned object +-- @{ "challenge": "ceremony-challenge-N" }@ (N from a per-'World' counter) and +-- whose @optionsBlob@ is the UTF-8 'Data.Aeson.encode' of that same object, so the +-- blob and the JSON always agree on the challenge. +-- +-- * To complete, the test crafts a credential 'Value' echoing the blob's challenge +-- plus the credential fields it wants verified — an object with keys +-- @challenge@ (matching the begin step), and base64url-without-padding strings +-- @credentialId@, @userHandle@, @publicKey@. 'CompleteRegistrationCeremony' +-- succeeds with those fields and @signCounter = 0@ when the challenges match, +-- else returns @Left WebAuthnChallengeMismatch@ (or @Left WebAuthnDecodeError@ for +-- malformed JSON). +-- +-- * 'CompleteAuthenticationCeremony' additionally requires the crafted +-- @credentialId@ to equal the @StoredCredentialForVerify@'s; on success it returns +-- @newSignCounter = stored + 1@ and @cloneWarning = False@, on a credential-id +-- mismatch @Left WebAuthnSignatureInvalid@, on a challenge mismatch +-- @Left WebAuthnChallengeMismatch@. +runWebAuthnCeremonyFake :: (IOE :> es) => IORef World -> Eff (WebAuthnCeremony : es) a -> Eff es a +runWebAuthnCeremonyFake ref = interpret_ \case + BeginRegistrationCeremony _userInfo _exclude -> liftIO (mkCannedCeremony ref) + BeginAuthenticationCeremony _userVerification _allow -> liftIO (mkCannedCeremony ref) + CompleteRegistrationCeremony blob credJson -> pure (fakeCompleteRegistration blob credJson) + CompleteAuthenticationCeremony blob stored credJson -> + pure (fakeCompleteAuthentication blob stored credJson) + +-- Build a canned begin result with a deterministic, counter-derived challenge. +mkCannedCeremony :: IORef World -> IO BeginCeremony +mkCannedCeremony ref = do + n <- atomicModifyIORef' ref \w -> (w & #ceremonyCounter %~ (+ 1), w.ceremonyCounter) + let chal = "ceremony-challenge-" <> Text.pack (show n) + optionsJson = object ["challenge" Aeson..= chal] + pure BeginCeremony {optionsJson, optionsBlob = LBS.toStrict (encode optionsJson)} + +-- The challenge baked into a begin step's options blob. +blobChallenge :: ByteString -> Maybe Text +blobChallenge blob = case eitherDecodeStrict' blob of + Right v -> parseMaybe (withObject "options" (.: "challenge")) v + Left _ -> Nothing + +-- Parse the test-crafted credential JSON into (challenge, credentialId, userHandle, publicKey). +credentialFields :: Value -> Parser (Text, WebAuthnCredentialId, UserHandle, PublicKeyBytes) +credentialFields = withObject "credential" $ \o -> + (,,,) <$> o .: "challenge" <*> o .: "credentialId" <*> o .: "userHandle" <*> o .: "publicKey" + +fakeCompleteRegistration :: ByteString -> Value -> Either WebAuthnError VerifiedRegistration +fakeCompleteRegistration blob credJson = + case parseMaybe credentialFields credJson of + Nothing -> Left (WebAuthnDecodeError "fake: malformed credential JSON") + Just (chal, cid, uh, pk) + | blobChallenge blob == Just chal -> + Right + VerifiedRegistration + { credentialId = cid, + userHandle = uh, + publicKey = pk, + signCounter = SignatureCounter 0, + transports = [] + } + | otherwise -> Left WebAuthnChallengeMismatch + +fakeCompleteAuthentication :: + ByteString -> StoredCredentialForVerify -> Value -> Either WebAuthnError VerifiedAuthentication +fakeCompleteAuthentication blob StoredCredentialForVerify {credentialId = storedCid, signCounter = SignatureCounter n} credJson = + case parseMaybe credentialFields credJson of + Nothing -> Left (WebAuthnDecodeError "fake: malformed credential JSON") + Just (chal, cid, _uh, _pk) + | blobChallenge blob /= Just chal -> Left WebAuthnChallengeMismatch + | storedCid /= cid -> Left WebAuthnSignatureInvalid + | otherwise -> + Right + VerifiedAuthentication + { credentialId = storedCid, + newSignCounter = SignatureCounter (n + 1), + cloneWarning = False + } + +-- | Run an 'Eff' computation that uses every port against a shared in-memory 'World', with no +-- claims enrichment. See 'runInMemoryWith' to supply a host hook. +runInMemory :: IORef World -> Eff InMemoryPorts a -> IO a +runInMemory = runInMemoryWith (\_ _ -> emptyClaimsDelta) + +-- | The effect list 'runInMemory' provides, in the order 'Shomei.Servant.Seam.AppEffects' +-- fixes. (Named so the servant/core test harnesses can restate it without drift.) +type InMemoryPorts = + [ UserStore, + RoleStore, + CredentialStore, + SessionStore, + RefreshTokenStore, + AuthUnitOfWork, + VerificationTokenStore, + PasswordResetTokenStore, + LoginAttemptStore, + PasskeyStore, + PendingCeremonyStore, + ServiceAccountStore, + OAuthClientStore, + OAuthCodeStore, + TotpCredentialStore, + RecoveryCodeStore, + Notifier, + ClaimsEnricher, + WebAuthnCeremony, + PasswordBreachChecker, + PasswordHasher, + TokenSigner, + TokenVerifier, + AuthEventPublisher, + SigningKeyStore, + Clock, + TokenGen, + IOE + ] + +-- | 'runInMemory' with a caller-supplied 'ClaimsEnricher' hook, for tests (and embedding-host +-- experiments) that need to observe what a host delta does to minted claims. +runInMemoryWith :: (UserId -> Set Role -> ClaimsDelta) -> IORef World -> Eff InMemoryPorts a -> IO a +runInMemoryWith enrich ref = + runEff + . runTokenGen ref + . runClock ref + . runSigningKeyStore ref + . runAuthEventPublisher ref + . runTokenVerifier + . runTokenSigner + . runPasswordHasher ref + . runPasswordBreachCheckerFake ref + . runWebAuthnCeremonyFake ref + . runClaimsEnricherPure enrich + . 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 diff --git a/src/Shomei/Time/Store.hs b/src/Shomei/Time/Store.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Time/Store.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The clock port: the current wall-clock time. Abstracting it lets tests fix or +-- advance time deterministically. +module Shomei.Time.Store + ( Clock (..), + now, + ) +where + +import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) +import Effectful.Dispatch.Dynamic (send) +import Shomei.Prelude + +data Clock :: Effect where + Now :: Clock m UTCTime + +type instance DispatchOf Clock = Dynamic + +now :: (Clock :> es) => Eff es UTCTime +now = send Now diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,67 @@ +module Main (main) where + +import Shomei.Account.Admin.WorkflowSpec qualified +import Shomei.Account.Lifecycle.CostSpec qualified +import Shomei.Account.Password.DomainSpec qualified +import Shomei.Account.Verification.WorkflowSpec qualified +import Shomei.AccountSpec qualified +import Shomei.Audit.Event.CodecSpec qualified +import Shomei.Authorization.Role.WorkflowSpec qualified +import Shomei.BreachSpec qualified +import Shomei.Delegation.WorkflowSpec qualified +import Shomei.LockoutSpec qualified +import Shomei.Mfa.Totp.AlgorithmSpec qualified +import Shomei.Mfa.Totp.StoreSpec qualified +import Shomei.Mfa.WorkflowSpec qualified +import Shomei.OAuth.Authorize.WorkflowSpec qualified +import Shomei.OAuth.Client.WorkflowSpec qualified +import Shomei.OAuth.Revocation.DomainSpec qualified +import Shomei.OAuth.TokenExchange.WorkflowSpec qualified +import Shomei.OAuth.TokenGrant.WorkflowSpec qualified +import Shomei.OAuthClientStoreSpec qualified +import Shomei.OAuthCodeStoreSpec qualified +import Shomei.Passkey.WorkflowSpec qualified +import Shomei.PasskeyStoreSpec qualified +import Shomei.ServiceAccount.ClientCredentials.WorkflowSpec qualified +import Shomei.ServiceAccountStoreSpec qualified +import Shomei.Session.Authentication.ConcurrencySpec qualified +import Shomei.Session.Authentication.TimingSpec qualified +import Shomei.Session.Authentication.WorkflowSpec qualified +import Shomei.WebAuthnCeremonySpec qualified +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain + ( testGroup + "shomei-core-test" + [ Shomei.Session.Authentication.WorkflowSpec.tests, + Shomei.Account.Lifecycle.CostSpec.tests, + Shomei.Mfa.Totp.AlgorithmSpec.tests, + Shomei.Mfa.Totp.StoreSpec.tests, + Shomei.AccountSpec.tests, + Shomei.BreachSpec.tests, + Shomei.Audit.Event.CodecSpec.tests, + Shomei.Account.Password.DomainSpec.tests, + Shomei.LockoutSpec.tests, + Shomei.PasskeyStoreSpec.tests, + Shomei.OAuthClientStoreSpec.tests, + Shomei.OAuthCodeStoreSpec.tests, + Shomei.OAuth.Authorize.WorkflowSpec.tests, + Shomei.OAuth.Client.WorkflowSpec.tests, + Shomei.OAuth.Revocation.DomainSpec.tests, + Shomei.ServiceAccountStoreSpec.tests, + Shomei.WebAuthnCeremonySpec.tests, + Shomei.Mfa.WorkflowSpec.tests, + Shomei.Delegation.WorkflowSpec.tests, + Shomei.Account.Admin.WorkflowSpec.tests, + Shomei.Authorization.Role.WorkflowSpec.tests, + Shomei.Session.Authentication.TimingSpec.tests, + Shomei.Account.Verification.WorkflowSpec.tests, + Shomei.Passkey.WorkflowSpec.tests, + Shomei.ServiceAccount.ClientCredentials.WorkflowSpec.tests, + Shomei.Session.Authentication.ConcurrencySpec.tests, + Shomei.OAuth.TokenExchange.WorkflowSpec.tests, + Shomei.OAuth.TokenGrant.WorkflowSpec.tests + ] + ) diff --git a/test/Shomei/Account/Admin/WorkflowSpec.hs b/test/Shomei/Account/Admin/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Account/Admin/WorkflowSpec.hs @@ -0,0 +1,226 @@ +-- | The audited admin lifecycle workflows (EP-2): status transitions, session revocation, and +-- the actor recorded on every event. +-- +-- These run on the in-memory interpreters, which implement the same semantics as the PostgreSQL +-- ones (@shomei-postgres/test/Main.hs@ pins the SQL side of listing and revocation). +module Shomei.Account.Admin.WorkflowSpec (tests) where + +import Control.Concurrent.Async (mapConcurrently) +import Control.Monad (replicateM) +import Data.IORef (IORef, newIORef, readIORef) +import Data.Time (UTCTime (..), fromGregorian) +import Effectful (Eff) +import Shomei.Account.Admin.Workflow (deleteUser, reinstateUser, revokeOneSession, revokeUserSessions, suspendUser) +import Shomei.Account.Email.Domain (mkEmail) +import Shomei.Account.LoginId.Domain (LoginId, mkLoginId) +import Shomei.Account.Password.Domain (PlainPassword (..)) +import Shomei.Account.User.Domain (User (..), UserStatus (..)) +import Shomei.Account.User.Store (findUserById) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..)) +import Shomei.Config (ShomeiConfig, defaultShomeiConfig) +import Shomei.Error (AuthError (..)) +import Shomei.Id (genSessionId, genUserId) +import Shomei.Session.Authentication.Workflow (LoginResult (..), login, signup) +import Shomei.Session.Command (ClientContext (..), LoginCommand (..), SignupCommand (..)) +import Shomei.Session.Domain (Session (..), SessionStatus (SessionActive)) +import Shomei.Session.Domain qualified as Session +import Shomei.Session.LoginAttempt.Domain (AccountKey (..), ClientIp (..)) +import Shomei.Session.Store (listSessionsForUser) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Shomei.Account.Admin.Workflow" + [ testSuspendFlipsStatusRevokesSessionsAndRecordsActor, + testConcurrentSuspendsAuditOnce, + testStrictTransitions, + testDeleteIsTerminal, + testReinstateRestoresLogin, + testRevokeUserSessionsCountsOnlyActiveOnes, + testRevokeOneSessionRecordsActor, + testMissingTargetsAreNotFound + ] + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +aliceLogin :: LoginId +aliceLogin = either (\e -> error ("bad test login id: " <> show e)) id (mkLoginId "alice@example.com") + +ctx :: ClientContext +ctx = ClientContext {clientIp = ClientIp "1.2.3.4", accountKey = AccountKey "k-alice"} + +signupCmd :: SignupCommand +signupCmd = + SignupCommand + { loginId = aliceLogin, + email = Just (either (\e -> error ("bad test email: " <> show e)) id (mkEmail "alice@example.com")), + password = strongPw, + displayName = Nothing + } + +loginCmd :: LoginCommand +loginCmd = LoginCommand {loginId = aliceLogin, password = strongPw} + +orFail :: (Show e) => Either e a -> Eff es a +orFail = either (\e -> error ("workflow failed: " <> show e)) pure + +withWorld :: (IORef World -> IO a) -> IO a +withWorld k = newIORef (emptyWorld (UTCTime (fromGregorian 2026 1 1) 0)) >>= k + +-- | Suspension does three things at once, and all three are the point: the status flips, the +-- live sessions die, and the audit event names the administrator who did it. A suspension nobody +-- can be held responsible for is not an administrative action. +testSuspendFlipsStatusRevokesSessionsAndRecordsActor :: TestTree +testSuspendFlipsStatusRevokesSessionsAndRecordsActor = + testCase "suspend: status flips, sessions die, the event names the actor" $ withWorld \ref -> do + (targetId, suspended, admin, sessions) <- runInMemory ref do + (user, _) <- orFail =<< signup cfg signupCmd + admin <- genUserId + _ <- orFail =<< suspendUser admin user.userId + after <- findUserById user.userId + sessions <- listSessionsForUser user.userId + pure (user.userId, after, admin, sessions) + fmap (.status) suspended @?= Just UserSuspended + assertBool "no session is left active" (all ((/= SessionActive) . (.status)) sessions) + + published <- (.publishedEvents) <$> readIORef ref + case [d | Event.UserSuspended d <- published] of + [d] -> do + d.actor @?= Just admin + d.userId @?= targetId + other -> assertFailure ("expected exactly one user_suspended event, got " <> show (length other)) + +-- | The status transition itself is the linearization point: exactly one of many administrators +-- may move the same active account to suspended, and only that winner performs the revocation +-- and audit tail. +testConcurrentSuspendsAuditOnce :: TestTree +testConcurrentSuspendsAuditOnce = + testCase "100 concurrent suspends have one winner and one audit event" $ withWorld \ref -> do + signupResult <- runInMemory ref (signup cfg signupCmd) + (user, _) <- either (assertFailure . ("signup failed: " <>) . show) pure signupResult + admins <- runInMemory ref (replicateM 100 genUserId) + results <- mapConcurrently (\admin -> runInMemory ref (suspendUser admin user.userId)) admins + length (filter (== Right ()) results) @?= 1 + length (filter (== Left InvalidUserStatus) results) @?= 99 + published <- (.publishedEvents) <$> readIORef ref + length [() | Event.UserSuspended _ <- published] @?= 1 + +-- | Suspending twice is a 'InvalidUserStatus', not a silent success: two administrators handling +-- one incident must be able to tell which of them changed the state. +testStrictTransitions :: TestTree +testStrictTransitions = + testCase "wrong-state transitions are InvalidUserStatus, never silent" $ withWorld \ref -> do + (doubleSuspend, reinstateActive) <- runInMemory ref do + (user, _) <- orFail =<< signup cfg signupCmd + admin <- genUserId + _ <- orFail =<< suspendUser admin user.userId + doubleSuspend <- suspendUser admin user.userId + _ <- orFail =<< reinstateUser admin user.userId + reinstateActive <- reinstateUser admin user.userId + pure (doubleSuspend, reinstateActive) + doubleSuspend @?= Left InvalidUserStatus + reinstateActive @?= Left InvalidUserStatus + +-- | Soft delete is terminal: a deleted user still exists (the audit trail references them) but +-- accepts no further transition. +testDeleteIsTerminal :: TestTree +testDeleteIsTerminal = + testCase "delete is a soft, terminal state" $ withWorld \ref -> do + (after, redelete, reinstate) <- runInMemory ref do + (user, _) <- orFail =<< signup cfg signupCmd + admin <- genUserId + _ <- orFail =<< deleteUser admin user.userId + after <- findUserById user.userId + redelete <- deleteUser admin user.userId + reinstate <- reinstateUser admin user.userId + pure (after, redelete, reinstate) + fmap (.status) after @?= Just UserDeleted + redelete @?= Left InvalidUserStatus + reinstate @?= Left InvalidUserStatus + +-- | Reinstatement returns the account to service. The old sessions stay revoked — the user logs +-- in again, which is the whole point of having killed them. +testReinstateRestoresLogin :: TestTree +testReinstateRestoresLogin = + testCase "a reinstated user can log in again; the killed sessions stay dead" $ withWorld \ref -> do + (loginWhileSuspended, loginAfterReinstate, oldSessionStatuses) <- runInMemory ref do + (user, _) <- orFail =<< signup cfg signupCmd + admin <- genUserId + _ <- orFail =<< suspendUser admin user.userId + blocked <- login cfg ctx loginCmd + _ <- orFail =<< reinstateUser admin user.userId + allowed <- login cfg ctx loginCmd + sessions <- listSessionsForUser user.userId + -- The signup session, revoked by the suspension, must still be revoked. + pure (blocked, allowed, [s.status | s <- drop 1 sessions]) + -- The workflow says UserNotActive; the HTTP layer collapses it to the generic invalid_login + -- so the API never discloses account state to an unauthenticated caller. + loginWhileSuspended @?= Left UserNotActive + case loginAfterReinstate of + Right (LoginComplete _ _) -> pure () + Right (MfaRequired _) -> assertFailure "unexpected MFA challenge" + Left e -> assertFailure ("a reinstated user must log in, got " <> show e) + assertBool "the pre-suspension session was not resurrected" (all (/= SessionActive) oldSessionStatuses) + +-- | The count is the number of sessions this call actually ended, so an operator reading +-- "revoked 0 sessions" learns something true rather than "revoked 3" about three corpses. +testRevokeUserSessionsCountsOnlyActiveOnes :: TestTree +testRevokeUserSessionsCountsOnlyActiveOnes = + testCase "revokeUserSessions counts only the sessions it ended" $ withWorld \ref -> do + (firstCount, secondCount, admin) <- runInMemory ref do + (user, _) <- orFail =<< signup cfg signupCmd + admin <- genUserId + _ <- orFail =<< login cfg ctx loginCmd -- a second live session + first' <- orFail =<< revokeUserSessions admin user.userId + second' <- orFail =<< revokeUserSessions admin user.userId + pure (first', second', admin) + firstCount @?= 2 + secondCount @?= 0 + + published <- (.publishedEvents) <$> readIORef ref + let adminRevocations = [d | Event.SessionRevoked d <- published, d.revokedBy == Just admin] + length adminRevocations @?= 2 + +testRevokeOneSessionRecordsActor :: TestTree +testRevokeOneSessionRecordsActor = + testCase "revokeOneSession revokes exactly one session and names the actor" $ withWorld \ref -> do + (sessions, admin) <- runInMemory ref do + (user, _) <- orFail =<< signup cfg signupCmd + admin <- genUserId + _ <- orFail =<< login cfg ctx loginCmd + allSessions <- listSessionsForUser user.userId + case allSessions of + (newest : _) -> do + _ <- orFail =<< revokeOneSession admin newest.sessionId + pure () + [] -> error "expected two sessions" + after <- listSessionsForUser user.userId + pure (after, admin) + map (.status) sessions @?= [Session.SessionRevoked, SessionActive] + + published <- (.publishedEvents) <$> readIORef ref + [d.revokedBy | Event.SessionRevoked d <- published] @?= [Just admin] + +testMissingTargetsAreNotFound :: TestTree +testMissingTargetsAreNotFound = + testCase "a target that does not exist is UserNotFound / SessionNotFound" $ withWorld \ref -> do + (suspendMissing, revokeMissing, revokeGhostSession) <- runInMemory ref do + admin <- genUserId + ghost <- genUserId + ghostSession <- genSessionId + suspendMissing <- suspendUser admin ghost + -- revokeUserSessions on an unknown user is not an error: they have no sessions to end. + revokeMissing <- revokeUserSessions admin ghost + revokeGhostSession <- revokeOneSession admin ghostSession + pure (suspendMissing, revokeMissing, revokeGhostSession) + suspendMissing @?= Left UserNotFound + revokeMissing @?= Right 0 + revokeGhostSession @?= Left SessionNotFound diff --git a/test/Shomei/Account/Lifecycle/CostSpec.hs b/test/Shomei/Account/Lifecycle/CostSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Account/Lifecycle/CostSpec.hs @@ -0,0 +1,106 @@ +module Shomei.Account.Lifecycle.CostSpec (tests) where + +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Time (UTCTime (..), fromGregorian) +import Effectful (Eff, IOE, liftIO, (:>)) +import Effectful.Dispatch.Dynamic (interpose, passthrough, send) +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +import Shomei.Account.Lifecycle.Workflow + ( RequestEmailVerification (..), + RequestPasswordReset (..), + requestEmailVerification, + requestPasswordReset, + ) +import Shomei.Account.LoginId.Domain (mkLoginId) +import Shomei.Account.Password.Domain (PlainPassword (..)) +import Shomei.Account.User.Store (UserStore (..)) +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..)) +import Shomei.Config (ShomeiConfig, defaultShomeiConfig) +import Shomei.Error (AuthError) +import Shomei.Session.Authentication.Workflow (signup) +import Shomei.Session.Command (SignupCommand (..)) +import Shomei.Test.InMemory (InMemoryPorts, World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +data Costs = Costs + { userLookups :: !Int, + tokenInserts :: !Int, + enqueues :: !Int, + auditInserts :: !Int + } + deriving stock (Eq, Show) + +tests :: TestTree +tests = + testGroup + "CostSpec" + [ testCase "email-verification hit costs lookup + token + enqueue + audit" do + ref <- seededWorld + measure ref (\w -> Map.size w.verificationTokens) (requestEmailVerification cfg (RequestEmailVerification aliceEmail)) + >>= (@?= Costs 1 1 1 1), + testCase "email-verification miss costs only one lookup" do + ref <- newIORef (emptyWorld fixedTime) + measure ref (\w -> Map.size w.verificationTokens) (requestEmailVerification cfg (RequestEmailVerification aliceEmail)) + >>= (@?= Costs 1 0 0 0), + testCase "password-reset hit costs lookup + token + enqueue + audit" do + ref <- seededWorld + measure ref (\w -> Map.size w.passwordResetTokens) (requestPasswordReset cfg (RequestPasswordReset aliceEmail)) + >>= (@?= Costs 1 1 1 1), + testCase "password-reset miss costs only one lookup" do + ref <- newIORef (emptyWorld fixedTime) + measure ref (\w -> Map.size w.passwordResetTokens) (requestPasswordReset cfg (RequestPasswordReset aliceEmail)) + >>= (@?= Costs 1 0 0 0) + ] + +-- | Pin the deliberate residual between a known and unknown address. Delivery is represented by +-- the Notifier port call here; the server interpreter turns that call into a bounded enqueue. +measure :: IORef World -> (World -> Int) -> Eff InMemoryPorts (Either AuthError ()) -> IO Costs +measure worldRef tokenCount action = do + lookups <- newIORef 0 + before <- readIORef worldRef + result <- runInMemory worldRef (countEmailLookups lookups action) + result @?= Right () + after <- readIORef worldRef + lookupCount <- readIORef lookups + pure + Costs + { userLookups = lookupCount, + tokenInserts = tokenCount after - tokenCount before, + enqueues = length after.sentNotifications - length before.sentNotifications, + auditInserts = length after.publishedEvents - length before.publishedEvents + } + +countEmailLookups :: (UserStore :> es, IOE :> es) => IORef Int -> Eff es a -> Eff es a +countEmailLookups countRef = interpose \env -> \case + FindUserByEmail email -> do + liftIO (modifyIORef' countRef (+ 1)) + send (FindUserByEmail email) + operation -> passthrough env operation + +seededWorld :: IO (IORef World) +seededWorld = do + ref <- newIORef (emptyWorld fixedTime) + outcome <- runInMemory ref (signup cfg signupAlice) + case outcome of + Left err -> assertFailure ("seed signup failed: " <> show err) + Right _ -> pure ref + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 8 27) 0 + +aliceEmail :: Email +aliceEmail = either (error . show) id (mkEmail "alice@example.com") + +signupAlice :: SignupCommand +signupAlice = + SignupCommand + { loginId = either (error . show) id (mkLoginId (emailText aliceEmail)), + email = Just aliceEmail, + password = PlainPassword "correct horse battery staple", + displayName = Just "Alice" + } diff --git a/test/Shomei/Account/Password/DomainSpec.hs b/test/Shomei/Account/Password/DomainSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Account/Password/DomainSpec.hs @@ -0,0 +1,57 @@ +module Shomei.Account.Password.DomainSpec (tests) where + +import Shomei.Account.Password.Common.Domain (commonPasswordCount, isCommonPassword) +import Shomei.Account.Password.Domain + ( PasswordContext (..), + PasswordPolicy (..), + PlainPassword (..), + defaultPasswordPolicy, + validatePassword, + ) +import Shomei.Error (PasswordPolicyViolation (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +aliceCtx :: PasswordContext +aliceCtx = PasswordContext {contextEmail = Just "alice@example.com", contextDisplayName = Just "Alice"} + +-- | The default policy (rejectCommonPasswords=True, rejectContextualPasswords=True) but with a +-- small minLength so the length guard does not pre-empt the common/contextual checks under test. +basePolicy :: PasswordPolicy +basePolicy = defaultPasswordPolicy {minLength = 4} + +tests :: TestTree +tests = + testGroup + "Shomei.Account.Password.DomainSpec" + [ testCase "dictionary is non-empty" $ + assertBool "expected a non-empty common-password dictionary" (commonPasswordCount > 0), + testCase "a known common password is detected" $ + isCommonPassword "password" @?= True, + testCase "case and whitespace are normalized" $ + isCommonPassword " PASSWORD " @?= True, + testCase "a strong passphrase is not common" $ + isCommonPassword "correct horse battery staple" @?= False, + testCase "too short" $ + validatePassword defaultPasswordPolicy aliceCtx (PlainPassword "short") + @?= Left (PasswordTooShort defaultPasswordPolicy.minLength), + testCase "common password rejected" $ + validatePassword basePolicy aliceCtx (PlainPassword "password123") + @?= Left PasswordTooCommon, + testCase "email local-part rejected" $ + validatePassword basePolicy aliceCtx (PlainPassword "alice") + @?= Left PasswordResemblesIdentity, + testCase "full email rejected" $ + validatePassword basePolicy aliceCtx (PlainPassword "alice@example.com") + @?= Left PasswordResemblesIdentity, + testCase "display name rejected" $ + validatePassword basePolicy aliceCtx (PlainPassword "Alice") + @?= Left PasswordResemblesIdentity, + testCase "strong unrelated password accepted" $ + validatePassword basePolicy aliceCtx (PlainPassword "correct horse battery staple") + @?= Right (), + testCase "flags off let common and contextual through" $ do + let off = basePolicy {rejectCommonPasswords = False, rejectContextualPasswords = False} + validatePassword off aliceCtx (PlainPassword "password123") @?= Right () + validatePassword off aliceCtx (PlainPassword "alice@example.com") @?= Right () + ] diff --git a/test/Shomei/Account/Verification/WorkflowSpec.hs b/test/Shomei/Account/Verification/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Account/Verification/WorkflowSpec.hs @@ -0,0 +1,195 @@ +-- | @emailVerificationRequired@ used to be a configuration flag that nothing read: an +-- operator could set it and unverified accounts would keep logging in. These tests pin the +-- behavior it now has — token issuance is refused for an account whose email is present but +-- unverified, on every path that mints tokens — and, just as importantly, that the flag off +-- (the default) changes nothing. +module Shomei.Account.Verification.WorkflowSpec (tests) where + +import Data.Aeson (Value, object, (.=)) +import Data.Aeson.Types (parseMaybe, withObject, (.:)) +import Data.IORef (IORef, newIORef, readIORef) +import Data.Text (Text) +import Data.Time (UTCTime (..), fromGregorian) +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +import Shomei.Account.Lifecycle.Workflow + ( ConfirmEmailVerification (..), + RequestEmailVerification (..), + confirmEmailVerification, + requestEmailVerification, + ) +import Shomei.Account.LoginId.Domain (LoginId, loginIdText, 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 (..)) +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..)) +import Shomei.Config (NotifierConfig (..), ShomeiConfig (..), defaultShomeiConfig) +import Shomei.Error (AuthError (EmailNotVerified)) +import Shomei.Mfa.Workflow (beginPasswordlessLogin, completePasswordlessLogin) +import Shomei.Passkey.Domain + ( NewPasskeyCredential (..), + PublicKeyBytes (..), + SignatureCounter (..), + UserHandle (..), + WebAuthnCredentialId (..), + ) +import Shomei.Passkey.Store (createPasskey) +import Shomei.Session.Authentication.Workflow (login, refresh, signup) +import Shomei.Session.Command (ClientContext (..), LoginCommand (..), ProofContext (..), RefreshCommand (..), SignupCommand (..)) +import Shomei.Session.LoginAttempt.Domain (AccountKey (..), ClientIp (..)) +import Shomei.Session.Token.Domain (TokenPair (..)) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "emailVerificationRequired" + [ testCase "an unverified account cannot log in" do + ref <- newIORef (emptyWorld fixedTime) + _ <- expectRight =<< runInMemory ref (signup gatedCfg (signupEmail aliceEmail)) + result <- runInMemory ref (login gatedCfg (ctxFor aliceEmail) (loginEmail aliceEmail strongPw)) + expectBlocked result, + testCase "an unverified account cannot refresh the pair signup handed it" do + -- Signup still issues tokens (changing that would break the response shape), so the + -- gate has to close at the first renewal or the account never expires. + ref <- newIORef (emptyWorld fixedTime) + (_, pair) <- expectRight =<< runInMemory ref (signup gatedCfg (signupEmail aliceEmail)) + result <- runInMemory ref (refresh gatedCfg (RefreshCommand pair.refreshToken)) + expectBlocked result, + testCase "verifying the email unblocks login" do + ref <- newIORef (emptyWorld fixedTime) + _ <- expectRight =<< runInMemory ref (signup gatedCfg (signupEmail aliceEmail)) + _ <- expectRight =<< runInMemory ref (requestEmailVerification gatedCfg (RequestEmailVerification aliceEmail)) + raw <- verificationTokenOf ref + _ <- expectRight =<< runInMemory ref (confirmEmailVerification gatedCfg (ConfirmEmailVerification raw)) + result <- runInMemory ref (login gatedCfg (ctxFor aliceEmail) (loginEmail aliceEmail strongPw)) + _ <- expectRight result + pure (), + testCase "an account with no email is exempt (it could never verify one)" do + ref <- newIORef (emptyWorld fixedTime) + let lid = mkLoginId' "alice" + _ <- expectRight =<< runInMemory ref (signup gatedCfg (signupLoginId lid)) + result <- runInMemory ref (login gatedCfg (ctxForLogin lid) (LoginCommand lid strongPw)) + _ <- expectRight result + pure (), + testCase "with the flag off an unverified account logs in (the default)" do + ref <- newIORef (emptyWorld fixedTime) + _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail)) + result <- runInMemory ref (login cfg (ctxFor aliceEmail) (loginEmail aliceEmail strongPw)) + _ <- expectRight result + pure (), + testCase "passwordless passkey login is gated too" do + ref <- newIORef (emptyWorld fixedTime) + seedUserWithPasskey ref + (cid, opts) <- expectRight =<< runInMemory ref (beginPasswordlessLogin gatedCfg) + chal <- maybe (assertFailure "no challenge in options") pure (challengeOf opts) + result <- runInMemory ref (completePasswordlessLogin gatedCfg proofContext cid (acceptedAssertion chal)) + expectBlocked result + ] + +-- | A gated result must name 'EmailNotVerified' — not the generic 401. Every path that can +-- reach it has already proven account control, so the reason leaks nothing. +expectBlocked :: (Show a) => Either AuthError a -> IO () +expectBlocked = \case + Left EmailNotVerified -> pure () + Left e -> assertFailure ("expected EmailNotVerified, got " <> show e) + Right a -> assertFailure ("expected EmailNotVerified, got a token pair: " <> show a) + +expectRight :: (Show e) => Either e a -> IO a +expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure + +proofContext :: ProofContext +proofContext = ProofContext {clientIp = ClientIp "test-ip", accountKeyOf = AccountKey} + +-- | The raw token from the most recent email-verification notification. +verificationTokenOf :: IORef World -> IO OneTimeToken +verificationTokenOf ref = do + w <- readIORef ref + case w.sentNotifications of + EmailVerificationRequested {token = raw} : _ -> pure raw + _ -> assertFailure "expected an email-verification notification" + +seedUserWithPasskey :: IORef World -> IO () +seedUserWithPasskey ref = do + (user, _) <- expectRight =<< runInMemory ref (signup gatedCfg (signupEmail aliceEmail)) + let User {userId = uid} = user + _ <- + runInMemory + ref + ( createPasskey + NewPasskeyCredential + { userId = uid, + credentialId = seededCredId, + userHandle = seededHandle, + publicKey = seededKey, + signCounter = SignatureCounter 0, + transports = [], + label = Just "Test Key", + createdAt = fixedTime + } + ) + pure () + +acceptedAssertion :: Text -> Value +acceptedAssertion chal = + object + [ "challenge" .= chal, + "credentialId" .= seededCredId, + "userHandle" .= seededHandle, + "publicKey" .= seededKey + ] + +challengeOf :: Value -> Maybe Text +challengeOf = parseMaybe (withObject "options" (\o -> o .: "challenge")) + +seededCredId :: WebAuthnCredentialId +seededCredId = WebAuthnCredentialId "cred-1" + +seededHandle :: UserHandle +seededHandle = UserHandle "uh-1" + +seededKey :: PublicKeyBytes +seededKey = PublicKeyBytes "pk-1" + +-- Fixtures ------------------------------------------------------------------- + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +-- | The same config with the gate switched on. +gatedCfg :: ShomeiConfig +gatedCfg = cfg {notifierConfig = cfg.notifierConfig {emailVerificationRequired = True}} + +aliceEmail :: Email +aliceEmail = mkEmail' "alice@example.com" + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +mkEmail' :: Text -> Email +mkEmail' t = either (\e -> error ("bad test email: " <> show e)) id (mkEmail t) + +mkLoginId' :: Text -> LoginId +mkLoginId' t = either (\e -> error ("bad test login id: " <> show e)) id (mkLoginId t) + +signupEmail :: Email -> SignupCommand +signupEmail e = + SignupCommand {loginId = either (error . show) id (mkLoginId (emailText e)), email = Just e, password = strongPw, displayName = Nothing} + +signupLoginId :: LoginId -> SignupCommand +signupLoginId l = + SignupCommand {loginId = l, email = Nothing, password = strongPw, displayName = Nothing} + +loginEmail :: Email -> PlainPassword -> LoginCommand +loginEmail e pw = LoginCommand {loginId = either (error . show) id (mkLoginId (emailText e)), password = pw} + +ctxForLogin :: LoginId -> ClientContext +ctxForLogin l = ClientContext (ClientIp "test-ip") (AccountKey (loginIdText l)) + +ctxFor :: Email -> ClientContext +ctxFor email = ctxForLogin (either (error . show) id (mkLoginId (emailText email))) diff --git a/test/Shomei/AccountSpec.hs b/test/Shomei/AccountSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/AccountSpec.hs @@ -0,0 +1,382 @@ +module Shomei.AccountSpec (tests) where + +import Control.Monad (replicateM_) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Time (UTCTime (..), fromGregorian) +import Shomei.Account.Credential.Domain (Credential (..)) +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +import Shomei.Account.Lifecycle.Workflow + ( ChangePassword (..), + ConfirmEmailVerification (..), + ConfirmPasswordReset (..), + RequestEmailVerification (..), + RequestPasswordReset (..), + changePassword, + confirmEmailVerification, + confirmPasswordReset, + requestEmailVerification, + requestPasswordReset, + ) +import Shomei.Account.LoginId.Domain (LoginId, mkLoginId) +import Shomei.Account.Notification.Domain (Notification (..)) +import Shomei.Account.OneTimeToken.Domain (OneTimeToken (..), OneTimeTokenHash (..), OneTimeTokenStatus (..)) +import Shomei.Account.Password.Domain (PasswordHash (..), PasswordPolicy (..), PlainPassword (..)) +import Shomei.Account.PasswordReset.Domain (PersistedPasswordResetToken (..)) +import Shomei.Account.User.Domain (User (..)) +import Shomei.Account.Verification.Domain (PersistedVerificationToken (..)) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..)) +import Shomei.Config (ShomeiConfig (..), defaultShomeiConfig) +import Shomei.Error + ( AuthError (InvalidCredentials, PasswordResetTokenInvalid, VerificationTokenInvalid, WeakPassword), + PasswordPolicyViolation (PasswordBreached, PasswordResemblesIdentity, PasswordTooCommon), + ) +import Shomei.Session.Authentication.Workflow (login, signup) +import Shomei.Session.Command (ClientContext (..), LoginCommand (..), ProofContext (..), SignupCommand (..)) +import Shomei.Session.Domain (Session (..), SessionStatus (..)) +import Shomei.Session.LoginAttempt.Domain (AccountKey (..), AttemptFactor (..), ClientIp (..), LoginAttempt (..), LoginOutcome (..)) +import Shomei.Session.RefreshToken.Domain (PersistedRefreshToken (..), RefreshTokenStatus (..)) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +aliceEmail :: Email +aliceEmail = mkEmail' "alice@example.com" + +unknownEmail :: Email +unknownEmail = mkEmail' "nobody@example.com" + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +newPw :: PlainPassword +newPw = PlainPassword "correct horse battery staple two" + +wrongPw :: PlainPassword +wrongPw = PlainPassword "totally the wrong password" + +proofContext :: ProofContext +proofContext = ProofContext {clientIp = ClientIp "test-ip", accountKeyOf = AccountKey} + +mkEmail' :: Text -> Email +mkEmail' t = case mkEmail t of + Right e -> e + Left err -> error ("bad test email: " <> show err) + +-- | An email-first signup command: login id defaults to the email text, email carried through. +signupEmail :: Email -> PlainPassword -> Maybe Text -> SignupCommand +signupEmail e pw dn = + SignupCommand {loginId = either (error . show) id (mkLoginId (emailText e)), email = Just e, password = pw, displayName = dn} + +-- | An email-first login command keyed on the email-derived login id. +loginEmail :: Email -> PlainPassword -> LoginCommand +loginEmail e pw = LoginCommand {loginId = either (error . show) id (mkLoginId (emailText e)), password = pw} + +expectRight :: (Show e) => Either e a -> IO a +expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure + +tests :: TestTree +tests = + testGroup + "Shomei.Account" + [ testRequestEmailVerification, + testConfirmEmailVerification, + testRejectConsumedVerification, + testVerificationRevokesSiblingTokens, + testUnknownPasswordResetSuccess, + testUnknownPasswordResetNoNotification, + testPasswordResetDeliversToEmail, + testConfirmPasswordReset, + testRejectConsumedReset, + testPasswordResetRevokesSiblingTokens, + testChangePasswordWrongCurrent, + testChangePasswordFailuresLock, + testChangePasswordRejectsCommon, + testChangePasswordRejectsIdentity, + testConfirmResetRejectsCommon, + testSignupRejectsBreached, + testSignupAcceptsCleanWhenEnabled, + testSignupAllowsBreachedWhenDisabled, + testSignupFailOpen, + testSignupFailClosed, + testChangePasswordRejectsBreached, + testConfirmResetRejectsBreached + ] + +-- EP-3 breach-check fixtures. The pure validation runs first, so the password used in these +-- tests ('strongPw'/'newPw') must clear the length/common/contextual checks and be rejected +-- only by the breach guard. The in-memory fake treats a plaintext as breached iff it is in the +-- World's 'breachedPasswords' set, and reports 'BreachCheckUnavailable' when +-- 'breachCheckAvailable' is False. + +breachCfg :: ShomeiConfig +breachCfg = cfg {passwordPolicy = cfg.passwordPolicy {breachCheckEnabled = True}} + +breachCfgFailClosed :: ShomeiConfig +breachCfgFailClosed = + cfg {passwordPolicy = cfg.passwordPolicy {breachCheckEnabled = True, breachCheckFailClosed = True}} + +seedBreached :: IORef World -> PlainPassword -> IO () +seedBreached ref (PlainPassword pw) = + modifyIORef' ref (\w -> w {breachedPasswords = Set.insert pw w.breachedPasswords}) + +markBreachCheckUnavailable :: IORef World -> IO () +markBreachCheckUnavailable ref = modifyIORef' ref (\w -> w {breachCheckAvailable = False}) + +testSignupRejectsBreached :: TestTree +testSignupRejectsBreached = testCase "signup rejects a breached password when the check is enabled" do + ref <- newIORef (emptyWorld fixedTime) + seedBreached ref strongPw + result <- runInMemory ref (signup breachCfg (signupEmail aliceEmail strongPw Nothing)) + fmap fst result @?= Left (WeakPassword PasswordBreached) + +testSignupAcceptsCleanWhenEnabled :: TestTree +testSignupAcceptsCleanWhenEnabled = testCase "signup accepts a clean password when the check is enabled" do + ref <- newIORef (emptyWorld fixedTime) + result <- runInMemory ref (signup breachCfg (signupEmail aliceEmail strongPw Nothing)) + assertBool "expected Right" (isRightResult result) + +testSignupAllowsBreachedWhenDisabled :: TestTree +testSignupAllowsBreachedWhenDisabled = testCase "signup allows a breached password when the check is disabled (default)" do + ref <- newIORef (emptyWorld fixedTime) + seedBreached ref strongPw + result <- runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + assertBool "expected Right" (isRightResult result) + +testSignupFailOpen :: TestTree +testSignupFailOpen = testCase "fail-open: an unreachable checker allows the password" do + ref <- newIORef (emptyWorld fixedTime) + seedBreached ref strongPw + markBreachCheckUnavailable ref + result <- runInMemory ref (signup breachCfg (signupEmail aliceEmail strongPw Nothing)) + assertBool "expected Right" (isRightResult result) + +testSignupFailClosed :: TestTree +testSignupFailClosed = testCase "fail-closed: an unreachable checker rejects the password" do + ref <- newIORef (emptyWorld fixedTime) + markBreachCheckUnavailable ref + result <- runInMemory ref (signup breachCfgFailClosed (signupEmail aliceEmail strongPw Nothing)) + fmap fst result @?= Left (WeakPassword PasswordBreached) + +testChangePasswordRejectsBreached :: TestTree +testChangePasswordRejectsBreached = testCase "change password rejects a breached new password" do + ref <- newIORef (emptyWorld fixedTime) + (user, _) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + seedBreached ref newPw + result <- runInMemory ref (changePassword breachCfg proofContext (ChangePassword user.userId strongPw newPw)) + result @?= Left (WeakPassword PasswordBreached) + +testConfirmResetRejectsBreached :: TestTree +testConfirmResetRejectsBreached = testCase "confirm password reset rejects a breached new password" do + (ref, _, raw) <- passwordResetRequestedWorld + seedBreached ref newPw + result <- runInMemory ref (confirmPasswordReset breachCfg (ConfirmPasswordReset raw newPw)) + result @?= Left (WeakPassword PasswordBreached) + +isRightResult :: Either e a -> Bool +isRightResult = either (const False) (const True) + +-- | A policy with a small minimum length so identity-derived passwords (e.g. "alice") +-- reach the contextual check instead of failing the default length guard first. +smallMinCfg :: ShomeiConfig +smallMinCfg = cfg {passwordPolicy = cfg.passwordPolicy {minLength = 4}} + +commonPw :: PlainPassword +commonPw = PlainPassword "passwordpassword" -- in the bundled dictionary, length >= 12 + +testChangePasswordRejectsCommon :: TestTree +testChangePasswordRejectsCommon = testCase "change password rejects a common new password" do + ref <- newIORef (emptyWorld fixedTime) + (user, _) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + result <- runInMemory ref (changePassword cfg proofContext (ChangePassword user.userId strongPw commonPw)) + result @?= Left (WeakPassword PasswordTooCommon) + +testChangePasswordRejectsIdentity :: TestTree +testChangePasswordRejectsIdentity = testCase "change password rejects an identity-derived new password" do + ref <- newIORef (emptyWorld fixedTime) + (user, _) <- expectRight =<< runInMemory ref (signup smallMinCfg (signupEmail aliceEmail strongPw Nothing)) + result <- runInMemory ref (changePassword smallMinCfg proofContext (ChangePassword user.userId strongPw (PlainPassword "alice"))) + result @?= Left (WeakPassword PasswordResemblesIdentity) + +testConfirmResetRejectsCommon :: TestTree +testConfirmResetRejectsCommon = testCase "confirm password reset rejects a common new password" do + (ref, _, raw) <- passwordResetRequestedWorld + result <- runInMemory ref (confirmPasswordReset cfg (ConfirmPasswordReset raw commonPw)) + result @?= Left (WeakPassword PasswordTooCommon) + +testRequestEmailVerification :: TestTree +testRequestEmailVerification = testCase "request email verification emits a notification with a token" do + ref <- newIORef (emptyWorld fixedTime) + (user, _) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + result <- runInMemory ref (requestEmailVerification cfg (RequestEmailVerification aliceEmail)) + result @?= Right () + w <- readIORef ref + case w.sentNotifications of + EmailVerificationRequested {token = raw} : _ -> do + assertBool "token is non-empty" (oneTimeRawNonEmpty raw) + Map.size w.verificationTokens @?= 1 + assertBool "stored token hash matches notification token" (Map.member (expectedHash raw) w.verificationByHash) + _ -> assertFailure "expected email-verification notification" + +testConfirmEmailVerification :: TestTree +testConfirmEmailVerification = testCase "confirm email verification flips emailVerifiedAt" do + (ref, raw) <- verificationRequestedWorld + result <- runInMemory ref (confirmEmailVerification cfg (ConfirmEmailVerification raw)) + result @?= Right () + w <- readIORef ref + assertBool "user is marked verified" (any (\u -> u.emailVerifiedAt == Just fixedTime) (Map.elems w.users)) + assertBool "token is consumed" (all (\t -> t.status == OneTimeTokenConsumed) (Map.elems w.verificationTokens)) + +testRejectConsumedVerification :: TestTree +testRejectConsumedVerification = testCase "confirming an already-consumed verification token is rejected" do + (ref, raw) <- verificationRequestedWorld + _ <- expectRight =<< runInMemory ref (confirmEmailVerification cfg (ConfirmEmailVerification raw)) + result <- runInMemory ref (confirmEmailVerification cfg (ConfirmEmailVerification raw)) + result @?= Left VerificationTokenInvalid + +testVerificationRevokesSiblingTokens :: TestTree +testVerificationRevokesSiblingTokens = testCase "confirming email revokes the user's other verification links" do + ref <- newIORef (emptyWorld fixedTime) + _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + _ <- expectRight =<< runInMemory ref (requestEmailVerification cfg (RequestEmailVerification aliceEmail)) + first <- latestVerificationToken =<< readIORef ref + _ <- expectRight =<< runInMemory ref (requestEmailVerification cfg (RequestEmailVerification aliceEmail)) + second <- latestVerificationToken =<< readIORef ref + _ <- expectRight =<< runInMemory ref (confirmEmailVerification cfg (ConfirmEmailVerification first)) + replay <- runInMemory ref (confirmEmailVerification cfg (ConfirmEmailVerification second)) + replay @?= Left VerificationTokenInvalid + w <- readIORef ref + length [() | tok <- Map.elems w.verificationTokens, tok.status == OneTimeTokenConsumed] @?= 1 + length [() | tok <- Map.elems w.verificationTokens, tok.status == OneTimeTokenRevoked] @?= 1 + +testUnknownPasswordResetSuccess :: TestTree +testUnknownPasswordResetSuccess = testCase "request password reset for unknown email still returns success" do + ref <- newIORef (emptyWorld fixedTime) + result <- runInMemory ref (requestPasswordReset cfg (RequestPasswordReset unknownEmail)) + result @?= Right () + +testUnknownPasswordResetNoNotification :: TestTree +testUnknownPasswordResetNoNotification = testCase "request password reset for unknown email emits no notification" do + ref <- newIORef (emptyWorld fixedTime) + _ <- expectRight =<< runInMemory ref (requestPasswordReset cfg (RequestPasswordReset unknownEmail)) + w <- readIORef ref + w.sentNotifications @?= [] + Map.size w.passwordResetTokens @?= 0 + +testPasswordResetDeliversToEmail :: TestTree +testPasswordResetDeliversToEmail = testCase "password reset delivers to the email when present" do + (ref, _, _) <- passwordResetRequestedWorld + w <- readIORef ref + case w.sentNotifications of + PasswordResetRequested {email} : _ -> email @?= aliceEmail + _ -> assertFailure "expected a password-reset notification addressed to the email" + +testConfirmPasswordReset :: TestTree +testConfirmPasswordReset = testCase "confirm password reset changes password and revokes all sessions" do + (ref, user, raw) <- passwordResetRequestedWorld + result <- runInMemory ref (confirmPasswordReset cfg (ConfirmPasswordReset raw newPw)) + result @?= Right () + w <- readIORef ref + assertBool "password hash was updated" (any newHash (Map.elems w.credsByLoginId)) + assertBool "sessions are revoked" (all (\s -> s.userId /= user.userId || s.status == SessionRevoked) (Map.elems w.sessions)) + assertBool "refresh tokens are revoked" (all (\t -> t.status == RefreshTokenRevoked) (Map.elems w.refreshTokens)) + assertBool "reset token is consumed" (all (\t -> t.status == OneTimeTokenConsumed) (Map.elems w.passwordResetTokens)) + assertBool "completion event was published" (any isCompleted w.publishedEvents) + where + newHash c = c.passwordHash == PasswordHash "argon2-fake:correct horse battery staple two" + isCompleted (Event.PasswordResetCompleted _) = True + isCompleted _ = False + +testRejectConsumedReset :: TestTree +testRejectConsumedReset = testCase "confirming an already-consumed reset token is rejected" do + (ref, _, raw) <- passwordResetRequestedWorld + _ <- expectRight =<< runInMemory ref (confirmPasswordReset cfg (ConfirmPasswordReset raw newPw)) + result <- runInMemory ref (confirmPasswordReset cfg (ConfirmPasswordReset raw newPw)) + result @?= Left PasswordResetTokenInvalid + +testPasswordResetRevokesSiblingTokens :: TestTree +testPasswordResetRevokesSiblingTokens = testCase "confirming a reset revokes the user's other reset links" do + ref <- newIORef (emptyWorld fixedTime) + _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + _ <- expectRight =<< runInMemory ref (requestPasswordReset cfg (RequestPasswordReset aliceEmail)) + first <- latestResetToken =<< readIORef ref + _ <- expectRight =<< runInMemory ref (requestPasswordReset cfg (RequestPasswordReset aliceEmail)) + second <- latestResetToken =<< readIORef ref + _ <- expectRight =<< runInMemory ref (confirmPasswordReset cfg (ConfirmPasswordReset first newPw)) + replay <- runInMemory ref (confirmPasswordReset cfg (ConfirmPasswordReset second newPw)) + replay @?= Left PasswordResetTokenInvalid + w <- readIORef ref + length [() | tok <- Map.elems w.passwordResetTokens, tok.status == OneTimeTokenConsumed] @?= 1 + length [() | tok <- Map.elems w.passwordResetTokens, tok.status == OneTimeTokenRevoked] @?= 1 + +testChangePasswordWrongCurrent :: TestTree +testChangePasswordWrongCurrent = testCase "change password with wrong current password is rejected" do + ref <- newIORef (emptyWorld fixedTime) + (user, _) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + result <- runInMemory ref (changePassword cfg proofContext (ChangePassword user.userId wrongPw newPw)) + result @?= Left InvalidCredentials + w <- readIORef ref + assertBool "password hash is unchanged" (all oldHash (Map.elems w.credsByLoginId)) + where + oldHash c = c.passwordHash == PasswordHash "argon2-fake:correct horse battery staple" + +testChangePasswordFailuresLock :: TestTree +testChangePasswordFailuresLock = testCase "five wrong current passwords lock and audit the account" do + ref <- newIORef (emptyWorld fixedTime) + (user, _) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + replicateM_ 5 do + result <- runInMemory ref (changePassword cfg proofContext (ChangePassword user.userId wrongPw newPw)) + result @?= Left InvalidCredentials + denied <- runInMemory ref (login cfg (ClientContext (ClientIp "other-ip") (AccountKey (emailText aliceEmail))) (loginEmail aliceEmail strongPw)) + denied @?= Left InvalidCredentials + w <- readIORef ref + length [() | Event.PasswordChangeFailed _ <- w.publishedEvents] @?= 5 + length + [ () + | attempt <- w.loginAttempts, + attempt.factor == FactorPasswordChange, + attempt.outcome == LoginFailure + ] + @?= 5 + +verificationRequestedWorld :: IO (IORef World, OneTimeToken) +verificationRequestedWorld = do + ref <- newIORef (emptyWorld fixedTime) + (user, _) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + _ <- expectRight =<< runInMemory ref (requestEmailVerification cfg (RequestEmailVerification aliceEmail)) + raw <- latestVerificationToken =<< readIORef ref + pure (ref, raw) + +passwordResetRequestedWorld :: IO (IORef World, User, OneTimeToken) +passwordResetRequestedWorld = do + ref <- newIORef (emptyWorld fixedTime) + (user, _) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + _ <- expectRight =<< runInMemory ref (login cfg (ClientContext (ClientIp "test-ip") (AccountKey "alice")) (loginEmail aliceEmail strongPw)) + _ <- expectRight =<< runInMemory ref (requestPasswordReset cfg (RequestPasswordReset aliceEmail)) + raw <- latestResetToken =<< readIORef ref + pure (ref, user, raw) + +latestVerificationToken :: World -> IO OneTimeToken +latestVerificationToken w = case w.sentNotifications of + EmailVerificationRequested {token = raw} : _ -> pure raw + _ -> assertFailure "expected email-verification notification" + +latestResetToken :: World -> IO OneTimeToken +latestResetToken w = case w.sentNotifications of + PasswordResetRequested {token = raw} : _ -> pure raw + _ -> assertFailure "expected password-reset notification" + +oneTimeRawNonEmpty :: OneTimeToken -> Bool +oneTimeRawNonEmpty raw = expectedHash raw /= OneTimeTokenHash "hash:" + +expectedHash :: OneTimeToken -> OneTimeTokenHash +expectedHash (OneTimeToken t) = OneTimeTokenHash ("hash:" <> t) diff --git a/test/Shomei/Audit/Event/CodecSpec.hs b/test/Shomei/Audit/Event/CodecSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Audit/Event/CodecSpec.hs @@ -0,0 +1,222 @@ +-- | Pure round-trip tests for 'reconstructAuthEvent'. For a representative value of every +-- 'AuthEvent' constructor, assert that @reconstructAuthEvent event_type (toJSON dataRecord)@ +-- returns @Right (Constructor dataRecord)@ — i.e. the read path inverts what the write path +-- ('Shomei.Audit.Publisher.Postgres.projectAuthEvent') stores. This is the primary guard +-- against the @event_type@/payload mapping drifting from the writer. +-- +-- If a new 'AuthEvent' constructor is added, add a case here (and the @event_type@ string is +-- exercised by the writer's mapping). The @allEventTypes@ count assertion catches a missing +-- constructor cheaply. +module Shomei.Audit.Event.CodecSpec (tests) where + +import Data.Aeson (ToJSON, toJSON) +import Data.Aeson qualified as Aeson +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime) +import Data.UUID qualified as UUID +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +import Shomei.Account.LoginId.Domain (LoginId, mkLoginId) +import Shomei.Audit.Event.Codec (reconstructAuthEvent) +import Shomei.Audit.Event.Domain +import Shomei.Authorization.Claims.Domain (Role (..), Scope (..)) +import Shomei.Config (ServiceAccountId (..)) +import Shomei.Id + ( CeremonyId, + PasskeyId, + RefreshTokenId, + SessionId, + UserId, + ceremonyIdFromUUID, + passkeyIdFromUUID, + refreshTokenIdFromUUID, + sessionIdFromUUID, + userIdFromUUID, + ) +import Shomei.Session.LoginAttempt.Domain (AccountKey (..), ClientIp (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +-- Fixtures ------------------------------------------------------------------- + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 6 17) (secondsToDiffTime 0) + +t1 :: UTCTime +t1 = UTCTime (fromGregorian 2026 6 17) (secondsToDiffTime 3600) + +uid :: UserId +uid = userIdFromUUID (UUID.fromWords 0 0 0 1) + +uid2 :: UserId +uid2 = userIdFromUUID (UUID.fromWords 0 0 0 2) + +sid :: SessionId +sid = sessionIdFromUUID (UUID.fromWords 0 0 0 3) + +rtid :: RefreshTokenId +rtid = refreshTokenIdFromUUID (UUID.fromWords 0 0 0 4) + +pkid :: PasskeyId +pkid = passkeyIdFromUUID (UUID.fromWords 0 0 0 5) + +cid :: CeremonyId +cid = ceremonyIdFromUUID (UUID.fromWords 0 0 0 6) + +aliceEmail :: Email +aliceEmail = case mkEmail "alice@example.com" of + Right e -> e + Left err -> error ("bad test email: " <> show err) + +aliceLogin :: LoginId +aliceLogin = either (error . show) id (mkLoginId (emailText aliceEmail)) + +-- | Assert that the event survives @project → toJSON → reconstruct@. +check :: (ToJSON a) => Text -> a -> AuthEvent -> TestTree +check ty dataRecord expected = + testCase (Text.unpack ty) (reconstructAuthEvent ty (toJSON dataRecord) @?= Right expected) + +-- Tests ---------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "Shomei.Audit.Event.Codec" + [ testGroup "round-trips every constructor" roundTrips, + testUnknownType, + testConstructorCount, + testOldLoginFailedDecodes, + testOldSessionRevokedDecodes, + testOldRoleGrantedDecodes + ] + +-- | One assertion per 'AuthEvent' constructor. The @event_type@ strings here MUST match +-- 'Shomei.Audit.Publisher.Postgres.projectAuthEvent' verbatim. +roundTrips :: [TestTree] +roundTrips = + [ let d = UserRegisteredData uid aliceLogin (Just aliceEmail) t0 in check "user_registered" d (UserRegistered d), + let d = LoginSucceededData uid sid t0 in check "login_succeeded" d (LoginSucceeded d), + let d = LoginFailedData (Just (AccountKey "k-alice")) (Just uid) t0 in check "login_failed" d (LoginFailed d), + let d = SessionStartedData sid uid t0 in check "session_started" d (SessionStarted d), + let d = SessionRevokedData sid (Just uid2) t0 in check "session_revoked" d (SessionRevoked d), + let d = RefreshTokenRotatedData sid rtid t0 in check "refresh_token_rotated" d (RefreshTokenRotated d), + let d = RefreshTokenReuseDetectedData sid rtid t0 in check "refresh_token_reuse_detected" d (RefreshTokenReuseDetected d), + let d = EmailVerificationRequestedData uid aliceEmail t0 in check "email_verification_requested" d (EmailVerificationRequested d), + let d = EmailVerifiedData uid aliceEmail t0 in check "email_verified" d (EmailVerified d), + let d = PasswordResetRequestedData uid aliceEmail t0 in check "password_reset_requested" d (PasswordResetRequested d), + let d = PasswordResetCompletedData uid t0 in check "password_reset_completed" d (PasswordResetCompleted d), + let d = PasswordChangedData uid t0 in check "password_changed" d (PasswordChanged d), + let d = PasswordChangeFailedData uid t0 in check "password_change_failed" d (PasswordChangeFailed d), + let d = UserSuspendedData uid (Just uid2) t0 in check "user_suspended" d (UserSuspended d), + let d = UserDeletedData uid (Just uid2) t0 in check "user_deleted" d (UserDeleted d), + let d = UserReinstatedData uid (Just uid2) t0 in check "user_reinstated" d (UserReinstated d), + let d = AccountLockedData (AccountKey "k-abc") (ClientIp "1.2.3.4") 5 t1 t0 in check "account_locked" d (AccountLocked d), + let d = LoginThrottledData (ClientIp "1.2.3.4") 5 t0 in check "login_throttled" d (LoginThrottled d), + let d = PasskeyRegisteredData uid pkid t0 in check "passkey_registered" d (PasskeyRegistered d), + let d = PasskeyRemovedData uid pkid t0 in check "passkey_removed" d (PasskeyRemoved d), + let d = MfaChallengedData uid cid t0 in check "mfa_challenged" d (MfaChallenged d), + let d = MfaSucceededData uid sid t0 in check "mfa_succeeded" d (MfaSucceeded d), + let d = MfaFailedData (Just uid) "bad assertion" t0 in check "mfa_failed" d (MfaFailed d), + -- EP-7 TOTP / recovery-code factor management. + let d = TotpEnrolledData uid t0 in check "totp_enrolled" d (TotpEnrolled d), + let d = TotpRemovedData uid t0 in check "totp_removed" d (TotpRemoved d), + let d = RecoveryCodesGeneratedData uid 10 t0 in check "recovery_codes_generated" d (RecoveryCodesGenerated d), + let d = RecoveryCodeUsedData uid t0 in check "recovery_code_used" d (RecoveryCodeUsed d), + let d = ImpersonationStartedData uid2 uid sid "support ticket" (Just "TICKET-1") (Just "1.2.3.4") t0 in check "impersonation_started" d (ImpersonationStarted d), + let d = ImpersonationStoppedData uid2 uid sid t0 in check "impersonation_stopped" d (ImpersonationStopped d), + let d = ImpersonationActionBlockedData uid2 uid sid "password_change" t0 in check "impersonation_action_blocked" d (ImpersonationActionBlocked d), + let d = ServiceTokenIssuedData uid sid (ServiceAccountId "connector:rei") (Set.singleton (Scope "kawa:ingest")) (Just uid2) t0 in check "service_token_issued" d (ServiceTokenIssued d), + -- EP-6 on-behalf-of: subject (the user) is uid; actor (the service's backing user) is uid2. + let d = ServiceOnBehalfIssuedData "svcacct_01" uid2 uid sid (Set.singleton (Scope "kawa:ingest")) t0 in check "service_on_behalf_issued" d (ServiceOnBehalfIssued d), + -- An HTTP grant records the acting admin; a CLI bootstrap grant / default role records none. + -- EP-9 widened this with @expiresAt@; a time-bound grant round-trips it (a forever grant is + -- 'Nothing', pinned by 'testOldRoleGrantedDecodes'). + let d = RoleGrantedData uid (Role "admin") (Just uid2) (Just t1) t0 in check "role_granted" d (RoleGranted d), + let d = RoleRevokedData uid (Role "admin") Nothing t0 in check "role_revoked" d (RoleRevoked d), + -- EP-4 service-account lifecycle. The payload never carries the secret, only the account's + -- public identifiers and its backing user. + let d = ServiceAccountCreatedData "svcacct_01" "svcacct_01" uid "rei connector" (Set.singleton (Scope "kawa:ingest")) t0 + in check "service_account_created" d (ServiceAccountCreated d), + let d = ServiceAccountSecretRotatedData "svcacct_01" "svcacct_01" uid t0 + in check "service_account_secret_rotated" d (ServiceAccountSecretRotated d), + let d = ServiceAccountRevokedData "svcacct_01" "svcacct_01" uid t0 + in check "service_account_revoked" d (ServiceAccountRevoked d), + -- EP-5 OAuth-client lifecycle. No backing user, so no user id in the payload at all. + let d = OAuthClientCreatedData "oauthclient_01" "oauthclient_01" "confidential" "grafana" ["https://grafana.example.com/callback"] (Set.singleton (Scope "openid")) t0 + in check "oauth_client_created" d (OAuthClientCreated d), + let d = OAuthClientRevokedData "oauthclient_01" "oauthclient_01" t0 + in check "oauth_client_revoked" d (OAuthClientRevoked d), + let d = OAuthCodeIssuedData "oauthclient_01" uid (Set.singleton (Scope "openid")) t0 + in check "oauth_code_issued" d (OAuthCodeIssued d), + let d = OAuthCodeReplayedData "oauthclient_01" "oauthclient_01" uid sid t0 + in check "oauth_code_replayed" d (OAuthCodeReplayed d), + -- EP-8 notifier delivery failure. No principal, so both id columns stay NULL; the token is + -- never in the payload. + let d = NotificationDeliveryFailedData "smtp" "email_verification_requested" "alice@example.com" "Network.Socket.connect: does not exist (Connection refused)" t0 + in check "notification_delivery_failed" d (NotificationDeliveryFailed d) + ] + +-- | An unrecognized @event_type@ is a 'Left', never a crash. +testUnknownType :: TestTree +testUnknownType = + testCase "unknown event_type yields Left" $ + case reconstructAuthEvent "not_a_real_event" (toJSON ()) of + Left _ -> pure () + Right _ -> error "expected Left for unknown event_type" + +-- | Guard: the round-trip list must cover every 'AuthEvent' constructor (currently 42). +testConstructorCount :: TestTree +testConstructorCount = + testCase "covers all 42 AuthEvent constructors" (length roundTrips @?= 42) + +-- | Historical rows contained the submitted login identifier verbatim. The new optional fields +-- deliberately make those rows readable without reproducing that identifier in the typed event. +testOldLoginFailedDecodes :: TestTree +testOldLoginFailedDecodes = + testCase "a legacy login_failed payload decodes without reproducing the raw identifier" $ + reconstructAuthEvent "login_failed" oldPayload + @?= Right (LoginFailed (LoginFailedData Nothing Nothing t0)) + where + oldPayload = + Aeson.object + [ "loginId" Aeson..= ("alice" :: Text), + "occurredAt" Aeson..= t0 + ] + +-- | EP-2 widened 'SessionRevokedData' with @revokedBy@. Rows written before that exist in every +-- deployment's @shomei_auth_events@ (logout, refresh-token reuse, stopping an impersonation all +-- write them), and they carry no such key. Decoding one must still succeed, yielding 'Nothing' — +-- which is precisely what those rows mean: nobody administrative revoked that session. +-- +-- This is the compatibility rule for every future widening of an event payload: add 'Maybe' +-- fields, never required ones. +testOldSessionRevokedDecodes :: TestTree +testOldSessionRevokedDecodes = + testCase "a pre-EP-2 session_revoked payload decodes with revokedBy = Nothing" $ + reconstructAuthEvent "session_revoked" oldPayload @?= Right (SessionRevoked expected) + where + oldPayload = + Aeson.object + [ "sessionId" Aeson..= sid, + "occurredAt" Aeson..= t0 + ] + expected = SessionRevokedData sid Nothing t0 + +-- | EP-9 widened 'RoleGrantedData' with @expiresAt@. Every @role_granted@ row written before EP-9 +-- (CLI bootstrap grants, default-role grants at signup, EP-2 admin grants) carries no such key, +-- and must still decode — to 'Nothing', a grant that does not expire. Same compatibility rule as +-- 'testOldSessionRevokedDecodes': widen only with 'Maybe' fields. +testOldRoleGrantedDecodes :: TestTree +testOldRoleGrantedDecodes = + testCase "a pre-EP-9 role_granted payload decodes with expiresAt = Nothing" $ + reconstructAuthEvent "role_granted" oldPayload @?= Right (RoleGranted expected) + where + oldPayload = + Aeson.object + [ "userId" Aeson..= uid, + "role" Aeson..= Role "admin", + "grantedBy" Aeson..= (Nothing :: Maybe UserId), + "occurredAt" Aeson..= t0 + ] + expected = RoleGrantedData uid (Role "admin") Nothing Nothing t0 diff --git a/test/Shomei/Authorization/Role/WorkflowSpec.hs b/test/Shomei/Authorization/Role/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Authorization/Role/WorkflowSpec.hs @@ -0,0 +1,297 @@ +-- | Roles reaching the token: the grant path, the claims-enrichment hook, and default roles. +module Shomei.Authorization.Role.WorkflowSpec (tests) where + +import Data.Aeson (eitherDecode) +import Data.Aeson.KeyMap qualified as KeyMap +import Data.IORef (newIORef, readIORef) +import Data.Set qualified as Set +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TLE +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Effectful (Eff, IOE, (:>)) +import Shomei.Account.Email.Domain (mkEmail) +import Shomei.Account.LoginId.Domain (LoginId, mkLoginId) +import Shomei.Account.Password.Domain (PlainPassword (..)) +import Shomei.Account.User.Domain (User (..)) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Permission (..), Role (..), Scope (..)) +import Shomei.Authorization.Claims.Store (ClaimsDelta (..), emptyClaimsDelta) +import Shomei.Authorization.Role.Store (allowPermission, defineRole) +import Shomei.Authorization.Role.Workflow (grantRoleTo, revokeRoleFrom, rolesOf, undefinedDefaultRoles) +import Shomei.Config (ShomeiConfig (..), defaultShomeiConfig) +import Shomei.Id (genSessionId) +import Shomei.Prelude +import Shomei.Session.Authentication.Workflow (LoginResult (..), login, refresh, signup) +import Shomei.Session.Command (ClientContext (..), LoginCommand (..), RefreshCommand (..), SignupCommand (..)) +import Shomei.Session.LoginAttempt.Domain (AccountKey (..), ClientIp (..)) +import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..)) +import Shomei.Session.Workflow (buildEnrichedClaims) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory, runInMemoryWith) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Shomei.Authorization.Role.Workflow" + [ testGrantedRoleReachesTheNextToken, + testRefreshPicksUpAGrant, + testRevocationDropsTheRoleOnRefresh, + testEnricherCannotForgeReservedClaims, + testEnricherAddsRolesAndScopes, + testDefaultRolesLandOnTheFirstToken, + testUndefinedDefaultRolesAreReported, + testPermissionUnionReachesTheToken, + testExpiredGrantDropsRoleAndPermissions, + testEnricherRoleContributesPermissions + ] + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +baseCfg :: ShomeiConfig +baseCfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +adminRole, memberRole, betaRole, supportRole, billingRole :: Role +adminRole = Role "admin" +memberRole = Role "member" +betaRole = Role "beta-tester" +supportRole = Role "support" +billingRole = Role "billing" + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +aliceLogin :: LoginId +aliceLogin = either (\e -> error ("bad test login id: " <> show e)) id (mkLoginId "alice@example.com") + +-- | The abuse store plays no part in these tests; one fixed IP and account key throughout. +ctx :: ClientContext +ctx = ClientContext {clientIp = ClientIp "1.2.3.4", accountKey = AccountKey "k-alice"} + +signupCmd :: SignupCommand +signupCmd = + SignupCommand + { loginId = aliceLogin, + email = Just (either (\e -> error ("bad test email: " <> show e)) id (mkEmail "alice@example.com")), + password = strongPw, + displayName = Nothing + } + +loginCmd :: LoginCommand +loginCmd = LoginCommand {loginId = aliceLogin, password = strongPw} + +-- | Unwrap a workflow's @Either AuthError@ inside the effect stack; a 'Left' is a test bug. +orFail :: (Show e) => Either e a -> Eff es a +orFail = either (\e -> error ("workflow failed: " <> show e)) pure + +-- | The access token from a login that must not have demanded a second factor. +completeLogin :: (IOE :> es) => LoginResult -> Eff es AccessToken +completeLogin = \case + LoginComplete _ pair -> pure pair.accessToken + MfaRequired _ -> error "unexpected MFA challenge" + +decodeAccess :: AccessToken -> IO AuthClaims +decodeAccess (AccessToken t) = + either + (\e -> assertFailure ("could not decode access token: " <> e)) + pure + (eitherDecode (TLE.encodeUtf8 (TL.fromStrict t))) + +-- | A granted role does not appear in an already-issued token, but does appear in the next one +-- minted by login. This is the staleness contract stated in @docs/user/security.md@. +testGrantedRoleReachesTheNextToken :: TestTree +testGrantedRoleReachesTheNextToken = + testCase "a role granted after signup appears in the next login's token, not the old one" do + ref <- newIORef (emptyWorld fixedTime) + (before, after, storedRoles) <- runInMemory ref do + (user, firstPair) <- orFail =<< signup baseCfg signupCmd + _ <- orFail =<< grantRoleTo Nothing Nothing user.userId adminRole + after <- completeLogin =<< orFail =<< login baseCfg ctx loginCmd + roles <- orFail =<< rolesOf user.userId + pure (firstPair.accessToken, after, roles) + beforeClaims <- decodeAccess before + afterClaims <- decodeAccess after + beforeClaims.roles @?= Set.empty + afterClaims.roles @?= Set.singleton adminRole + storedRoles @?= Set.singleton adminRole + +-- | @refresh@ re-runs the enrichment, which is why a grant propagates without a fresh login. +testRefreshPicksUpAGrant :: TestTree +testRefreshPicksUpAGrant = + testCase "a role granted after login appears in the token minted by refresh" do + ref <- newIORef (emptyWorld fixedTime) + refreshed <- runInMemory ref do + (user, pair) <- orFail =<< signup baseCfg signupCmd + _ <- orFail =<< grantRoleTo Nothing Nothing user.userId adminRole + newPair <- orFail =<< refresh baseCfg RefreshCommand {refreshToken = pair.refreshToken} + pure newPair.accessToken + claims <- decodeAccess refreshed + claims.roles @?= Set.singleton adminRole + +-- | And the same lever in reverse: revoking then refreshing mints a role-less token. +testRevocationDropsTheRoleOnRefresh :: TestTree +testRevocationDropsTheRoleOnRefresh = + testCase "a role revoked after a grant is gone from the token minted by refresh" do + ref <- newIORef (emptyWorld fixedTime) + refreshed <- runInMemory ref do + (user, pair) <- orFail =<< signup baseCfg signupCmd + _ <- orFail =<< grantRoleTo Nothing Nothing user.userId adminRole + _ <- orFail =<< revokeRoleFrom Nothing user.userId adminRole + newPair <- orFail =<< refresh baseCfg RefreshCommand {refreshToken = pair.refreshToken} + pure newPair.accessToken + claims <- decodeAccess refreshed + claims.roles @?= Set.empty + +-- | The hook's extra-claims object runs through @mkExtraClaims@, so a host cannot override a +-- standard claim through it — not @sub@, not @roles@, not @scopes@. +testEnricherCannotForgeReservedClaims :: TestTree +testEnricherCannotForgeReservedClaims = + testCase "a ClaimsDelta cannot smuggle reserved claim keys into extraClaims" do + ref <- newIORef (emptyWorld fixedTime) + let forged = + KeyMap.fromList + [ ("sub", toJSON ("attacker" :: Text)), + ("roles", toJSON ["admin" :: Text]), + ("scopes", toJSON ["impersonate:user" :: Text]), + ("permissions", toJSON ["billing:write" :: Text]), + ("iss", toJSON ("evil" :: Text)), + ("act", toJSON ("operator" :: Text)), + ("tenant", toJSON ("acme" :: Text)) + ] + -- Named constructor, not a record update: 'extraClaims' lives on both 'ClaimsDelta' + -- and 'AuthClaims', so an update would be ambiguous under DuplicateRecordFields. + hook _ _ = ClaimsDelta {extraRoles = Set.empty, extraScopes = Set.empty, extraClaims = forged} + (claims, realUserId) <- runInMemoryWith hook ref do + (user, _) <- orFail =<< signup baseCfg signupCmd + sid <- genSessionId + c <- buildEnrichedClaims baseCfg user.userId sid fixedTime + pure (c, user.userId) + -- Only the non-reserved key survives, and the standard claims are the real ones. + KeyMap.keys claims.extraClaims @?= ["tenant"] + claims.subject @?= realUserId + claims.issuer @?= baseCfg.issuer + claims.roles @?= Set.empty + claims.scopes @?= Set.empty + claims.permissions @?= Set.empty + claims.actor @?= Nothing + +-- | The hook's roles are unioned with the stored ones; its scopes are the only source of scopes. +testEnricherAddsRolesAndScopes :: TestTree +testEnricherAddsRolesAndScopes = + testCase "a ClaimsDelta's roles union with the store's, and its scopes reach the token" do + ref <- newIORef (emptyWorld fixedTime) + let hook _ _ = + emptyClaimsDelta + { extraRoles = Set.singleton betaRole, + extraScopes = Set.singleton (Scope "reports:read") + } + access <- runInMemoryWith hook ref do + (user, _) <- orFail =<< signup baseCfg signupCmd + _ <- orFail =<< grantRoleTo Nothing Nothing user.userId adminRole + completeLogin =<< orFail =<< login baseCfg ctx loginCmd + claims <- decodeAccess access + claims.roles @?= Set.fromList [adminRole, betaRole] + claims.scopes @?= Set.singleton (Scope "reports:read") + +-- | Default roles are applied inside 'signup', before the first token is minted, and each is +-- audited as a 'Event.RoleGranted' with no acting admin. +testDefaultRolesLandOnTheFirstToken :: TestTree +testDefaultRolesLandOnTheFirstToken = + testCase "signup under defaultRoles mints them on the FIRST token and audits each grant" do + ref <- newIORef (emptyWorld fixedTime) + let cfg = baseCfg {defaultRoles = Set.singleton memberRole} + firstAccess <- runInMemory ref do + _ <- defineRole memberRole (Just "an ordinary user") fixedTime + (_user, pair) <- orFail =<< signup cfg signupCmd + pure pair.accessToken + claims <- decodeAccess firstAccess + claims.roles @?= Set.singleton memberRole + world <- readIORef ref + let grants = [d | Event.RoleGranted d <- world.publishedEvents] + map (.role) grants @?= [memberRole] + -- The bootstrap/system actor: no acting admin, exactly like a CLI grant. + map (.grantedBy) grants @?= [Nothing] + +-- | The @permissions@ claim (EP-9) is the deduplicated union of the granted roles' catalog +-- permissions — the whole point of the indirection: a consumer checks @tickets:read@ regardless +-- of which of the user's roles supplies it. +testPermissionUnionReachesTheToken :: TestTree +testPermissionUnionReachesTheToken = + testCase "the permissions claim is the deduplicated union of the granted roles' permissions" do + ref <- newIORef (emptyWorld fixedTime) + access <- runInMemory ref do + (user, _) <- orFail =<< signup baseCfg signupCmd + _ <- defineRole supportRole (Just "support staff") fixedTime + _ <- defineRole billingRole (Just "billing staff") fixedTime + _ <- allowPermission supportRole (Permission "tickets:write") fixedTime + _ <- allowPermission supportRole (Permission "tickets:read") fixedTime + _ <- allowPermission billingRole (Permission "tickets:read") fixedTime -- overlaps support + _ <- allowPermission billingRole (Permission "invoices:read") fixedTime + _ <- orFail =<< grantRoleTo Nothing Nothing user.userId supportRole + _ <- orFail =<< grantRoleTo Nothing Nothing user.userId billingRole + completeLogin =<< orFail =<< login baseCfg ctx loginCmd + claims <- decodeAccess access + claims.roles @?= Set.fromList [supportRole, billingRole] + claims.permissions + @?= Set.fromList [Permission "invoices:read", Permission "tickets:read", Permission "tickets:write"] + +-- | Grant expiry is passive and read-time: a grant whose expiry has passed contributes neither its +-- role nor its permissions to a token minted after the expiry instant, while one minted before it +-- carries both — from the same grant, with nothing fired in between. +testExpiredGrantDropsRoleAndPermissions :: TestTree +testExpiredGrantDropsRoleAndPermissions = + testCase "an expired grant contributes neither its role nor its permissions at mint" do + ref <- newIORef (emptyWorld fixedTime) + let expiry = addUTCTime 3600 fixedTime + afterExpiry = addUTCTime 7200 fixedTime + (live, expired) <- runInMemory ref do + (user, _) <- orFail =<< signup baseCfg signupCmd + _ <- defineRole supportRole (Just "support staff") fixedTime + _ <- allowPermission supportRole (Permission "tickets:write") fixedTime + _ <- orFail =<< grantRoleTo Nothing (Just expiry) user.userId supportRole + sid1 <- genSessionId + live <- buildEnrichedClaims baseCfg user.userId sid1 fixedTime -- before expiry + sid2 <- genSessionId + expired <- buildEnrichedClaims baseCfg user.userId sid2 afterExpiry -- after expiry + pure (live, expired) + live.roles @?= Set.singleton supportRole + live.permissions @?= Set.singleton (Permission "tickets:write") + expired.roles @?= Set.empty + expired.permissions @?= Set.empty + +-- | Permissions are resolved from the /effective/ role set (Decision Log): a role a host injects +-- through its 'ClaimsEnricher' brings its catalog permissions exactly as a granted role would. +testEnricherRoleContributesPermissions :: TestTree +testEnricherRoleContributesPermissions = + testCase "an enricher-added role brings its catalog permissions into the token" do + ref <- newIORef (emptyWorld fixedTime) + let hook _ _ = emptyClaimsDelta {extraRoles = Set.singleton betaRole} + claims <- runInMemoryWith hook ref do + (user, _) <- orFail =<< signup baseCfg signupCmd + _ <- defineRole betaRole (Just "beta cohort") fixedTime + _ <- allowPermission betaRole (Permission "beta:features") fixedTime + sid <- genSessionId + buildEnrichedClaims baseCfg user.userId sid fixedTime + claims.roles @?= Set.singleton betaRole + claims.permissions @?= Set.singleton (Permission "beta:features") + +-- | The boot-time guard: a configured default role missing from the registry is reported. +testUndefinedDefaultRolesAreReported :: TestTree +testUndefinedDefaultRolesAreReported = + testCase "undefinedDefaultRoles names exactly the configured roles absent from the registry" do + ref <- newIORef (emptyWorld fixedTime) + -- 'admin' is seeded by emptyWorld (mirroring the migration); 'member' and 'staff' are not. + let cfg = baseCfg {defaultRoles = Set.fromList [adminRole, memberRole, Role "staff"]} + missing <- runInMemory ref (undefinedDefaultRoles cfg) + missing @?= Set.fromList [memberRole, Role "staff"] + + -- Define one of them and it drops out of the report. + missing' <- runInMemory ref do + _ <- defineRole memberRole Nothing fixedTime + undefinedDefaultRoles cfg + missing' @?= Set.singleton (Role "staff") + + -- An empty config short-circuits without reading the registry at all. + none <- runInMemory ref (undefinedDefaultRoles baseCfg) + assertBool "no defaultRoles means nothing is missing" (Set.null none) diff --git a/test/Shomei/BreachSpec.hs b/test/Shomei/BreachSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/BreachSpec.hs @@ -0,0 +1,39 @@ +module Shomei.BreachSpec (tests) where + +import Data.Text qualified as Text +import Shomei.Account.Password.Breach.Store (parseHibpResponse, sha1PrefixSuffix) +import Shomei.Account.Password.Domain (PlainPassword (..)) +import Shomei.Prelude +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "PasswordBreachChecker pure helpers" + [ testCase "sha1PrefixSuffix of \"password\" has prefix 5BAA6" $ + fst (sha1PrefixSuffix (PlainPassword "password")) @?= "5BAA6", + testCase "sha1PrefixSuffix of \"password\" has the expected 35-char suffix" $ + snd (sha1PrefixSuffix (PlainPassword "password")) + @?= "1E4C9B93F3F0682250B6CF8331B7EE68FD8", + testCase "sha1PrefixSuffix suffix is 35 chars" $ + Text.length (snd (sha1PrefixSuffix (PlainPassword "password"))) @?= 35, + testCase "parseHibpResponse matches a present suffix with count > 0" $ + let (_, suffix) = sha1PrefixSuffix (PlainPassword "password") + body = suffix <> ":12345\r\nDEADBEEF:0\r\n" + in parseHibpResponse body suffix @?= True, + testCase "parseHibpResponse match is case-insensitive on the suffix" $ + let (_, suffix) = sha1PrefixSuffix (PlainPassword "password") + body = Text.toLower suffix <> ":7\r\n" + in parseHibpResponse body suffix @?= True, + testCase "parseHibpResponse ignores count 0 (padding)" $ + parseHibpResponse + "ABCDEF1234567890ABCDEF1234567890ABCDE:0\r\n" + "ABCDEF1234567890ABCDEF1234567890ABCDE" + @?= False, + testCase "parseHibpResponse returns False when suffix absent" $ + parseHibpResponse + "0000000000000000000000000000000000000:9\r\n" + "ABCDEF1234567890ABCDEF1234567890ABCDE" + @?= False + ] diff --git a/test/Shomei/Delegation/WorkflowSpec.hs b/test/Shomei/Delegation/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Delegation/WorkflowSpec.hs @@ -0,0 +1,237 @@ +-- | Behavioral tests for the impersonation token-exchange workflow +-- ('Shomei.Delegation.Workflow'), run entirely through the in-memory interpreter +-- ('Shomei.Test.InMemory.runInMemory'). No cryptography, no database, no network. +-- +-- The in-memory 'Shomei.SigningKey.Signer' fake renders 'AuthClaims' as JSON, so a +-- minted access token decodes straight back to 'AuthClaims' for inspection. +module Shomei.Delegation.WorkflowSpec (tests) where + +import Data.Aeson (eitherDecode) +import Data.IORef (IORef, newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TLE +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +import Shomei.Account.LoginId.Domain (mkLoginId) +import Shomei.Account.Password.Domain (PlainPassword (..)) +import Shomei.Account.User.Domain (User (..), UserStatus (UserActive, UserSuspended)) +import Shomei.Account.User.Store (updateUserStatus) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Scope (..)) +import Shomei.Config (ImpersonationConfig (..), ShomeiConfig (..), defaultShomeiConfig) +import Shomei.Delegation.Workflow (StartImpersonation (..), startImpersonation, stopImpersonation) +import Shomei.Error (AuthError (ImpersonationForbidden, ImpersonationTargetInvalid)) +import Shomei.Id (SessionId, UserId, genUserId) +import Shomei.Session.Authentication.Workflow (signup) +import Shomei.Session.Command (SignupCommand (..)) +import Shomei.Session.Domain (Session (..), SessionStatus (SessionRevoked)) +import Shomei.Session.RefreshToken.Domain (PersistedRefreshToken (..)) +import Shomei.Session.Store (revokeSession) +import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..)) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +-- Fixtures ------------------------------------------------------------------- + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +impScope :: Scope +impScope = cfg.impersonationConfig.impersonateScope + +customerEmail :: Email +customerEmail = mkEmail' "customer@example.com" + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +mkEmail' :: Text -> Email +mkEmail' t = either (\e -> error ("bad test email: " <> show e)) id (mkEmail t) + +expectRight :: (Show e) => Either e a -> IO a +expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure + +-- | Caller (operator) claims with the given scopes, issued at @iat@. The caller need +-- not be a stored user — the workflow only reads scopes/issuedAt/subject from the token. +callerClaims :: UserId -> SessionId -> Set Scope -> UTCTime -> AuthClaims +callerClaims uid sid scs iat = + AuthClaims + { subject = uid, + sessionId = sid, + issuer = cfg.issuer, + audience = cfg.audience, + issuedAt = iat, + expiresAt = addUTCTime 900 iat, + authTime = iat, + scopes = scs, + roles = Set.empty, + permissions = Set.empty, + actor = Nothing, + extraClaims = mempty + } + +-- | Sign up the customer and return their (active) user id. +seedCustomer :: IORef World -> IO UserId +seedCustomer ref = do + (user, _) <- expectRight =<< runInMemory ref (signup cfg (SignupCommand {loginId = either (error . show) id (mkLoginId (emailText customerEmail)), email = Just customerEmail, password = strongPw, displayName = Just "Customer"})) + pure user.userId + +-- | A real, live operator session with caller-selected claims. +operatorClaims :: IORef World -> Set Scope -> UTCTime -> IO AuthClaims +operatorClaims ref scopes issuedAt = do + let email = mkEmail' "operator@example.com" + (operator, pair) <- expectRight =<< runInMemory ref (signup cfg (SignupCommand {loginId = either (error . show) id (mkLoginId (emailText email)), email = Just email, password = strongPw, displayName = Just "Operator"})) + signed <- decodeAccess pair.accessToken + pure (callerClaims operator.userId signed.sessionId scopes issuedAt) + +freshOperator :: IORef World -> IO AuthClaims +freshOperator ref = operatorClaims ref (Set.singleton impScope) fixedTime + +mkStart :: AuthClaims -> UserId -> StartImpersonation +mkStart caller target = + StartImpersonation + { actorClaims = caller, + targetUserId = target, + reason = "Debugging support issue", + ticketId = Just "SUP-1234", + clientIp = Just "203.0.113.7" + } + +-- | Decode the JSON the in-memory signer renders back into 'AuthClaims'. +decodeAccess :: AccessToken -> IO AuthClaims +decodeAccess (AccessToken t) = + either + (\e -> assertFailure ("could not decode access token: " <> e)) + pure + (eitherDecode (TLE.encodeUtf8 (TL.fromStrict t))) + +-- Tests ---------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "Shomei.Delegation.Workflow" + [ testHappyPath, + testMissingScope, + testStaleCaller, + testRevokedCaller, + testSuspendedCaller, + testSelfTarget, + testUnknownTarget, + testInactiveTarget, + testStop + ] + +testHappyPath :: TestTree +testHappyPath = testCase "fresh scoped caller impersonating an active target succeeds" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedCustomer ref + caller <- freshOperator ref + (session, access) <- expectRight =<< runInMemory ref (startImpersonation cfg (mkStart caller target)) + -- the delegated session records the operator as actor + session.actor @?= Just caller.subject + session.userId @?= target + -- the token names the customer as subject and the operator as actor + claims <- decodeAccess access + claims.subject @?= target + claims.actor @?= Just caller.subject + -- no refresh token was minted for the delegated session + world <- readIORef ref + let refsForSession = filter (\PersistedRefreshToken {sessionId = s} -> s == session.sessionId) (Map.elems world.refreshTokens) + assertBool "delegated session has no refresh token" (null refsForSession) + -- an ImpersonationStarted event carrying both ids + the reason was published + assertBool "ImpersonationStarted published" (any (matchesStarted caller.subject target) world.publishedEvents) + where + matchesStarted actorId subj = \case + Event.ImpersonationStarted d -> + d.actorUserId == actorId + && d.subjectUserId == subj + && d.reason == "Debugging support issue" + _ -> False + +testMissingScope :: TestTree +testMissingScope = testCase "caller without the impersonate scope is forbidden" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedCustomer ref + caller <- operatorClaims ref Set.empty fixedTime + res <- runInMemory ref (startImpersonation cfg (mkStart caller target)) + fmap (const ()) res @?= Left ImpersonationForbidden + +testStaleCaller :: TestTree +testStaleCaller = testCase "caller whose token predates the freshness window is forbidden" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedCustomer ref + -- issued one second before the freshness window opens + let stale = addUTCTime (negate (cfg.impersonationConfig.actorFreshnessWindow + 1)) fixedTime + caller <- operatorClaims ref (Set.singleton impScope) stale + res <- runInMemory ref (startImpersonation cfg (mkStart caller target)) + fmap (const ()) res @?= Left ImpersonationForbidden + +testRevokedCaller :: TestTree +testRevokedCaller = testCase "caller with a revoked session is forbidden" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedCustomer ref + caller <- freshOperator ref + runInMemory ref (revokeSession caller.sessionId fixedTime) + res <- runInMemory ref (startImpersonation cfg (mkStart caller target)) + fmap (const ()) res @?= Left ImpersonationForbidden + +testSuspendedCaller :: TestTree +testSuspendedCaller = testCase "suspended caller is forbidden" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedCustomer ref + caller <- freshOperator ref + _ <- runInMemory ref (updateUserStatus caller.subject [UserActive] UserSuspended fixedTime) + res <- runInMemory ref (startImpersonation cfg (mkStart caller target)) + fmap (const ()) res @?= Left ImpersonationForbidden + +testSelfTarget :: TestTree +testSelfTarget = testCase "impersonating yourself is an invalid target" do + ref <- newIORef (emptyWorld fixedTime) + caller <- freshOperator ref + res <- runInMemory ref (startImpersonation cfg (mkStart caller caller.subject)) + fmap (const ()) res @?= Left ImpersonationTargetInvalid + +testUnknownTarget :: TestTree +testUnknownTarget = testCase "unknown target is an invalid target" do + ref <- newIORef (emptyWorld fixedTime) + caller <- freshOperator ref + ghost <- genUserId + res <- runInMemory ref (startImpersonation cfg (mkStart caller ghost)) + fmap (const ()) res @?= Left ImpersonationTargetInvalid + +testInactiveTarget :: TestTree +testInactiveTarget = testCase "suspended target is an invalid target" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedCustomer ref + _ <- runInMemory ref (updateUserStatus target [UserActive] UserSuspended fixedTime) + caller <- freshOperator ref + res <- runInMemory ref (startImpersonation cfg (mkStart caller target)) + fmap (const ()) res @?= Left ImpersonationTargetInvalid + +testStop :: TestTree +testStop = testCase "stopImpersonation revokes the delegated session and audits the stop" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedCustomer ref + caller <- freshOperator ref + (session, access) <- expectRight =<< runInMemory ref (startImpersonation cfg (mkStart caller target)) + delegatedClaims <- decodeAccess access + _ <- expectRight =<< runInMemory ref (stopImpersonation delegatedClaims) + world <- readIORef ref + -- the delegated session is now revoked + case Map.lookup session.sessionId world.sessions of + Just s -> s.status @?= SessionRevoked + Nothing -> assertFailure "delegated session vanished" + assertBool "ImpersonationStopped published" (any (matchesStopped caller.subject target) world.publishedEvents) + where + matchesStopped actorId subj = \case + Event.ImpersonationStopped d -> d.actorUserId == actorId && d.subjectUserId == subj + _ -> False diff --git a/test/Shomei/LockoutSpec.hs b/test/Shomei/LockoutSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/LockoutSpec.hs @@ -0,0 +1,280 @@ +-- | Pure, in-memory tests for the EP-2 brute-force lockout and per-IP failure throttle +-- ('Shomei.Session.Authentication.Workflow.login' abuse protection). Every case runs through +-- 'Shomei.Test.InMemory.runInMemory' with no database or network, and asserts both the +-- returned 'Either' and the resulting lockout state read back from the 'World'. +-- +-- The test config tightens the thresholds (3 failures per account, 5 per IP) so the loops are +-- short; the windowed-counting and cooldown semantics are otherwise the production defaults. +module Shomei.LockoutSpec (tests) where + +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Effectful (Eff, IOE, liftIO, (:>)) +import Effectful.Dispatch.Dynamic (interpose, passthrough, send) +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +import Shomei.Account.LoginId.Domain (LoginId, mkLoginId) +import Shomei.Account.Password.Domain (PlainPassword (..)) +import Shomei.Account.User.Domain (User (..), UserStatus (UserActive, UserSuspended)) +import Shomei.Account.User.Store (updateUserStatus) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..)) +import Shomei.Config (RateLimitConfig (..), ShomeiConfig (..), defaultRateLimitConfig, defaultShomeiConfig) +import Shomei.Error (AuthError (..)) +import Shomei.Session.Authentication.Workflow (login, signup) +import Shomei.Session.Command (ClientContext (..), LoginCommand (..), SignupCommand (..)) +import Shomei.Session.LoginAttempt.Domain (AccountKey (..), AccountLockout (..), ClientIp (..)) +import Shomei.Session.LoginAttempt.Store (LoginAttemptStore (..)) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +-- Fixtures ------------------------------------------------------------------- + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 1 1) 0 + +-- | Tightened thresholds: lock after 3 per-account failures, throttle after 5 per-IP failures. +cfg :: ShomeiConfig +cfg = + (defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")) + { rateLimitConfig = + defaultRateLimitConfig + { maxFailedLoginsPerAccount = 3, + maxFailedLoginsPerIp = 5 + } + } + +ip1, ip2 :: ClientIp +ip1 = ClientIp "10.0.0.1" +ip2 = ClientIp "10.0.0.2" + +aliceEmail :: Email +aliceEmail = mkEmail' "alice@example.com" + +unknownEmail :: Email +unknownEmail = mkEmail' "nobody@example.com" + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +wrongPw :: PlainPassword +wrongPw = PlainPassword "totally the wrong password" + +mkEmail' :: Text -> Email +mkEmail' t = case mkEmail t of + Right e -> e + Left err -> error ("bad test email: " <> show err) + +keyOf :: Email -> AccountKey +keyOf e = AccountKey (emailText e) + +ctxOf :: ClientIp -> Email -> ClientContext +ctxOf ip e = ClientContext ip (keyOf e) + +badLogin :: IORef World -> ClientIp -> Email -> IO (Either AuthError ()) +badLogin ref ip e = fmap (const ()) <$> runInMemory ref (login cfg (ctxOf ip e) (LoginCommand (either (error . show) id (mkLoginId (emailText e))) wrongPw)) + +goodLogin :: IORef World -> ClientIp -> Email -> IO (Either AuthError ()) +goodLogin ref ip e = fmap (const ()) <$> runInMemory ref (login cfg (ctxOf ip e) (LoginCommand (either (error . show) id (mkLoginId (emailText e))) strongPw)) + +advanceClock :: IORef World -> UTCTime -> IO () +advanceClock ref t = modifyIORef' ref (\w -> w {clock = t}) + +seedAlice :: IORef World -> IO () +seedAlice ref = do + r <- runInMemory ref (signup cfg (SignupCommand {loginId = either (error . show) id (mkLoginId (emailText aliceEmail)), email = Just aliceEmail, password = strongPw, displayName = Just "Alice"})) + case r of + Right _ -> pure () + Left e -> assertFailure ("seed signup failed: " <> show e) + +isLocked :: World -> AccountKey -> Bool +isLocked w k = case Map.lookup k w.accountLockouts of + Just lo -> maybe False (> t0) lo.lockedUntil + Nothing -> False + +-- | Record every 'LoginAttemptStore' operation a workflow issues, then forward it unchanged to +-- the in-memory interpreter underneath. +-- +-- 'interpose' replaces the handler of an effect that is already in the stack, for the duration +-- of the wrapped action. Sending the operation again from inside the handler dispatches to the +-- /upstream/ (original) handler rather than recursing, and 'passthrough' forwards the +-- operations this wrapper does not care about. The point is to observe which operations were +-- issued: the in-memory 'ClearAccountLockout' is a @Map.delete@, so a clear of an absent key +-- leaves the 'World' identical to no clear at all and cannot be detected by reading state. +recordAttemptOps :: (LoginAttemptStore :> es, IOE :> es) => IORef [Text] -> Eff es a -> Eff es a +recordAttemptOps traceRef = interpose \env -> \case + ClearAccountLockout k -> do + liftIO (modifyIORef' traceRef ("ClearAccountLockout" :)) + send (ClearAccountLockout k) + op -> passthrough env op + +-- | Run a successful login, returning the 'LoginAttemptStore' operations it issued. +tracedGoodLogin :: IORef World -> ClientIp -> Email -> IO (Either AuthError (), [Text]) +tracedGoodLogin ref ip e = do + traceRef <- newIORef [] + r <- + runInMemory + ref + (recordAttemptOps traceRef (login cfg (ctxOf ip e) (LoginCommand (either (error . show) id (mkLoginId (emailText e))) strongPw))) + ops <- readIORef traceRef + pure (fmap (const ()) r, ops) + +-- Tests ---------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "Shomei.Lockout" + [ testLocksAfterN, + testLockedSameGenericError, + testUnknownAndWrongIndistinguishable, + testUnlockAfterCooldown, + testSuccessClearsCounter, + testPerIpThrottle, + testSuspendedAttemptsCount, + testNoLockoutIssuesNoClear, + testStandingLockoutStillCleared + ] + +-- | The round-trip saving of MasterPlan 6 EP-1 M2: a login on an account with no lockout row +-- must not issue the DELETE at all. Lockouts are rare, so the unconditional clear this +-- replaces cost a wasted database round-trip on virtually every successful login. +testNoLockoutIssuesNoClear :: TestTree +testNoLockoutIssuesNoClear = testCase "a successful login with no standing lockout issues no ClearAccountLockout" do + ref <- newIORef (emptyWorld t0) + seedAlice ref + (ok, ops) <- tracedGoodLogin ref ip1 aliceEmail + ok @?= Right () + assertBool + ("expected no ClearAccountLockout, got: " <> show ops) + (notElem "ClearAccountLockout" ops) + +-- | The other half of the same change: when a lockout row does exist, the clear still happens. +-- Three failures lock alice; advancing past the cooldown lets the correct password through, and +-- that login must delete the (now expired) row exactly as the unconditional version did. +testStandingLockoutStillCleared :: TestTree +testStandingLockoutStillCleared = testCase "a successful login with a standing lockout still issues ClearAccountLockout" do + ref <- newIORef (emptyWorld t0) + seedAlice ref + _ <- badLogin ref ip1 aliceEmail + _ <- badLogin ref ip1 aliceEmail + _ <- badLogin ref ip1 aliceEmail + advanceClock ref (addUTCTime (16 * 60) t0) + (ok, ops) <- tracedGoodLogin ref ip1 aliceEmail + ok @?= Right () + assertBool + ("expected a ClearAccountLockout, got: " <> show ops) + (elem "ClearAccountLockout" ops) + w <- readIORef ref + assertBool "the lockout row is gone" (not (Map.member (keyOf aliceEmail) w.accountLockouts)) + +testLocksAfterN :: TestTree +testLocksAfterN = testCase "account locks after N failed logins" do + ref <- newIORef (emptyWorld t0) + seedAlice ref + r1 <- badLogin ref ip1 aliceEmail + r2 <- badLogin ref ip1 aliceEmail + r3 <- badLogin ref ip1 aliceEmail + r1 @?= Left InvalidCredentials + r2 @?= Left InvalidCredentials + r3 @?= Left InvalidCredentials + w <- readIORef ref + assertBool "alice's account is locked after 3 failures" (isLocked w (keyOf aliceEmail)) + case Map.lookup (keyOf aliceEmail) w.accountLockouts of + Just lo -> lo.lockedUntil @?= Just (addUTCTime (15 * 60) t0) + Nothing -> assertFailure "expected a lockout row for alice" + +testLockedSameGenericError :: TestTree +testLockedSameGenericError = testCase "locked account returns the same generic error (even with correct password)" do + ref <- newIORef (emptyWorld t0) + seedAlice ref + _ <- badLogin ref ip1 aliceEmail + _ <- badLogin ref ip1 aliceEmail + _ <- badLogin ref ip1 aliceEmail + -- Even the CORRECT password is refused while locked, with the identical generic error. + locked <- goodLogin ref ip1 aliceEmail + locked @?= Left InvalidCredentials + +testUnknownAndWrongIndistinguishable :: TestTree +testUnknownAndWrongIndistinguishable = testCase "unknown email and wrong password are indistinguishable and both count toward lockout" do + ref <- newIORef (emptyWorld t0) + seedAlice ref + -- Failures against an email with NO account still lock that key and return the generic error. + u1 <- badLogin ref ip1 unknownEmail + u2 <- badLogin ref ip1 unknownEmail + u3 <- badLogin ref ip1 unknownEmail + u1 @?= Left InvalidCredentials + u3 @?= Left InvalidCredentials + -- A wrong password against the real account returns the identical generic error. + wrong <- badLogin ref ip2 aliceEmail + wrong @?= u2 + w <- readIORef ref + assertBool "the unknown-email key is locked after 3 failures" (isLocked w (keyOf unknownEmail)) + +testUnlockAfterCooldown :: TestTree +testUnlockAfterCooldown = testCase "account unlocks after the cooldown elapses" do + ref <- newIORef (emptyWorld t0) + seedAlice ref + _ <- badLogin ref ip1 aliceEmail + _ <- badLogin ref ip1 aliceEmail + _ <- badLogin ref ip1 aliceEmail + wLocked <- readIORef ref + assertBool "alice is locked immediately after the failures" (isLocked wLocked (keyOf aliceEmail)) + -- Advance the clock past lockedUntil (lockoutDuration default = 15 min) and the window. + advanceClock ref (addUTCTime (16 * 60) t0) + ok <- goodLogin ref ip1 aliceEmail + ok @?= Right () + w <- readIORef ref + assertBool "the lockout row is cleared after a successful login" (not (Map.member (keyOf aliceEmail) w.accountLockouts)) + +testSuccessClearsCounter :: TestTree +testSuccessClearsCounter = testCase "successful login clears the failure counter" do + ref <- newIORef (emptyWorld t0) + seedAlice ref + -- One short of the lock threshold (2 of 3), then a correct login. + _ <- badLogin ref ip1 aliceEmail + _ <- badLogin ref ip1 aliceEmail + ok <- goodLogin ref ip1 aliceEmail + ok @?= Right () + wAfter <- readIORef ref + assertBool "no lockout row after the successful login" (not (Map.member (keyOf aliceEmail) wAfter.accountLockouts)) + length [() | Event.AccountLocked _ <- wAfter.publishedEvents] @?= 0 + -- A subsequent single failure must NOT lock (the success reset the counter). + _ <- badLogin ref ip1 aliceEmail + w <- readIORef ref + assertBool "a single failure after a success does not lock" (not (isLocked w (keyOf aliceEmail))) + +testPerIpThrottle :: TestTree +testPerIpThrottle = testCase "per-IP failure throttle trips across different accounts" do + ref <- newIORef (emptyWorld t0) + -- Fail logins against 5 distinct (unregistered) emails from one IP: 5 failures, none of + -- which individually locks an account, but together they trip the per-IP throttle (5). + let spread = map (\u -> mkEmail' (u <> "@example.com")) ["u1", "u2", "u3", "u4", "u5"] + results <- traverse (badLogin ref ip1) spread + assertBool "the 5 spread failures each return the generic error" (all (== Left InvalidCredentials) results) + -- The next attempt from the SAME IP is throttled. + throttled <- badLogin ref ip1 (mkEmail' "u6@example.com") + throttled @?= Left TooManyRequests + -- The SAME attempt from a DIFFERENT IP returns the ordinary generic error, not 429. + other <- badLogin ref ip2 (mkEmail' "u6@example.com") + other @?= Left InvalidCredentials + +testSuspendedAttemptsCount :: TestTree +testSuspendedAttemptsCount = testCase "attempts against a suspended account count and publish LoginFailed" do + ref <- newIORef (emptyWorld t0) + seedAlice ref + w0 <- readIORef ref + _ <- case Map.elems w0.users of + [user] -> runInMemory ref (updateUserStatus user.userId [UserActive] UserSuspended t0) + users -> assertFailure ("expected one seeded user, got " <> show (length users)) + r1 <- goodLogin ref ip1 aliceEmail + r2 <- goodLogin ref ip1 aliceEmail + r3 <- goodLogin ref ip1 aliceEmail + r1 @?= Left UserNotActive + r2 @?= Left UserNotActive + r3 @?= Left UserNotActive + w <- readIORef ref + assertBool "the suspended account is locked after three attempts" (isLocked w (keyOf aliceEmail)) + length [() | Event.LoginFailed _ <- w.publishedEvents] @?= 3 diff --git a/test/Shomei/Mfa/Totp/AlgorithmSpec.hs b/test/Shomei/Mfa/Totp/AlgorithmSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Mfa/Totp/AlgorithmSpec.hs @@ -0,0 +1,61 @@ +-- | RFC 6238 conformance for "Shomei.Mfa.Totp.Algorithm": the Appendix B vectors, the ±1 acceptance +-- window, the strictly-greater replay rule, and a Base32 round-trip. +module Shomei.Mfa.Totp.AlgorithmSpec (tests) where + +import Data.Text (Text) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Shomei.Mfa.Totp.Algorithm +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +-- | The RFC 6238 Appendix B secret: the 20 ASCII bytes @"12345678901234567890"@. +rfcSecret :: TotpSecret +rfcSecret = TotpSecret "12345678901234567890" + +-- | The 8-digit code the RFC prescribes for a given Unix time. +vectorAt :: Integer -> Text -> TestTree +vectorAt t expected = + testCase ("matches RFC 6238 vector at t=" <> show t) $ + totpCode 8 rfcSecret (totpCounter (posixSecondsToUTCTime (fromIntegral t))) @?= expected + +tests :: TestTree +tests = + testGroup + "Shomei.Mfa.Totp.Algorithm" + [ vectorAt 59 "94287082", + vectorAt 1111111109 "07081804", + vectorAt 1234567890 "89005924", + vectorAt 2000000000 "69279037", + testCase "counter derivation floors to the 30-second step" $ do + totpCounter (posixSecondsToUTCTime 59) @?= 1 + totpCounter (posixSecondsToUTCTime 1234567890) @?= 41152263, + testCase "6-digit code is the 8-digit value mod 10^6" $ + -- 94287082 `mod` 1000000 == 287082 + totpCode 6 rfcSecret 1 @?= "287082", + testCase "accepts a code for the current counter and returns it" $ do + let now = posixSecondsToUTCTime 1234567890 + c = totpCounter now + verifyTotp rfcSecret Nothing now (totpCode 6 rfcSecret c) @?= Just c, + testCase "accepts the previous-step code within the window" $ do + let now = posixSecondsToUTCTime 1234567890 + c = totpCounter now + verifyTotp rfcSecret Nothing now (totpCode 6 rfcSecret (c - 1)) @?= Just (c - 1), + testCase "rejects a code two steps in the past (outside the window)" $ do + let now = posixSecondsToUTCTime 1234567890 + c = totpCounter now + verifyTotp rfcSecret Nothing now (totpCode 6 rfcSecret (c - 2)) @?= Nothing, + testCase "rejects a replayed counter (strictly-greater rule)" $ do + let now = posixSecondsToUTCTime 1234567890 + c = totpCounter now + verifyTotp rfcSecret (Just c) now (totpCode 6 rfcSecret c) @?= Nothing, + testCase "rejects a wrong code" $ do + let now = posixSecondsToUTCTime 1234567890 + verifyTotp rfcSecret Nothing now "000000" @?= Nothing, + testCase "Base32 of the RFC secret is the well-known value" $ + secretToBase32 rfcSecret @?= "GEZDGNBVGY3TQOJQGEZDGNBVGY3TQOJQ", + testCase "Base32 round-trips" $ + assertBool "decode . encode == id" (base32ToSecret (secretToBase32 rfcSecret) == Right rfcSecret), + testCase "otpauth URI carries the Base32 secret and issuer" $ + otpauthUri "shomei" "alice" rfcSecret + @?= "otpauth://totp/shomei:alice?secret=GEZDGNBVGY3TQOJQGEZDGNBVGY3TQOJQ&issuer=shomei" + ] diff --git a/test/Shomei/Mfa/Totp/StoreSpec.hs b/test/Shomei/Mfa/Totp/StoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Mfa/Totp/StoreSpec.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DataKinds #-} + +-- | Pure tests for the in-memory EP-7 stores +-- ('Shomei.Test.InMemory.runTotpCredentialStore' and 'runRecoveryCodeStore'), proving the +-- persistence contract the TOTP workflows build on against the fake 'World'. The same behavior +-- is re-proven against real PostgreSQL by @shomei-postgres@'s integration test (including the +-- AES-256-GCM round-trip, which the in-memory interpreter does not exercise). +module Shomei.Mfa.Totp.StoreSpec (tests) where + +import Data.IORef (IORef, newIORef) +import Data.Int (Int64) +import Data.Maybe (isJust) +import Data.Time (UTCTime (..), fromGregorian) +import Shomei.Id (genRecoveryCodeId, genTotpCredentialId, genUserId) +import Shomei.Mfa.RecoveryCode.Store + ( consumeRecoveryCode, + countUnusedRecoveryCodes, + replaceRecoveryCodes, + ) +import Shomei.Mfa.Totp.Algorithm (TotpSecret (..)) +import Shomei.Mfa.Totp.Domain (NewRecoveryCode (..), NewTotpCredential (..), TotpCredential (..)) +import Shomei.Mfa.Totp.Store + ( confirmTotp, + deleteTotpByUser, + findTotpByUser, + setTotpLastUsedCounter, + upsertTotpEnrollment, + ) +import Shomei.Test.InMemory (World, emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 7 10) 0 + +newWorld :: IO (IORef World) +newWorld = newIORef (emptyWorld t0) + +rawSecret :: TotpSecret +rawSecret = TotpSecret "12345678901234567890" + +tcConfirmedAt :: TotpCredential -> Maybe UTCTime +tcConfirmedAt TotpCredential {confirmedAt} = confirmedAt + +tcLastUsedCounter :: TotpCredential -> Maybe Int64 +tcLastUsedCounter TotpCredential {lastUsedCounter} = lastUsedCounter + +tcSecret :: TotpCredential -> TotpSecret +tcSecret TotpCredential {secret} = secret + +tests :: TestTree +tests = + testGroup + "TOTP + recovery-code stores (in-memory)" + [ testCase "totp: enroll, find, confirm, counter, delete" totpRoundTrip, + testCase "totp: re-enroll replaces the unconfirmed row" totpReenrollReplaces, + testCase "recovery: replace-set, consume-once, count drops, regenerate replaces" recoveryCas + ] + +totpRoundTrip :: IO () +totpRoundTrip = do + ref <- newWorld + (created, found0, advanced, replayed, older, found1, found2) <- runInMemory ref do + u <- genUserId + tcid <- genTotpCredentialId + created <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = u, secret = rawSecret, createdAt = t0} + found0 <- findTotpByUser u + confirmTotp tcid t0 + advanced <- setTotpLastUsedCounter tcid 42 + replayed <- setTotpLastUsedCounter tcid 42 + older <- setTotpLastUsedCounter tcid 41 + found1 <- findTotpByUser u + deleteTotpByUser u + found2 <- findTotpByUser u + pure (created, found0, advanced, replayed, older, found1, found2) + tcSecret created @?= rawSecret + fmap tcConfirmedAt found0 @?= Just Nothing + (advanced, replayed, older) @?= (True, False, False) + fmap (isJust . tcConfirmedAt) found1 @?= Just True + fmap tcLastUsedCounter found1 @?= Just (Just 42) + found2 @?= Nothing + +totpReenrollReplaces :: IO () +totpReenrollReplaces = do + ref <- newWorld + (found, secondId) <- runInMemory ref do + u <- genUserId + tcid1 <- genTotpCredentialId + _ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid1, userId = u, secret = rawSecret, createdAt = t0} + tcid2 <- genTotpCredentialId + second <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid2, userId = u, secret = TotpSecret "09876543210987654321", createdAt = t0} + found <- findTotpByUser u + pure (found, second.totpCredentialId) + -- Only one credential per user: the re-enrollment's id is what a lookup now returns. + fmap (.totpCredentialId) found @?= Just secondId + +recoveryCas :: IO () +recoveryCas = do + ref <- newWorld + (countBefore, firstConsume, secondConsume, countAfter, countAfterReplace, oldConsume) <- runInMemory ref do + u <- genUserId + ids <- mapM (const genRecoveryCodeId) [1 :: Int, 2, 3] + let mk i h = NewRecoveryCode {recoveryCodeId = i, codeHash = h, createdAt = t0} + replaceRecoveryCodes u (zipWith mk ids ["h1", "h2", "h3"]) + countBefore <- countUnusedRecoveryCodes u + firstConsume <- consumeRecoveryCode u "h1" t0 + secondConsume <- consumeRecoveryCode u "h1" t0 + countAfter <- countUnusedRecoveryCodes u + ids2 <- mapM (const genRecoveryCodeId) [1 :: Int, 2] + replaceRecoveryCodes u (zipWith mk ids2 ["n1", "n2"]) + countAfterReplace <- countUnusedRecoveryCodes u + oldConsume <- consumeRecoveryCode u "h2" t0 + pure (countBefore, firstConsume, secondConsume, countAfter, countAfterReplace, oldConsume) + countBefore @?= 3 + firstConsume @?= True + secondConsume @?= False + countAfter @?= 2 + countAfterReplace @?= 2 + oldConsume @?= False diff --git a/test/Shomei/Mfa/WorkflowSpec.hs b/test/Shomei/Mfa/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Mfa/WorkflowSpec.hs @@ -0,0 +1,271 @@ +-- | Behavioral tests for the EP-4 MFA step-up and passwordless login workflows +-- ('Shomei.Session.Authentication.Workflow.login' widened to 'LoginResult', and 'Shomei.Mfa.Workflow'), run entirely +-- through the in-memory interpreter ('Shomei.Test.InMemory.runInMemory') with EP-1's +-- deterministic fake 'Shomei.Passkey.Ceremony.Port'. No cryptography, no database, no network. +-- +-- The fake accepts an assertion 'Data.Aeson.Value' that echoes the begin step's @challenge@ and +-- carries base64url @credentialId@/@userHandle@/@publicKey@ fields; 'acceptedAssertion' builds +-- one matching the seeded passkey. +module Shomei.Mfa.WorkflowSpec (tests) where + +import Control.Monad (replicateM_) +import Data.Aeson (Value, object, (.=)) +import Data.Aeson.Types (parseMaybe, withObject, (.:)) +import Data.IORef (IORef, newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (UTCTime (..), fromGregorian) +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +import Shomei.Account.LoginId.Domain (LoginId, mkLoginId) +import Shomei.Account.Password.Domain (PlainPassword (..)) +import Shomei.Account.User.Domain (User (..)) +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..)) +import Shomei.Config (ShomeiConfig, defaultShomeiConfig) +import Shomei.Error (AuthError (InvalidCredentials, MfaAssertionInvalid, PendingCeremonyNotFound, TotpCodeInvalid)) +import Shomei.Id (CeremonyId, genCeremonyId, genTotpCredentialId) +import Shomei.Mfa.Totp.Algorithm (TotpSecret (..), totpCode, totpCounter) +import Shomei.Mfa.Totp.Domain (NewTotpCredential (..)) +import Shomei.Mfa.Totp.Store (confirmTotp, findTotpByUser, upsertTotpEnrollment) +import Shomei.Mfa.Totp.Workflow (TotpRemovalProof (..), removeTotp) +import Shomei.Mfa.Workflow (MfaCompletion (..), beginPasswordlessLogin, completeMfa, completePasswordlessLogin) +import Shomei.Passkey.Domain + ( NewPasskeyCredential (..), + PublicKeyBytes (..), + SignatureCounter (..), + UserHandle (..), + WebAuthnCredentialId (..), + ) +import Shomei.Passkey.Store (createPasskey) +import Shomei.Session.Authentication.Workflow (LoginResult (..), MfaChallenge (..), login, signup) +import Shomei.Session.Command (ClientContext (..), LoginCommand (..), ProofContext (..), SignupCommand (..)) +import Shomei.Session.LoginAttempt.Domain (AccountKey (..), AccountLockout (..), ClientIp (..)) +import Shomei.Session.LoginAttempt.Store (setAccountLockout) +import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..)) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +-- Fixtures ------------------------------------------------------------------- + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +-- | The default config requires a second factor when one is enrolled. +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +aliceEmail :: Email +aliceEmail = mkEmail' "alice@example.com" + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +proofContext :: ProofContext +proofContext = ProofContext {clientIp = ClientIp "test-ip", accountKeyOf = AccountKey} + +mkEmail' :: Text -> Email +mkEmail' t = either (\e -> error ("bad test email: " <> show e)) id (mkEmail t) + +ctxFor :: Email -> ClientContext +ctxFor e = ClientContext (ClientIp "test-ip") (AccountKey (emailText e)) + +-- The fixed bytes of the single seeded passkey. +seededCredId :: WebAuthnCredentialId +seededCredId = WebAuthnCredentialId "cred-1" + +seededHandle :: UserHandle +seededHandle = UserHandle "uh-1" + +seededKey :: PublicKeyBytes +seededKey = PublicKeyBytes "pk-1" + +expectRight :: (Show e) => Either e a -> IO a +expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure + +-- | Sign a user up and seed one passkey for them (directly through 'createPasskey'). +seedUserWithPasskey :: IORef World -> IO () +seedUserWithPasskey ref = do + (user, _) <- expectRight =<< runInMemory ref (signup cfg (SignupCommand {loginId = either (error . show) id (mkLoginId (emailText aliceEmail)), email = Just aliceEmail, password = strongPw, displayName = Just "Alice"})) + let User {userId = uid} = user + _ <- + runInMemory + ref + ( createPasskey + NewPasskeyCredential + { userId = uid, + credentialId = seededCredId, + userHandle = seededHandle, + publicKey = seededKey, + signCounter = SignatureCounter 0, + transports = [], + label = Just "Test Key", + createdAt = fixedTime + } + ) + pure () + +-- | An assertion JSON the fake accepts for the seeded passkey, echoing @challenge@. +acceptedAssertion :: Text -> Value +acceptedAssertion chal = + object + [ "challenge" .= chal, + "credentialId" .= seededCredId, + "userHandle" .= seededHandle, + "publicKey" .= seededKey + ] + +-- | The @challenge@ baked into a begin step's options 'Value'. +challengeOf :: Value -> Maybe Text +challengeOf = parseMaybe (withObject "options" (\o -> o .: "challenge")) + +-- | Assert a token pair carries a non-empty access token. +assertTokenPresent :: (User, TokenPair) -> IO () +assertTokenPresent (_user, TokenPair (AccessToken at) _ _) = + assertBool "access token present" (not (T.null at)) + +-- Tests ---------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "Shomei.Mfa.Workflow" + [ testNoPasskeyComplete, + testMfaRequired, + testCompleteMfa, + testCeremonyHygiene, + testBadAssertion, + testBadPasskeysLock, + testSecondFactorSuccessClearsLockout, + testTotpRemovalFailuresLock, + testPasswordless + ] + +testNoPasskeyComplete :: TestTree +testNoPasskeyComplete = testCase "no-passkey login yields LoginComplete with a token" do + ref <- newIORef (emptyWorld fixedTime) + _ <- expectRight =<< runInMemory ref (signup cfg (SignupCommand {loginId = either (error . show) id (mkLoginId (emailText aliceEmail)), email = Just aliceEmail, password = strongPw, displayName = Just "Alice"})) + res <- expectRight =<< runInMemory ref (login cfg (ctxFor aliceEmail) (LoginCommand (either (error . show) id (mkLoginId (emailText aliceEmail))) strongPw)) + case res of + LoginComplete u pair -> assertTokenPresent (u, pair) + MfaRequired _ -> assertFailure "expected LoginComplete (no passkey enrolled)" + +testMfaRequired :: TestTree +testMfaRequired = testCase "passkey + required second factor yields MfaRequired, no token" do + ref <- newIORef (emptyWorld fixedTime) + seedUserWithPasskey ref + res <- expectRight =<< runInMemory ref (login cfg (ctxFor aliceEmail) (LoginCommand (either (error . show) id (mkLoginId (emailText aliceEmail))) strongPw)) + case res of + MfaRequired (MfaChallenge _cid opts _methods) -> + assertBool "a challenge is present in the options" (challengeOf opts /= Nothing) + LoginComplete _ _ -> assertFailure "expected MfaRequired (passkey enrolled, second factor required)" + +testCompleteMfa :: TestTree +testCompleteMfa = testCase "completeMfa with a valid assertion yields a token pair" do + ref <- newIORef (emptyWorld fixedTime) + seedUserWithPasskey ref + (cid, opts) <- loginExpectingChallenge ref + chal <- maybe (assertFailure "no challenge in options") pure (challengeOf opts) + done <- expectRight =<< runInMemory ref (completeMfa cfg proofContext cid (MfaPasskey (acceptedAssertion chal))) + assertTokenPresent done + +testCeremonyHygiene :: TestTree +testCeremonyHygiene = testCase "bogus or consumed ceremony is rejected (PendingCeremonyNotFound)" do + ref <- newIORef (emptyWorld fixedTime) + seedUserWithPasskey ref + -- A ceremony id that was never stored. + bogus <- genCeremonyId + bad <- runInMemory ref (completeMfa cfg proofContext bogus (MfaPasskey (acceptedAssertion "x"))) + bad @?= Left PendingCeremonyNotFound + -- A real challenge succeeds once; re-completing the now-consumed ceremony is a 404. + (cid, opts) <- loginExpectingChallenge ref + chal <- maybe (assertFailure "no challenge in options") pure (challengeOf opts) + _ <- expectRight =<< runInMemory ref (completeMfa cfg proofContext cid (MfaPasskey (acceptedAssertion chal))) + again <- runInMemory ref (completeMfa cfg proofContext cid (MfaPasskey (acceptedAssertion chal))) + again @?= Left PendingCeremonyNotFound + +testBadAssertion :: TestTree +testBadAssertion = testCase "completeMfa with an unknown credential fails with MfaAssertionInvalid" do + ref <- newIORef (emptyWorld fixedTime) + seedUserWithPasskey ref + (cid, opts) <- loginExpectingChallenge ref + chal <- maybe (assertFailure "no challenge in options") pure (challengeOf opts) + let wrong = + object + [ "challenge" .= chal, + "credentialId" .= WebAuthnCredentialId "cred-unknown", + "userHandle" .= UserHandle "uh-x", + "publicKey" .= PublicKeyBytes "pk-x" + ] + res <- runInMemory ref (completeMfa cfg proofContext cid (MfaPasskey wrong)) + res @?= Left MfaAssertionInvalid + +testBadPasskeysLock :: TestTree +testBadPasskeysLock = testCase "five bad passkey assertions lock the account" do + ref <- newIORef (emptyWorld fixedTime) + seedUserWithPasskey ref + replicateM_ 5 do + (cid, opts) <- loginExpectingChallenge ref + chal <- maybe (assertFailure "no challenge in options") pure (challengeOf opts) + let wrong = + object + [ "challenge" .= chal, + "credentialId" .= WebAuthnCredentialId "cred-unknown", + "userHandle" .= UserHandle "uh-x", + "publicKey" .= PublicKeyBytes "pk-x" + ] + result <- runInMemory ref (completeMfa cfg proofContext cid (MfaPasskey wrong)) + result @?= Left MfaAssertionInvalid + denied <- runInMemory ref (login cfg (ctxFor aliceEmail) (LoginCommand (either (error . show) id (mkLoginId (emailText aliceEmail))) strongPw)) + denied @?= Left InvalidCredentials + +testSecondFactorSuccessClearsLockout :: TestTree +testSecondFactorSuccessClearsLockout = testCase "second-factor success clears an expired standing lockout" do + ref <- newIORef (emptyWorld fixedTime) + seedUserWithPasskey ref + let key = AccountKey (emailText aliceEmail) + expired = AccountLockout key 5 (Just fixedTime) fixedTime + runInMemory ref (setAccountLockout expired) + (cid, opts) <- loginExpectingChallenge ref + chal <- maybe (assertFailure "no challenge in options") pure (challengeOf opts) + _ <- expectRight =<< runInMemory ref (completeMfa cfg proofContext cid (MfaPasskey (acceptedAssertion chal))) + w <- readIORef ref + assertBool "the standing lockout row is cleared" (not (Map.member key w.accountLockouts)) + +testTotpRemovalFailuresLock :: TestTree +testTotpRemovalFailuresLock = testCase "wrong TOTP removal codes count and a locked account cannot remove the factor" do + ref <- newIORef (emptyWorld fixedTime) + (user, _) <- expectRight =<< runInMemory ref (signup cfg (SignupCommand {loginId = either (error . show) id (mkLoginId (emailText aliceEmail)), email = Just aliceEmail, password = strongPw, displayName = Just "Alice"})) + tcid <- genTotpCredentialId + let secret = TotpSecret "12345678901234567890" + correct = totpCode 6 secret (totpCounter fixedTime) + wrong = if correct == "000000" then "999999" else "000000" + runInMemory ref do + _ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = user.userId, secret, createdAt = fixedTime} + confirmTotp tcid fixedTime + replicateM_ 5 do + result <- runInMemory ref (removeTotp cfg proofContext user (RemoveWithCode wrong)) + result @?= Left TotpCodeInvalid + lockedResult <- runInMemory ref (removeTotp cfg proofContext user (RemoveWithCode correct)) + lockedResult @?= Left TotpCodeInvalid + remaining <- runInMemory ref (findTotpByUser user.userId) + assertBool "the locked removal leaves the TOTP credential intact" (isJust remaining) + +testPasswordless :: TestTree +testPasswordless = testCase "passwordless login resolves the user and mints tokens" do + ref <- newIORef (emptyWorld fixedTime) + seedUserWithPasskey ref + (cid, opts) <- expectRight =<< runInMemory ref (beginPasswordlessLogin cfg) + chal <- maybe (assertFailure "no challenge in options") pure (challengeOf opts) + done <- expectRight =<< runInMemory ref (completePasswordlessLogin cfg proofContext cid (acceptedAssertion chal)) + assertTokenPresent done + +-- | Log in (password) for the seeded user and expect an MFA challenge, returning its +-- ceremony id and options. +loginExpectingChallenge :: IORef World -> IO (CeremonyId, Value) +loginExpectingChallenge ref = do + res <- expectRight =<< runInMemory ref (login cfg (ctxFor aliceEmail) (LoginCommand (either (error . show) id (mkLoginId (emailText aliceEmail))) strongPw)) + case res of + MfaRequired (MfaChallenge cid opts _methods) -> pure (cid, opts) + LoginComplete _ _ -> assertFailure "expected MfaRequired" diff --git a/test/Shomei/OAuth/Authorize/WorkflowSpec.hs b/test/Shomei/OAuth/Authorize/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/OAuth/Authorize/WorkflowSpec.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DataKinds #-} + +module Shomei.OAuth.Authorize.WorkflowSpec (tests) where + +import Data.IORef (newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Scope (..)) +import Shomei.Config (ShomeiConfig, defaultShomeiConfig) +import Shomei.Id (SessionId, UserId, genOAuthClientId, genSessionId, genUserId, idText) +import Shomei.OAuth.Authorize.Workflow + ( AuthorizeError (..), + AuthorizeParams (..), + AuthorizeRefusal (..), + IssuedCode, + authorize, + ) +import Shomei.OAuth.Client.Domain (ClientType (ConfidentialClient), NewOAuthClient (..)) +import Shomei.OAuth.Client.Store (createOAuthClient) +import Shomei.ServiceAccount.Secret (sha256Hex) +import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (..)) +import Shomei.Session.Store (createSession, revokeSession) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Shomei.OAuth.Authorize.Workflow" + [ testCase "interactive session is accepted" testInteractive, + testCase "impersonation/delegated session is refused" (testKind DelegatedSession), + testCase "on-behalf-of/delegated session is refused" (testKind DelegatedSession), + testCase "client_credentials/machine session is refused" (testKind MachineSession), + testCase "an act claim is refused before an unknown session is read" testActorBeforeSession, + testCase "a revoked interactive session is refused" testRevoked, + testCase "an expired interactive session is refused" testExpired, + testCase "an unknown session is refused" testUnknown + ] + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +callback :: Text +callback = "https://app.example.com/callback" + +params :: AuthorizeParams +params = + AuthorizeParams + { responseType = Just "code", + redirectUri = callback, + scope = Just "openid", + state = Nothing, + nonce = Nothing, + codeChallenge = Nothing, + codeChallengeMethod = Nothing + } + +claimsFor :: UserId -> SessionId -> Maybe UserId -> AuthClaims +claimsFor uid sid actor = + AuthClaims + { subject = uid, + sessionId = sid, + issuer = Issuer "shomei", + audience = Audience "shomei-clients", + issuedAt = fixedTime, + expiresAt = addUTCTime 900 fixedTime, + authTime = fixedTime, + scopes = Set.empty, + roles = Set.empty, + permissions = Set.empty, + actor, + extraClaims = mempty + } + +data SessionState = Live | Revoked | Expired | Missing + +runAuthorize :: SessionKind -> SessionState -> Bool -> IO (Either AuthorizeError IssuedCode, World) +runAuthorize kind state carriesActor = do + ref <- newIORef (emptyWorld fixedTime) + result <- runInMemory ref do + uid <- genUserId + actor <- if carriesActor then Just <$> genUserId else pure Nothing + session <- + createSession + NewSession + { userId = uid, + createdAt = fixedTime, + expiresAt = case state of + Expired -> fixedTime + _ -> addUTCTime 3600 fixedTime, + actor, + oauthClientId = Nothing, + kind, + grantedScopes = Set.empty, + authenticatedAt = fixedTime + } + case state of + Revoked -> revokeSession session.sessionId fixedTime + _ -> pure () + sid <- case state of + Missing -> genSessionId + _ -> pure session.sessionId + ocid <- genOAuthClientId + client <- + createOAuthClient + NewOAuthClient + { oauthClientId = ocid, + clientId = idText ocid, + secretHash = Just (sha256Hex "secret"), + clientType = ConfidentialClient, + displayName = "test", + redirectUris = [callback], + allowedScopes = Set.singleton (Scope "openid"), + createdAt = fixedTime + } + authorize cfg client (claimsFor uid sid actor) params + world <- readIORef ref + pure (result, world) + +expectRefusal :: AuthorizeRefusal -> (Either AuthorizeError IssuedCode, World) -> IO () +expectRefusal expected (result, world) = do + result @?= Left (AuthorizeLoginRequired expected) + Map.size (oauthCodes world) @?= 0 + +testInteractive :: IO () +testInteractive = do + (result, world) <- runAuthorize InteractiveSession Live False + case result of + Left err -> assertFailure ("interactive authorize was refused: " <> show err) + Right _ -> pure () + Map.size (oauthCodes world) @?= 1 + +testKind :: SessionKind -> IO () +testKind kind = runAuthorize kind Live False >>= expectRefusal NonInteractiveCredential + +testActorBeforeSession :: IO () +testActorBeforeSession = runAuthorize InteractiveSession Missing True >>= expectRefusal NonInteractiveCredential + +testRevoked :: IO () +testRevoked = runAuthorize InteractiveSession Revoked False >>= expectRefusal SessionNotLive + +testExpired :: IO () +testExpired = runAuthorize InteractiveSession Expired False >>= expectRefusal SessionNotLive + +testUnknown :: IO () +testUnknown = runAuthorize InteractiveSession Missing False >>= expectRefusal SessionNotLive diff --git a/test/Shomei/OAuth/Client/WorkflowSpec.hs b/test/Shomei/OAuth/Client/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/OAuth/Client/WorkflowSpec.hs @@ -0,0 +1,81 @@ +-- | Policy tests for OAuth client registration. +module Shomei.OAuth.Client.WorkflowSpec (tests) where + +import Data.IORef (newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Time (UTCTime (..), fromGregorian) +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..), Scope (..)) +import Shomei.Authorization.Scope.Domain (adminScope, tokenExchangeSubjectScope) +import Shomei.Config (ImpersonationConfig (..), ShomeiConfig (..), defaultShomeiConfig) +import Shomei.Id (genOAuthClientId, idText) +import Shomei.OAuth.Client.Domain (ClientType (ConfidentialClient), NewOAuthClient (..)) +import Shomei.OAuth.Client.Workflow (ClientRegistrationError (..), registerOAuthClient) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Shomei.OAuth.Client.Workflow" + [ testCase "all built-in privilege scopes are refused" refusesBuiltIns, + testCase "the configured impersonation scope is refused" refusesConfiguredImpersonation, + testCase "ordinary capability scopes are registered" acceptsCapabilities + ] + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 8 27) 0 + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +newClient :: Set.Set Scope -> IO NewOAuthClient +newClient allowedScopes = do + oauthClientId <- genOAuthClientId + pure + NewOAuthClient + { oauthClientId, + clientId = idText oauthClientId, + secretHash = Just "digest", + clientType = ConfidentialClient, + displayName = "test client", + redirectUris = ["https://client.example.com/callback"], + allowedScopes, + createdAt = t0 + } + +register :: ShomeiConfig -> Set.Set Scope -> IO (Either ClientRegistrationError (), World) +register config scopes = do + ref <- newIORef (emptyWorld t0) + candidate <- newClient scopes + result <- fmap (const ()) <$> runInMemory ref (registerOAuthClient config candidate) + world <- readIORef ref + pure (result, world) + +refusesBuiltIns :: IO () +refusesBuiltIns = + mapM_ + ( \scope -> do + (result, world) <- register cfg (Set.singleton scope) + result @?= Left (PrivilegeScopesRefused (Set.singleton scope)) + Map.size world.oauthClients @?= 0 + ) + [cfg.impersonationConfig.impersonateScope, adminScope, tokenExchangeSubjectScope] + +refusesConfiguredImpersonation :: IO () +refusesConfiguredImpersonation = do + let configured = Scope "support:act-as" + custom = cfg {impersonationConfig = cfg.impersonationConfig {impersonateScope = configured}} + (result, world) <- register custom (Set.singleton configured) + result @?= Left (PrivilegeScopesRefused (Set.singleton configured)) + Map.size world.oauthClients @?= 0 + +acceptsCapabilities :: IO () +acceptsCapabilities = do + let scopes = Set.fromList [Scope "openid", Scope "kawa:read"] + (result, world) <- register cfg scopes + case result of + Left err -> assertFailure ("ordinary scopes were refused: " <> show err) + Right () -> pure () + Map.size world.oauthClients @?= 1 diff --git a/test/Shomei/OAuth/Revocation/DomainSpec.hs b/test/Shomei/OAuth/Revocation/DomainSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/OAuth/Revocation/DomainSpec.hs @@ -0,0 +1,69 @@ +module Shomei.OAuth.Revocation.DomainSpec (tests) where + +import Data.Set qualified as Set +import Data.Time (UTCTime (..), fromGregorian) +import Shomei.Authorization.Claims.Domain (Scope (..)) +import Shomei.Authorization.Scope.Domain (adminScope) +import Shomei.Id (UserId, genServiceAccountDbId, genSessionId, genUserId, idText) +import Shomei.OAuth.Revocation.Domain (RevocationCaller (..), mayRevokeSession) +import Shomei.ServiceAccount.Domain (ServiceAccount (..), ServiceAccountStatus (ServiceAccountActive)) +import Shomei.Session.Domain (Session (..), SessionKind (InteractiveSession), SessionStatus (SessionActive)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Shomei.OAuth.Revocation.Domain" + [ testCase "an OAuth client owns a session minted under its client_id" $ withPrincipals \_ _ session -> + mayRevokeSession (RevokingOAuthClient "oauthclient_owner") session @?= True, + testCase "an OAuth client does not own another client's session" $ withPrincipals \_ _ session -> + mayRevokeSession (RevokingOAuthClient "oauthclient_other") session @?= False, + testCase "a service account owns a session whose subject is its backing user" $ withPrincipals \account _ session -> + mayRevokeSession (RevokingServiceAccount account) session {userId = account.userId, oauthClientId = Nothing} @?= True, + testCase "a service account owns a delegated session whose actor is its backing user" $ withPrincipals \account subject session -> + mayRevokeSession (RevokingServiceAccount account) session {userId = subject, actor = Just account.userId, oauthClientId = Nothing} @?= True, + testCase "an ordinary service account cannot revoke an unrelated session" $ withPrincipals \account _ session -> + mayRevokeSession (RevokingServiceAccount account) session @?= False, + testCase "a service account holding shomei:admin may revoke every session" $ withPrincipals \account _ session -> + mayRevokeSession (RevokingServiceAccount account {allowedScopes = Set.singleton adminScope}) session @?= True + ] + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 8 27) 0 + +withPrincipals :: (ServiceAccount -> UserId -> Session -> IO ()) -> IO () +withPrincipals assertion = do + accountUser <- genUserId + subjectUser <- genUserId + sessionUser <- genUserId + serviceAccountId <- genServiceAccountDbId + sessionId <- genSessionId + let account = + ServiceAccount + { serviceAccountId, + clientId = idText serviceAccountId, + userId = accountUser, + secretHash = "digest", + displayName = "caller", + allowedScopes = Set.singleton (Scope "kawa:ingest"), + status = ServiceAccountActive, + createdAt = t0, + rotatedAt = Nothing, + revokedAt = Nothing + } + session = + Session + { sessionId, + userId = sessionUser, + status = SessionActive, + createdAt = t0, + expiresAt = t0, + revokedAt = Nothing, + actor = Nothing, + oauthClientId = Just "oauthclient_owner", + kind = InteractiveSession, + grantedScopes = Set.empty, + authenticatedAt = t0 + } + assertion account subjectUser session diff --git a/test/Shomei/OAuth/TokenExchange/WorkflowSpec.hs b/test/Shomei/OAuth/TokenExchange/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/OAuth/TokenExchange/WorkflowSpec.hs @@ -0,0 +1,424 @@ +-- | Behavioral tests for the RFC 8693 token-exchange workflow +-- ('Shomei.OAuth.TokenExchange.Workflow'), run entirely through the in-memory interpreter +-- ('Shomei.Test.InMemory.runInMemory'). The in-memory 'Shomei.SigningKey.Signer' renders +-- 'AuthClaims' as JSON and the matching 'Shomei.SigningKey.Verifier' parses it back, so a +-- subject\/actor token is just a signed 'AuthClaims' and the minted token decodes for inspection. +module Shomei.OAuth.TokenExchange.WorkflowSpec (tests) where + +import Data.Aeson (eitherDecode) +import Data.IORef (IORef, newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TLE +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +import Shomei.Account.LoginId.Domain (mkLoginId) +import Shomei.Account.Password.Domain (PlainPassword (..)) +import Shomei.Account.User.Domain (User (..), UserStatus (UserActive, UserSuspended)) +import Shomei.Account.User.Store (updateUserStatus) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Scope (..)) +import Shomei.Config (ImpersonationConfig (..), MachineTokenConfig (..), ShomeiConfig (..), defaultShomeiConfig) +import Shomei.Error (AuthError (..)) +import Shomei.Id (SessionId, UserId, genServiceAccountDbId, genUserId, idText) +import Shomei.OAuth.TokenExchange.Workflow + ( ExchangeRequest (..), + ExchangedToken (..), + accessTokenType, + exchangeToken, + tokenExchangeSubjectScope, + userIdTokenType, + ) +import Shomei.ServiceAccount.Domain (ServiceAccount (..), ServiceAccountStatus (..)) +import Shomei.Session.Authentication.Workflow (signup) +import Shomei.Session.Command (SignupCommand (..)) +import Shomei.Session.RefreshToken.Domain (PersistedRefreshToken (..)) +import Shomei.Session.Store (revokeSession) +import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..)) +import Shomei.SigningKey.Signer (signAccessToken) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +-- Fixtures ------------------------------------------------------------------- + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +impScope :: Scope +impScope = cfg.impersonationConfig.impersonateScope + +ingestScope, readScope, adminScope :: Scope +ingestScope = Scope "kawa:ingest" +readScope = Scope "kawa:read" +adminScope = Scope "admin:everything" + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +mkEmail' :: Text -> Email +mkEmail' t = either (\e -> error ("bad test email: " <> show e)) id (mkEmail t) + +expectRight :: (Show e) => Either e a -> IO a +expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure + +-- | Sign up a user with the given email and return their active user/session pair. +seedPrincipal :: IORef World -> Text -> IO (UserId, SessionId) +seedPrincipal ref email = do + let e = mkEmail' email + (user, pair) <- expectRight =<< runInMemory ref (signup cfg (SignupCommand {loginId = either (error . show) id (mkLoginId (emailText e)), email = Just e, password = strongPw, displayName = Just "User"})) + claims <- decodeAccess pair.accessToken + pure (user.userId, claims.sessionId) + +seedUser :: IORef World -> Text -> IO UserId +seedUser ref email = fst <$> seedPrincipal ref email + +-- | Build claims for a principal. The in-memory verifier accepts them verbatim. +claimsFor :: UserId -> SessionId -> Set Scope -> Maybe UserId -> UTCTime -> AuthClaims +claimsFor uid sid scs act iat = + AuthClaims + { subject = uid, + sessionId = sid, + issuer = cfg.issuer, + audience = cfg.audience, + issuedAt = iat, + expiresAt = addUTCTime 900 iat, + authTime = iat, + scopes = scs, + roles = Set.empty, + permissions = Set.empty, + actor = act, + extraClaims = mempty + } + +-- | Sign an access token for a principal (through the in-memory signer, so it round-trips). +signToken :: IORef World -> AuthClaims -> IO Text +signToken ref claims = do + AccessToken t <- runInMemory ref (signAccessToken claims) + pure t + +-- | A fresh operator token holding the impersonation scope, issued now. +freshOperatorToken :: IORef World -> IO Text +freshOperatorToken ref = do + (op, sid) <- seedPrincipal ref "operator@example.com" + signToken ref (claimsFor op sid (Set.singleton impScope) Nothing fixedTime) + +-- | A service account with the given allowed scopes, backed by 'svcUser'. +mkServiceAccount :: UserId -> Set Scope -> IO ServiceAccount +mkServiceAccount svcUser scopes = do + dbid <- genServiceAccountDbId + pure + ServiceAccount + { serviceAccountId = dbid, + clientId = idText dbid, + userId = svcUser, + secretHash = "0000000000000000000000000000000000000000000000000000000000000000", + displayName = "svc", + allowedScopes = scopes, + status = ServiceAccountActive, + createdAt = fixedTime, + rotatedAt = Nothing, + revokedAt = Nothing + } + +-- | The base impersonation request: the target's id as the user-id subject, the operator token as +-- the actor. Extension parameters left at their defaults. +impersonationReq :: UserId -> Text -> ExchangeRequest +impersonationReq target operatorToken = + ExchangeRequest + { subjectToken = idText target, + subjectTokenType = userIdTokenType, + actorToken = Just operatorToken, + actorTokenType = Just accessTokenType, + requestedScopes = Nothing, + requestedTokenType = Nothing, + reason = Nothing, + ticketId = Nothing, + clientIp = Just "203.0.113.7", + authenticatedService = Nothing + } + +-- | The base on-behalf-of request: a user's access token as the subject, presented by an +-- authenticated service account. +onBehalfReq :: Text -> ServiceAccount -> Maybe (Set Scope) -> ExchangeRequest +onBehalfReq subjectToken svc requested = + ExchangeRequest + { subjectToken = subjectToken, + subjectTokenType = accessTokenType, + actorToken = Nothing, + actorTokenType = Nothing, + requestedScopes = requested, + requestedTokenType = Nothing, + reason = Nothing, + ticketId = Nothing, + clientIp = Nothing, + authenticatedService = Just svc + } + +decodeAccess :: AccessToken -> IO AuthClaims +decodeAccess (AccessToken t) = + either + (\e -> assertFailure ("could not decode access token: " <> e)) + pure + (eitherDecode (TLE.encodeUtf8 (TL.fromStrict t))) + +-- | Assert no refresh token was minted for the delegated session. +assertNoRefresh :: IORef World -> SessionId -> IO () +assertNoRefresh ref sid = do + world <- readIORef ref + let refs = filter (\PersistedRefreshToken {sessionId = s} -> s == sid) (Map.elems world.refreshTokens) + assertBool "delegated session has no refresh token" (null refs) + +-- Tests ---------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "Shomei.OAuth.TokenExchange.Workflow" + [ testImpersonationHappyPath, + testImpersonationDefaultReason, + testImpersonationMissingScope, + testImpersonationStaleActor, + testImpersonationSelfTarget, + testImpersonationDelegatedActorRefused, + testImpersonationRevokedOperator, + testImpersonationSuspendedOperator, + testOnBehalfHappyPath, + testOnBehalfDefaultScopes, + testOnBehalfMissingGateScope, + testOnBehalfScopeOutsideCeiling, + testOnBehalfGateNeverGranted, + testOnBehalfSubjectScopeBoundOk, + testOnBehalfSubjectScopeBoundViolation, + testOnBehalfChainRefused, + testOnBehalfInactiveSubject, + testOnBehalfRevokedSubject, + testRefreshlessRequestedTypeRejected + ] + +testImpersonationHappyPath :: TestTree +testImpersonationHappyPath = testCase "impersonation: target sub + operator act, refresh-less, audited" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedUser ref "customer@example.com" + opTok <- freshOperatorToken ref + operatorClaims <- decodeAccess (AccessToken opTok) + result <- expectRight =<< runInMemory ref (exchangeToken cfg (impersonationReq target opTok)) + claims <- decodeAccess result.accessToken + claims.subject @?= target + claims.actor @?= Just operatorClaims.subject + result.grantedScopes @?= Set.empty + result.expiresIn @?= cfg.impersonationConfig.impersonationSessionTTL + assertNoRefresh ref result.sessionId + world <- readIORef ref + assertBool "ImpersonationStarted published" (any (startedFor operatorClaims.subject target) world.publishedEvents) + where + startedFor actorId subj = \case + Event.ImpersonationStarted d -> d.actorUserId == actorId && d.subjectUserId == subj + _ -> False + +testImpersonationDefaultReason :: TestTree +testImpersonationDefaultReason = testCase "impersonation: absent reason defaults to token_exchange" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedUser ref "customer@example.com" + opTok <- freshOperatorToken ref + _ <- expectRight =<< runInMemory ref (exchangeToken cfg (impersonationReq target opTok)) + world <- readIORef ref + assertBool "reason defaulted to token_exchange" (any defaulted world.publishedEvents) + where + defaulted = \case + Event.ImpersonationStarted d -> d.reason == "token_exchange" + _ -> False + +testImpersonationMissingScope :: TestTree +testImpersonationMissingScope = testCase "impersonation: operator without impersonate:user is forbidden" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedUser ref "customer@example.com" + (op, sid) <- seedPrincipal ref "operator@example.com" + opTok <- signToken ref (claimsFor op sid Set.empty Nothing fixedTime) + res <- runInMemory ref (exchangeToken cfg (impersonationReq target opTok)) + fmap (const ()) res @?= Left ImpersonationForbidden + +testImpersonationStaleActor :: TestTree +testImpersonationStaleActor = testCase "impersonation: operator token past the freshness window is forbidden" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedUser ref "customer@example.com" + (op, sid) <- seedPrincipal ref "operator@example.com" + let stale = addUTCTime (negate (cfg.impersonationConfig.actorFreshnessWindow + 1)) fixedTime + opTok <- signToken ref (claimsFor op sid (Set.singleton impScope) Nothing stale) + res <- runInMemory ref (exchangeToken cfg (impersonationReq target opTok)) + fmap (const ()) res @?= Left ImpersonationForbidden + +testImpersonationSelfTarget :: TestTree +testImpersonationSelfTarget = testCase "impersonation: targeting the operator themselves is invalid" do + ref <- newIORef (emptyWorld fixedTime) + (op, sid) <- seedPrincipal ref "operator@example.com" + opTok <- signToken ref (claimsFor op sid (Set.singleton impScope) Nothing fixedTime) + res <- runInMemory ref (exchangeToken cfg (impersonationReq op opTok)) + fmap (const ()) res @?= Left ImpersonationTargetInvalid + +testImpersonationDelegatedActorRefused :: TestTree +testImpersonationDelegatedActorRefused = testCase "impersonation: a delegated actor token is refused (no chains)" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedUser ref "customer@example.com" + (op, sid) <- seedPrincipal ref "operator@example.com" + other <- genUserId + -- An actor token that already carries `act` cannot be used to start another exchange. + opTok <- signToken ref (claimsFor op sid (Set.singleton impScope) (Just other) fixedTime) + res <- runInMemory ref (exchangeToken cfg (impersonationReq target opTok)) + fmap (const ()) res @?= Left OAuthGrantInvalid + +testImpersonationRevokedOperator :: TestTree +testImpersonationRevokedOperator = testCase "impersonation: a revoked operator session is an invalid grant" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedUser ref "customer@example.com" + (op, sid) <- seedPrincipal ref "operator@example.com" + opTok <- signToken ref (claimsFor op sid (Set.singleton impScope) Nothing fixedTime) + runInMemory ref (revokeSession sid fixedTime) + res <- runInMemory ref (exchangeToken cfg (impersonationReq target opTok)) + fmap (const ()) res @?= Left OAuthGrantInvalid + +testImpersonationSuspendedOperator :: TestTree +testImpersonationSuspendedOperator = testCase "impersonation: a suspended operator is forbidden" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedUser ref "customer@example.com" + (op, sid) <- seedPrincipal ref "operator@example.com" + opTok <- signToken ref (claimsFor op sid (Set.singleton impScope) Nothing fixedTime) + _ <- runInMemory ref (updateUserStatus op [UserActive] UserSuspended fixedTime) + res <- runInMemory ref (exchangeToken cfg (impersonationReq target opTok)) + fmap (const ()) res @?= Left ImpersonationForbidden + +testOnBehalfHappyPath :: TestTree +testOnBehalfHappyPath = testCase "on-behalf-of: user sub + service act, narrowed scopes, audited, refresh-less" do + ref <- newIORef (emptyWorld fixedTime) + (user, usid) <- seedPrincipal ref "customer@example.com" + svcUser <- seedUser ref "svc@example.com" + subjTok <- signToken ref (claimsFor user usid Set.empty Nothing fixedTime) + svc <- mkServiceAccount svcUser (Set.fromList [ingestScope, readScope, tokenExchangeSubjectScope]) + result <- expectRight =<< runInMemory ref (exchangeToken cfg (onBehalfReq subjTok svc (Just (Set.singleton ingestScope)))) + claims <- decodeAccess result.accessToken + claims.subject @?= user + claims.actor @?= Just svcUser + claims.scopes @?= Set.singleton ingestScope + result.grantedScopes @?= Set.singleton ingestScope + result.expiresIn @?= cfg.machineTokenConfig.machineTokenTTL + assertNoRefresh ref result.sessionId + world <- readIORef ref + assertBool "ServiceOnBehalfIssued published" (any (behalfFor svcUser user) world.publishedEvents) + where + behalfFor act subj = \case + Event.ServiceOnBehalfIssued d -> + d.actorUserId == act && d.subjectUserId == subj && d.scopes == Set.singleton ingestScope + _ -> False + +testOnBehalfDefaultScopes :: TestTree +testOnBehalfDefaultScopes = testCase "on-behalf-of: absent scope grants the ceiling, never the gate scope" do + ref <- newIORef (emptyWorld fixedTime) + (user, usid) <- seedPrincipal ref "customer@example.com" + svcUser <- seedUser ref "svc@example.com" + subjTok <- signToken ref (claimsFor user usid Set.empty Nothing fixedTime) + svc <- mkServiceAccount svcUser (Set.fromList [ingestScope, readScope, tokenExchangeSubjectScope]) + result <- expectRight =<< runInMemory ref (exchangeToken cfg (onBehalfReq subjTok svc Nothing)) + -- The gate scope is stripped; the two functional scopes remain. + result.grantedScopes @?= Set.fromList [ingestScope, readScope] + assertBool "gate scope is never granted" (not (tokenExchangeSubjectScope `Set.member` result.grantedScopes)) + +testOnBehalfMissingGateScope :: TestTree +testOnBehalfMissingGateScope = testCase "on-behalf-of: account without the gate scope is refused" do + ref <- newIORef (emptyWorld fixedTime) + (user, usid) <- seedPrincipal ref "customer@example.com" + svcUser <- seedUser ref "svc@example.com" + subjTok <- signToken ref (claimsFor user usid Set.empty Nothing fixedTime) + svc <- mkServiceAccount svcUser (Set.fromList [ingestScope, readScope]) + res <- runInMemory ref (exchangeToken cfg (onBehalfReq subjTok svc (Just (Set.singleton ingestScope)))) + fmap (const ()) res @?= Left OAuthScopeInvalid + +testOnBehalfScopeOutsideCeiling :: TestTree +testOnBehalfScopeOutsideCeiling = testCase "on-behalf-of: requesting a scope outside the ceiling is refused" do + ref <- newIORef (emptyWorld fixedTime) + (user, usid) <- seedPrincipal ref "customer@example.com" + svcUser <- seedUser ref "svc@example.com" + subjTok <- signToken ref (claimsFor user usid Set.empty Nothing fixedTime) + svc <- mkServiceAccount svcUser (Set.fromList [ingestScope, tokenExchangeSubjectScope]) + res <- runInMemory ref (exchangeToken cfg (onBehalfReq subjTok svc (Just (Set.singleton adminScope)))) + fmap (const ()) res @?= Left OAuthScopeInvalid + +testOnBehalfGateNeverGranted :: TestTree +testOnBehalfGateNeverGranted = testCase "on-behalf-of: requesting the gate scope itself yields an empty grant, refused" do + ref <- newIORef (emptyWorld fixedTime) + (user, usid) <- seedPrincipal ref "customer@example.com" + svcUser <- seedUser ref "svc@example.com" + subjTok <- signToken ref (claimsFor user usid Set.empty Nothing fixedTime) + svc <- mkServiceAccount svcUser (Set.fromList [ingestScope, tokenExchangeSubjectScope]) + res <- runInMemory ref (exchangeToken cfg (onBehalfReq subjTok svc (Just (Set.singleton tokenExchangeSubjectScope)))) + fmap (const ()) res @?= Left OAuthScopeInvalid + +testOnBehalfSubjectScopeBoundOk :: TestTree +testOnBehalfSubjectScopeBoundOk = testCase "on-behalf-of: non-empty subject scopes that contain the grant are allowed" do + ref <- newIORef (emptyWorld fixedTime) + (user, usid) <- seedPrincipal ref "customer@example.com" + svcUser <- seedUser ref "svc@example.com" + -- The subject token itself carries a scope set; the grant must be within it. + subjTok <- signToken ref (claimsFor user usid (Set.fromList [ingestScope, readScope]) Nothing fixedTime) + svc <- mkServiceAccount svcUser (Set.fromList [ingestScope, readScope, tokenExchangeSubjectScope]) + result <- expectRight =<< runInMemory ref (exchangeToken cfg (onBehalfReq subjTok svc (Just (Set.singleton ingestScope)))) + result.grantedScopes @?= Set.singleton ingestScope + +testOnBehalfSubjectScopeBoundViolation :: TestTree +testOnBehalfSubjectScopeBoundViolation = testCase "on-behalf-of: a grant exceeding non-empty subject scopes is refused" do + ref <- newIORef (emptyWorld fixedTime) + (user, usid) <- seedPrincipal ref "customer@example.com" + svcUser <- seedUser ref "svc@example.com" + -- Subject holds only kawa:ingest; the service asks for kawa:read too — outside the user's authority. + subjTok <- signToken ref (claimsFor user usid (Set.singleton ingestScope) Nothing fixedTime) + svc <- mkServiceAccount svcUser (Set.fromList [ingestScope, readScope, tokenExchangeSubjectScope]) + res <- runInMemory ref (exchangeToken cfg (onBehalfReq subjTok svc (Just (Set.fromList [ingestScope, readScope])))) + fmap (const ()) res @?= Left OAuthScopeInvalid + +testOnBehalfChainRefused :: TestTree +testOnBehalfChainRefused = testCase "on-behalf-of: an already-delegated subject token is refused (no chains)" do + ref <- newIORef (emptyWorld fixedTime) + (user, usid) <- seedPrincipal ref "customer@example.com" + svcUser <- seedUser ref "svc@example.com" + other <- genUserId + -- Subject token already carries `act`: it is itself a delegated token and cannot be re-exchanged. + subjTok <- signToken ref (claimsFor user usid Set.empty (Just other) fixedTime) + svc <- mkServiceAccount svcUser (Set.fromList [ingestScope, tokenExchangeSubjectScope]) + res <- runInMemory ref (exchangeToken cfg (onBehalfReq subjTok svc (Just (Set.singleton ingestScope)))) + fmap (const ()) res @?= Left OAuthGrantInvalid + +testOnBehalfInactiveSubject :: TestTree +testOnBehalfInactiveSubject = testCase "on-behalf-of: an inactive subject user is refused" do + ref <- newIORef (emptyWorld fixedTime) + (user, usid) <- seedPrincipal ref "customer@example.com" + svcUser <- seedUser ref "svc@example.com" + _ <- runInMemory ref (updateUserStatus user [UserActive] UserSuspended fixedTime) + subjTok <- signToken ref (claimsFor user usid Set.empty Nothing fixedTime) + svc <- mkServiceAccount svcUser (Set.fromList [ingestScope, tokenExchangeSubjectScope]) + res <- runInMemory ref (exchangeToken cfg (onBehalfReq subjTok svc (Just (Set.singleton ingestScope)))) + fmap (const ()) res @?= Left OAuthGrantInvalid + +testOnBehalfRevokedSubject :: TestTree +testOnBehalfRevokedSubject = testCase "on-behalf-of: a revoked subject session is an invalid grant" do + ref <- newIORef (emptyWorld fixedTime) + (user, usid) <- seedPrincipal ref "customer@example.com" + svcUser <- seedUser ref "svc@example.com" + subjTok <- signToken ref (claimsFor user usid Set.empty Nothing fixedTime) + svc <- mkServiceAccount svcUser (Set.fromList [ingestScope, tokenExchangeSubjectScope]) + runInMemory ref (revokeSession usid fixedTime) + res <- runInMemory ref (exchangeToken cfg (onBehalfReq subjTok svc (Just (Set.singleton ingestScope)))) + fmap (const ()) res @?= Left OAuthGrantInvalid + +testRefreshlessRequestedTypeRejected :: TestTree +testRefreshlessRequestedTypeRejected = testCase "a requested_token_type other than access_token is malformed" do + ref <- newIORef (emptyWorld fixedTime) + target <- seedUser ref "customer@example.com" + opTok <- freshOperatorToken ref + let req = (impersonationReq target opTok) {requestedTokenType = Just "urn:ietf:params:oauth:token-type:refresh_token"} + res <- runInMemory ref (exchangeToken cfg req) + fmap (const ()) res @?= Left OAuthRequestMalformed diff --git a/test/Shomei/OAuth/TokenGrant/WorkflowSpec.hs b/test/Shomei/OAuth/TokenGrant/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/OAuth/TokenGrant/WorkflowSpec.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DataKinds #-} + +-- | Regression coverage for policy shared by the authorization-code grant and ordinary login. +module Shomei.OAuth.TokenGrant.WorkflowSpec (tests) where + +import Data.Either (isRight) +import Data.IORef (newIORef) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Shomei.Account.Email.Domain (Email, mkEmail) +import Shomei.Account.LoginId.Domain (mkLoginId) +import Shomei.Account.Password.Domain (PlainPassword (..)) +import Shomei.Account.User.Domain (User (..)) +import Shomei.Account.User.Store (markUserEmailVerified) +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..)) +import Shomei.Config (NotifierConfig (..), ShomeiConfig (..), defaultShomeiConfig) +import Shomei.Id (genOAuthClientId, idText) +import Shomei.OAuth.AuthorizationCode.Domain (NewAuthorizationCode (..)) +import Shomei.OAuth.AuthorizationCode.Store (putAuthorizationCode) +import Shomei.OAuth.Client.Domain (ClientType (ConfidentialClient), NewOAuthClient (..), OAuthClient (..)) +import Shomei.OAuth.Client.Store (createOAuthClient) +import Shomei.OAuth.TokenGrant.Workflow + ( ExchangeAuthorizationCode (..), + TokenGrantError (..), + exchangeAuthorizationCode, + ) +import Shomei.ServiceAccount.Secret (sha256Hex) +import Shomei.Session.Authentication.Workflow (signup) +import Shomei.Session.Command (SignupCommand (..)) +import Shomei.Test.InMemory (emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Shomei.OAuth.TokenGrant.Workflow" + [ testCase "authorization-code exchange refuses an unverified email when the gate is enabled" testUnverifiedEmail, + testCase "authorization-code exchange accepts an unverified email when the gate is disabled" testUngatedEmail, + testCase "authorization-code exchange accepts a verified email when the gate is enabled" testVerifiedEmail, + testCase "authorization-code exchange exempts a login-id-only account from the email gate" testNoEmail + ] + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +baseCfg :: ShomeiConfig +baseCfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +gatedCfg :: ShomeiConfig +gatedCfg = baseCfg {notifierConfig = baseCfg.notifierConfig {emailVerificationRequired = True}} + +callback :: Text +callback = "https://app.example.com/callback" + +rawCode :: Text +rawCode = "authorization-code-for-email-gate" + +testClientSecret :: Text +testClientSecret = "oauth-client-secret" + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +mkEmail' :: Text -> Email +mkEmail' = either (error . show) id . mkEmail + +data PrincipalShape = UnverifiedEmail | VerifiedEmail | NoEmail + +exchangeFor :: ShomeiConfig -> PrincipalShape -> IO (Either TokenGrantError ()) +exchangeFor exchangeCfg shape = do + ref <- newIORef (emptyWorld fixedTime) + clientId <- runInMemory ref do + let email = case shape of + NoEmail -> Nothing + _ -> Just (mkEmail' "code-user@example.com") + login = case shape of + NoEmail -> "code-user" + _ -> "code-user@example.com" + loginId <- either (error . show) pure (mkLoginId login) + signupResult <- signup baseCfg SignupCommand {loginId, email, password = strongPw, displayName = Just "Code User"} + user <- either (error . show) (pure . fst) signupResult + case shape of + VerifiedEmail -> markUserEmailVerified user.userId fixedTime + _ -> pure () + ocid <- genOAuthClientId + client <- + createOAuthClient + NewOAuthClient + { oauthClientId = ocid, + clientId = idText ocid, + secretHash = Just (sha256Hex testClientSecret), + clientType = ConfidentialClient, + displayName = "test client", + redirectUris = [callback], + allowedScopes = Set.empty, + createdAt = fixedTime + } + putAuthorizationCode + NewAuthorizationCode + { codeHash = sha256Hex rawCode, + clientId = client.clientId, + redirectUri = callback, + userId = user.userId, + scopes = Set.empty, + nonce = Nothing, + codeChallenge = Nothing, + authTime = fixedTime, + createdAt = fixedTime, + expiresAt = addUTCTime 60 fixedTime + } + pure client.clientId + result <- + runInMemory ref $ + exchangeAuthorizationCode + exchangeCfg + ExchangeAuthorizationCode + { clientId, + clientSecret = Just testClientSecret, + code = rawCode, + redirectUri = callback, + codeVerifier = Nothing + } + pure (() <$ result) + +testUnverifiedEmail :: IO () +testUnverifiedEmail = do + result <- exchangeFor gatedCfg UnverifiedEmail + result @?= Left (GrantInvalidGrant "the code's user has not verified their email") + +testUngatedEmail :: IO () +testUngatedEmail = do + result <- exchangeFor baseCfg UnverifiedEmail + assertBool "unverified email should exchange when the gate is off" (isRight result) + +testVerifiedEmail :: IO () +testVerifiedEmail = do + result <- exchangeFor gatedCfg VerifiedEmail + assertBool "verified email should exchange" (isRight result) + +testNoEmail :: IO () +testNoEmail = do + result <- exchangeFor gatedCfg NoEmail + case result of + Left err -> assertFailure ("login-id-only account was refused: " <> show err) + Right () -> pure () diff --git a/test/Shomei/OAuthClientStoreSpec.hs b/test/Shomei/OAuthClientStoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/OAuthClientStoreSpec.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE DataKinds #-} + +-- | Pure tests for the in-memory 'Shomei.OAuth.Client.Store' interpreter +-- ('Shomei.Test.InMemory.runOAuthClientStore'). +-- +-- They prove the persistence contract EP-5's authorization-code flow builds on, against the fake +-- 'World': a client can be created and found by its client id; a public client stores no secret +-- hash at all; a client can be revoked (status flips, @revoked_at@ is stamped, and the row +-- survives so the lookup still resolves and the authorize endpoint can refuse it); and the +-- listing is newest-first. The same behavior is re-proven against real PostgreSQL by +-- @shomei-postgres@'s integration test. +-- +-- 'isRegisteredRedirectUri' is tested here too: it is the single rule that keeps +-- @GET \/oauth\/authorize@ from being an open redirector, and it is pure. +module Shomei.OAuthClientStoreSpec (tests) where + +import Control.Monad.IO.Class (MonadIO) +import Data.IORef (IORef, newIORef) +import Data.Maybe (isNothing) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Shomei.Authorization.Claims.Domain (Scope (..)) +import Shomei.Id (OAuthClientId, genOAuthClientId, idText) +import Shomei.OAuth.Client.Domain + ( ClientType (..), + NewOAuthClient (..), + OAuthClient (..), + OAuthClientStatus (..), + isRegisteredRedirectUri, + ) +import Shomei.OAuth.Client.Store + ( createOAuthClient, + findOAuthClientByClientId, + listOAuthClients, + revokeOAuthClient, + ) +import Shomei.Test.InMemory (World, emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "OAuthClientStore (in-memory)" + [ testCase "create then find by client id" createAndFind, + testCase "a public client stores no secret hash" publicClientHasNoSecret, + testCase "find by an unknown client id returns Nothing" findUnknown, + testCase "revoke flips status, stamps revoked_at, and keeps the row" revoke, + testCase "list is newest-first" listNewestFirst, + testCase "a redirect uri matches only by exact string equality" redirectUriExactMatch + ] + +-- Field accessors: OverloadedRecordDot is unreliable for these DuplicateRecordFields +-- records (MasterPlan 3 discovery), so read them by record-pattern matching. + +ocStatus :: OAuthClient -> OAuthClientStatus +ocStatus OAuthClient {status} = status + +ocSecretHash :: OAuthClient -> Maybe Text +ocSecretHash OAuthClient {secretHash} = secretHash + +ocRevokedAt :: OAuthClient -> Maybe UTCTime +ocRevokedAt OAuthClient {revokedAt} = revokedAt + +ocClientId :: OAuthClient -> Text +ocClientId OAuthClient {clientId} = clientId + +ocAllowedScopes :: OAuthClient -> Set Scope +ocAllowedScopes OAuthClient {allowedScopes} = allowedScopes + +ocId :: OAuthClient -> OAuthClientId +ocId OAuthClient {oauthClientId} = oauthClientId + +ocDisplayName :: OAuthClient -> Text +ocDisplayName OAuthClient {displayName} = displayName + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 7 10) 0 + +newWorld :: IO (IORef World) +newWorld = newIORef (emptyWorld t0) + +openidScope :: Set Scope +openidScope = Set.singleton (Scope "openid") + +callbackUri :: Text +callbackUri = "https://app.example.com/callback" + +-- | Build a 'NewOAuthClient' whose @client_id@ is its id's TypeID text, exactly as the CLI does. +mkNew :: (MonadIO m) => ClientType -> UTCTime -> Text -> m NewOAuthClient +mkNew clientType createdAt displayName = do + ocid <- genOAuthClientId + pure + NewOAuthClient + { oauthClientId = ocid, + clientId = idText ocid, + secretHash = case clientType of + ConfidentialClient -> Just "hash-one" + PublicClient -> Nothing, + clientType, + displayName, + redirectUris = [callbackUri], + allowedScopes = openidScope, + createdAt + } + +createAndFind :: IO () +createAndFind = do + ref <- newWorld + (created, found) <- runInMemory ref do + new <- mkNew ConfidentialClient t0 "grafana" + created <- createOAuthClient new + found <- findOAuthClientByClientId (ocClientId created) + pure (created, found) + ocStatus created @?= OAuthClientActive + ocRevokedAt created @?= Nothing + ocSecretHash created @?= Just "hash-one" + ocAllowedScopes created @?= openidScope + fmap ocId found @?= Just (ocId created) + +-- | A public client is issued no secret, rather than one that is stored and never checked. +publicClientHasNoSecret :: IO () +publicClientHasNoSecret = do + ref <- newWorld + found <- runInMemory ref do + new <- mkNew PublicClient t0 "spa" + created <- createOAuthClient new + findOAuthClientByClientId (ocClientId created) + fmap ocSecretHash found @?= Just Nothing + +findUnknown :: IO () +findUnknown = do + ref <- newWorld + found <- runInMemory ref (findOAuthClientByClientId "oauthclient_nope") + assertBool "unknown client id must not resolve" (isNothing found) + +revoke :: IO () +revoke = do + ref <- newWorld + let revokedTime = addUTCTime 7200 t0 + found <- runInMemory ref do + new <- mkNew ConfidentialClient t0 "grafana" + created <- createOAuthClient new + revokeOAuthClient (ocId created) revokedTime + -- The row survives revocation: the authorize endpoint must be able to see that this client + -- exists and is revoked, so it refuses without redirecting. + findOAuthClientByClientId (ocClientId created) + fmap ocStatus found @?= Just OAuthClientRevoked + fmap ocRevokedAt found @?= Just (Just revokedTime) + +listNewestFirst :: IO () +listNewestFirst = do + ref <- newWorld + clients <- runInMemory ref do + older <- mkNew ConfidentialClient t0 "older" + newer <- mkNew PublicClient (addUTCTime 60 t0) "newer" + _ <- createOAuthClient older + _ <- createOAuthClient newer + listOAuthClients + map ocDisplayName clients @?= ["newer", "older"] + +-- | Every near-miss here is an open-redirector attempt: a prefix match, a suffix match, a +-- traversal, and a trailing slash all name a target the operator never registered. +redirectUriExactMatch :: IO () +redirectUriExactMatch = do + ref <- newWorld + client <- runInMemory ref (createOAuthClient =<< mkNew ConfidentialClient t0 "grafana") + assertBool "the registered uri matches" (isRegisteredRedirectUri client callbackUri) + mapM_ + (\uri -> assertBool ("must not match: " <> show uri) (not (isRegisteredRedirectUri client uri))) + [ "https://app.example.com/callback/", + "https://app.example.com/callback/../evil", + "https://app.example.com/callback?x=1", + "https://app.example.com.evil.test/callback", + "https://evil.test/https://app.example.com/callback", + "http://app.example.com/callback" + ] diff --git a/test/Shomei/OAuthCodeStoreSpec.hs b/test/Shomei/OAuthCodeStoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/OAuthCodeStoreSpec.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE DataKinds #-} + +-- | Pure tests for the in-memory 'Shomei.OAuth.AuthorizationCode.Store' interpreter and for +-- 'Shomei.OAuth.Authorize.Workflow.authorize', the policy the authorize endpoint enforces. +-- +-- The store's contract is consume-once: a code is redeemable exactly once, never after it +-- expires, and a replay is indistinguishable from an unknown code. Those three misses are what +-- the token endpoint answers @invalid_grant@ for, and getting any of them wrong turns a +-- single-use credential into a reusable one. The same behavior is re-proven against real +-- PostgreSQL — including under a genuine race — by @shomei-postgres@'s integration test. +-- +-- The workflow's contract is the PKCE and scope policy: a public client cannot skip PKCE, only +-- S256 is accepted, and a client cannot be granted a scope it was never registered for. +module Shomei.OAuthCodeStoreSpec (tests) where + +import Data.IORef (IORef, newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust, isNothing) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Scope (..)) +import Shomei.Config (ShomeiConfig, defaultShomeiConfig) +import Shomei.Id (SessionId, UserId, genOAuthClientId, genSessionId, genUserId, idText) +import Shomei.OAuth.AuthorizationCode.Domain (AuthorizationCode (..), NewAuthorizationCode (..)) +import Shomei.OAuth.AuthorizationCode.Store + ( bindAuthorizationCodeSession, + consumeAuthorizationCode, + deleteExpiredAuthorizationCodes, + findConsumedAuthorizationCode, + putAuthorizationCode, + ) +import Shomei.OAuth.Authorize.Workflow + ( AuthorizeError (..), + AuthorizeParams (..), + IssuedCode (..), + authorize, + isValidS256Challenge, + ) +import Shomei.OAuth.Client.Domain (ClientType (..), NewOAuthClient (..), OAuthClient (..)) +import Shomei.OAuth.Client.Store (createOAuthClient) +import Shomei.ServiceAccount.Secret (sha256Hex) +import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (InteractiveSession)) +import Shomei.Session.Store (createSession) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "OAuthCodeStore and the authorize workflow" + [ testGroup + "OAuthCodeStore (in-memory)" + [ testCase "a stored code is consumable exactly once" consumeOnce, + testCase "a consumed code can be bound to and recover its minted session" bindAndFindConsumed, + testCase "an expired code never consumes" expiredNeverConsumes, + testCase "an unknown code hash consumes to Nothing" unknownConsumes, + testCase "deleteExpired removes only what is past its expiry" deleteExpired + ], + testGroup + "authorize (workflow policy)" + [ testCase "a valid request mints a code, stores only its digest, and audits it" happyPath, + testCase "a public client without a code_challenge is refused" publicClientNeedsPkce, + testCase "a confidential client may omit PKCE" confidentialMayOmitPkce, + testCase "code_challenge_method other than S256 is refused" onlyS256, + testCase "a code_challenge present with no method is refused (no silent `plain`)" noImplicitPlain, + testCase "a malformed code_challenge is refused at authorize" malformedChallenge, + testCase "response_type other than code is unsupported_response_type" onlyCodeResponseType, + testCase "an absent scope grants the client's whole allow-list" absentScopeGrantsAll, + testCase "an absent scope strips privilege scopes from a hand-inserted client" absentScopeStripsPrivileges, + testCase "a requested privilege scope is invalid_scope" requestedPrivilegeScopeFails, + testCase "an absent scope is invalid when only privilege scopes remain" privilegeOnlyDefaultFails, + testCase "a scope outside the allow-list is invalid_scope" scopeOutsideAllowList, + testCase "an empty scope parameter is invalid_scope, not a request for nothing" emptyScope, + testCase "auth_time is copied from the authorizing token, not its iat or now" authTimeIsCredentialTime, + testCase "isValidS256Challenge accepts only 43 unpadded base64url chars" challengeShape + ] + ] + +-- Fixtures ------------------------------------------------------------------- + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 7 10) 0 + +-- | The stock config: 'authorize' reads only @oauthConfig.authorizationCodeTTL@ from it (60s by +-- default). @oidcEnabled@ gates the /route/, not the workflow. +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "https://shomei.test") (Audience "shomei-clients") + +newWorld :: IO (IORef World) +newWorld = newIORef (emptyWorld t0) + +callbackUri :: Text +callbackUri = "https://app.example.com/callback" + +-- | A well-formed S256 challenge: 43 unpadded base64url characters. +challenge :: Text +challenge = Text.replicate 43 "a" + +openidScope, profileScope :: Scope +openidScope = Scope "openid" +profileScope = Scope "profile" + +allowed :: Set Scope +allowed = Set.fromList [openidScope, profileScope] + +baseParams :: AuthorizeParams +baseParams = + AuthorizeParams + { responseType = Just "code", + redirectUri = callbackUri, + scope = Nothing, + state = Nothing, + nonce = Nothing, + codeChallenge = Just challenge, + codeChallengeMethod = Just "S256" + } + +-- | Claims for a user whose token was refreshed at request time but who authenticated an hour +-- earlier, so the authorization-code test can distinguish @auth_time@ from @iat@ and "now". +claimsFor :: UserId -> SessionId -> AuthClaims +claimsFor uid sid = + AuthClaims + { subject = uid, + sessionId = sid, + issuer = Issuer "https://shomei.test", + audience = Audience "shomei-clients", + issuedAt = t0, + expiresAt = addUTCTime 900 t0, + authTime = addUTCTime (-3600) t0, + scopes = Set.empty, + roles = Set.empty, + permissions = Set.empty, + actor = Nothing, + extraClaims = mempty + } + +newCode :: UserId -> UTCTime -> Text -> NewAuthorizationCode +newCode uid expiresAt codeHash = + NewAuthorizationCode + { codeHash, + clientId = "oauthclient_x", + redirectUri = callbackUri, + userId = uid, + scopes = Set.singleton openidScope, + nonce = Nothing, + codeChallenge = Just challenge, + authTime = t0, + createdAt = t0, + expiresAt + } + +-- Store ---------------------------------------------------------------------- + +-- | The single most important property in this plan: a code is a one-shot credential. +consumeOnce :: IO () +consumeOnce = do + ref <- newWorld + (first', second') <- runInMemory ref do + uid <- genUserId + putAuthorizationCode (newCode uid (addUTCTime 60 t0) "hash-1") + a <- consumeAuthorizationCode "hash-1" t0 + b <- consumeAuthorizationCode "hash-1" t0 + pure (a, b) + assertBool "the first consume returns the code" (isJust first') + fmap (.consumedAt) first' @?= Just (Just t0) + assertBool "the second consume returns nothing" (isNothing second') + +bindAndFindConsumed :: IO () +bindAndFindConsumed = do + ref <- newWorld + (sid, found, expired) <- runInMemory ref do + uid <- genUserId + sid <- genSessionId + putAuthorizationCode (newCode uid (addUTCTime 60 t0) "hash-bound") + _ <- consumeAuthorizationCode "hash-bound" t0 + bindAuthorizationCodeSession "hash-bound" sid + found <- findConsumedAuthorizationCode "hash-bound" t0 + expired <- findConsumedAuthorizationCode "hash-bound" (addUTCTime 61 t0) + pure (sid, found, expired) + fmap (.sessionId) found @?= Just (Just sid) + assertBool "an expired consumed row is no longer replay-actionable" (isNothing expired) + +expiredNeverConsumes :: IO () +expiredNeverConsumes = do + ref <- newWorld + result <- runInMemory ref do + uid <- genUserId + putAuthorizationCode (newCode uid (addUTCTime 60 t0) "hash-1") + -- One second past the expiry. + consumeAuthorizationCode "hash-1" (addUTCTime 61 t0) + assertBool "an expired code must not consume" (isNothing result) + +unknownConsumes :: IO () +unknownConsumes = do + ref <- newWorld + result <- runInMemory ref (consumeAuthorizationCode "no-such-hash" t0) + assertBool "an unknown code hash consumes to Nothing" (isNothing result) + +deleteExpired :: IO () +deleteExpired = do + ref <- newWorld + remaining <- runInMemory ref do + uid <- genUserId + putAuthorizationCode (newCode uid (addUTCTime 10 t0) "expired") + putAuthorizationCode (newCode uid (addUTCTime 600 t0) "live") + deleteExpiredAuthorizationCodes (addUTCTime 60 t0) + (,) <$> consumeAuthorizationCode "expired" (addUTCTime 60 t0) <*> consumeAuthorizationCode "live" (addUTCTime 60 t0) + assertBool "the expired code is gone" (isNothing (fst remaining)) + assertBool "the live code survives" (isJust (snd remaining)) + +-- Workflow ------------------------------------------------------------------- + +-- | Run 'authorize' against a freshly registered client of the given type. +runAuthorize :: ClientType -> AuthorizeParams -> IO (Either AuthorizeError IssuedCode, World) +runAuthorize = runAuthorizeWithAllowed allowed + +runAuthorizeWithAllowed :: Set Scope -> ClientType -> AuthorizeParams -> IO (Either AuthorizeError IssuedCode, World) +runAuthorizeWithAllowed registeredScopes clientType params = do + ref <- newWorld + result <- runInMemory ref do + uid <- genUserId + session <- + createSession + NewSession + { userId = uid, + createdAt = t0, + expiresAt = addUTCTime 3600 t0, + actor = Nothing, + oauthClientId = Nothing, + kind = InteractiveSession, + grantedScopes = Set.empty, + authenticatedAt = t0 + } + ocid <- genOAuthClientId + client <- + createOAuthClient + NewOAuthClient + { oauthClientId = ocid, + clientId = idText ocid, + secretHash = case clientType of + ConfidentialClient -> Just "hash" + PublicClient -> Nothing, + clientType, + displayName = "test", + redirectUris = [callbackUri], + allowedScopes = registeredScopes, + createdAt = t0 + } + authorize cfg client (claimsFor uid session.sessionId) params + world <- readIORef ref + pure (result, world) + +expectLeft :: Either AuthorizeError IssuedCode -> IO AuthorizeError +expectLeft = either pure (const (assertFailure "expected the authorize request to be refused")) + +expectRight :: Either AuthorizeError IssuedCode -> IO IssuedCode +expectRight = either (\e -> assertFailure ("expected success, got " <> show e)) pure + +happyPath :: IO () +happyPath = do + (result, world) <- runAuthorize ConfidentialClient baseParams {state = Just "xyz", nonce = Just "n-0S6"} + issued <- expectRight result + issued.state @?= Just "xyz" + issued.grantedScopes @?= allowed + -- Only the digest is stored: the code itself lives in the redirect URL and nowhere else. + case Map.elems (oauthCodes world) of + [stored] -> do + stored.codeHash @?= sha256Hex issued.code + assertBool "the plaintext code is never a key" (Map.notMember issued.code (oauthCodes world)) + stored.nonce @?= Just "n-0S6" + stored.consumedAt @?= Nothing + stored.expiresAt @?= addUTCTime 60 t0 + other -> assertFailure ("expected exactly one stored code, got " <> show (length other)) + -- The audit trail records the authorization without naming the code. + assertBool + "an oauth_code_issued event is published" + (any isCodeIssued (publishedEvents world)) + where + isCodeIssued = \case + Event.OAuthCodeIssued _ -> True + _ -> False + +publicClientNeedsPkce :: IO () +publicClientNeedsPkce = do + (result, _) <- runAuthorize PublicClient baseParams {codeChallenge = Nothing, codeChallengeMethod = Nothing} + e <- expectLeft result + case e of + AuthorizeInvalidRequest _ -> pure () + other -> assertFailure ("expected invalid_request, got " <> show other) + +confidentialMayOmitPkce :: IO () +confidentialMayOmitPkce = do + (result, _) <- runAuthorize ConfidentialClient baseParams {codeChallenge = Nothing, codeChallengeMethod = Nothing} + _ <- expectRight result + pure () + +onlyS256 :: IO () +onlyS256 = do + (result, _) <- runAuthorize ConfidentialClient baseParams {codeChallengeMethod = Just "plain"} + e <- expectLeft result + case e of + AuthorizeInvalidRequest _ -> pure () + other -> assertFailure ("expected invalid_request, got " <> show other) + +-- | RFC 7636 defaults an absent method to @plain@. Accepting that default would silently downgrade +-- a client that meant S256, so the method must be spelled out. +noImplicitPlain :: IO () +noImplicitPlain = do + (result, _) <- runAuthorize ConfidentialClient baseParams {codeChallengeMethod = Nothing} + e <- expectLeft result + case e of + AuthorizeInvalidRequest _ -> pure () + other -> assertFailure ("expected invalid_request, got " <> show other) + +malformedChallenge :: IO () +malformedChallenge = do + (result, _) <- runAuthorize ConfidentialClient baseParams {codeChallenge = Just "too-short"} + e <- expectLeft result + case e of + AuthorizeInvalidRequest _ -> pure () + other -> assertFailure ("expected invalid_request, got " <> show other) + +onlyCodeResponseType :: IO () +onlyCodeResponseType = do + (result, _) <- runAuthorize ConfidentialClient baseParams {responseType = Just "token"} + e <- expectLeft result + e @?= UnsupportedResponseType + +absentScopeGrantsAll :: IO () +absentScopeGrantsAll = do + (result, _) <- runAuthorize ConfidentialClient baseParams {scope = Nothing} + issued <- expectRight result + issued.grantedScopes @?= allowed + +absentScopeStripsPrivileges :: IO () +absentScopeStripsPrivileges = do + let registered = Set.insert (Scope "shomei:admin") allowed + (result, _) <- runAuthorizeWithAllowed registered ConfidentialClient baseParams {scope = Nothing} + issued <- expectRight result + issued.grantedScopes @?= allowed + +requestedPrivilegeScopeFails :: IO () +requestedPrivilegeScopeFails = do + let registered = Set.insert (Scope "shomei:admin") allowed + (result, _) <- + runAuthorizeWithAllowed registered ConfidentialClient baseParams {scope = Just "openid shomei:admin"} + e <- expectLeft result + e @?= AuthorizeInvalidScope + +privilegeOnlyDefaultFails :: IO () +privilegeOnlyDefaultFails = do + (result, _) <- + runAuthorizeWithAllowed (Set.singleton (Scope "shomei:admin")) ConfidentialClient baseParams {scope = Nothing} + e <- expectLeft result + e @?= AuthorizeInvalidScope + +scopeOutsideAllowList :: IO () +scopeOutsideAllowList = do + (result, _) <- runAuthorize ConfidentialClient baseParams {scope = Just "openid admin:everything"} + e <- expectLeft result + e @?= AuthorizeInvalidScope + +emptyScope :: IO () +emptyScope = do + (result, _) <- runAuthorize ConfidentialClient baseParams {scope = Just " "} + e <- expectLeft result + e @?= AuthorizeInvalidScope + +-- | OIDC's @auth_time@ means "when the user authenticated", which is the authorizing access +-- token's carried credential time — an hour ago here — not its refreshed @iat@ or request time. +authTimeIsCredentialTime :: IO () +authTimeIsCredentialTime = do + (result, world) <- runAuthorize ConfidentialClient baseParams + _ <- expectRight result + case Map.elems (oauthCodes world) of + [stored] -> stored.authTime @?= addUTCTime (-3600) t0 + _ -> assertFailure "expected exactly one stored code" + +challengeShape :: IO () +challengeShape = do + assertBool "43 base64url chars is valid" (isValidS256Challenge challenge) + assertBool "42 chars is not" (not (isValidS256Challenge (Text.replicate 42 "a"))) + assertBool "44 chars is not" (not (isValidS256Challenge (Text.replicate 44 "a"))) + -- Standard base64 (+ /) and padding are exactly what a client that forgot base64url emits. + assertBool "'+' is not base64url" (not (isValidS256Challenge (Text.replicate 42 "a" <> "+"))) + assertBool "'/' is not base64url" (not (isValidS256Challenge (Text.replicate 42 "a" <> "/"))) + assertBool "'=' padding is not accepted" (not (isValidS256Challenge (Text.replicate 42 "a" <> "="))) + assertBool "'-' and '_' are base64url" (isValidS256Challenge (Text.replicate 41 "a" <> "-_")) diff --git a/test/Shomei/Passkey/WorkflowSpec.hs b/test/Shomei/Passkey/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Passkey/WorkflowSpec.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DataKinds #-} + +-- | Pure tests for the EP-3 passkey enrollment workflows ('Shomei.Passkey.Workflow'), +-- driven over EP-2's in-memory stores and EP-1's deterministic fake 'WebAuthnCeremony' +-- interpreter via 'Shomei.Test.InMemory.runInMemory'. No HTTP, no cryptography. +-- +-- The fake's @completeRegistrationCeremony@ accepts a credential JSON whose @challenge@ +-- echoes the begin step's options blob and returns the credential id / user handle / public +-- key carried in that JSON, so each test extracts the challenge from the begin response and +-- crafts a matching credential. The same behavior is re-proven over HTTP by the +-- @shomei-servant@ end-to-end test. +module Shomei.Passkey.WorkflowSpec (tests) where + +import Data.Aeson (Value, object, (.=)) +import Data.Aeson.Types (parseMaybe, withObject, (.:)) +import Data.ByteString (ByteString) +import Data.IORef (IORef, newIORef) +import Data.Text (Text) +import Data.Time (UTCTime (..), fromGregorian) +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +import Shomei.Account.LoginId.Domain (LoginId, mkLoginId) +import Shomei.Account.User.Domain (NewUser (..), User (..)) +import Shomei.Account.User.Store (createUser) +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..)) +import Shomei.Config (ShomeiConfig, defaultShomeiConfig) +import Shomei.Error (AuthError (..)) +import Shomei.Id (PasskeyId, UserId, genCeremonyId, genUserId) +import Shomei.Passkey.Ceremony.Port (WebAuthnError (..)) +import Shomei.Passkey.Domain + ( PasskeyCredential (..), + PublicKeyBytes (..), + UserHandle (..), + WebAuthnCredentialId (..), + ) +import Shomei.Passkey.Workflow + ( beginPasskeyRegistration, + completePasskeyRegistration, + listPasskeys, + removePasskey, + ) +import Shomei.Test.InMemory (World, emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Shomei.Passkey.Workflow" + [ testCase "begin then complete stores a passkey; list returns it; remove deletes it" enrollListRemove, + testCase "wrong-user complete is rejected" wrongUserComplete, + testCase "absent ceremony is rejected" absentCeremony, + testCase "an already-consumed ceremony is rejected on the second complete" consumedCeremony, + testCase "a credential the verifier rejects yields WebAuthnCeremonyError" rejectedCredential + ] + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 1 1) 0 + +aliceEmail :: Email +aliceEmail = case mkEmail "alice@example.com" of + Right e -> e + Left err -> error ("bad test email: " <> show err) + +newWorld :: IO (IORef World) +newWorld = newIORef (emptyWorld t0) + +seedUser :: IORef World -> IO UserId +seedUser ref = runInMemory ref do + User {userId} <- createUser NewUser {loginId = either (error . show) id (mkLoginId (emailText aliceEmail)), email = Just aliceEmail, displayName = Just "Ada"} + pure userId + +-- Field accessors (OverloadedRecordDot is unreliable for these EP-1 records). +pkPasskeyId :: PasskeyCredential -> PasskeyId +pkPasskeyId PasskeyCredential {passkeyId} = passkeyId + +pkLabel :: PasskeyCredential -> Maybe Text +pkLabel PasskeyCredential {label} = label + +-- | The challenge the fake baked into a begin step's options JSON (we echo it back). +challengeOf :: Value -> Text +challengeOf v = case parseMaybe (withObject "options" (.: "challenge")) v of + Just c -> c + Nothing -> error "challengeOf: no challenge in options" + +cid1, uh1, pk1 :: ByteString +cid1 = "passkey-cred-1" +uh1 = "passkey-uh-1" +pk1 = "passkey-pk-1" + +-- | A credential JSON the fake accepts: it echoes the challenge and carries base64url bytes. +credentialJson :: Text -> Value +credentialJson chal = + object + [ "challenge" .= chal, + "credentialId" .= WebAuthnCredentialId cid1, + "userHandle" .= UserHandle uh1, + "publicKey" .= PublicKeyBytes pk1 + ] + +mustRight :: (Show e) => Either e a -> IO a +mustRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure + +enrollListRemove :: IO () +enrollListRemove = do + ref <- newWorld + uid <- seedUser ref + (cid, opts) <- mustRight =<< runInMemory ref (beginPasskeyRegistration cfg uid) + pk <- mustRight =<< runInMemory ref (completePasskeyRegistration cfg uid cid (credentialJson (challengeOf opts)) (Just "YubiKey")) + pkLabel pk @?= Just "YubiKey" + -- list returns exactly the enrolled passkey + listed <- runInMemory ref (listPasskeys uid) + map pkPasskeyId listed @?= [pkPasskeyId pk] + -- remove deletes it + _ <- mustRight =<< runInMemory ref (removePasskey uid (pkPasskeyId pk)) + listed2 <- runInMemory ref (listPasskeys uid) + map pkPasskeyId listed2 @?= [] + +wrongUserComplete :: IO () +wrongUserComplete = do + ref <- newWorld + uid <- seedUser ref + otherUid <- genUserId + (cid, opts) <- mustRight =<< runInMemory ref (beginPasskeyRegistration cfg uid) + result <- runInMemory ref (completePasskeyRegistration cfg otherUid cid (credentialJson (challengeOf opts)) Nothing) + result @?= Left PendingCeremonyNotFound + +absentCeremony :: IO () +absentCeremony = do + ref <- newWorld + uid <- seedUser ref + bogusCid <- genCeremonyId + result <- runInMemory ref (completePasskeyRegistration cfg uid bogusCid (credentialJson "anything") Nothing) + result @?= Left PendingCeremonyNotFound + +consumedCeremony :: IO () +consumedCeremony = do + ref <- newWorld + uid <- seedUser ref + (cid, opts) <- mustRight =<< runInMemory ref (beginPasskeyRegistration cfg uid) + _ <- mustRight =<< runInMemory ref (completePasskeyRegistration cfg uid cid (credentialJson (challengeOf opts)) Nothing) + -- the ceremony was consumed by the first complete; a second is rejected + again <- runInMemory ref (completePasskeyRegistration cfg uid cid (credentialJson (challengeOf opts)) Nothing) + again @?= Left PendingCeremonyNotFound + +rejectedCredential :: IO () +rejectedCredential = do + ref <- newWorld + uid <- seedUser ref + (cid, _opts) <- mustRight =<< runInMemory ref (beginPasskeyRegistration cfg uid) + -- a credential whose challenge does not match the ceremony fails verification + result <- runInMemory ref (completePasskeyRegistration cfg uid cid (credentialJson "not-the-challenge") Nothing) + result @?= Left (WebAuthnCeremonyError WebAuthnChallengeMismatch) diff --git a/test/Shomei/PasskeyStoreSpec.hs b/test/Shomei/PasskeyStoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/PasskeyStoreSpec.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE DataKinds #-} + +-- | Pure tests for the in-memory 'Shomei.Passkey.Store' and +-- 'Shomei.Passkey.Ceremony.Store' interpreters +-- ('Shomei.Test.InMemory.runPasskeyStore' / 'runPendingCeremonyStore'). +-- +-- They prove the persistence contract EP-3/EP-4 build on, against the fake 'World': +-- a credential can be created and found three ways (by user, by credential id, by user +-- handle), its signature counter and last-used timestamp bumped, counted per user, and +-- deleted only by its owning user; and a pending ceremony is consumed exactly once and +-- never returned after it has expired. No database is involved — the same behavior is +-- re-proven against real PostgreSQL by @shomei-postgres@'s integration test. +module Shomei.PasskeyStoreSpec (tests) where + +import Data.ByteString (ByteString) +import Data.IORef (IORef, newIORef) +import Data.Maybe (isNothing) +import Data.Text (Text) +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Shomei.Id (CeremonyId, PasskeyId, UserId, genCeremonyId, genUserId) +import Shomei.Passkey.Ceremony.Store (putPendingCeremony, takePendingCeremony) +import Shomei.Passkey.Domain + ( CeremonyKind (..), + NewPasskeyCredential (..), + PasskeyCredential (..), + PendingCeremony (..), + PublicKeyBytes (..), + SignatureCounter (..), + UserHandle (..), + WebAuthnCredentialId (..), + ) +import Shomei.Passkey.Store + ( countPasskeysByUser, + createPasskey, + deletePasskey, + findPasskeyByCredentialId, + findPasskeysByUser, + findPasskeysByUserHandle, + updatePasskeySignCounter, + ) +import Shomei.Test.InMemory (World, emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "PasskeyStore (in-memory)" + [ testCase "create + find by user/credential-id/user-handle" createAndFind, + testCase "update sign counter sets counter and last_used_at" updateSignCounter, + testCase "count passkeys by user" countByUser, + testCase "delete is scoped to the owning user" userScopedDelete, + testGroup + "PendingCeremony (in-memory)" + [ testCase "put then take returns the row exactly once" consumeOnce, + testCase "take of an expired ceremony returns Nothing" expiredTake + ] + ] + +-- Field accessors: OverloadedRecordDot is unreliable for these DuplicateRecordFields +-- records (MasterPlan 3 discovery), so read via plain record-pattern matching. + +pkPasskeyId :: PasskeyCredential -> PasskeyId +pkPasskeyId PasskeyCredential {passkeyId} = passkeyId + +pkSignCounter :: PasskeyCredential -> SignatureCounter +pkSignCounter PasskeyCredential {signCounter} = signCounter + +pkLastUsedAt :: PasskeyCredential -> Maybe UTCTime +pkLastUsedAt PasskeyCredential {lastUsedAt} = lastUsedAt + +pkTransports :: PasskeyCredential -> [Text] +pkTransports PasskeyCredential {transports} = transports + +pkLabel :: PasskeyCredential -> Maybe Text +pkLabel PasskeyCredential {label} = label + +pkCreatedAt :: PasskeyCredential -> UTCTime +pkCreatedAt PasskeyCredential {createdAt} = createdAt + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 1 1) 0 + +t1 :: UTCTime +t1 = addUTCTime 60 t0 + +cid1, uh1, pk1 :: ByteString +cid1 = "cred-1" +uh1 = "uh-1" +pk1 = "pk-1" + +newWorld :: IO (IORef World) +newWorld = newIORef (emptyWorld t0) + +-- | A 'NewPasskeyCredential' for the given user with the canned test bytes. +sampleNew :: UserId -> NewPasskeyCredential +sampleNew uid = + NewPasskeyCredential + { userId = uid, + credentialId = WebAuthnCredentialId cid1, + userHandle = UserHandle uh1, + publicKey = PublicKeyBytes pk1, + signCounter = SignatureCounter 0, + transports = ["internal", "hybrid"], + label = Just "My YubiKey", + createdAt = t0 + } + +-- | Like 'sampleNew' but with a distinct credential id (avoids ambiguous record-update syntax). +sampleNewWithCred :: UserId -> ByteString -> NewPasskeyCredential +sampleNewWithCred uid cidBytes = + NewPasskeyCredential + { userId = uid, + credentialId = WebAuthnCredentialId cidBytes, + userHandle = UserHandle uh1, + publicKey = PublicKeyBytes pk1, + signCounter = SignatureCounter 0, + transports = ["internal", "hybrid"], + label = Just "My YubiKey", + createdAt = t0 + } + +createAndFind :: IO () +createAndFind = do + ref <- newWorld + uid <- genUserId + (created, byUser, byCred, byHandle) <- runInMemory ref do + created <- createPasskey (sampleNew uid) + byUser <- findPasskeysByUser uid + byCred <- findPasskeyByCredentialId (WebAuthnCredentialId cid1) + byHandle <- findPasskeysByUserHandle (UserHandle uh1) + pure (created, byUser, byCred, byHandle) + -- the round-tripped metadata survives unchanged + pkTransports created @?= ["internal", "hybrid"] + pkLabel created @?= Just "My YubiKey" + pkSignCounter created @?= SignatureCounter 0 + pkCreatedAt created @?= t0 + pkLastUsedAt created @?= Nothing + -- all three lookups resolve to the same passkey + map pkPasskeyId byUser @?= [pkPasskeyId created] + fmap pkPasskeyId byCred @?= Just (pkPasskeyId created) + map pkPasskeyId byHandle @?= [pkPasskeyId created] + +updateSignCounter :: IO () +updateSignCounter = do + ref <- newWorld + uid <- genUserId + (advanced, replayed, older, found) <- runInMemory ref do + created <- createPasskey (sampleNew uid) + advanced <- updatePasskeySignCounter (pkPasskeyId created) (SignatureCounter 7) t1 + replayed <- updatePasskeySignCounter (pkPasskeyId created) (SignatureCounter 7) t1 + older <- updatePasskeySignCounter (pkPasskeyId created) (SignatureCounter 6) t1 + found <- findPasskeyByCredentialId (WebAuthnCredentialId cid1) + pure (advanced, replayed, older, found) + (advanced, replayed, older) @?= (True, False, False) + fmap pkSignCounter found @?= Just (SignatureCounter 7) + fmap pkLastUsedAt found @?= Just (Just t1) + +countByUser :: IO () +countByUser = do + ref <- newWorld + uid <- genUserId + otherUid <- genUserId + n <- runInMemory ref do + _ <- createPasskey (sampleNew uid) + -- a second passkey for the same user (distinct credential id) + _ <- createPasskey (sampleNewWithCred uid "cred-2") + -- a third for a different user + _ <- createPasskey (sampleNewWithCred otherUid "cred-3") + countPasskeysByUser uid + n @?= 2 + +userScopedDelete :: IO () +userScopedDelete = do + ref <- newWorld + uid <- genUserId + otherUid <- genUserId + (afterWrongUser, afterOwner) <- runInMemory ref do + created <- createPasskey (sampleNew uid) + let pid = pkPasskeyId created + deletePasskey otherUid pid -- wrong user: no-op + afterWrongUser <- findPasskeyByCredentialId (WebAuthnCredentialId cid1) + deletePasskey uid pid -- owner: removes it + afterOwner <- findPasskeyByCredentialId (WebAuthnCredentialId cid1) + pure (afterWrongUser, afterOwner) + assertBool "wrong-user delete leaves the passkey present" (maybe False (const True) afterWrongUser) + assertBool "owner delete removes the passkey" (isNothing afterOwner) + +samplePending :: CeremonyId -> UTCTime -> PendingCeremony +samplePending cid expiry = + PendingCeremony + { ceremonyId = cid, + userId = Nothing, + kind = RegistrationCeremony, + optionsBlob = "{\"challenge\":\"abc\"}", + createdAt = t0, + expiresAt = expiry + } + +consumeOnce :: IO () +consumeOnce = do + ref <- newWorld + cid <- genCeremonyId + (first, second) <- runInMemory ref do + putPendingCeremony (samplePending cid (addUTCTime 300 t0)) + first <- takePendingCeremony cid t0 + second <- takePendingCeremony cid t0 + pure (first, second) + assertBool "first take returns the ceremony" (maybe False (const True) first) + assertBool "second take returns Nothing" (isNothing second) + +expiredTake :: IO () +expiredTake = do + ref <- newWorld + cid <- genCeremonyId + (firstTake, afterTake) <- runInMemory ref do + putPendingCeremony (samplePending cid (addUTCTime 60 t0)) + -- "now" is past expiry: returns Nothing and removes the stale row + firstTake <- takePendingCeremony cid (addUTCTime 120 t0) + afterTake <- takePendingCeremony cid (addUTCTime 120 t0) + pure (firstTake, afterTake) + assertBool "expired take returns Nothing" (isNothing firstTake) + assertBool "subsequent take also Nothing" (isNothing afterTake) diff --git a/test/Shomei/ServiceAccount/ClientCredentials/WorkflowSpec.hs b/test/Shomei/ServiceAccount/ClientCredentials/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/ServiceAccount/ClientCredentials/WorkflowSpec.hs @@ -0,0 +1,236 @@ +-- | Unit tests for the EP-4 @client_credentials@ grant over database-backed service accounts, +-- run against the in-memory interpreters with a fixed clock and a fake signer. +-- +-- The security-relevant property these pin down: an unknown @client_id@, a wrong secret, a +-- revoked account, and an inactive backing user all yield exactly 'OAuthClientInvalid'. A caller +-- must not be able to tell them apart. +module Shomei.ServiceAccount.ClientCredentials.WorkflowSpec (tests) where + +import Data.Aeson (eitherDecode) +import Data.Generics.Labels () +import Data.IORef (IORef, newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TLE +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Shomei.Account.Email.Domain (mkEmail) +import Shomei.Account.LoginId.Domain (LoginId, mkLoginId) +import Shomei.Account.Password.Domain (PlainPassword (..)) +import Shomei.Account.User.Domain (User (..), UserStatus (UserActive, UserSuspended)) +import Shomei.Account.User.Store (updateUserStatus) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Scope (..)) +import Shomei.Config (ServiceAccountId (..), ShomeiConfig (..), defaultShomeiConfig) +import Shomei.Error (AuthError (..)) +import Shomei.Id (ServiceAccountDbId, UserId, genServiceAccountDbId, idText) +import Shomei.Prelude +import Shomei.ServiceAccount.ClientCredentials.Workflow (ClientCredentialsGrant (..), GrantedToken (..), grantClientCredentials) +import Shomei.ServiceAccount.Domain (NewServiceAccount (..), ServiceAccount (..)) +import Shomei.ServiceAccount.Secret (sha256Hex) +import Shomei.ServiceAccount.Store (createServiceAccount, revokeServiceAccount) +import Shomei.Session.Authentication.Workflow (signup) +import Shomei.Session.Command (SignupCommand (..)) +import Shomei.Session.RefreshToken.Domain (PersistedRefreshToken (..)) +import Shomei.Session.Token.Domain (AccessToken (..)) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +baseCfg :: ShomeiConfig +baseCfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +clientSecret' :: Text +clientSecret' = "test-secret" + +ingestScope, signalScope, egressScope :: Scope +ingestScope = Scope "kawa:ingest" +signalScope = Scope "signal:raise" +egressScope = Scope "channel:egress" + +allowedScopes' :: Set Scope +allowedScopes' = Set.fromList [ingestScope, signalScope] + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +expectRight :: (Show e) => Either e a -> IO a +expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure + +decodeAccess :: AccessToken -> IO AuthClaims +decodeAccess (AccessToken t) = + either + (\e -> assertFailure ("could not decode access token: " <> e)) + pure + (eitherDecode (TLE.encodeUtf8 (TL.fromStrict t))) + +mkLoginId' :: Text -> LoginId +mkLoginId' t = either (\e -> error ("bad test login id: " <> show e)) id (mkLoginId t) + +-- | The backing user every service account needs: 'AuthClaims.subject' is a 'UserId', and a +-- session cannot exist without one. +seedUser :: IORef World -> Text -> IO User +seedUser ref name = do + let loginId = mkLoginId' name + email = either (\e -> error ("bad test email: " <> show e)) id (mkEmail (name <> "@example.com")) + (user, _) <- + expectRight + =<< runInMemory + ref + (signup baseCfg SignupCommand {loginId, email = Just email, password = strongPw, displayName = Just name}) + pure user + +-- | Seed an active service account whose @client_id@ is its id's TypeID text. +seedAccount :: IORef World -> UserId -> IO ServiceAccount +seedAccount ref uid = runInMemory ref do + said <- genServiceAccountDbId + createServiceAccount + NewServiceAccount + { serviceAccountId = said, + clientId = idText said, + userId = uid, + secretHash = sha256Hex clientSecret', + displayName = "rei connector", + allowedScopes = allowedScopes', + createdAt = fixedTime + } + +saClientId :: ServiceAccount -> Text +saClientId ServiceAccount {clientId} = clientId + +saId :: ServiceAccount -> ServiceAccountDbId +saId ServiceAccount {serviceAccountId} = serviceAccountId + +-- | A grant request naming the given account, with the correct secret and no @scope@ parameter. +grantFor :: ServiceAccount -> ClientCredentialsGrant +grantFor account = + ClientCredentialsGrant + { clientId = saClientId account, + clientSecret = clientSecret', + requestedScopes = Nothing + } + +-- | Seed a user and an account, then run one grant against them. +withAccount :: (ServiceAccount -> ClientCredentialsGrant) -> IO (IORef World, Either AuthError GrantedToken) +withAccount mkGrant = do + ref <- newIORef (emptyWorld fixedTime) + serviceUser <- seedUser ref "connector-rei" + account <- seedAccount ref serviceUser.userId + res <- runInMemory ref (grantClientCredentials baseCfg (mkGrant account)) + pure (ref, res) + +tests :: TestTree +tests = + testGroup + "Shomei.ServiceAccount.ClientCredentials.Workflow" + [ testOmittedScopeGrantsAll, + testRequestedScopeSubset, + testUnknownClient, + testWrongSecret, + testRevokedAccount, + testInactiveBackingUser, + testScopeOutsideAllowList, + testEmptyScopeSet, + testNoRefreshToken, + testFailureDoesNotMint + ] + +testOmittedScopeGrantsAll :: TestTree +testOmittedScopeGrantsAll = testCase "an omitted scope parameter grants every allowed scope" do + ref <- newIORef (emptyWorld fixedTime) + serviceUser <- seedUser ref "connector-rei" + account <- seedAccount ref serviceUser.userId + granted <- expectRight =<< runInMemory ref (grantClientCredentials baseCfg (grantFor account)) + granted.grantedScopes @?= allowedScopes' + -- the default TTL for machine tokens, shared with the config-defined path + granted.expiresIn @?= 300 + claims <- decodeAccess granted.accessToken + claims.subject @?= serviceUser.userId + claims.scopes @?= allowedScopes' + claims.expiresAt @?= addUTCTime 300 fixedTime + -- client_credentials is not a delegation: there is no actor on behalf of whom it acts + claims.actor @?= Nothing + +testRequestedScopeSubset :: TestTree +testRequestedScopeSubset = testCase "a requested subset is granted, and echoed back" do + (_, res) <- withAccount \a -> (grantFor a) {requestedScopes = Just (Set.singleton ingestScope)} + granted <- expectRight res + granted.grantedScopes @?= Set.singleton ingestScope + claims <- decodeAccess granted.accessToken + claims.scopes @?= Set.singleton ingestScope + +testUnknownClient :: TestTree +testUnknownClient = testCase "an unknown client id is invalid_client" do + (_, res) <- withAccount \a -> (grantFor a) {clientId = "svcacct_does_not_exist"} + fmap (const ()) res @?= Left OAuthClientInvalid + +testWrongSecret :: TestTree +testWrongSecret = testCase "a wrong secret is invalid_client, indistinguishable from an unknown client" do + (_, res) <- withAccount \a -> (grantFor a) {clientSecret = "wrong"} + fmap (const ()) res @?= Left OAuthClientInvalid + +testRevokedAccount :: TestTree +testRevokedAccount = testCase "a revoked account is invalid_client, indistinguishable from a wrong secret" do + ref <- newIORef (emptyWorld fixedTime) + serviceUser <- seedUser ref "connector-rei" + account <- seedAccount ref serviceUser.userId + _ <- runInMemory ref (revokeServiceAccount (saId account) fixedTime) + res <- runInMemory ref (grantClientCredentials baseCfg (grantFor account)) + fmap (const ()) res @?= Left OAuthClientInvalid + +testInactiveBackingUser :: TestTree +testInactiveBackingUser = testCase "an inactive backing user is invalid_client" do + ref <- newIORef (emptyWorld fixedTime) + serviceUser <- seedUser ref "connector-rei" + account <- seedAccount ref serviceUser.userId + _ <- runInMemory ref (updateUserStatus serviceUser.userId [UserActive] UserSuspended fixedTime) + res <- runInMemory ref (grantClientCredentials baseCfg (grantFor account)) + fmap (const ()) res @?= Left OAuthClientInvalid + +testScopeOutsideAllowList :: TestTree +testScopeOutsideAllowList = testCase "a scope outside allowed_scopes is invalid_scope" do + (_, res) <- withAccount \a -> (grantFor a) {requestedScopes = Just (Set.singleton egressScope)} + fmap (const ()) res @?= Left OAuthScopeInvalid + +testEmptyScopeSet :: TestTree +testEmptyScopeSet = testCase "an explicitly empty scope parameter is invalid_scope, not 'grant nothing'" do + (_, res) <- withAccount \a -> (grantFor a) {requestedScopes = Just Set.empty} + fmap (const ()) res @?= Left OAuthScopeInvalid + +testNoRefreshToken :: TestTree +testNoRefreshToken = testCase "the minted session carries no refresh token" do + ref <- newIORef (emptyWorld fixedTime) + serviceUser <- seedUser ref "connector-rei" + account <- seedAccount ref serviceUser.userId + granted <- expectRight =<< runInMemory ref (grantClientCredentials baseCfg (grantFor account)) + world <- readIORef ref + let forSession = filter (\PersistedRefreshToken {sessionId} -> sessionId == granted.sessionId) (Map.elems world.refreshTokens) + assertBool "client_credentials session has no refresh token" (null forSession) + -- exactly one ServiceTokenIssued, naming the account by its client id + assertBool + "ServiceTokenIssued published once for the client id" + (length (filter (matchesIssued (saClientId account)) world.publishedEvents) == 1) + where + matchesIssued cid = \case + Event.ServiceTokenIssued d -> (d ^. #accountId) == ServiceAccountId cid && isNothing (d ^. #actorId) + _ -> False + +testFailureDoesNotMint :: TestTree +testFailureDoesNotMint = testCase "a failed grant creates no session and publishes no event" do + ref <- newIORef (emptyWorld fixedTime) + serviceUser <- seedUser ref "connector-rei" + account <- seedAccount ref serviceUser.userId + before <- readIORef ref + res <- runInMemory ref (grantClientCredentials baseCfg ((grantFor account) {clientSecret = "wrong"})) + fmap (const ()) res @?= Left OAuthClientInvalid + after <- readIORef ref + length after.sessions @?= length before.sessions + assertBool "no ServiceTokenIssued event on failure" (not (any isServiceTokenIssued after.publishedEvents)) + where + isServiceTokenIssued = \case + Event.ServiceTokenIssued _ -> True + _ -> False diff --git a/test/Shomei/ServiceAccountStoreSpec.hs b/test/Shomei/ServiceAccountStoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/ServiceAccountStoreSpec.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DataKinds #-} + +-- | Pure tests for the in-memory 'Shomei.ServiceAccount.Store' interpreter +-- ('Shomei.Test.InMemory.runServiceAccountStore'). +-- +-- They prove the persistence contract EP-4's @client_credentials@ grant builds on, against the +-- fake 'World': an account can be created and found by its client id; its secret can be rotated +-- (the new hash is what a later lookup sees, and @rotated_at@ is stamped); it can be revoked +-- (status flips, @revoked_at@ is stamped, and the row survives so the lookup still resolves); +-- and the listing is newest-first. No database is involved — the same behavior is re-proven +-- against real PostgreSQL by @shomei-postgres@'s integration test. +-- +-- Each case runs its port actions inside 'runInMemory' and asserts on the returned values in +-- 'IO', which is how the sibling 'Shomei.PasskeyStoreSpec' is written. +module Shomei.ServiceAccountStoreSpec (tests) where + +import Control.Monad.IO.Class (MonadIO) +import Data.IORef (IORef, newIORef) +import Data.Maybe (isNothing) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Shomei.Authorization.Claims.Domain (Scope (..)) +import Shomei.Id (ServiceAccountDbId, UserId, genServiceAccountDbId, genUserId, idText) +import Shomei.ServiceAccount.Domain + ( NewServiceAccount (..), + ServiceAccount (..), + ServiceAccountStatus (..), + ) +import Shomei.ServiceAccount.Store + ( createServiceAccount, + findServiceAccountByClientId, + listServiceAccounts, + revokeServiceAccount, + rotateServiceAccountSecret, + ) +import Shomei.Test.InMemory (World, emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "ServiceAccountStore (in-memory)" + [ testCase "create then find by client id" createAndFind, + testCase "find by an unknown client id returns Nothing" findUnknown, + testCase "rotate replaces the hash and stamps rotated_at" rotateSecret, + testCase "revoke flips status, stamps revoked_at, and keeps the row" revoke, + testCase "list is newest-first" listNewestFirst + ] + +-- Field accessors: OverloadedRecordDot is unreliable for these DuplicateRecordFields +-- records (MasterPlan 3 discovery), so read them by record-pattern matching. + +saStatus :: ServiceAccount -> ServiceAccountStatus +saStatus ServiceAccount {status} = status + +saSecretHash :: ServiceAccount -> Text +saSecretHash ServiceAccount {secretHash} = secretHash + +saRotatedAt :: ServiceAccount -> Maybe UTCTime +saRotatedAt ServiceAccount {rotatedAt} = rotatedAt + +saRevokedAt :: ServiceAccount -> Maybe UTCTime +saRevokedAt ServiceAccount {revokedAt} = revokedAt + +saClientId :: ServiceAccount -> Text +saClientId ServiceAccount {clientId} = clientId + +saAllowedScopes :: ServiceAccount -> Set Scope +saAllowedScopes ServiceAccount {allowedScopes} = allowedScopes + +saId :: ServiceAccount -> ServiceAccountDbId +saId ServiceAccount {serviceAccountId} = serviceAccountId + +saDisplayName :: ServiceAccount -> Text +saDisplayName ServiceAccount {displayName} = displayName + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 7 10) 0 + +newWorld :: IO (IORef World) +newWorld = newIORef (emptyWorld t0) + +ingestScope :: Set Scope +ingestScope = Set.singleton (Scope "kawa:ingest") + +-- | Build a 'NewServiceAccount' whose @client_id@ is its id's TypeID text, exactly as the CLI +-- does. Runs in any 'MonadIO' so it can be called straight from an 'Eff' block. +mkNew :: (MonadIO m) => UserId -> UTCTime -> Text -> m NewServiceAccount +mkNew uid createdAt displayName = do + said <- genServiceAccountDbId + pure + NewServiceAccount + { serviceAccountId = said, + clientId = idText said, + userId = uid, + secretHash = "hash-one", + displayName, + allowedScopes = ingestScope, + createdAt + } + +createAndFind :: IO () +createAndFind = do + ref <- newWorld + (created, found) <- runInMemory ref do + uid <- genUserId + new <- mkNew uid t0 "rei connector" + created <- createServiceAccount new + found <- findServiceAccountByClientId (saClientId created) + pure (created, found) + saStatus created @?= ServiceAccountActive + saRotatedAt created @?= Nothing + saRevokedAt created @?= Nothing + saAllowedScopes created @?= ingestScope + fmap saId found @?= Just (saId created) + +findUnknown :: IO () +findUnknown = do + ref <- newWorld + found <- runInMemory ref (findServiceAccountByClientId "svcacct_nope") + assertBool "unknown client id must not resolve" (isNothing found) + +rotateSecret :: IO () +rotateSecret = do + ref <- newWorld + let rotatedTime = addUTCTime 3600 t0 + found <- runInMemory ref do + uid <- genUserId + new <- mkNew uid t0 "rei connector" + created <- createServiceAccount new + rotateServiceAccountSecret (saId created) "hash-two" rotatedTime + findServiceAccountByClientId (saClientId created) + fmap saSecretHash found @?= Just "hash-two" + fmap saRotatedAt found @?= Just (Just rotatedTime) + -- Rotation does not revoke. + fmap saStatus found @?= Just ServiceAccountActive + +revoke :: IO () +revoke = do + ref <- newWorld + let revokedTime = addUTCTime 7200 t0 + found <- runInMemory ref do + uid <- genUserId + new <- mkNew uid t0 "rei connector" + created <- createServiceAccount new + revokeServiceAccount (saId created) revokedTime + -- The row survives revocation: the grant workflow must be able to see that this client + -- exists and is revoked, so it can refuse it exactly as it refuses a wrong secret. + findServiceAccountByClientId (saClientId created) + fmap saStatus found @?= Just ServiceAccountRevoked + fmap saRevokedAt found @?= Just (Just revokedTime) + +listNewestFirst :: IO () +listNewestFirst = do + ref <- newWorld + accounts <- runInMemory ref do + uid <- genUserId + older <- mkNew uid t0 "older" + newer <- mkNew uid (addUTCTime 60 t0) "newer" + _ <- createServiceAccount older + _ <- createServiceAccount newer + listServiceAccounts + map saDisplayName accounts @?= ["newer", "older"] diff --git a/test/Shomei/Session/Authentication/ConcurrencySpec.hs b/test/Shomei/Session/Authentication/ConcurrencySpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Session/Authentication/ConcurrencySpec.hs @@ -0,0 +1,306 @@ +-- | Concurrency regression tests for the compare-and-swap token-state transitions. +-- +-- Every one of these cases would pass trivially if the workflows were run sequentially; what +-- they prove is that /simultaneous/ presentations of the same single-use secret cannot both +-- succeed. They run many green threads against one shared 'IORef' 'World' — the in-memory +-- interpreters mutate it with 'Data.IORef.atomicModifyIORef'', which gives the same +-- "inspect and transition in one indivisible step" guarantee that PostgreSQL's row lock gives +-- the @UPDATE … WHERE status = 'active' RETURNING@ statements. +-- +-- Reverting either CAS (in "Shomei.Test.InMemory") to a plain @modifyIORef'@ plus an +-- unconditional adjust makes these tests fail with two or more winners. +module Shomei.Session.Authentication.ConcurrencySpec (tests) where + +import Control.Concurrent (MVar, newEmptyMVar, putMVar, readMVar) +import Control.Concurrent.Async (mapConcurrently) +import Control.Monad (replicateM, when) +import Data.Either (partitionEithers) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Time (UTCTime (..), fromGregorian) +import Effectful (Eff, IOE, liftIO, (:>)) +import Effectful.Dispatch.Dynamic (interpose, passthrough) +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +-- Qualified: several 'AuthError' constructors share names with 'SessionStatus' constructors. + +import Shomei.Account.Lifecycle.Workflow + ( ConfirmPasswordReset (..), + RequestPasswordReset (..), + confirmPasswordReset, + requestPasswordReset, + ) +import Shomei.Account.LoginId.Domain (loginIdText, mkLoginId) +import Shomei.Account.Notification.Domain (Notification (..)) +import Shomei.Account.OneTimeToken.Domain (OneTimeToken) +import Shomei.Account.Password.Domain (PasswordHash (..), PlainPassword (..)) +import Shomei.Account.Password.Hash.Store (PasswordHasher (..)) +import Shomei.Account.User.Domain (User (..)) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..)) +import Shomei.Config (RateLimitConfig (..), ShomeiConfig (..), defaultShomeiConfig) +import Shomei.Error qualified as Err +import Shomei.Id (CeremonyId, genTotpCredentialId) +import Shomei.Mfa.Totp.Algorithm (TotpSecret (..), totpCode, totpCounter) +import Shomei.Mfa.Totp.Domain (NewTotpCredential (..)) +import Shomei.Mfa.Totp.Store (TotpCredentialStore (..), confirmTotp, upsertTotpEnrollment) +import Shomei.Mfa.Workflow (MfaCompletion (MfaTotp), completeMfa) +import Shomei.Session.Authentication.Workflow (LoginResult (..), MfaChallenge (..), login, refresh, signup) +import Shomei.Session.Command (ClientContext (..), LoginCommand (..), ProofContext (..), RefreshCommand (..), SignupCommand (..)) +import Shomei.Session.Domain (Session (..), SessionStatus (..)) +import Shomei.Session.LoginAttempt.Domain (AccountKey (..), AccountLockout (..), ClientIp (..)) +import Shomei.Session.RefreshToken.Domain (PersistedRefreshToken (..), RefreshToken) +import Shomei.Session.Token.Domain (TokenPair (..)) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +-- | How many threads race for one token, and how many times the whole scenario is repeated +-- to shake different schedulings out of the runtime. +racers, rounds :: Int +racers = 100 +rounds = 10 + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +aliceEmail :: Email +aliceEmail = mkEmail' "alice@example.com" + +strongPw, newPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" +newPw = PlainPassword "correct horse battery staple two" + +mkEmail' :: Text -> Email +mkEmail' t = case mkEmail t of + Right e -> e + Left err -> error ("bad test email: " <> show err) + +expectRight :: (Show e) => Either e a -> IO a +expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure + +tests :: TestTree +tests = + testGroup + "Shomei.Session.Authentication.Workflow.Concurrency" + [ testConcurrentRefreshHasOneWinner, + testConcurrentPasswordResetHasOneWinner, + testConcurrentWrongPasswordsRespectTheBudget, + testConcurrentTotpCompletionsHaveOneWinner + ] + +signupCmd :: Email -> SignupCommand +signupCmd e = + SignupCommand {loginId = either (error . show) id (mkLoginId (emailText e)), email = Just e, password = strongPw, displayName = Nothing} + +-- | Sign up, then hand back the refresh token every racer will present. +signupThenRace :: IORef World -> IO RefreshToken +signupThenRace ref = do + (_, pair) <- expectRight =<< runInMemory ref (signup cfg (signupCmd aliceEmail)) + pure pair.refreshToken + +-- | Sign up and request a password reset, then hand back the raw one-time token from the +-- notification the in-memory 'Shomei.Account.Notification.Store' captured. +resetRequestedWorld :: IORef World -> IO OneTimeToken +resetRequestedWorld ref = do + _ <- expectRight =<< runInMemory ref (signup cfg (signupCmd aliceEmail)) + _ <- expectRight =<< runInMemory ref (requestPasswordReset cfg (RequestPasswordReset aliceEmail)) + w <- readIORef ref + case w.sentNotifications of + PasswordResetRequested {token = raw} : _ -> pure raw + _ -> assertFailure "expected a password-reset notification carrying a token" + +testConcurrentRefreshHasOneWinner :: TestTree +testConcurrentRefreshHasOneWinner = + testCase (show racers <> " concurrent refreshes: exactly one winner") do + mapM_ (const oneRound) [1 .. rounds] + where + oneRound = do + ref <- newIORef (emptyWorld fixedTime) + tok <- signupThenRace ref + results <- mapConcurrently (const (runInMemory ref (refresh cfg (RefreshCommand tok)))) [1 .. racers] + let (failures, winners) = partitionEithers results + length winners @?= 1 + -- A loser either lost the compare-and-swap, or arrived after another loser had already + -- revoked the family (reuse), or after the session itself was revoked. All three are + -- 401s; none is a rotation. + assertBool + ("unexpected failure among losers: " <> show failures) + (all (`elem` [Err.RefreshTokenReuseDetected, Err.SessionRevoked]) failures) + w <- readIORef ref + -- The presented token forked no second branch: at most one child was ever created. + let children = filter (isJust . (.parentTokenId)) (Map.elems w.refreshTokens) + assertBool ("token family forked into " <> show (length children) <> " children") (length children <= 1) + -- Losers exist (99 of them), so the theft response fired: the session is revoked. + assertBool + "session was not revoked by the reuse response" + (all (\s -> s.status == SessionRevoked) (Map.elems w.sessions)) + length (filter isReuse w.publishedEvents) @?= 1 + isReuse (Event.RefreshTokenReuseDetected _) = True + isReuse _ = False + +testConcurrentPasswordResetHasOneWinner :: TestTree +testConcurrentPasswordResetHasOneWinner = + testCase (show racers <> " concurrent password-reset confirms: exactly one winner") do + mapM_ (const oneRound) [1 .. rounds] + where + oneRound = do + ref <- newIORef (emptyWorld fixedTime) + raw <- resetRequestedWorld ref + results <- + mapConcurrently + (const (runInMemory ref (confirmPasswordReset cfg (ConfirmPasswordReset raw newPw)))) + [1 .. racers] + let (failures, winners) = partitionEithers results + length winners @?= 1 + assertBool + ("unexpected failure among losers: " <> show failures) + (all (== Err.PasswordResetTokenInvalid) failures) + -- The sharper assertion: the password was changed exactly once, not 100 times. + w <- readIORef ref + length (filter isCompleted w.publishedEvents) @?= 1 + isCompleted (Event.PasswordResetCompleted _) = True + isCompleted _ = False + +-- | Count stored-hash and dummy-hash verification separately while preserving the deterministic +-- fake hash format used by 'runInMemory'. The distinction proves that the account budget bounds +-- real guesses even though every request still pays one Argon2-equivalent operation. +countingPasswordHasher :: + (PasswordHasher :> es, IOE :> es) => + IORef Int -> + IORef Int -> + Eff es a -> + Eff es a +countingPasswordHasher realCalls dummyCalls = interpose \_env -> \case + HashPassword (PlainPassword pw) -> pure (PasswordHash ("argon2-fake:" <> pw)) + VerifyPassword (PlainPassword pw) (PasswordHash h) -> do + liftIO (atomicModifyIORef' realCalls \n -> (n + 1, ())) + pure (h == "argon2-fake:" <> pw) + VerifyPasswordDummy _ -> + liftIO (atomicModifyIORef' dummyCalls \n -> (n + 1, ())) + +testConcurrentWrongPasswordsRespectTheBudget :: TestTree +testConcurrentWrongPasswordsRespectTheBudget = + testCase (show racers <> " concurrent wrong passwords: at most 3 real verifications, one lock") do + ref <- newIORef (emptyWorld fixedTime) + realCalls <- newIORef 0 + dummyCalls <- newIORef 0 + let raceCfg = + cfg + { rateLimitConfig = + cfg.rateLimitConfig + { maxFailedLoginsPerAccount = 3, + maxFailedLoginsPerIp = racers + 1 + } + } + lid = either (error . show) id (mkLoginId (emailText aliceEmail)) + ctx = ClientContext (ClientIp "10.0.0.9") (AccountKey (loginIdText lid)) + wrongLogin = login raceCfg ctx (LoginCommand lid (PlainPassword "wrong password")) + _ <- + expectRight + =<< runInMemory + ref + (countingPasswordHasher realCalls dummyCalls (signup raceCfg (signupCmd aliceEmail))) + writeIORef realCalls 0 + writeIORef dummyCalls 0 + + results <- + mapConcurrently + (const (runInMemory ref (countingPasswordHasher realCalls dummyCalls wrongLogin))) + [1 .. racers] + assertBool ("unexpected result among wrong-password racers: " <> show results) (all (== Left Err.InvalidCredentials) results) + real <- readIORef realCalls + dummy <- readIORef dummyCalls + assertBool ("real verifications exceeded the budget: " <> show real) (real <= 3) + real + dummy @?= racers + w <- readIORef ref + length (filter isAccountLocked w.publishedEvents) @?= 1 + assertBool "account was not locked" (isJust (Map.lookup ctx.accountKey w.accountLockouts >>= (.lockedUntil))) + where + isAccountLocked (Event.AccountLocked _) = True + isAccountLocked _ = False + +testConcurrentTotpCompletionsHaveOneWinner :: TestTree +testConcurrentTotpCompletionsHaveOneWinner = + testCase (show racers <> " concurrent submissions of one TOTP code: exactly one winner") do + mapM_ (const oneRound) [1 .. rounds] + where + secret = TotpSecret "12345678901234567890" + proofContext = ProofContext {clientIp = ClientIp "10.0.0.10", accountKeyOf = AccountKey} + raceCfg = + cfg + { rateLimitConfig = + cfg.rateLimitConfig + { maxFailedLoginsPerAccount = racers + 1, + maxFailedLoginsPerIp = racers + 1 + } + } + + oneRound = do + ref <- newIORef (emptyWorld fixedTime) + (user, _) <- expectRight =<< runInMemory ref (signup raceCfg (signupCmd aliceEmail)) + tcid <- genTotpCredentialId + runInMemory ref do + _ <- + upsertTotpEnrollment + NewTotpCredential + { totpCredentialId = tcid, + userId = user.userId, + secret, + createdAt = fixedTime + } + confirmTotp tcid fixedTime + + ceremonies <- replicateM racers (loginExpectingTotpChallenge ref) + let code = totpCode 6 secret (totpCounter fixedTime) + readCount <- newIORef 0 + allRead <- newEmptyMVar + results <- + mapConcurrently + ( \cid -> + runInMemory + ref + (synchronizeTotpRead readCount allRead (completeMfa raceCfg proofContext cid (MfaTotp code))) + ) + ceremonies + let (failures, winners) = partitionEithers results + length winners @?= 1 + assertBool + ("unexpected failure among replay losers: " <> show failures) + (all (== Err.TotpCodeInvalid) failures) + w <- readIORef ref + length (filter isMfaSucceeded w.publishedEvents) @?= 1 + + loginExpectingTotpChallenge :: IORef World -> IO CeremonyId + loginExpectingTotpChallenge ref = do + let lid = either (error . show) id (mkLoginId (emailText aliceEmail)) + ctx = ClientContext (ClientIp "10.0.0.10") (AccountKey (loginIdText lid)) + result <- expectRight =<< runInMemory ref (login raceCfg ctx (LoginCommand lid strongPw)) + case result of + MfaRequired MfaChallenge {ceremonyId} -> pure ceremonyId + LoginComplete _ _ -> assertFailure "expected a TOTP MFA challenge" + + -- Force every completion to verify against the same stale high-water mark before any one + -- of them may advance it. This makes the old read-then-unconditional-write behavior fail + -- deterministically instead of relying on a favorable scheduler interleaving. + synchronizeTotpRead :: + (TotpCredentialStore :> es, IOE :> es) => + IORef Int -> + MVar () -> + Eff es a -> + Eff es a + synchronizeTotpRead readCount allRead = interpose \env -> \case + op@(FindTotpByUser _) -> do + result <- passthrough env op + isLast <- liftIO (atomicModifyIORef' readCount \n -> let n' = n + 1 in (n', n' == racers)) + when isLast (liftIO (putMVar allRead ())) + liftIO (readMVar allRead) + pure result + op -> passthrough env op + + isMfaSucceeded (Event.MfaSucceeded _) = True + isMfaSucceeded _ = False diff --git a/test/Shomei/Session/Authentication/TimingSpec.hs b/test/Shomei/Session/Authentication/TimingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Session/Authentication/TimingSpec.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE DataKinds #-} + +-- | The login timing oracle: a failed login must perform the same password-hashing work no +-- matter /why/ it failed, or an attacker can enumerate accounts by measuring response time. +-- +-- The security property under test is "every login attempt invokes the password hasher +-- exactly once". That is asserted with an invocation counter rather than a stopwatch: +-- Argon2id at the production parameters costs ~100 ms, so a wall-clock assertion would be +-- both slow and flaky, while the counter is exact. +-- +-- Equal invocation counts imply equal cost because the two hashing operations a login can +-- reach — 'VerifyPassword' on a stored hash, and 'VerifyPasswordDummy' on the paths that have +-- no stored hash to check — are derived by the real interpreter +-- ('Shomei.Account.Password.Hash.Postgres.runPasswordHasherCrypto') with the /same/ Argon2 parameters. That is why +-- the dummy is a port operation rather than a constant hash: a constant would keep whatever +-- parameters it was baked with, and an operator retuning the cost would silently make misses +-- and hits take measurably different times again. +module Shomei.Session.Authentication.TimingSpec (tests) where + +import Control.Monad (replicateM_, void) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Time (UTCTime (..), fromGregorian) +import Effectful (Eff, IOE, liftIO, runEff, (:>)) +import Effectful.Dispatch.Dynamic (interpret_) +import Shomei.Account.Credential.Store (CredentialStore) +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +import Shomei.Account.LoginId.Domain (LoginId, loginIdText, mkLoginId) +import Shomei.Account.Notification.Store (Notifier) +import Shomei.Account.Password.Breach.Store (PasswordBreachChecker) +import Shomei.Account.Password.Domain (PasswordHash (..), PlainPassword (..)) +import Shomei.Account.Password.Hash.Store (PasswordHasher (..)) +import Shomei.Account.PasswordReset.Store (PasswordResetTokenStore) +import Shomei.Account.User.Domain (User (..), UserStatus (UserActive, UserSuspended)) +import Shomei.Account.User.Store (UserStore, updateUserStatus) +import Shomei.Account.Verification.Store (VerificationTokenStore) +import Shomei.Audit.Publisher.Store (AuthEventPublisher) +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..)) +import Shomei.Authorization.Claims.Store (ClaimsEnricher) +import Shomei.Authorization.Role.Store (RoleStore) +import Shomei.Config (ShomeiConfig (..), defaultShomeiConfig) +import Shomei.Error (AuthError (InvalidCredentials, UserNotActive)) +import Shomei.Mfa.RecoveryCode.Store (RecoveryCodeStore) +import Shomei.Mfa.Totp.Store (TotpCredentialStore) +import Shomei.Passkey.Ceremony.Port (WebAuthnCeremony) +import Shomei.Passkey.Ceremony.Store (PendingCeremonyStore) +import Shomei.Passkey.Store (PasskeyStore) +import Shomei.Session.Authentication.Workflow (login, signup) +import Shomei.Session.Command (ClientContext (..), LoginCommand (..), SignupCommand (..)) +import Shomei.Session.LoginAttempt.Domain (AccountKey (..), ClientIp (..)) +import Shomei.Session.LoginAttempt.Store (LoginAttemptStore) +import Shomei.Session.RefreshToken.Store (RefreshTokenStore) +import Shomei.Session.Store (SessionStore) +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.Test.InMemory + ( World (..), + emptyWorld, + runAuthEventPublisher, + runAuthUnitOfWork, + runClaimsEnricherNull, + runClock, + runCredentialStore, + runLoginAttemptStore, + runNotifier, + runPasskeyStore, + runPasswordBreachCheckerFake, + runPasswordResetTokenStore, + runPendingCeremonyStore, + runRecoveryCodeStore, + runRefreshTokenStore, + runRoleStore, + runSessionStore, + runSigningKeyStore, + runTokenGen, + runTokenSigner, + runTokenVerifier, + runTotpCredentialStore, + runUserStore, + runVerificationTokenStore, + runWebAuthnCeremonyFake, + ) +import Shomei.Time.Store (Clock) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Shomei.Session.Authentication.Workflow login timing" + [ testCase "unknown login id still verifies a password (dummy hash)" do + (result, hashCalls) <- withWorld \ref counter -> do + runCounting ref counter (login cfg (ctxFor unknownEmail) (loginEmail unknownEmail strongPw)) + expectLeft InvalidCredentials result + hashCalls @?= 1, + testCase "wrong password verifies exactly once" do + (result, hashCalls) <- afterSignup (\_ -> pure ()) (loginEmail aliceEmail wrongPw) + expectLeft InvalidCredentials result + hashCalls @?= 1, + testCase "suspended account still verifies a password" do + (result, hashCalls) <- afterSignup suspendEveryone (loginEmail aliceEmail strongPw) + expectLeft UserNotActive result + hashCalls @?= 1, + testCase "locked account still verifies a password" do + (result, hashCalls) <- afterSignup lockAlice (loginEmail aliceEmail strongPw) + expectLeft InvalidCredentials result + hashCalls @?= 1, + testCase "successful login verifies exactly once" do + (result, hashCalls) <- afterSignup (\_ -> pure ()) (loginEmail aliceEmail strongPw) + case result of + Right _ -> pure () + Left e -> assertFailure ("expected a successful login, got " <> show e) + hashCalls @?= 1 + ] + +-- Harness -------------------------------------------------------------------- + +-- | The 'runInMemory' effect list, which 'runCounting' must reproduce exactly. +type Ports = + '[ UserStore, + RoleStore, + CredentialStore, + SessionStore, + RefreshTokenStore, + AuthUnitOfWork, + VerificationTokenStore, + PasswordResetTokenStore, + LoginAttemptStore, + PasskeyStore, + PendingCeremonyStore, + TotpCredentialStore, + RecoveryCodeStore, + Notifier, + ClaimsEnricher, + WebAuthnCeremony, + PasswordBreachChecker, + PasswordHasher, + TokenSigner, + TokenVerifier, + AuthEventPublisher, + SigningKeyStore, + Clock, + TokenGen, + IOE + ] + +-- | The in-memory fake hasher, counting every password-hashing operation — both +-- 'VerifyPassword' and 'VerifyPasswordDummy', because the two cost the same and the property +-- under test is that each login performs exactly one of them. Only the /invocation/ is +-- observed, never the result. +runCountingPasswordHasher :: (IOE :> es) => IORef Int -> Eff (PasswordHasher : es) a -> Eff es a +runCountingPasswordHasher counter = interpret_ \case + HashPassword (PlainPassword pw) -> pure (PasswordHash ("argon2-fake:" <> pw)) + VerifyPassword (PlainPassword pw) (PasswordHash h) -> do + liftIO (atomicModifyIORef' counter \n -> (n + 1, ())) + pure (h == "argon2-fake:" <> pw) + VerifyPasswordDummy _ -> liftIO (atomicModifyIORef' counter \n -> (n + 1, ())) + +-- | 'Shomei.Test.InMemory.runInMemory' with the counting hasher in the 'PasswordHasher' +-- slot. The interpreter order mirrors 'runInMemory'. +runCounting :: IORef World -> IORef Int -> Eff Ports a -> IO a +runCounting ref counter = + runEff + . runTokenGen ref + . runClock ref + . runSigningKeyStore ref + . runAuthEventPublisher ref + . runTokenVerifier + . runTokenSigner + . runCountingPasswordHasher counter + . runPasswordBreachCheckerFake ref + . runWebAuthnCeremonyFake ref + . runClaimsEnricherNull + . runNotifier ref + . runRecoveryCodeStore ref + . runTotpCredentialStore ref + . runPendingCeremonyStore ref + . runPasskeyStore ref + . runLoginAttemptStore ref + . runPasswordResetTokenStore ref + . runVerificationTokenStore ref + . runAuthUnitOfWork ref + . runRefreshTokenStore ref + . runSessionStore ref + . runCredentialStore ref + . runRoleStore ref + . runUserStore ref + +withWorld :: (IORef World -> IORef Int -> IO (Either AuthError a)) -> IO (Either AuthError (), Int) +withWorld act = do + ref <- newIORef (emptyWorld fixedTime) + counter <- newIORef 0 + result <- act ref counter + calls <- readIORef counter + pure (void result, calls) + +-- | Sign Alice up, run @setup@ against the resulting world, reset the counter, then log in. +-- Resetting after signup is what makes the count "verifications performed by the login". +afterSignup :: (IORef World -> IO ()) -> LoginCommand -> IO (Either AuthError (), Int) +afterSignup setup cmd = do + ref <- newIORef (emptyWorld fixedTime) + counter <- newIORef 0 + signupResult <- runCounting ref counter (signup cfg (signupEmail aliceEmail strongPw)) + case signupResult of + Left e -> do + _ <- assertFailure ("signup failed: " <> show e) + pure (Left e, 0) + Right _ -> do + setup ref + writeIORef counter 0 + result <- runCounting ref counter (login cfg (ctxForLogin cmd.loginId) cmd) + calls <- readIORef counter + pure (void result, calls) + +-- | Suspend every user in the world (the tests seed exactly one). +suspendEveryone :: IORef World -> IO () +suspendEveryone ref = do + w <- readIORef ref + counter <- newIORef 0 + runCounting ref counter (mapM_ (\u -> updateUserStatus u.userId [UserActive] UserSuspended fixedTime) (Map.elems w.users)) + +-- | Exhaust Alice's default five-attempt account budget before the measured login. +lockAlice :: IORef World -> IO () +lockAlice ref = do + counter <- newIORef 0 + replicateM_ 5 do + void (runCounting ref counter (login cfg (ctxFor aliceEmail) (loginEmail aliceEmail wrongPw))) + +expectLeft :: AuthError -> Either AuthError a -> IO () +expectLeft expected = \case + Left e | e == expected -> pure () + Left e -> assertFailure ("expected " <> show expected <> ", got " <> show e) + Right _ -> assertFailure ("expected " <> show expected <> ", got a successful login") + +-- Fixtures ------------------------------------------------------------------- + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +aliceEmail :: Email +aliceEmail = mkEmail' "alice@example.com" + +unknownEmail :: Email +unknownEmail = mkEmail' "nobody@example.com" + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +wrongPw :: PlainPassword +wrongPw = PlainPassword "totally the wrong password" + +mkEmail' :: Text -> Email +mkEmail' t = either (\e -> error ("bad test email: " <> show e)) id (mkEmail t) + +signupEmail :: Email -> PlainPassword -> SignupCommand +signupEmail e pw = + SignupCommand {loginId = either (error . show) id (mkLoginId (emailText e)), email = Just e, password = pw, displayName = Nothing} + +loginEmail :: Email -> PlainPassword -> LoginCommand +loginEmail e pw = LoginCommand {loginId = either (error . show) id (mkLoginId (emailText e)), password = pw} + +ctxForLogin :: LoginId -> ClientContext +ctxForLogin l = ClientContext (ClientIp "test-ip") (AccountKey (loginIdText l)) + +ctxFor :: Email -> ClientContext +ctxFor email = ctxForLogin (either (error . show) id (mkLoginId (emailText email))) diff --git a/test/Shomei/Session/Authentication/WorkflowSpec.hs b/test/Shomei/Session/Authentication/WorkflowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Session/Authentication/WorkflowSpec.hs @@ -0,0 +1,377 @@ +-- | Behavioral tests for the auth workflows, run entirely through the in-memory port +-- interpreter ('Shomei.Test.InMemory.runInMemory'). No PostgreSQL, no JWT library, no +-- network: a green run proves the security-critical workflow logic in isolation. +-- +-- Each case builds a fresh 'World' in an 'IORef' (so there is no cross-test +-- contamination) and runs one or more workflows against it, then asserts on the returned +-- 'Either' and, for state-changing cases, on the 'World' read back from the 'IORef'. +module Shomei.Session.Authentication.WorkflowSpec (tests) where + +import Data.Aeson qualified as Aeson +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text.Encoding qualified as TE +import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, fromGregorian) +import Shomei.Account.Email.Domain (Email, emailText, mkEmail) +import Shomei.Account.LoginId.Domain (LoginId, loginIdText, mkLoginId) +import Shomei.Account.Password.Domain (PasswordPolicy (..), PlainPassword (..)) +import Shomei.Account.User.Domain (User (..)) +import Shomei.Audit.Event.Domain qualified as Event +import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Scope (..)) +import Shomei.Config (SessionCheckMode (..), ShomeiConfig (..), defaultShomeiConfig) +import Shomei.Error + ( AuthError (InvalidCredentials, RefreshTokenReuseDetected, WeakPassword), + PasswordPolicyViolation (PasswordResemblesIdentity, PasswordTooCommon), + ) +-- Qualified: 'Shomei.Error.SessionExpired' (an 'AuthError') and +-- 'Shomei.Session.Domain.SessionExpired' (a 'SessionStatus') share a name. +import Shomei.Error qualified as Err +import Shomei.Session.Authentication.Workflow (LoginResult (..), Refreshed (..), login, logout, refresh, refreshFrom, signup, verifyToken) +import Shomei.Session.Command (ClientContext (..), LoginCommand (..), LogoutCommand (..), RefreshCommand (..), RefreshOrigin (..), SignupCommand (..)) +import Shomei.Session.Domain (Session (..), SessionStatus (..)) +import Shomei.Session.LoginAttempt.Domain (AccountKey (..), ClientIp (..)) +import Shomei.Session.RefreshToken.Domain (PersistedRefreshToken (..), RefreshTokenStatus (..)) +import Shomei.Session.RefreshToken.Store (markRefreshTokenUsed) +import Shomei.Session.Token.Domain (TokenPair (..)) +import Shomei.Session.Workflow (SessionOptions (..), issueSessionWith) +import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +-- Fixtures ------------------------------------------------------------------- + +fixedTime :: UTCTime +fixedTime = UTCTime (fromGregorian 2026 1 1) 0 + +cfg :: ShomeiConfig +cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients") + +aliceEmail :: Email +aliceEmail = mkEmail' "alice@example.com" + +unknownEmail :: Email +unknownEmail = mkEmail' "nobody@example.com" + +strongPw :: PlainPassword +strongPw = PlainPassword "correct horse battery staple" + +wrongPw :: PlainPassword +wrongPw = PlainPassword "totally the wrong password" + +mkEmail' :: Text -> Email +mkEmail' t = case mkEmail t of + Right e -> e + Left err -> error ("bad test email: " <> show err) + +mkLoginId' :: Text -> LoginId +mkLoginId' t = case mkLoginId t of + Right l -> l + Left err -> error ("bad test login id: " <> show err) + +-- | An email-first signup command: the principal login id defaults to the email text +-- (the compatibility rule), and the optional email is carried through. +signupEmail :: Email -> PlainPassword -> Maybe Text -> SignupCommand +signupEmail e pw dn = + SignupCommand {loginId = either (error . show) id (mkLoginId (emailText e)), email = Just e, password = pw, displayName = dn} + +-- | An email-first login command keyed on the email-derived login id. +loginEmail :: Email -> PlainPassword -> LoginCommand +loginEmail e pw = LoginCommand {loginId = either (error . show) id (mkLoginId (emailText e)), password = pw} + +-- | A fixed client context per login id: a constant test IP and the login-id text as the +-- account key (mirroring how the HTTP layer derives the abuse key from the principal). +ctxForLogin :: LoginId -> ClientContext +ctxForLogin l = ClientContext (ClientIp "test-ip") (AccountKey (loginIdText l)) + +-- | The email-keyed convenience: derive the login id from the email, then the context. +ctxFor :: Email -> ClientContext +ctxFor email = ctxForLogin (either (error . show) id (mkLoginId (emailText email))) + +expectRight :: (Show e) => Either e a -> IO a +expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure + +-- | Move the in-memory clock to @fixedTime + delta@. The interpreters read 'World.clock' on +-- every 'Shomei.Time.Store.now', so this is how a test travels forward in time. +advanceTo :: IORef World -> NominalDiffTime -> IO () +advanceTo ref delta = modifyIORef' ref \w -> w {clock = addUTCTime delta fixedTime} + +-- | A config whose refresh tokens outlive the session, so a token minted at signup is still +-- unexpired when the session's absolute deadline passes. Without it the two deadlines +-- coincide and 'SessionExpired' would be masked by 'RefreshTokenExpired'. +longTokenCfg :: ShomeiConfig +longTokenCfg = cfg {refreshTokenTTL = 61 * 24 * 60 * 60} + +-- Tests ---------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "Shomei.Session.Authentication.Workflow" + [ testSignupLogin, + testSignupLoginByIdentifierNoEmail, + testRefreshRotates, + testBespokeRefreshRejectsOAuthSession, + testRefreshRejectsExpiredSession, + testSlidingRefreshStillDiesAtDeadline, + testVerifyTokenRejectsExpiredSession, + testMarkUsedIsCompareAndSwap, + testReuseDetected, + testReuseRevokesSession, + testLogoutRevokes, + testRefreshAfterLogoutIsSessionRevoked, + testFailClosed, + testNoAccountLeak, + testSignupRejectsCommon, + testSignupRejectsIdentity + ] + +-- | A policy with a small minimum length so identity-derived passwords (e.g. "alice", +-- shorter than the default 12) reach the contextual check instead of failing on length. +smallMinCfg :: ShomeiConfig +smallMinCfg = cfg {passwordPolicy = cfg.passwordPolicy {minLength = 4}} + +testSignupRejectsCommon :: TestTree +testSignupRejectsCommon = testCase "signup rejects a common password" do + ref <- newIORef (emptyWorld fixedTime) + -- "passwordpassword" is in the bundled dictionary and is long enough to pass minLength. + res <- runInMemory ref (signup cfg (signupEmail aliceEmail (PlainPassword "passwordpassword") Nothing)) + res @?= Left (WeakPassword PasswordTooCommon) + +testSignupRejectsIdentity :: TestTree +testSignupRejectsIdentity = testCase "signup rejects the email local-part as password" do + ref <- newIORef (emptyWorld fixedTime) + res <- runInMemory ref (signup smallMinCfg (signupEmail aliceEmail (PlainPassword "alice") Nothing)) + res @?= Left (WeakPassword PasswordResemblesIdentity) + +testSignupLogin :: TestTree +testSignupLogin = testCase "signup then login round-trips" do + ref <- newIORef (emptyWorld fixedTime) + (user, pair) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw (Just "Alice"))) + loginRes <- expectRight =<< runInMemory ref (login cfg (ctxFor aliceEmail) (loginEmail aliceEmail strongPw)) + (user2, pair2) <- case loginRes of + LoginComplete u p -> pure (u, p) + MfaRequired _ -> assertFailure "expected LoginComplete (alice has no passkey), got MfaRequired" + user2.userId @?= user.userId + assertBool "login issues a different refresh token" (pair2.refreshToken /= pair.refreshToken) + +testSignupLoginByIdentifierNoEmail :: TestTree +testSignupLoginByIdentifierNoEmail = testCase "signup+login by identifier with no email" do + ref <- newIORef (emptyWorld fixedTime) + let agentLogin = mkLoginId' "agent-4815162342" + signupCmd = + SignupCommand {loginId = agentLogin, email = Nothing, password = strongPw, displayName = Nothing} + (user, _pair) <- expectRight =<< runInMemory ref (signup cfg signupCmd) + user.email @?= Nothing + user.loginId @?= agentLogin + loginRes <- + expectRight =<< runInMemory ref (login cfg (ctxForLogin agentLogin) (LoginCommand agentLogin strongPw)) + case loginRes of + LoginComplete u _ -> u.userId @?= user.userId + MfaRequired _ -> assertFailure "expected LoginComplete (agent has no passkey), got MfaRequired" + +testRefreshRotates :: TestTree +testRefreshRotates = testCase "refresh rotates token and old token becomes Used" do + ref <- newIORef (emptyWorld fixedTime) + (_, pair) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + originalClaims <- expectRight =<< runInMemory ref (verifyToken cfg pair.accessToken) + advanceTo ref 60 + pair2 <- expectRight =<< runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken)) + refreshedClaims <- expectRight =<< runInMemory ref (verifyToken cfg pair2.accessToken) + assertBool "rotated token differs from the original" (pair2.refreshToken /= pair.refreshToken) + refreshedClaims.authTime @?= originalClaims.authTime + refreshedClaims.issuedAt @?= addUTCTime 60 originalClaims.issuedAt + w <- readIORef ref + let toks = Map.elems w.refreshTokens + assertBool "exactly one token is marked Used" (length (filter (\t -> t.status == RefreshTokenUsed) toks) == 1) + assertBool "the rotated token links to its parent" (any (\t -> isJust t.parentTokenId) toks) + +testBespokeRefreshRejectsOAuthSession :: TestTree +testBespokeRefreshRejectsOAuthSession = testCase "bespoke refresh refuses a client-bound session without spending its token" do + ref <- newIORef (emptyWorld fixedTime) + (user, _) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + let granted = Set.fromList [Scope "openid", Scope "kawa:read"] + (_, oauthPair, _) <- + runInMemory + ref + ( issueSessionWith + cfg + SessionOptions + { oauthClientId = Just "oauthclient_test", + extraScopes = granted + } + user + fixedTime + ) + result <- runInMemory ref (refresh cfg (RefreshCommand oauthPair.refreshToken)) + result @?= Left Err.RefreshTokenInvalid + wrongClient <- runInMemory ref (refreshFrom (OAuthClientRefresh "oauthclient_other") cfg (RefreshCommand oauthPair.refreshToken)) + case wrongClient of + Left err -> err @?= Err.RefreshTokenInvalid + Right _ -> assertFailure "a different OAuth client rotated the session" + world <- readIORef ref + assertBool + "the refused binding mismatch leaves every token active" + (all ((== RefreshTokenActive) . (.status)) (Map.elems world.refreshTokens)) + refreshed <- + expectRight + =<< runInMemory ref (refreshFrom (OAuthClientRefresh "oauthclient_test") cfg (RefreshCommand oauthPair.refreshToken)) + refreshed.grantedScopes @?= granted + claims <- expectRight =<< runInMemory ref (verifyToken cfg refreshed.tokens.accessToken) + claims.scopes @?= granted + +testRefreshRejectsExpiredSession :: TestTree +testRefreshRejectsExpiredSession = testCase "refresh rejects a session past its absolute expiry" do + ref <- newIORef (emptyWorld fixedTime) + (_, pair) <- expectRight =<< runInMemory ref (signup longTokenCfg (signupEmail aliceEmail strongPw Nothing)) + advanceTo ref (longTokenCfg.sessionTTL + 1) + res <- runInMemory ref (refresh longTokenCfg (RefreshCommand pair.refreshToken)) + res @?= Left Err.SessionExpired + +testSlidingRefreshStillDiesAtDeadline :: TestTree +testSlidingRefreshStillDiesAtDeadline = testCase "sliding refresh still dies at the session deadline" do + ref <- newIORef (emptyWorld fixedTime) + (_, pair) <- expectRight =<< runInMemory ref (signup longTokenCfg (signupEmail aliceEmail strongPw Nothing)) + -- Two successful rotations well inside the 30-day session lifetime. + pair1 <- rotateAt ref (10 * day) pair.refreshToken + pair2 <- rotateAt ref (20 * day) pair1.refreshToken + -- Every *rotated* token is capped at the session deadline, so refreshing buys no extra + -- lifetime. (The token minted at signup is uncapped — see this plan's Surprises.) + w <- readIORef ref + session <- case Map.elems w.sessions of + (s : _) -> pure s + [] -> assertFailure "expected a session" + let rotated = filter (isJust . (.parentTokenId)) (Map.elems w.refreshTokens) + length rotated @?= 2 + assertBool + "no rotated refresh token expires after the session" + (all (\t -> t.expiresAt <= session.expiresAt) rotated) + -- Past the deadline the freshest token still cannot buy another rotation. + advanceTo ref (longTokenCfg.sessionTTL + 1) + res <- runInMemory ref (refresh longTokenCfg (RefreshCommand pair2.refreshToken)) + res @?= Left Err.SessionExpired + where + day = 24 * 60 * 60 :: NominalDiffTime + rotateAt ref delta tok = do + advanceTo ref delta + expectRight =<< runInMemory ref (refresh longTokenCfg (RefreshCommand tok)) + +testVerifyTokenRejectsExpiredSession :: TestTree +testVerifyTokenRejectsExpiredSession = testCase "verifyToken (token+session) rejects an expired session" do + let checkCfg = longTokenCfg {sessionCheckMode = VerifyTokenAndSession} + ref <- newIORef (emptyWorld fixedTime) + (_, pair) <- expectRight =<< runInMemory ref (signup checkCfg (signupEmail aliceEmail strongPw Nothing)) + ok <- runInMemory ref (verifyToken checkCfg pair.accessToken) + assertBool "the fresh access token verifies" (isRight ok) + advanceTo ref (checkCfg.sessionTTL + 1) + res <- runInMemory ref (verifyToken checkCfg pair.accessToken) + res @?= Left Err.SessionExpired + where + isRight = either (const False) (const True) + +testMarkUsedIsCompareAndSwap :: TestTree +testMarkUsedIsCompareAndSwap = testCase "mark-used CAS: the second sequential mark returns False" do + ref <- newIORef (emptyWorld fixedTime) + _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + w <- readIORef ref + rid <- case Map.keys w.refreshTokens of + (r : _) -> pure r + [] -> assertFailure "expected a refresh token to exist after signup" + first <- runInMemory ref (markRefreshTokenUsed rid fixedTime) + second <- runInMemory ref (markRefreshTokenUsed rid fixedTime) + first @?= True + second @?= False + +testReuseDetected :: TestTree +testReuseDetected = testCase "presenting an already-used refresh token detects reuse" do + ref <- newIORef (emptyWorld fixedTime) + (_, pair) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + _ <- expectRight =<< runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken)) + reused <- runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken)) + reused @?= Left RefreshTokenReuseDetected + +testReuseRevokesSession :: TestTree +testReuseRevokesSession = testCase "reuse detection revokes the session and family" do + ref <- newIORef (emptyWorld fixedTime) + (_, pair) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + _ <- expectRight =<< runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken)) + _ <- runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken)) + w <- readIORef ref + assertBool "session is revoked" (all (\s -> s.status == SessionRevoked) (Map.elems w.sessions)) + assertBool "whole refresh-token family is revoked" (all (\t -> t.status == RefreshTokenRevoked) (Map.elems w.refreshTokens)) + assertBool "a reuse event was published" (any isReuse w.publishedEvents) + where + isReuse (Event.RefreshTokenReuseDetected _) = True + isReuse _ = False + +testLogoutRevokes :: TestTree +testLogoutRevokes = testCase "logout revokes the session" do + ref <- newIORef (emptyWorld fixedTime) + _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + w0 <- readIORef ref + sid <- case Map.keys w0.sessions of + (s : _) -> pure s + [] -> assertFailure "expected a session to exist after signup" + result <- runInMemory ref (logout cfg (LogoutCommand sid)) + result @?= Right () + w <- readIORef ref + assertBool "session is revoked" (all (\s -> s.status == SessionRevoked) (Map.elems w.sessions)) + assertBool "session refresh tokens are revoked" (all (\t -> t.status == RefreshTokenRevoked) (Map.elems w.refreshTokens)) + assertBool "a session-revoked event was published" (any isRevoked w.publishedEvents) + where + isRevoked (Event.SessionRevoked _) = True + isRevoked _ = False + +testRefreshAfterLogoutIsSessionRevoked :: TestTree +testRefreshAfterLogoutIsSessionRevoked = testCase "a refresh token revoked by logout is not reported as theft" do + ref <- newIORef (emptyWorld fixedTime) + (_, pair) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + w0 <- readIORef ref + sid <- case Map.keys w0.sessions of + (s : _) -> pure s + [] -> assertFailure "expected a session to exist after signup" + _ <- expectRight =<< runInMemory ref (logout cfg (LogoutCommand sid)) + result <- runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken)) + result @?= Left Err.SessionRevoked + w <- readIORef ref + length [() | Event.RefreshTokenReuseDetected _ <- w.publishedEvents] @?= 0 + +testFailClosed :: TestTree +testFailClosed = testCase "wrong-password audit identifies the hashed account and resolved user" do + ref <- newIORef (emptyWorld fixedTime) + (alice, _) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + let ctx = ClientContext (ClientIp "test-ip") (AccountKey "sha256-alice") + cmd = loginEmail aliceEmail wrongPw + result <- runInMemory ref (login cfg ctx cmd) + result @?= Left InvalidCredentials + w <- readIORef ref + case [d | Event.LoginFailed d <- w.publishedEvents] of + [d] -> do + d.accountKey @?= Just ctx.accountKey + d.userId @?= Just alice.userId + assertBool + "the submitted identifier is absent from the encoded audit event" + (not (TE.encodeUtf8 (loginIdText cmd.loginId) `BS.isInfixOf` BSL.toStrict (Aeson.encode (Event.LoginFailed d)))) + ds -> assertFailure ("expected exactly one login-failed event, got " <> show (length ds)) + +testNoAccountLeak :: TestTree +testNoAccountLeak = testCase "unknown email yields the same generic error as a wrong password" do + ref <- newIORef (emptyWorld fixedTime) + _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing)) + wrong <- runInMemory ref (login cfg (ctxFor aliceEmail) (loginEmail aliceEmail wrongPw)) + let unknownCtx = ClientContext (ClientIp "test-ip") (AccountKey "sha256-unknown") + unknown <- runInMemory ref (login cfg unknownCtx (loginEmail unknownEmail strongPw)) + wrong @?= unknown + unknown @?= Left InvalidCredentials + w <- readIORef ref + case [d | Event.LoginFailed d <- w.publishedEvents, d.accountKey == Just unknownCtx.accountKey] of + [d] -> do + d.userId @?= Nothing + assertBool + "the unknown submitted identifier is absent from the encoded audit event" + (not (TE.encodeUtf8 (emailText unknownEmail) `BS.isInfixOf` BSL.toStrict (Aeson.encode (Event.LoginFailed d)))) + ds -> assertFailure ("expected one unknown-login audit event, got " <> show (length ds)) diff --git a/test/Shomei/WebAuthnCeremonySpec.hs b/test/Shomei/WebAuthnCeremonySpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/WebAuthnCeremonySpec.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DataKinds #-} + +-- | Pure tests for the deterministic fake 'WebAuthnCeremony' interpreter +-- ('Shomei.Test.InMemory.runWebAuthnCeremonyFake'). They prove the contract EP-3/EP-4 +-- rely on: a begin step emits an options blob carrying a deterministic challenge, and a +-- complete step succeeds when the test echoes that challenge back inside a crafted +-- credential JSON (and fails closed on a mismatch). No cryptography or database is +-- involved — the real ceremony is exercised by @shomei-webauthn@'s end-to-end test. +module Shomei.WebAuthnCeremonySpec (tests) where + +import Data.Aeson (Value, eitherDecodeStrict', object, (.=)) +import Data.Aeson.Types (parseMaybe, withObject, (.:)) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BC +import Data.IORef (newIORef) +import Data.Text (Text) +import Data.Time (UTCTime (..), fromGregorian) +import Effectful (runEff) +import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..)) +import Shomei.Config (ShomeiConfig (..), UserVerificationPolicy (UVRequired), defaultShomeiConfig, defaultWebAuthnConfig) +import Shomei.Passkey.Ceremony.Port + ( BeginCeremony (..), + CredentialUserInfo (..), + StoredCredentialForVerify (..), + VerifiedAuthentication (..), + VerifiedRegistration (..), + WebAuthnError (..), + beginAuthenticationCeremony, + beginRegistrationCeremony, + completeAuthenticationCeremony, + completeRegistrationCeremony, + ) +import Shomei.Passkey.Domain + ( PublicKeyBytes (..), + SignatureCounter (..), + UserHandle (..), + WebAuthnCredentialId (..), + ) +import Shomei.Test.InMemory (emptyWorld, runWebAuthnCeremonyFake) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "WebAuthnCeremony (fake interpreter)" + [ testCase "register then authenticate round-trips deterministically" registerThenAuthenticate, + testCase "webauthnConfig default is present in defaultShomeiConfig" configHasWebAuthnDefault + ] + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 1 1) 0 + +cidBytes, uhBytes, pkBytes :: ByteString +cidBytes = BC.pack "fake-credential-id" +uhBytes = BC.pack "fake-user-handle" +pkBytes = BC.pack "fake-public-key-bytes" + +sampleUser :: CredentialUserInfo +sampleUser = + CredentialUserInfo + { userHandle = UserHandle uhBytes, + accountName = "alice@example.com", + displayName = "Alice" + } + +-- | The challenge baked into a begin step's options blob (the test echoes it back). +challengeOf :: ByteString -> Text +challengeOf blob = case eitherDecodeStrict' blob of + Right v -> case parseMaybe (withObject "options" (.: "challenge")) v of + Just c -> c + Nothing -> error "challengeOf: no challenge in options blob" + Left e -> error ("challengeOf: " <> e) + +-- | A credential JSON of the shape the fake expects (base64url bytes via the newtypes' JSON). +credentialJson :: Text -> ByteString -> ByteString -> ByteString -> Value +credentialJson chal cid uh pk = + object + [ "challenge" .= chal, + "credentialId" .= WebAuthnCredentialId cid, + "userHandle" .= UserHandle uh, + "publicKey" .= PublicKeyBytes pk + ] + +registerThenAuthenticate :: IO () +registerThenAuthenticate = do + ref <- newIORef (emptyWorld t0) + (regResult, wrongResult, authResult) <- runEff . runWebAuthnCeremonyFake ref $ do + BeginCeremony {optionsBlob = regBlob} <- beginRegistrationCeremony sampleUser [] + regResult <- + completeRegistrationCeremony regBlob (credentialJson (challengeOf regBlob) cidBytes uhBytes pkBytes) + wrongResult <- + completeRegistrationCeremony regBlob (credentialJson "not-the-challenge" cidBytes uhBytes pkBytes) + BeginCeremony {optionsBlob = authBlob} <- beginAuthenticationCeremony UVRequired [WebAuthnCredentialId cidBytes] + let stored = + StoredCredentialForVerify + { credentialId = WebAuthnCredentialId cidBytes, + userHandle = UserHandle uhBytes, + publicKey = PublicKeyBytes pkBytes, + signCounter = SignatureCounter 0, + transports = [] + } + authResult <- + completeAuthenticationCeremony authBlob stored (credentialJson (challengeOf authBlob) cidBytes uhBytes pkBytes) + pure (regResult, wrongResult, authResult) + regResult + @?= Right + VerifiedRegistration + { credentialId = WebAuthnCredentialId cidBytes, + userHandle = UserHandle uhBytes, + publicKey = PublicKeyBytes pkBytes, + signCounter = SignatureCounter 0, + transports = [] + } + wrongResult @?= (Left WebAuthnChallengeMismatch :: Either WebAuthnError VerifiedRegistration) + authResult + @?= Right + VerifiedAuthentication + { credentialId = WebAuthnCredentialId cidBytes, + newSignCounter = SignatureCounter 1, + cloneWarning = False + } + +configHasWebAuthnDefault :: IO () +configHasWebAuthnDefault = + webauthnConfig (defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")) @?= defaultWebAuthnConfig