packages feed

shomei-core (empty) → 0.2.0.0

raw patch · 111 files changed

+16309/−0 lines, 111 filesdep +aesondep +asyncdep +base

Dependencies added: aeson, async, base, base64, bytestring, containers, crypton, effectful, effectful-core, file-embed, generic-lens, http-api-data, lens, mmzk-typeid, ram, shomei-core, tasty, tasty-hunit, text, time, uuid

Files

+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Nadeem Bitar++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ data/common-passwords.txt view
@@ -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
+ shomei-core.cabal view
@@ -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
+ src/Shomei/Account/Admin/Workflow.hs view
@@ -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 ())
+ src/Shomei/Account/Credential/Domain.hs view
@@ -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)
+ src/Shomei/Account/Credential/Store.hs view
@@ -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)
+ src/Shomei/Account/Email/Domain.hs view
@@ -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
+ src/Shomei/Account/Lifecycle/Workflow.hs view
@@ -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
+ src/Shomei/Account/LoginId/Domain.hs view
@@ -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)
+ src/Shomei/Account/Notification/Domain.hs view
@@ -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)
+ src/Shomei/Account/Notification/Store.hs view
@@ -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
+ src/Shomei/Account/OneTimeToken/Domain.hs view
@@ -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
+ src/Shomei/Account/Password/Breach/Store.hs view
@@ -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
+ src/Shomei/Account/Password/Breach/Workflow.hs view
@@ -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 ()
+ src/Shomei/Account/Password/Common/Domain.hs view
@@ -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
+ src/Shomei/Account/Password/Domain.hs view
@@ -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 <redacted>"++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)
+ src/Shomei/Account/Password/Hash/Store.hs view
@@ -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
+ src/Shomei/Account/PasswordReset/Domain.hs view
@@ -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)
+ src/Shomei/Account/PasswordReset/Store.hs view
@@ -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)
+ src/Shomei/Account/User/Domain.hs view
@@ -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)
+ src/Shomei/Account/User/Store.hs view
@@ -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
+ src/Shomei/Account/Verification/Domain.hs view
@@ -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)
+ src/Shomei/Account/Verification/Store.hs view
@@ -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)
+ src/Shomei/Audit/Event/Codec.hs view
@@ -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=<subject>` 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=<backing 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)
+ src/Shomei/Audit/Event/Domain.hs view
@@ -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)
+ src/Shomei/Audit/Publisher/Store.hs view
@@ -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
+ src/Shomei/Audit/Reader/Store.hs view
@@ -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
+ src/Shomei/Authorization/Claims/Domain.hs view
@@ -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
+ src/Shomei/Authorization/Claims/Store.hs view
@@ -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)
+ src/Shomei/Authorization/Role/Store.hs view
@@ -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
+ src/Shomei/Authorization/Role/Workflow.hs view
@@ -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
+ src/Shomei/Authorization/Scope/Domain.hs view
@@ -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)
+ src/Shomei/Config.hs view
@@ -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+    }
+ src/Shomei/Delegation/Workflow.hs view
@@ -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+          }+    )
+ src/Shomei/Error.hs view
@@ -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)
+ src/Shomei/Id.hs view
@@ -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
+ src/Shomei/Mfa/RecoveryCode/Store.hs view
@@ -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
+ src/Shomei/Mfa/Totp/Algorithm.hs view
@@ -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 <redacted>"++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
+ src/Shomei/Mfa/Totp/Domain.hs view
@@ -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
+ src/Shomei/Mfa/Totp/Store.hs view
@@ -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
+ src/Shomei/Mfa/Totp/Workflow.hs view
@@ -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"
+ src/Shomei/Mfa/Workflow.hs view
@@ -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"
+ src/Shomei/OAuth/AuthorizationCode/Domain.hs view
@@ -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)
+ src/Shomei/OAuth/AuthorizationCode/Store.hs view
@@ -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
+ src/Shomei/OAuth/Authorize/Workflow.hs view
@@ -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
+ src/Shomei/OAuth/Client/Domain.hs view
@@ -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
+ src/Shomei/OAuth/Client/Store.hs view
@@ -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)
+ src/Shomei/OAuth/Client/Workflow.hs view
@@ -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))
+ src/Shomei/OAuth/IdToken/Domain.hs view
@@ -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)
+ src/Shomei/OAuth/Revocation/Domain.hs view
@@ -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
+ src/Shomei/OAuth/TokenExchange/Workflow.hs view
@@ -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)
+ src/Shomei/OAuth/TokenGrant/Workflow.hs view
@@ -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
+ src/Shomei/Passkey/Ceremony/Port.hs view
@@ -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)
+ src/Shomei/Passkey/Ceremony/Store.hs view
@@ -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)
+ src/Shomei/Passkey/Domain.hs view
@@ -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)
+ src/Shomei/Passkey/Store.hs view
@@ -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
+ src/Shomei/Passkey/Workflow.hs view
@@ -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))
+ src/Shomei/Prelude.hs view
@@ -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+    }
+ src/Shomei/ServiceAccount/ClientCredentials/Workflow.hs view
@@ -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
+ src/Shomei/ServiceAccount/Domain.hs view
@@ -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)
+ src/Shomei/ServiceAccount/Secret.hs view
@@ -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))
+ src/Shomei/ServiceAccount/Store.hs view
@@ -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)
+ src/Shomei/Session/Authentication/Workflow.hs view
@@ -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
+ src/Shomei/Session/Command.hs view
@@ -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+    }
+ src/Shomei/Session/Domain.hs view
@@ -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)
+ src/Shomei/Session/LoginAttempt/Domain.hs view
@@ -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)
+ src/Shomei/Session/LoginAttempt/Store.hs view
@@ -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
+ src/Shomei/Session/LoginAttempt/Workflow.hs view
@@ -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)
+ src/Shomei/Session/RefreshToken/Domain.hs view
@@ -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 <redacted>"++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)
+ src/Shomei/Session/RefreshToken/Store.hs view
@@ -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)
+ src/Shomei/Session/Store.hs view
@@ -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
+ src/Shomei/Session/Token/Domain.hs view
@@ -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 <redacted>"++data TokenPair = TokenPair+  { accessToken :: !AccessToken,+    refreshToken :: !RefreshToken,+    expiresIn :: !NominalDiffTime+  }+  deriving stock (Generic, Eq, Show)
+ src/Shomei/Session/Token/Generator.hs view
@@ -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
+ src/Shomei/Session/UnitOfWork/Store.hs view
@@ -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)
+ src/Shomei/Session/Workflow.hs view
@@ -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+    )
+ src/Shomei/SigningKey/Domain.hs view
@@ -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)
+ src/Shomei/SigningKey/Signer.hs view
@@ -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
+ src/Shomei/SigningKey/Store.hs view
@@ -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)
+ src/Shomei/SigningKey/Verifier.hs view
@@ -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
+ src/Shomei/Test/InMemory.hs view
@@ -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
+ src/Shomei/Time/Store.hs view
@@ -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
+ test/Main.hs view
@@ -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+        ]+    )
+ test/Shomei/Account/Admin/WorkflowSpec.hs view
@@ -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
+ test/Shomei/Account/Lifecycle/CostSpec.hs view
@@ -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"+    }
+ test/Shomei/Account/Password/DomainSpec.hs view
@@ -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 ()+    ]
+ test/Shomei/Account/Verification/WorkflowSpec.hs view
@@ -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)))
+ test/Shomei/AccountSpec.hs view
@@ -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)
+ test/Shomei/Audit/Event/CodecSpec.hs view
@@ -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
+ test/Shomei/Authorization/Role/WorkflowSpec.hs view
@@ -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)
+ test/Shomei/BreachSpec.hs view
@@ -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+    ]
+ test/Shomei/Delegation/WorkflowSpec.hs view
@@ -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
+ test/Shomei/LockoutSpec.hs view
@@ -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
+ test/Shomei/Mfa/Totp/AlgorithmSpec.hs view
@@ -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"+    ]
+ test/Shomei/Mfa/Totp/StoreSpec.hs view
@@ -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
+ test/Shomei/Mfa/WorkflowSpec.hs view
@@ -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"
+ test/Shomei/OAuth/Authorize/WorkflowSpec.hs view
@@ -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
+ test/Shomei/OAuth/Client/WorkflowSpec.hs view
@@ -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
+ test/Shomei/OAuth/Revocation/DomainSpec.hs view
@@ -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
+ test/Shomei/OAuth/TokenExchange/WorkflowSpec.hs view
@@ -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
+ test/Shomei/OAuth/TokenGrant/WorkflowSpec.hs view
@@ -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 ()
+ test/Shomei/OAuthClientStoreSpec.hs view
@@ -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"+    ]
+ test/Shomei/OAuthCodeStoreSpec.hs view
@@ -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" <> "-_"))
+ test/Shomei/Passkey/WorkflowSpec.hs view
@@ -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)
+ test/Shomei/PasskeyStoreSpec.hs view
@@ -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)
+ test/Shomei/ServiceAccount/ClientCredentials/WorkflowSpec.hs view
@@ -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
+ test/Shomei/ServiceAccountStoreSpec.hs view
@@ -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"]
+ test/Shomei/Session/Authentication/ConcurrencySpec.hs view
@@ -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
+ test/Shomei/Session/Authentication/TimingSpec.hs view
@@ -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)))
+ test/Shomei/Session/Authentication/WorkflowSpec.hs view
@@ -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))
+ test/Shomei/WebAuthnCeremonySpec.hs view
@@ -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