shomei-core 0.2.0.0 → 0.3.0.0

raw patch · 51 files changed

+955/−292 lines, 51 filesdep ~shomei-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: shomei-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +38/−0
• shomei-core.cabal +64/−55
• src/Shomei/Account/Admin/Workflow.hs +8/−15
• src/Shomei/Account/Credential/Domain.hs +17/−3
• src/Shomei/Account/Email/Domain.hs +19/−5
• src/Shomei/Account/Lifecycle/Workflow.hs +5/−2
• src/Shomei/Account/LoginId/Domain.hs +18/−6
• src/Shomei/Account/Password/Domain.hs +1/−1
• src/Shomei/Account/User/Domain.hs +34/−4
• src/Shomei/Audit/Event/Domain.hs +41/−8
• src/Shomei/Authorization/Claims/Domain.hs +22/−3
• src/Shomei/Authorization/Role/Workflow.hs +9/−5
• src/Shomei/Config.hs +17/−3
• src/Shomei/Delegation/Workflow.hs +18/−14
• src/Shomei/Error.hs +4/−1
• src/Shomei/Mfa/Workflow.hs +60/−10
• src/Shomei/OAuth/AuthorizationCode/Store.hs +0/−7
• src/Shomei/OAuth/Authorize/Workflow.hs +4/−3
• src/Shomei/OAuth/IdToken/Domain.hs +5/−1
• src/Shomei/OAuth/TokenExchange/Workflow.hs +2/−1
• src/Shomei/OAuth/TokenGrant/Workflow.hs +16/−1
• src/Shomei/Passkey/Ceremony/Port.hs +1/−2
• src/Shomei/Passkey/Store.hs +9/−4
• src/Shomei/Passkey/Workflow.hs +16/−12
• src/Shomei/ServiceAccount/ClientCredentials/Workflow.hs +18/−13
• src/Shomei/Session/Authentication/Workflow.hs +12/−7
• src/Shomei/Session/Command.hs +3/−1
• src/Shomei/Session/Domain.hs +9/−2
• src/Shomei/Session/Store.hs +42/−6
• src/Shomei/Session/Token/Bearer.hs +25/−0
• src/Shomei/Session/Token/Domain.hs +4/−1
• src/Shomei/Session/UnitOfWork/Store.hs +7/−0
• src/Shomei/Session/Workflow.hs +16/−8
• src/Shomei/Test/InMemory.hs +66/−21
• test/Shomei/Account/Admin/WorkflowSpec.hs +11/−1
• test/Shomei/Account/Verification/WorkflowSpec.hs +3/−2
• test/Shomei/AccountSpec.hs +1/−1
• test/Shomei/Authorization/Role/WorkflowSpec.hs +1/−1
• test/Shomei/LockoutSpec.hs +3/−3
• test/Shomei/Mfa/WorkflowSpec.hs +6/−5
• test/Shomei/OAuth/Authorize/WorkflowSpec.hs +12/−4
• test/Shomei/OAuth/Revocation/DomainSpec.hs +2/−1
• test/Shomei/OAuth/TokenGrant/WorkflowSpec.hs +30/−4
• test/Shomei/OAuthCodeStoreSpec.hs +3/−16
• test/Shomei/Passkey/WorkflowSpec.hs +49/−5
• test/Shomei/PasskeyStoreSpec.hs +6/−6
• test/Shomei/ServiceAccount/ClientCredentials/WorkflowSpec.hs +17/−1
• test/Shomei/Session/Authentication/ConcurrencySpec.hs +3/−2
• test/Shomei/Session/Authentication/TimingSpec.hs +21/−3
• test/Shomei/Session/Authentication/WorkflowSpec.hs +156/−10
• test/Shomei/WebAuthnCeremonySpec.hs +1/−2

@@ -4,6 +4,44 @@ [PVP](https://pvp.haskell.org/) and is versioned independently of the other Shōmei packages. +## 0.3.0.0 — 2026-11-05++- **Breaking:** the package and its test suite move to the 0.3 API series.++- **Upgrade:** migration 0043 repairs legacy machine/delegated provenance and makes omitted SQL provenance default to machine. Missing kinds fail closed on read; authorize also refuses a stored actor. Stop old issuers before migration; affected backing-account humans can establish a new interactive session by logging in. See deployment.md.++- **Breaking:** remove the unreachable `VerifiedAuthentication.cloneWarning` field. Cloned/regressed counters return typed `WebAuthnCounterCloned` and follow the shared MFA failure/audit path. Signed software-authenticator fixtures now exercise the production verifier and workflows.++- **Breaking:** remove the unused unbatched authorization-code expiry port; cleanup uses the bounded sweeper. Password-hash updates now advance credential `updatedAt` in the fake interpreter as well.++- **Breaking:** PostgreSQL assembly uses the managed `Shomei.Persistence.Pool.Postgres.Pool` and its `UsageError`, `use` and `release` operations. Interrupted/failed sessions discard their connection and restore capacity; the external pool dependency is removed.++- Machine and delegated mints atomically enforce the configurable active principal ceiling (default 1000), preserving existing sessions after lowering the cap. Expiry frees capacity; finite sweeper retention bounds ordinary history by issuance rate and retention.++- **Breaking:** database transactions use the bounded statement wrapper; session bulk revocation returns winning IDs and the audited unit of work returns a count. Administrative session HTTP listing returns a keyset page (default 50, maximum 200). Server transaction limits default to three attempts/five seconds.++- Enforce finite new-write identity, display-name, passkey-label and role/scope budgets; preserve legacy identity authentication and snapshots. Login passwords over 256 code points fail before credential proof accounting. PostgreSQL adds migration 0039; see `docs/user/input-limits.md`.++- **Breaking:** `SigningKeyConfig` gains `legacyActorUntilUnix` and `emitLegacyActor` for the+  finite actor-format upgrade window; both default to strict object-form behavior.++- OAuth code exchange validates the RFC 7636 verifier length and ASCII alphabet before hashing.+- Add the shared RFC 6750 bearer parser for server and downstream consumers.++- **Breaking:** passkey creation requires an explicit enrollment ceiling and returns a typed+  result; `ShomeiConfig.maxPasskeysPerUser` defaults to 20. In-memory enrollment enforces the+  ceiling atomically and workflows publish success only for accepted enrollment.++- **Breaking:** `IdToken` now redacts `Show` and has no generic JSON instances. OAuth wire+  responses explicitly unwrap it, consistent with access and refresh token diagnostics.++- **Breaking:** `Session`, `NewSession`, `TokenPair`, `LoginCommand` and `SessionOptions` gain a+  `remembered`/`remember` field, and `issueSession` takes the remember choice. `ShomeiConfig` gains+  `rememberedSessionTTL` (`defaultRememberedSessionTTL`, 365 days), used for remembered sessions.+  `completeMfaWith` and `completePasswordlessLoginWith` take the choice; `completeMfa` and+  `completePasswordlessLogin` keep their signatures and are not remembered. The refresh token issued+  at sign-in no longer outlives its session.+ ## 0.2.0.0 — 2026-08-27  - **Breaking:** `AccessToken`, `RefreshToken`, and `TokenPair` no longer expose generic JSON

@@ -1,6 +1,6 @@-cabal-version:      3.0-name:               shomei-core-version:            0.2.0.0+cabal-version: 3.0+name: shomei-core+version: 0.3.0.0 synopsis:   Transport-agnostic domain: types, commands, events, errors, and effects @@ -14,31 +14,35 @@   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-+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+  type: git   location: https://github.com/shinzui/shomei.git  common warnings   ghc-options:-    -Wall -Wcompat -Widentities -Wincomplete-record-updates-    -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wpartial-fields+    -Wredundant-constraints  common shared-  default-language:   GHC2024+  default-language: GHC2024   default-extensions:     BlockArguments     DeriveAnyClass@@ -51,8 +55,8 @@     TemplateHaskell  library-  import:          warnings, shared-  hs-source-dirs:  src+  import: warnings, shared+  hs-source-dirs: src   exposed-modules:     Shomei.Account.Admin.Workflow     Shomei.Account.Credential.Domain@@ -122,6 +126,7 @@     Shomei.Session.RefreshToken.Domain     Shomei.Session.RefreshToken.Store     Shomei.Session.Store+    Shomei.Session.Token.Bearer     Shomei.Session.Token.Domain     Shomei.Session.Token.Generator     Shomei.Session.UnitOfWork.Store@@ -134,30 +139,34 @@     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+    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+  import: warnings, shared+  type: exitcode-stdio-1.0   hs-source-dirs: test-  main-is:        Main.hs-  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  main-is: Main.hs+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N+   other-modules:     Shomei.Account.Admin.WorkflowSpec     Shomei.Account.Lifecycle.CostSpec@@ -189,17 +198,17 @@     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+    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.3.0.0,+    tasty >=1.4 && <1.6,+    tasty-hunit >=0.10 && <0.11,+    text >=2.0 && <2.2,+    time >=1.12 && <1.15,+    uuid >=1.3 && <1.4,

@@ -35,14 +35,13 @@ import Shomei.Error (AuthError (..)) import Shomei.Id (SessionId, UserId) import Shomei.Prelude-import Shomei.Session.Domain (Session (..), SessionStatus (..))+import Shomei.Session.Domain (Session (..)) import Shomei.Session.Store   ( SessionStore,     findSessionById,-    listSessionsForUser,     revokeAllUserSessions,-    revokeSession,   )+import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork, revokeSessionWithTokens, revokeUserSessionsWithAudit) import Shomei.Time.Store (Clock, now)  -- | Suspend an active user and kill their sessions.@@ -63,7 +62,7 @@   Eff es (Either AuthError ()) suspendUser actingAdmin target =   transition target [UserActive] UserSuspended \ts -> do-    revokeAllUserSessions target ts+    void (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.@@ -84,7 +83,7 @@   Eff es (Either AuthError ()) deleteUser actingAdmin target =   transition target [UserActive, UserSuspended] UserDeleted \ts -> do-    revokeAllUserSessions target ts+    void (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@@ -115,22 +114,17 @@ -- 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) =>+  (AuthUnitOfWork :> 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))+  Right <$> revokeUserSessionsWithAudit actingAdmin target ts  -- | Revoke one session by id, whoever owns it. revokeOneSession ::-  (SessionStore :> es, AuthEventPublisher :> es, Clock :> es) =>+  (SessionStore :> es, AuthUnitOfWork :> es, Clock :> es) =>   UserId ->   SessionId ->   Eff es (Either AuthError ())@@ -140,6 +134,5 @@     Nothing -> pure (Left SessionNotFound)     Just _ -> do       ts <- now-      revokeSession sid ts-      publishAuthEvent (Event.SessionRevoked (Event.SessionRevokedData sid (Just actingAdmin) ts))+      void (revokeSessionWithTokens sid ts [Event.SessionRevoked (Event.SessionRevokedData sid (Just actingAdmin) ts)])       pure (Right ())

@@ -4,8 +4,9 @@   ) where -import Shomei.Account.Email.Domain (Email)-import Shomei.Account.LoginId.Domain (LoginId)+import Data.Aeson (withObject, (.:), (.:?))+import Shomei.Account.Email.Domain (Email, parseStoredEmail)+import Shomei.Account.LoginId.Domain (LoginId, parseLoginIdForAuthentication) import Shomei.Account.Password.Domain (PasswordHash) import Shomei.Id (CredentialId, UserId) import Shomei.Prelude@@ -20,4 +21,17 @@     updatedAt :: !UTCTime   }   deriving stock (Generic, Eq, Show)-  deriving anyclass (FromJSON, ToJSON)+  deriving anyclass (ToJSON)++instance FromJSON Credential where+  parseJSON = withObject "Credential" \o -> do+    loginId <- o .: "loginId" >>= either (const (fail "invalid stored login identifier")) pure . parseLoginIdForAuthentication+    email <- o .:? "email" >>= traverse (either (const (fail "invalid stored email")) pure . parseStoredEmail)+    PasswordCredential+      <$> o .: "credentialId"+      <*> o .: "userId"+      <*> pure loginId+      <*> pure email+      <*> o .: "passwordHash"+      <*> o .: "createdAt"+      <*> o .: "updatedAt"

@@ -1,22 +1,25 @@ -- | 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.+-- New writes use 'mkEmail'. 'parseStoredEmail' preserves legacy snapshot and recovery+-- compatibility; it must not be used to validate new writes. module Shomei.Account.Email.Domain   ( Email,     mkEmail,+    parseStoredEmail,     emailText,   ) where +import Data.Aeson (withText)+import Data.ByteString qualified as BS import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE import Shomei.Error (AuthError (..)) import Shomei.Prelude  newtype Email = Email Text   deriving stock (Generic)-  deriving newtype (Eq, Ord, Show, FromJSON, ToJSON)+  deriving newtype (Eq, Ord, Show, ToJSON)  emailText :: Email -> Text emailText (Email t) = t@@ -24,7 +27,15 @@ -- | 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 =+mkEmail raw+  | Text.length raw > 254 || BS.length (TE.encodeUtf8 raw) > 254 = Left InvalidEmail+  | otherwise = do+      email <- parseStoredEmail raw+      if BS.length (TE.encodeUtf8 (emailText email)) <= 254 then Right email else Left InvalidEmail++-- | Compatibility decoding for persisted identities and recovery lookup; never for writes.+parseStoredEmail :: Text -> Either AuthError Email+parseStoredEmail raw =   let t = Text.toLower (Text.strip raw)    in if isValidShape t then Right (Email t) else Left InvalidEmail   where@@ -35,3 +46,6 @@           && Text.isInfixOf "." domain           && not (Text.isInfixOf " " t)       _ -> False++instance FromJSON Email where+  parseJSON = withText "Email" (either (const (fail "invalid email")) pure . mkEmail)

@@ -13,6 +13,7 @@   ) where +import Data.Text qualified as Text import Data.Time (addUTCTime) import Effectful (Eff, (:>)) import Effectful.Error.Static (runErrorNoCallStack, throwError)@@ -25,7 +26,7 @@ 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.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@@ -46,7 +47,7 @@ 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.Error (AuthError (..), PasswordPolicyViolation (..)) import Shomei.Id (UserId) import Shomei.Prelude import Shomei.Session.Command (ProofContext, proofContextFor)@@ -225,6 +226,8 @@   ChangePassword ->   Eff es (Either AuthError ()) changePassword cfg pctx cmd = runErrorNoCallStack do+  let PlainPassword current = cmd.currentPassword+  when (Text.length current > 256) (throwError (WeakPassword (PasswordTooLong 256)))   user <- maybe (throwError InvalidCredentials) pure =<< findUserById cmd.userId   ts <- now   let ctx = proofContextFor pctx (loginIdText user.loginId)

@@ -5,17 +5,17 @@ -- 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'.+-- New writes use 'mkLoginId', which normalizes and bounds the handle. The explicitly+-- named compatibility parser is reserved for authentication and persisted snapshots. module Shomei.Account.LoginId.Domain   ( LoginId,     mkLoginId,+    parseLoginIdForAuthentication,     loginIdText,   ) where +import Data.Aeson (withText) import Data.Char (isSpace) import Data.Text qualified as Text import Shomei.Error (AuthError (..))@@ -23,7 +23,7 @@  newtype LoginId = LoginId Text   deriving stock (Generic)-  deriving newtype (Eq, Ord, Show, FromJSON, ToJSON)+  deriving newtype (Eq, Ord, Show, ToJSON)  -- | Project the normalized identifier text. loginIdText :: LoginId -> Text@@ -33,8 +33,20 @@ -- 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 =+mkLoginId raw+  | Text.length raw > 256 = Left InvalidLoginId+  | otherwise = do+      lid <- parseLoginIdForAuthentication raw+      if Text.length (loginIdText lid) <= 256 then Right lid else Left InvalidLoginId++-- | Compatibility parser for persisted identities and authentication only. New writes must+-- revalidate with mkLoginId; legacy principals are never truncated or renamed.+parseLoginIdForAuthentication :: Text -> Either AuthError LoginId+parseLoginIdForAuthentication raw =   let t = Text.toLower (Text.strip raw)    in if Text.null t || Text.any isSpace t         then Left InvalidLoginId         else Right (LoginId t)++instance FromJSON LoginId where+  parseJSON = withText "LoginId" (either (const (fail "invalid login identifier")) pure . mkLoginId)

@@ -75,7 +75,7 @@   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)+  | Text.length pw > min 256 policy.maxLength = Left (PasswordTooLong (min 256 policy.maxLength))   | policy.rejectCommonPasswords && isCommonPassword pw = Left PasswordTooCommon   | policy.rejectContextualPasswords && resemblesIdentity context pw = Left PasswordResemblesIdentity   | otherwise = Right ()

@@ -3,11 +3,15 @@   ( UserStatus (..),     User (..),     NewUser (..),+    validateNewUser,   ) where -import Shomei.Account.Email.Domain (Email)-import Shomei.Account.LoginId.Domain (LoginId)+import Data.Aeson (withObject, (.:), (.:?))+import Data.Text qualified as Text+import Shomei.Account.Email.Domain (Email, emailText, mkEmail, parseStoredEmail)+import Shomei.Account.LoginId.Domain (LoginId, loginIdText, mkLoginId, parseLoginIdForAuthentication)+import Shomei.Error (AuthError (..)) import Shomei.Id (UserId) import Shomei.Prelude @@ -26,12 +30,38 @@     updatedAt :: !UTCTime   }   deriving stock (Generic, Eq, Show)-  deriving anyclass (FromJSON, ToJSON)+  deriving anyclass (ToJSON) +-- Wire snapshots of persisted users deliberately retain legacy identity sizes.+instance FromJSON User where+  parseJSON = withObject "User" \o -> do+    loginId <- o .: "loginId" >>= either (const (fail "invalid stored login identifier")) pure . parseLoginIdForAuthentication+    email <- o .:? "email" >>= traverse (either (const (fail "invalid stored email")) pure . parseStoredEmail)+    User+      <$> o .: "userId"+      <*> pure loginId+      <*> pure email+      <*> o .:? "displayName"+      <*> o .: "status"+      <*> o .:? "emailVerifiedAt"+      <*> o .: "createdAt"+      <*> o .: "updatedAt"+ data NewUser = NewUser   { loginId :: !LoginId,     email :: !(Maybe Email),     displayName :: !(Maybe Text)   }   deriving stock (Generic, Eq, Show)-  deriving anyclass (FromJSON, ToJSON)+  deriving anyclass (ToJSON)++validateNewUser :: NewUser -> Either AuthError ()+validateNewUser new = do+  _ <- mkLoginId (loginIdText new.loginId)+  _ <- traverse (mkEmail . emailText) new.email+  when (maybe False ((> 256) . Text.length) new.displayName) (Left InvalidInput)++instance FromJSON NewUser where+  parseJSON = withObject "NewUser" \o -> do+    new <- NewUser <$> o .: "loginId" <*> o .:? "email" <*> o .:? "displayName"+    either (const (fail "invalid new user")) (const (pure new)) (validateNewUser new)

@@ -55,12 +55,14 @@   ) where +import Data.Aeson (withObject, (.:), (.:?)) import Data.Set (Set)-import Shomei.Account.Email.Domain (Email)-import Shomei.Account.LoginId.Domain (LoginId)+import Data.UUID qualified as UUID+import Shomei.Account.Email.Domain (Email, parseStoredEmail)+import Shomei.Account.LoginId.Domain (LoginId, parseLoginIdForAuthentication) import Shomei.Authorization.Claims.Domain (Role, Scope) import Shomei.Config (ServiceAccountId)-import Shomei.Id (CeremonyId, PasskeyId, RefreshTokenId, SessionId, UserId)+import Shomei.Id (CeremonyId, PasskeyId, RefreshTokenId, SessionId, UserId, parseId, sessionIdFromUUID) import Shomei.Prelude import Shomei.Session.LoginAttempt.Domain (AccountKey, ClientIp) @@ -71,7 +73,7 @@     occurredAt :: !UTCTime   }   deriving stock (Generic, Eq, Show)-  deriving anyclass (FromJSON, ToJSON)+  deriving anyclass (ToJSON)  data LoginSucceededData = LoginSucceededData   { userId :: !UserId,@@ -107,7 +109,7 @@     occurredAt :: !UTCTime   }   deriving stock (Generic, Eq, Show)-  deriving anyclass (FromJSON, ToJSON)+  deriving anyclass (ToJSON)  data RefreshTokenRotatedData = RefreshTokenRotatedData   { sessionId :: !SessionId,@@ -131,7 +133,7 @@     occurredAt :: !UTCTime   }   deriving stock (Generic, Eq, Show)-  deriving anyclass (FromJSON, ToJSON)+  deriving anyclass (ToJSON)  data EmailVerifiedData = EmailVerifiedData   { userId :: !UserId,@@ -139,7 +141,7 @@     occurredAt :: !UTCTime   }   deriving stock (Generic, Eq, Show)-  deriving anyclass (FromJSON, ToJSON)+  deriving anyclass (ToJSON)  data PasswordResetRequestedData = PasswordResetRequestedData   { userId :: !UserId,@@ -147,7 +149,7 @@     occurredAt :: !UTCTime   }   deriving stock (Generic, Eq, Show)-  deriving anyclass (FromJSON, ToJSON)+  deriving anyclass (ToJSON)  data PasswordResetCompletedData = PasswordResetCompletedData   { userId :: !UserId,@@ -550,3 +552,34 @@   | NotificationDeliveryFailed NotificationDeliveryFailedData   deriving stock (Generic, Eq, Show)   deriving anyclass (FromJSON, ToJSON)++instance FromJSON UserRegisteredData where+  parseJSON = withObject "UserRegisteredData" \o -> do+    loginId <- o .: "loginId" >>= either (const (fail "invalid stored login identifier")) pure . parseLoginIdForAuthentication+    email <- o .:? "email" >>= traverse (either (const (fail "invalid stored email")) pure . parseStoredEmail)+    UserRegisteredData <$> o .: "userId" <*> pure loginId <*> pure email <*> o .: "occurredAt"++instance FromJSON EmailVerificationRequestedData where+  parseJSON = withObject "EmailVerificationRequestedData" \o -> do+    email <- o .: "email" >>= either (const (fail "invalid stored email")) pure . parseStoredEmail+    EmailVerificationRequestedData <$> o .: "userId" <*> pure email <*> o .: "occurredAt"++instance FromJSON EmailVerifiedData where+  parseJSON = withObject "EmailVerifiedData" \o -> do+    email <- o .: "email" >>= either (const (fail "invalid stored email")) pure . parseStoredEmail+    EmailVerifiedData <$> o .: "userId" <*> pure email <*> o .: "occurredAt"++instance FromJSON PasswordResetRequestedData where+  parseJSON = withObject "PasswordResetRequestedData" \o -> do+    email <- o .: "email" >>= either (const (fail "invalid stored email")) pure . parseStoredEmail+    PasswordResetRequestedData <$> o .: "userId" <*> pure email <*> o .: "occurredAt"++-- Bulk SQL keeps the persisted session UUID in its payload. Public encoding remains the+-- canonical TypeID, matching ordinary single-session events and the session_id column.+instance FromJSON SessionRevokedData where+  parseJSON = withObject "SessionRevokedData" \o -> do+    raw <- o .: "sessionId"+    sid <- case parseId raw of+      Right typed -> pure typed+      Left _ -> maybe (fail "invalid audit session identifier") (pure . sessionIdFromUUID) (UUID.fromText raw)+    SessionRevokedData sid <$> o .:? "revokedBy" <*> o .: "occurredAt"

@@ -5,6 +5,8 @@     Audience (..),     Scope (..),     Role (..),+    validRoleName,+    validScopeName,     Permission (..),     AuthClaims (..),     reservedClaimKeys,@@ -13,10 +15,12 @@   ) where -import Data.Aeson (Object)+import Data.Aeson (Object, withText) import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap+import Data.Char (isSpace) import Data.Set (Set)+import Data.Text qualified as Text import Shomei.Id (SessionId, UserId) import Shomei.Prelude @@ -30,11 +34,26 @@  newtype Scope = Scope Text   deriving stock (Generic)-  deriving newtype (Eq, Ord, Show, FromJSON, ToJSON)+  deriving newtype (Eq, Ord, Show, ToJSON) +validScopeName :: Scope -> Bool+validScopeName (Scope t) = not (Text.null t) && Text.length t <= 128 && not (Text.any isSpace t)++instance FromJSON Scope where+  parseJSON = withText "Scope" \t ->+    if validScopeName (Scope t) then pure (Scope t) else fail "invalid scope name"+ newtype Role = Role Text   deriving stock (Generic)-  deriving newtype (Eq, Ord, Show, FromJSON, ToJSON)+  deriving newtype (Eq, Ord, Show, ToJSON)++-- Preserve the established vocabulary, including internal whitespace in role names.+validRoleName :: Role -> Bool+validRoleName (Role t) = not (Text.null (Text.strip t)) && Text.length t <= 128++instance FromJSON Role where+  parseJSON = withText "Role" \t ->+    if validRoleName (Role t) then pure (Role (Text.strip t)) else fail "invalid role name"  -- | 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.

@@ -7,9 +7,8 @@ -- 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.+-- Grants validate the finite role-name budget before lookup. Revocation retains compatibility+-- with stored roles; boundaries normalize submitted role text without changing its vocabulary. module Shomei.Authorization.Role.Workflow   ( grantRoleTo,     revokeRoleFrom,@@ -25,7 +24,7 @@ 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.Claims.Domain (Role, validRoleName) import Shomei.Authorization.Role.Store   ( RoleDefinition (..),     RoleStore,@@ -62,7 +61,12 @@   UserId ->   Role ->   Eff es (Either AuthError Bool)-grantRoleTo actor expiry subject role = do+grantRoleTo actor expiry subject role+  | not (validRoleName role) = pure (Left InvalidInput)+  | otherwise = grantValidRoleTo actor expiry subject role++grantValidRoleTo :: (UserStore :> es, RoleStore :> es, AuthEventPublisher :> es, Clock :> es) => Maybe UserId -> Maybe UTCTime -> UserId -> Role -> Eff es (Either AuthError Bool)+grantValidRoleTo actor expiry subject role = do   mUser <- findUserById subject   case mUser of     Nothing -> pure (Left UserNotFound)

@@ -41,6 +41,7 @@     defaultAccessTokenTTL,     defaultRefreshTokenTTL,     defaultSessionTTL,+    defaultRememberedSessionTTL,     defaultVerificationTokenTTL,     defaultPasswordResetTokenTTL,     defaultRateLimitConfig,@@ -151,7 +152,9 @@     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+    allowedClockSkewSeconds :: !Int,+    legacyActorUntilUnix :: !(Maybe Int),+    emitLegacyActor :: !Bool   }   deriving stock (Generic, Eq, Show)   deriving anyclass (FromJSON, ToJSON)@@ -438,6 +441,13 @@     accessTokenTTL :: !NominalDiffTime,     refreshTokenTTL :: !NominalDiffTime,     sessionTTL :: !NominalDiffTime,+    -- | the absolute lifetime of a session whose owner asked to stay signed in at sign-in (the+    --     @remember@ request field). Refresh tokens keep their 'refreshTokenTTL' sliding window+    --     and never outlive the session, so a remembered browser left unused for longer than+    --     'refreshTokenTTL' still has to sign in again.+    rememberedSessionTTL :: !NominalDiffTime,+    maxPasskeysPerUser :: !Int,+    maxActiveNonInteractiveSessions :: !Int,     passwordPolicy :: !PasswordPolicy,     tokenTransport :: !TokenTransport,     signingKeyConfig :: !SigningKeyConfig,@@ -465,10 +475,11 @@   deriving stock (Generic, Eq, Show)   deriving anyclass (FromJSON, ToJSON) -defaultAccessTokenTTL, defaultRefreshTokenTTL, defaultSessionTTL :: NominalDiffTime+defaultAccessTokenTTL, defaultRefreshTokenTTL, defaultSessionTTL, defaultRememberedSessionTTL :: NominalDiffTime defaultAccessTokenTTL = 15 * 60 -- 15 minutes defaultRefreshTokenTTL = 30 * 24 * 60 * 60 -- 30 days defaultSessionTTL = 30 * 24 * 60 * 60 -- 30 days+defaultRememberedSessionTTL = 365 * 24 * 60 * 60 -- 365 days  defaultVerificationTokenTTL, defaultPasswordResetTokenTTL :: NominalDiffTime defaultVerificationTokenTTL = 24 * 60 * 60 -- 24 hours@@ -509,9 +520,12 @@       accessTokenTTL = defaultAccessTokenTTL,       refreshTokenTTL = defaultRefreshTokenTTL,       sessionTTL = defaultSessionTTL,+      rememberedSessionTTL = defaultRememberedSessionTTL,+      maxPasskeysPerUser = 20,+      maxActiveNonInteractiveSessions = 1000,       passwordPolicy = defaultPasswordPolicy,       tokenTransport = BearerToken,-      signingKeyConfig = SigningKeyConfig {algorithm = "ES256", refreshIntervalSeconds = 60, allowedClockSkewSeconds = 30},+      signingKeyConfig = SigningKeyConfig {algorithm = "ES256", refreshIntervalSeconds = 60, allowedClockSkewSeconds = 30, legacyActorUntilUnix = Nothing, emitLegacyActor = False},       sessionCheckMode = VerifyTokenOnly,       notifierConfig =         NotifierConfig

@@ -23,7 +23,7 @@ import Data.Set qualified as Set import Data.Time (NominalDiffTime, addUTCTime) import Effectful (Eff, (:>))-import Effectful.Error.Static (runErrorNoCallStack, throwError)+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@@ -34,7 +34,7 @@ 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.Store (SessionStore, createSessionWithinLimit, revokeSession) import Shomei.Session.Token.Domain (AccessToken) import Shomei.Session.Workflow (requireLiveSession) import Shomei.SigningKey.Signer (TokenSigner, signAccessToken)@@ -138,7 +138,8 @@ -- different events. mintDelegatedToken ::   ( SessionStore :> es,-    TokenSigner :> es+    TokenSigner :> es,+    Error AuthError :> es   ) =>   ShomeiConfig ->   UTCTime ->@@ -147,17 +148,20 @@ 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-        }+    either throwError pure+      =<< createSessionWithinLimit+        cfg.maxActiveNonInteractiveSessions+        NewSession+          { userId = mint.subjectUserId,+            createdAt = ts,+            expiresAt = expires,+            actor = Just mint.actorUserId,+            oauthClientId = Nothing,+            kind = DelegatedSession,+            grantedScopes = Set.empty,+            authenticatedAt = ts,+            remembered = False+          }   let claims =         AuthClaims           { subject = mint.subjectUserId,

@@ -53,7 +53,8 @@   deriving anyclass (FromJSON, ToJSON)  data AuthError-  = InvalidEmail+  = InvalidInput+  | InvalidEmail   | -- | The supplied login identifier was empty or contained internal whitespace.     InvalidLoginId   | WeakPassword PasswordPolicyViolation@@ -90,6 +91,8 @@   | -- | The per-IP failure throttle tripped; the HTTP layer maps it to 429.     TooManyRequests   | TokenInvalid TokenError+  | SessionLimitReached+  | PasskeyLimitReached   | -- | A WebAuthn registration verification failed (bad attestation, origin/challenge     -- mismatch, or malformed credential JSON). The HTTP layer maps this to 400.     WebAuthnCeremonyError WebAuthnError

@@ -17,9 +17,11 @@ module Shomei.Mfa.Workflow   ( prepareMfaChallenge,     completeMfa,+    completeMfaWith,     MfaCompletion (..),     beginPasswordlessLogin,     completePasswordlessLogin,+    completePasswordlessLoginWith,   ) where @@ -173,7 +175,35 @@   CeremonyId ->   MfaCompletion ->   Eff es (Either AuthError (User, TokenPair))-completeMfa cfg pctx ceremonyId completion = runErrorNoCallStack do+completeMfa cfg pctx = completeMfaWith cfg pctx False++-- | 'completeMfa' for a sign-in whose owner may have asked to stay signed in. The decision+-- arrives with the second factor rather than the password, because the password step issues+-- no session.+completeMfaWith ::+  ( 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 ->+  -- | whether the person asked to stay signed in+  Bool ->+  CeremonyId ->+  MfaCompletion ->+  Eff es (Either AuthError (User, TokenPair))+completeMfaWith cfg pctx remember ceremonyId completion = runErrorNoCallStack do   ts <- now   PendingCeremony {kind, userId = mUid, optionsBlob} <-     maybe (throwError PendingCeremonyNotFound) pure =<< takePendingCeremony ceremonyId ts@@ -208,7 +238,7 @@     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+  (sid, pair) <- issueSession cfg remember user ts   publishAuthEvent (Event.MfaSucceeded (Event.MfaSucceededData uid sid ts))   pure (user, pair) @@ -314,7 +344,31 @@   CeremonyId ->   Value ->   Eff es (Either AuthError (User, TokenPair))-completePasswordlessLogin cfg pctx ceremonyId assertion = runErrorNoCallStack do+completePasswordlessLogin cfg pctx = completePasswordlessLoginWith cfg pctx False++-- | 'completePasswordlessLogin' for a sign-in whose owner may have asked to stay signed in.+completePasswordlessLoginWith ::+  ( 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 ->+  -- | whether the person asked to stay signed in+  Bool ->+  CeremonyId ->+  Value ->+  Eff es (Either AuthError (User, TokenPair))+completePasswordlessLoginWith cfg pctx remember ceremonyId assertion = runErrorNoCallStack do   ts <- now   PendingCeremony {kind, optionsBlob} <-     maybe (throwError PendingCeremonyNotFound) pure =<< takePendingCeremony ceremonyId ts@@ -341,14 +395,14 @@   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+  (sid, pair) <- issueSession cfg remember 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+-- 'completeAuthenticationCeremony'. On a decode/verify failure, a clone-counter error, 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 ::@@ -378,11 +432,7 @@   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)+    Right verified -> 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.

@@ -16,7 +16,6 @@     consumeAuthorizationCode,     bindAuthorizationCodeSession,     findConsumedAuthorizationCode,-    deleteExpiredAuthorizationCodes,   ) where @@ -40,9 +39,6 @@   -- | 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 @@ -57,6 +53,3 @@  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

@@ -33,12 +33,13 @@ 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.Claims.Domain (AuthClaims (..), Scope (..), validScopeName) import Shomei.Authorization.Scope.Domain (privilegeScopes, privilegeScopesIn) import Shomei.Config (ShomeiConfig) import Shomei.OAuth.AuthorizationCode.Domain (NewAuthorizationCode (..))@@ -161,7 +162,7 @@   session <-     either (const (throwError (AuthorizeLoginRequired SessionNotLive))) pure       =<< requireLiveSession ts claims.sessionId-  unless ((session ^. #kind) == InteractiveSession) $+  unless ((session ^. #kind) == InteractiveSession && not (isJust (session ^. #actor))) $     throwError (AuthorizeLoginRequired NonInteractiveCredential)   unless (params.responseType == Just "code") (throwError UnsupportedResponseType)   challenge <- resolvePkce@@ -219,7 +220,7 @@         when (Set.null granted) (throwError AuthorizeInvalidScope)         pure granted       Just requested -> do-        when (Set.null requested) (throwError AuthorizeInvalidScope)+        when (Set.null requested || not (all validScopeName requested)) (throwError AuthorizeInvalidScope)         unless (requested `Set.isSubsetOf` (client ^. #allowedScopes)) (throwError AuthorizeInvalidScope)         unless (Set.null (privilegeScopesIn cfg requested)) (throwError AuthorizeInvalidScope)         pure requested

@@ -18,7 +18,11 @@ -- | 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)+  deriving newtype (Eq)++-- | Wire DTOs explicitly unwrap ID tokens. Generic diagnostics never expose a credential.+instance Show IdToken where+  show _ = "IdToken <redacted>"  data IdTokenClaims = IdTokenClaims   { issuer :: !Issuer,

@@ -50,7 +50,7 @@ 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.Domain (AuthClaims (..), Scope (..), validScopeName) import Shomei.Authorization.Scope.Domain (tokenExchangeSubjectScope) import Shomei.Config (ImpersonationConfig (..), MachineTokenConfig (..), SessionCheckMode (VerifyTokenAndSession), ShomeiConfig (..)) import Shomei.Delegation.Workflow@@ -255,6 +255,7 @@   Set Scope ->   Eff es (Set Scope) narrowScopes mRequested allowed subjectScopes = do+  unless (maybe True (all validScopeName) mRequested) (throwError OAuthScopeInvalid)   let ceiling_ = Set.delete tokenExchangeSubjectScope allowed       requested = fromMaybe ceiling_ mRequested       granted = Set.intersection requested ceiling_

@@ -36,6 +36,7 @@ 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. @@ -193,7 +194,7 @@   (sid, pair, claims) <-     issueSessionWith       cfg-      SessionOptions {oauthClientId = Just (cmd ^. #clientId), extraScopes = granted}+      SessionOptions {oauthClientId = Just (cmd ^. #clientId), extraScopes = granted, remember = False}       user       ts   bindAuthorizationCodeSession (row ^. #codeHash) sid@@ -210,9 +211,23 @@       Nothing -> pure ()       Just expected -> do         verifier <- maybe (throwError (GrantInvalidGrant "code_verifier is required")) pure (cmd ^. #codeVerifier)+        unless (validVerifier verifier) $+          throwError (GrantInvalidGrant "code_verifier has invalid length or alphabet")         let actual = pkceChallengeFor verifier         unless (TE.encodeUtf8 expected `BA.constEq` TE.encodeUtf8 actual) $           throwError (GrantInvalidGrant "code_verifier does not match the stored code_challenge")++-- RFC 7636 section 4.1 requires ASCII unreserved characters, independently of+-- whether an invalid input happens to hash to the stored challenge.+validVerifier :: Text -> Bool+validVerifier verifier =+  Text.length verifier >= 43 && Text.length verifier <= 128 && Text.all unreserved verifier+  where+    unreserved c =+      (c >= 'A' && c <= 'Z')+        || (c >= 'a' && c <= 'z')+        || (c >= '0' && c <= '9')+        || c `elem` ("-._~" :: String)  -- | The ID token (OIDC Core §2) for a freshly exchanged code. --

@@ -98,8 +98,7 @@  data VerifiedAuthentication = VerifiedAuthentication   { credentialId :: !WebAuthnCredentialId,-    newSignCounter :: !SignatureCounter,-    cloneWarning :: !Bool+    newSignCounter :: !SignatureCounter   }   deriving stock (Generic, Eq, Show) 

@@ -25,11 +25,13 @@   ) where +import Data.Text qualified as Text import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) import Effectful.Dispatch.Dynamic (send)+import Shomei.Error (AuthError (..)) import Shomei.Id (PasskeyId, UserId) import Shomei.Passkey.Domain-  ( NewPasskeyCredential,+  ( NewPasskeyCredential (..),     PasskeyCredential,     SignatureCounter,     UserHandle,@@ -38,7 +40,8 @@ import Shomei.Prelude  data PasskeyStore :: Effect where-  CreatePasskey :: NewPasskeyCredential -> PasskeyStore m PasskeyCredential+  -- | Atomically count and insert within the requested 1–100 credential ceiling.+  CreatePasskey :: Int -> NewPasskeyCredential -> PasskeyStore m (Either AuthError PasskeyCredential)   FindPasskeysByUser :: UserId -> PasskeyStore m [PasskeyCredential]   FindPasskeyByCredentialId :: WebAuthnCredentialId -> PasskeyStore m (Maybe PasskeyCredential)   FindPasskeysByUserHandle :: UserHandle -> PasskeyStore m [PasskeyCredential]@@ -51,8 +54,10 @@  type instance DispatchOf PasskeyStore = Dynamic -createPasskey :: (PasskeyStore :> es) => NewPasskeyCredential -> Eff es PasskeyCredential-createPasskey = send . CreatePasskey+createPasskey :: (PasskeyStore :> es) => Int -> NewPasskeyCredential -> Eff es (Either AuthError PasskeyCredential)+createPasskey limit credential+  | maybe False ((> 128) . Text.length) credential.label = pure (Left InvalidInput)+  | otherwise = send (CreatePasskey limit credential)  findPasskeysByUser :: (PasskeyStore :> es) => UserId -> Eff es [PasskeyCredential] findPasskeysByUser = send . FindPasskeysByUser

@@ -83,6 +83,7 @@   ts <- now   user <- maybe (throwError InvalidCredentials) pure =<< findUserById uid   existing <- findPasskeysByUser uid+  when (length existing >= cfg.maxPasskeysPerUser) (throwError PasskeyLimitReached)   -- 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).@@ -120,7 +121,8 @@   Value ->   Maybe Text ->   Eff es (Either AuthError PasskeyCredential)-completePasskeyRegistration _cfg uid ceremonyId credentialJson mLabel = runErrorNoCallStack do+completePasskeyRegistration cfg uid ceremonyId credentialJson mLabel = runErrorNoCallStack do+  when (maybe False ((> 128) . Text.length) mLabel) (throwError InvalidInput)   ts <- now   PendingCeremony {kind, userId = pendingUid, optionsBlob} <-     maybe (throwError PendingCeremonyNotFound) pure =<< takePendingCeremony ceremonyId ts@@ -131,17 +133,19 @@     either (throwError . WebAuthnCeremonyError) pure       =<< completeRegistrationCeremony optionsBlob credentialJson   passkey <--    createPasskey-      NewPasskeyCredential-        { userId = uid,-          credentialId,-          userHandle,-          publicKey,-          signCounter,-          transports,-          label = normalizeLabel =<< mLabel,-          createdAt = ts-        }+    either throwError pure+      =<< createPasskey+        cfg.maxPasskeysPerUser+        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

@@ -19,6 +19,7 @@ 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@@ -28,7 +29,7 @@ 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.Authorization.Claims.Domain (Scope, validScopeName) import Shomei.Config (MachineTokenConfig (..), ServiceAccountId (..), ShomeiConfig (..)) import Shomei.Error (AuthError (..)) import Shomei.Id (SessionId)@@ -37,7 +38,7 @@ 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.Store (SessionStore, createSessionWithinLimit) import Shomei.Session.Token.Domain (AccessToken) import Shomei.Session.Workflow (buildClaims) import Shomei.SigningKey.Signer (TokenSigner, signAccessToken)@@ -79,6 +80,7 @@   ClientCredentialsGrant ->   Eff es (Either AuthError GrantedToken) grantClientCredentials cfg cmd = runErrorNoCallStack do+  unless (maybe True (all validScopeName) cmd.requestedScopes) (throwError OAuthScopeInvalid)   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.@@ -95,17 +97,20 @@   -- 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-        }+    either throwError pure+      =<< createSessionWithinLimit+        cfg.maxActiveNonInteractiveSessions+        NewSession+          { userId = serviceUser ^. #userId,+            createdAt = ts,+            expiresAt = expires,+            actor = Nothing,+            oauthClientId = Nothing,+            kind = MachineSession,+            grantedScopes = Set.empty,+            authenticatedAt = ts,+            remembered = False+          }   let claims =         (buildClaims cfg (serviceUser ^. #userId) (session ^. #sessionId) ts)           & #expiresAt

@@ -30,6 +30,7 @@ import Data.Aeson (Value) import Data.Set (Set) import Data.Set qualified as Set+import Data.Text qualified as Text import Data.Time (addUTCTime) import Effectful (Eff, IOE, (:>)) import Effectful.Error.Static (Error, runErrorNoCallStack, throwError)@@ -38,9 +39,9 @@ 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.Domain (PasswordContext (..), PlainPassword (..), validatePassword) import Shomei.Account.Password.Hash.Store (PasswordHasher, hashPassword, verifyPassword, verifyPasswordDummy)-import Shomei.Account.User.Domain (NewUser (..), User (..), UserStatus (UserActive))+import Shomei.Account.User.Domain (NewUser (..), User (..), UserStatus (UserActive), validateNewUser) 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)@@ -49,7 +50,7 @@ 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.Error (AuthError (..), PasswordPolicyViolation (..)) import Shomei.Id (CeremonyId, UserId) import Shomei.Mfa.RecoveryCode.Store (RecoveryCodeStore) import Shomei.Mfa.Totp.Domain (isTotpConfirmed)@@ -130,6 +131,7 @@   SignupCommand ->   Eff es (Either AuthError (User, TokenPair)) signup cfg cmd = runErrorNoCallStack do+  either throwError pure (validateNewUser NewUser {loginId = cmd.loginId, email = cmd.email, displayName = cmd.displayName})   let pwContext =         PasswordContext           { contextEmail = emailText <$> cmd.email,@@ -163,7 +165,8 @@           oauthClientId = Nothing,           kind = InteractiveSession,           grantedScopes = Set.empty,-          authenticatedAt = ts+          authenticatedAt = ts,+          remembered = False         }       NewSessionToken         { tokenHash = tokHash,@@ -177,7 +180,7 @@   access <- signAccessToken =<< buildEnrichedClaims cfg user.userId session.sessionId ts   pure     ( user,-      TokenPair {accessToken = access, refreshToken = rawToken, expiresIn = cfg.accessTokenTTL}+      TokenPair {accessToken = access, refreshToken = rawToken, expiresIn = cfg.accessTokenTTL, remembered = session.remembered}     )  -- | Authenticate a login-id/password pair, with EP-2 abuse protection layered on the@@ -216,6 +219,8 @@   LoginCommand ->   Eff es (Either AuthError LoginResult) login cfg ctx cmd = runErrorNoCallStack do+  let PlainPassword submittedPassword = cmd.password+  when (Text.length submittedPassword > 256) (throwError (WeakPassword (PasswordTooLong 256)))   ts <- now   let rl = cfg.rateLimitConfig   guardIpBudget rl ctx ts@@ -265,7 +270,7 @@     else do       convertLoginAttemptToSuccess outcome.attemptId       when (outcome.lockedNow || isJust outcome.priorLockout) (clearAccountLockout ctx.accountKey)-      (_sid, pair) <- issueSession cfg user ts+      (_sid, pair) <- issueSession cfg cmd.remember user ts       pure (LoginComplete user pair)  -- | 'failLogin' preceded by a dummy Argon2id verification, for the login paths that fail@@ -427,7 +432,7 @@                         pure                           ( Right                               Refreshed-                                { tokens = TokenPair {accessToken = access, refreshToken = rawNew, expiresIn = cfg.accessTokenTTL},+                                { tokens = TokenPair {accessToken = access, refreshToken = rawNew, expiresIn = cfg.accessTokenTTL, remembered = s.remembered},                                   grantedScopes = s.grantedScopes                                 }                           )

@@ -33,7 +33,9 @@  data LoginCommand = LoginCommand   { loginId :: !LoginId,-    password :: !PlainPassword+    password :: !PlainPassword,+    -- | the person asked to stay signed in; see 'Shomei.Session.Domain.Session'.+    remember :: !Bool   }   deriving stock (Generic, Show) 

@@ -52,7 +52,12 @@     --     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+    authenticatedAt :: !UTCTime,+    -- | whether the person asked to stay signed in when this session began. A remembered+    --     session lasts 'Shomei.Config.rememberedSessionTTL' instead of 'Shomei.Config.sessionTTL',+    --     and every token pair it yields reports it so the embedder can keep its cookies across+    --     browser restarts. Rows that predate the column read as remembered.+    remembered :: !Bool   }   deriving stock (Generic, Eq, Show)   deriving anyclass (FromJSON, ToJSON)@@ -70,7 +75,9 @@     -- | 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+    authenticatedAt :: !UTCTime,+    -- | whether the person asked to stay signed in; see 'Session'.+    remembered :: !Bool   }   deriving stock (Generic, Eq, Show)   deriving anyclass (FromJSON, ToJSON)

@@ -6,27 +6,34 @@ module Shomei.Session.Store   ( SessionStore (..),     createSession,+    createSessionWithinLimit,     findSessionById,     revokeSession,     revokeAllUserSessions,     listSessionsForUser,+    SessionCursor (..),+    SessionListQuery (..),+    emptySessionListQuery,+    clampSessionLimit,+    listSessionPage,   ) where  import Effectful (Dispatch (..), DispatchOf, Eff, Effect, (:>)) import Effectful.Dispatch.Dynamic (send)+import Shomei.Error (AuthError (..)) import Shomei.Id (SessionId, UserId) import Shomei.Prelude-import Shomei.Session.Domain (NewSession, Session)+import Shomei.Session.Domain (NewSession (..), Session, SessionKind (InteractiveSession))  data SessionStore :: Effect where   CreateSession :: NewSession -> SessionStore m Session+  CreateSessionWithinLimit :: Int -> NewSession -> SessionStore m (Either AuthError 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.+  RevokeAllUserSessions :: UserId -> UTCTime -> SessionStore m [SessionId]+  ListSessionPage :: UserId -> SessionListQuery -> SessionStore m [Session]+  -- | Compatibility only: every session, materialized in memory. HTTP must use ListSessionPage.   ListSessionsForUser :: UserId -> SessionStore m [Session]  type instance DispatchOf SessionStore = Dynamic@@ -40,8 +47,37 @@ revokeSession :: (SessionStore :> es) => SessionId -> UTCTime -> Eff es () revokeSession sid t = send (RevokeSession sid t) -revokeAllUserSessions :: (SessionStore :> es) => UserId -> UTCTime -> Eff es ()+revokeAllUserSessions :: (SessionStore :> es) => UserId -> UTCTime -> Eff es [SessionId] revokeAllUserSessions uid t = send (RevokeAllUserSessions uid t)  listSessionsForUser :: (SessionStore :> es) => UserId -> Eff es [Session] listSessionsForUser = send . ListSessionsForUser++-- | Stable newest-first keyset over timestamp and unique ID.+data SessionCursor = SessionCursor+  { cursorCreatedAt :: !UTCTime,+    cursorSessionId :: !SessionId+  }+  deriving stock (Eq, Show)++data SessionListQuery = SessionListQuery+  { queryLimit :: !Int,+    queryBefore :: !(Maybe SessionCursor)+  }+  deriving stock (Eq, Show)++emptySessionListQuery :: SessionListQuery+emptySessionListQuery = SessionListQuery 50 Nothing++clampSessionLimit :: Int -> Int+clampSessionLimit = max 1 . min 200++listSessionPage :: (SessionStore :> es) => UserId -> SessionListQuery -> Eff es [Session]+listSessionPage uid query = send (ListSessionPage uid query {queryLimit = clampSessionLimit query.queryLimit})++-- | Each machine/delegated session spends its subject and (when distinct) actor's active+-- budget. Lock both principals in stable order at persistence. Expired sessions spend none.+createSessionWithinLimit :: (SessionStore :> es) => Int -> NewSession -> Eff es (Either AuthError Session)+createSessionWithinLimit cap session+  | cap < 1 || session.kind == InteractiveSession = pure (Left InvalidInput)+  | otherwise = send (CreateSessionWithinLimit cap session)

@@ -0,0 +1,25 @@+-- | RFC 6750 section 2.1 credentials. Schemes are case-insensitive; separators are+-- one or more ASCII spaces, and token padding is allowed only at the end.+module Shomei.Session.Token.Bearer (parseBearer) where++import Data.Text qualified as Text+import Shomei.Prelude++parseBearer :: Text -> Maybe Text+parseBearer raw = do+  let (scheme, separator) = Text.break (== ' ') raw+      token = Text.dropWhile (== ' ') separator+      (body, padding) = Text.break (== '=') token+  if Text.toCaseFold scheme == "bearer"+    && not (Text.null separator)+    && not (Text.null body)+    && Text.all tokenChar body+    && Text.all (== '=') padding+    then Just token+    else Nothing+  where+    tokenChar c =+      (c >= 'A' && c <= 'Z')+        || (c >= 'a' && c <= 'z')+        || (c >= '0' && c <= '9')+        || c `elem` ("-._~+/" :: String)

@@ -23,6 +23,9 @@ data TokenPair = TokenPair   { accessToken :: !AccessToken,     refreshToken :: !RefreshToken,-    expiresIn :: !NominalDiffTime+    expiresIn :: !NominalDiffTime,+    -- | whether the session behind this pair is remembered (see+    --     'Shomei.Session.Domain.Session'); constant for the session's whole life.+    remembered :: !Bool   }   deriving stock (Generic, Eq, Show)

@@ -25,6 +25,7 @@     completePasswordReset,     completePasswordChange,     revokeSessionWithTokens,+    revokeUserSessionsWithAudit,   ) where @@ -106,6 +107,7 @@     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.+  RevokeUserSessionsWithAudit :: UserId -> UserId -> UTCTime -> AuthUnitOfWork m Int   RevokeSessionWithTokens ::     SessionId ->     UTCTime ->@@ -164,3 +166,8 @@   [AuthEvent] ->   Eff es Bool revokeSessionWithTokens sid ts events = send (RevokeSessionWithTokens sid ts events)++-- | Revoke every active session and its tokens, auditing each winner in the same commit.+-- Arguments are actor, target and the application clock timestamp. Returns the winner count.+revokeUserSessionsWithAudit :: (AuthUnitOfWork :> es) => UserId -> UserId -> UTCTime -> Eff es Int+revokeUserSessionsWithAudit actor target ts = send (RevokeUserSessionsWithAudit actor target ts)

@@ -155,12 +155,15 @@     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)+    extraScopes :: !(Set Scope),+    -- | the person asked to stay signed in: the session lasts 'rememberedSessionTTL' instead of+    --     'sessionTTL' and every token pair it yields reports @remembered@.+    remember :: !Bool   }   deriving stock (Generic, Eq, Show)  defaultSessionOptions :: SessionOptions-defaultSessionOptions = SessionOptions {oauthClientId = Nothing, extraScopes = Set.empty}+defaultSessionOptions = SessionOptions {oauthClientId = Nothing, extraScopes = Set.empty, remember = False}  issueSession ::   ( AuthUnitOfWork :> es,@@ -170,11 +173,13 @@     ClaimsEnricher :> es   ) =>   ShomeiConfig ->+  -- | whether the person asked to stay signed in (the sign-in request's @remember@)+  Bool ->   User ->   UTCTime ->   Eff es (SessionId, TokenPair)-issueSession cfg user ts = do-  (sid, pair, _claims) <- issueSessionWith cfg defaultSessionOptions user ts+issueSession cfg remember user ts = do+  (sid, pair, _claims) <- issueSessionWith cfg defaultSessionOptions {remember} user ts   pure (sid, pair)  -- | 'issueSession' with the OAuth-specific knobs, and returning the claims it signed.@@ -197,23 +202,26 @@ issueSessionWith cfg opts user ts = do   rawToken <- generateOpaqueToken   tokHash <- hashRefreshToken rawToken+  let sessionExpiresAt = addUTCTime (if opts.remember then cfg.rememberedSessionTTL else cfg.sessionTTL) ts   (session, _token) <-     persistNewSession       NewSession         { userId = user.userId,           createdAt = ts,-          expiresAt = addUTCTime cfg.sessionTTL ts,+          expiresAt = sessionExpiresAt,           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+          authenticatedAt = ts,+          remembered = opts.remember         }       NewSessionToken         { tokenHash = tokHash,           createdAt = ts,-          expiresAt = addUTCTime cfg.refreshTokenTTL ts+          -- Never mint a token that outlives its session, as rotation also guarantees.+          expiresAt = min (addUTCTime cfg.refreshTokenTTL ts) sessionExpiresAt         }       \sid ->         [ Event.LoginSucceeded (Event.LoginSucceededData user.userId sid ts),@@ -226,6 +234,6 @@   access <- signAccessToken claims   pure     ( session.sessionId,-      TokenPair {accessToken = access, refreshToken = rawToken, expiresIn = cfg.accessTokenTTL},+      TokenPair {accessToken = access, refreshToken = rawToken, expiresIn = cfg.accessTokenTTL, remembered = session.remembered},       claims     )

@@ -106,7 +106,7 @@ 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.Error (AuthError (PasskeyLimitReached, SessionLimitReached), TokenError (..)) import Shomei.Id   ( CeremonyId,     LoginAttemptId,@@ -178,7 +178,7 @@     ServiceAccountStatus (..),   ) import Shomei.ServiceAccount.Store (ServiceAccountStore (..))-import Shomei.Session.Domain (NewSession (..), Session (..), SessionStatus (..))+import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (..), SessionStatus (..)) import Shomei.Session.LoginAttempt.Domain   ( AccountKey,     AccountLockout (..),@@ -197,7 +197,7 @@     RefreshTokenStatus (..),   ) import Shomei.Session.RefreshToken.Store (RefreshTokenStore (..))-import Shomei.Session.Store (SessionStore (..))+import Shomei.Session.Store (SessionCursor (..), SessionListQuery (..), SessionStore (..), clampSessionLimit) import Shomei.Session.Token.Domain (AccessToken (..)) import Shomei.Session.Token.Generator (TokenGen (..)) import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork (..), NewSessionToken (..), RotationOutcome (..))@@ -418,7 +418,7 @@     liftIO       ( modifyWorld           ref-          (#credsByLoginId %~ Map.map (\c -> if c.userId == uid then c & #passwordHash .~ h else c))+          (\w -> w & #credsByLoginId %~ Map.map (\c -> if c.userId == uid then c & #passwordHash .~ h & #updatedAt .~ w.clock else c))       )  runSessionStore :: (IOE :> es) => IORef World -> Eff (SessionStore : es) a -> Eff es a@@ -428,19 +428,46 @@     let s = mkSession sid ns     liftIO (modifyWorld ref (#sessions %~ Map.insert sid s))     pure s+  CreateSessionWithinLimit cap ns -> do+    sid <- genSessionId+    let session = mkSession sid ns+        principals = Set.fromList (ns.userId : maybe [] pure ns.actor)+    liftIO+      ( atomicModifyIORef' ref \w ->+          let count principal =+                length+                  [ ()+                  | s <- Map.elems w.sessions,+                    s.status == SessionActive,+                    s.kind /= InteractiveSession,+                    s.expiresAt > ns.createdAt,+                    s.userId == principal || s.actor == Just principal+                  ]+           in if any ((>= cap) . count) principals+                then (w, Left SessionLimitReached)+                else (w & #sessions %~ Map.insert sid session, Right session)+      )   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))+      ( atomicModifyIORef' ref \w ->+          let winners = [s.sessionId | s <- Map.elems w.sessions, s.userId == uid, s.status == SessionActive]+           in (w & #sessions %~ Map.map (\s -> if s.userId == uid then revoke t s else s), winners)       )+  ListSessionPage uid query -> liftIO do+    w <- readIORef ref+    let before s = case query.queryBefore of+          Nothing -> True+          Just cursor -> (s.createdAt, sessionIdToUUID s.sessionId) < (cursor.cursorCreatedAt, sessionIdToUUID cursor.cursorSessionId)+    pure (take (clampSessionLimit query.queryLimit) (filter before (sessionsOf uid w)))   ListSessionsForUser uid ->     liftIO (sessionsOf uid <$> readIORef ref)   where-    revoke t s = s & #status .~ SessionRevoked & #revokedAt .~ Just t+    revoke t s+      | s.status == SessionActive = s & #status .~ SessionRevoked & #revokedAt .~ Just t+      | otherwise = s     sessionsOf uid w =       sortOn (Down . \s -> (s.createdAt, sessionIdToUUID s.sessionId)) [s | s <- Map.elems w.sessions, s.userId == uid] @@ -458,7 +485,8 @@       oauthClientId = ns.oauthClientId,       kind = ns.kind,       grantedScopes = ns.grantedScopes,-      authenticatedAt = ns.authenticatedAt+      authenticatedAt = ns.authenticatedAt,+      remembered = ns.remembered     }  runRefreshTokenStore :: (IOE :> es) => IORef World -> Eff (RefreshTokenStore : es) a -> Eff es a@@ -661,7 +689,7 @@                                . Map.adjust (consumeReset ts) tid                            )                         & #credsByLoginId-                        %~ Map.map (replaceUserHash uid newHash)+                        %~ Map.map (replaceUserHash uid newHash ts)                         & #sessions                         %~ Map.map (revokeUserSession uid ts)                         & #refreshTokens@@ -677,7 +705,7 @@           let userSessions = w.sessions            in w                 & #credsByLoginId-                %~ Map.map (replaceUserHash uid newHash)+                %~ Map.map (replaceUserHash uid newHash ts)                 & #sessions                 %~ Map.map (revokeUserSession uid ts)                 & #refreshTokens@@ -685,6 +713,22 @@                 & #publishedEvents                 %~ (reverse events <>)       )+  RevokeUserSessionsWithAudit actor uid ts ->+    liftIO+      ( atomicModifyIORef' ref \w ->+          let winners = [s | s <- Map.elems w.sessions, s.userId == uid, s.status == SessionActive]+              ids = Set.fromList (map (.sessionId) winners)+              events = [Event.SessionRevoked (Event.SessionRevokedData s.sessionId (Just actor) ts) | s <- winners]+           in ( w+                  & #sessions+                  %~ Map.map (revokeUserSession uid ts)+                  & #refreshTokens+                  %~ Map.map (\tok -> if tok.sessionId `Set.member` ids then tok & #status .~ RefreshTokenRevoked & #revokedAt .~ Just ts else tok)+                  & #publishedEvents+                  %~ (reverse events <>),+                length winners+              )+      )   RevokeSessionWithTokens sid ts events ->     liftIO       ( atomicModifyIORef' ref \w -> case Map.lookup sid w.sessions of@@ -710,8 +754,8 @@         tok.status == OneTimeTokenActive =           tok & #status .~ OneTimeTokenRevoked & #revokedAt .~ Just t       | otherwise = tok-    replaceUserHash uid h credential-      | credential.userId == uid = credential & #passwordHash .~ h+    replaceUserHash uid h ts credential+      | credential.userId == uid = credential & #passwordHash .~ h & #updatedAt .~ ts       | otherwise = credential     revokeUserSession uid t session       | session.userId == uid,@@ -929,7 +973,7 @@  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+  CreatePasskey limit NewPasskeyCredential {userId, credentialId, userHandle, publicKey, signCounter, transports, label, createdAt} -> do     pid <- genPasskeyId     let pc =           PasskeyCredential@@ -944,8 +988,12 @@               createdAt,               lastUsedAt = Nothing             }-    liftIO (modifyWorld ref (#passkeys %~ Map.insert pid pc))-    pure pc+    liftIO+      ( atomicModifyIORef' ref \w ->+          if limit < 1 || limit > 100 || length [p | p <- Map.elems w.passkeys, pkUserId p == userId] >= limit+            then (w, Left PasskeyLimitReached)+            else (w & #passkeys %~ Map.insert pid pc, Right pc)+      )   FindPasskeysByUser uid ->     liftIO ((\w -> [p | p <- Map.elems w.passkeys, pkUserId p == uid]) <$> readIORef ref)   FindPasskeyByCredentialId cid ->@@ -1137,8 +1185,6 @@             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).@@ -1393,7 +1439,7 @@ -- --   * '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+--     @newSignCounter = stored + 1@, 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@@ -1451,8 +1497,7 @@           Right             VerifiedAuthentication               { credentialId = storedCid,-                newSignCounter = SignatureCounter (n + 1),-                cloneWarning = False+                newSignCounter = SignatureCounter (n + 1)               }  -- | Run an 'Eff' computation that uses every port against a shared in-memory 'World', with no

@@ -41,6 +41,7 @@       testDeleteIsTerminal,       testReinstateRestoresLogin,       testRevokeUserSessionsCountsOnlyActiveOnes,+      testConcurrentBulkRevocation,       testRevokeOneSessionRecordsActor,       testMissingTargetsAreNotFound     ]@@ -67,7 +68,7 @@     }  loginCmd :: LoginCommand-loginCmd = LoginCommand {loginId = aliceLogin, password = strongPw}+loginCmd = LoginCommand {loginId = aliceLogin, password = strongPw, remember = False}  orFail :: (Show e) => Either e a -> Eff es a orFail = either (\e -> error ("workflow failed: " <> show e)) pure@@ -224,3 +225,12 @@     suspendMissing @?= Left UserNotFound     revokeMissing @?= Right 0     revokeGhostSession @?= Left SessionNotFound++testConcurrentBulkRevocation :: TestTree+testConcurrentBulkRevocation = testCase "eight bulk revokers audit each active session exactly once" $ withWorld \ref -> do+  (user, _) <- either (assertFailure . show) pure =<< runInMemory ref (signup cfg signupCmd)+  admin <- genUserId+  results <- mapConcurrently (\_ -> runInMemory ref (revokeUserSessions admin user.userId)) [1 .. 8 :: Int]+  sum <$> traverse (either (assertFailure . show) pure) results >>= (@?= 1)+  events <- (.publishedEvents) <$> readIORef ref+  length [() | Event.SessionRevoked _ <- events] @?= 1

@@ -71,7 +71,7 @@         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))+        result <- runInMemory ref (login gatedCfg (ctxForLogin lid) (LoginCommand lid strongPw False))         _ <- expectRight result         pure (),       testCase "with the flag off an unverified account logs in (the default)" do@@ -119,6 +119,7 @@     runInMemory       ref       ( createPasskey+          20           NewPasskeyCredential             { userId = uid,               credentialId = seededCredId,@@ -186,7 +187,7 @@   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}+loginEmail e pw = LoginCommand {loginId = either (error . show) id (mkLoginId (emailText e)), password = pw, remember = False}  ctxForLogin :: LoginId -> ClientContext ctxForLogin l = ClientContext (ClientIp "test-ip") (AccountKey (loginIdText l))

@@ -79,7 +79,7 @@  -- | 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}+loginEmail e pw = LoginCommand {loginId = either (error . show) id (mkLoginId (emailText e)), password = pw, remember = False}  expectRight :: (Show e) => Either e a -> IO a expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure

@@ -79,7 +79,7 @@     }  loginCmd :: LoginCommand-loginCmd = LoginCommand {loginId = aliceLogin, password = strongPw}+loginCmd = LoginCommand {loginId = aliceLogin, password = strongPw, remember = False}  -- | 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

@@ -74,10 +74,10 @@ 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))+badLogin ref ip e = fmap (const ()) <$> runInMemory ref (login cfg (ctxOf ip e) (LoginCommand (either (error . show) id (mkLoginId (emailText e))) wrongPw False))  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))+goodLogin ref ip e = fmap (const ()) <$> runInMemory ref (login cfg (ctxOf ip e) (LoginCommand (either (error . show) id (mkLoginId (emailText e))) strongPw False))  advanceClock :: IORef World -> UTCTime -> IO () advanceClock ref t = modifyIORef' ref (\w -> w {clock = t})@@ -117,7 +117,7 @@   r <-     runInMemory       ref-      (recordAttemptOps traceRef (login cfg (ctxOf ip e) (LoginCommand (either (error . show) id (mkLoginId (emailText e))) strongPw)))+      (recordAttemptOps traceRef (login cfg (ctxOf ip e) (LoginCommand (either (error . show) id (mkLoginId (emailText e))) strongPw False)))   ops <- readIORef traceRef   pure (fmap (const ()) r, ops) 

@@ -93,6 +93,7 @@     runInMemory       ref       ( createPasskey+          20           NewPasskeyCredential             { userId = uid,               credentialId = seededCredId,@@ -122,7 +123,7 @@  -- | Assert a token pair carries a non-empty access token. assertTokenPresent :: (User, TokenPair) -> IO ()-assertTokenPresent (_user, TokenPair (AccessToken at) _ _) =+assertTokenPresent (_user, TokenPair (AccessToken at) _ _ _) =   assertBool "access token present" (not (T.null at))  -- Tests ----------------------------------------------------------------------@@ -146,7 +147,7 @@ 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))+  res <- expectRight =<< runInMemory ref (login cfg (ctxFor aliceEmail) (LoginCommand (either (error . show) id (mkLoginId (emailText aliceEmail))) strongPw False))   case res of     LoginComplete u pair -> assertTokenPresent (u, pair)     MfaRequired _ -> assertFailure "expected LoginComplete (no passkey enrolled)"@@ -155,7 +156,7 @@ 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))+  res <- expectRight =<< runInMemory ref (login cfg (ctxFor aliceEmail) (LoginCommand (either (error . show) id (mkLoginId (emailText aliceEmail))) strongPw False))   case res of     MfaRequired (MfaChallenge _cid opts _methods) ->       assertBool "a challenge is present in the options" (challengeOf opts /= Nothing)@@ -217,7 +218,7 @@             ]     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 <- runInMemory ref (login cfg (ctxFor aliceEmail) (LoginCommand (either (error . show) id (mkLoginId (emailText aliceEmail))) strongPw False))   denied @?= Left InvalidCredentials  testSecondFactorSuccessClearsLockout :: TestTree@@ -265,7 +266,7 @@ -- 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))+  res <- expectRight =<< runInMemory ref (login cfg (ctxFor aliceEmail) (LoginCommand (either (error . show) id (mkLoginId (emailText aliceEmail))) strongPw False))   case res of     MfaRequired (MfaChallenge cid opts _methods) -> pure (cid, opts)     LoginComplete _ _ -> assertFailure "expected MfaRequired"

@@ -31,6 +31,7 @@   testGroup     "Shomei.OAuth.Authorize.Workflow"     [ testCase "interactive session is accepted" testInteractive,+      testCase "a stored actor is refused even when the token omits act" testStoredActor,       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),@@ -81,11 +82,14 @@ data SessionState = Live | Revoked | Expired | Missing  runAuthorize :: SessionKind -> SessionState -> Bool -> IO (Either AuthorizeError IssuedCode, World)-runAuthorize kind state carriesActor = do+runAuthorize kind state carriesActor = runAuthorizeWithActor kind state carriesActor carriesActor++runAuthorizeWithActor :: SessionKind -> SessionState -> Bool -> Bool -> IO (Either AuthorizeError IssuedCode, World)+runAuthorizeWithActor kind state storedActor claimActor = do   ref <- newIORef (emptyWorld fixedTime)   result <- runInMemory ref do     uid <- genUserId-    actor <- if carriesActor then Just <$> genUserId else pure Nothing+    actor <- if storedActor then Just <$> genUserId else pure Nothing     session <-       createSession         NewSession@@ -98,7 +102,8 @@             oauthClientId = Nothing,             kind,             grantedScopes = Set.empty,-            authenticatedAt = fixedTime+            authenticatedAt = fixedTime,+            remembered = False           }     case state of       Revoked -> revokeSession session.sessionId fixedTime@@ -119,7 +124,7 @@             allowedScopes = Set.singleton (Scope "openid"),             createdAt = fixedTime           }-    authorize cfg client (claimsFor uid sid actor) params+    authorize cfg client (claimsFor uid sid (if claimActor then actor else Nothing)) params   world <- readIORef ref   pure (result, world) @@ -150,3 +155,6 @@  testUnknown :: IO () testUnknown = runAuthorize InteractiveSession Missing False >>= expectRefusal SessionNotLive++testStoredActor :: IO ()+testStoredActor = runAuthorizeWithActor InteractiveSession Live True False >>= expectRefusal NonInteractiveCredential

@@ -64,6 +64,7 @@             oauthClientId = Just "oauthclient_owner",             kind = InteractiveSession,             grantedScopes = Set.empty,-            authenticatedAt = t0+            authenticatedAt = t0,+            remembered = False           }   assertion account subjectUser session

@@ -3,10 +3,12 @@ -- | Regression coverage for policy shared by the authorization-code grant and ordinary login. module Shomei.OAuth.TokenGrant.WorkflowSpec (tests) where +import Control.Monad (forM_) import Data.Either (isRight) import Data.IORef (newIORef) import Data.Set qualified as Set import Data.Text (Text)+import Data.Text qualified as Text import Data.Time (UTCTime (..), addUTCTime, fromGregorian) import Shomei.Account.Email.Domain (Email, mkEmail) import Shomei.Account.LoginId.Domain (mkLoginId)@@ -20,14 +22,17 @@ import Shomei.OAuth.AuthorizationCode.Store (putAuthorizationCode) import Shomei.OAuth.Client.Domain (ClientType (ConfidentialClient), NewOAuthClient (..), OAuthClient (..)) import Shomei.OAuth.Client.Store (createOAuthClient)+import Shomei.OAuth.IdToken.Domain (IdToken (..)) import Shomei.OAuth.TokenGrant.Workflow   ( ExchangeAuthorizationCode (..),     TokenGrantError (..),     exchangeAuthorizationCode,+    pkceChallengeFor,   ) import Shomei.ServiceAccount.Secret (sha256Hex) import Shomei.Session.Authentication.Workflow (signup) import Shomei.Session.Command (SignupCommand (..))+import Shomei.Session.Token.Bearer (parseBearer) import Shomei.Test.InMemory (emptyWorld, runInMemory) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))@@ -36,7 +41,10 @@ tests =   testGroup     "Shomei.OAuth.TokenGrant.Workflow"-    [ testCase "authorization-code exchange refuses an unverified email when the gate is enabled" testUnverifiedEmail,+    [ testCase "PKCE validates the verifier even when its digest matches" testVerifierShape,+      testCase "Bearer syntax accepts scheme case and ASCII spaces, refusing ambiguous credentials" testBearerShape,+      testCase "ID token diagnostics redact the credential" (show (IdToken "sensitive-jwt") @?= "IdToken <redacted>"),+      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@@ -69,7 +77,10 @@ data PrincipalShape = UnverifiedEmail | VerifiedEmail | NoEmail  exchangeFor :: ShomeiConfig -> PrincipalShape -> IO (Either TokenGrantError ())-exchangeFor exchangeCfg shape = do+exchangeFor exchangeCfg shape = exchangeForVerifier exchangeCfg shape Nothing++exchangeForVerifier :: ShomeiConfig -> PrincipalShape -> Maybe Text -> IO (Either TokenGrantError ())+exchangeForVerifier exchangeCfg shape verifier = do   ref <- newIORef (emptyWorld fixedTime)   clientId <- runInMemory ref do     let email = case shape of@@ -105,7 +116,7 @@           userId = user.userId,           scopes = Set.empty,           nonce = Nothing,-          codeChallenge = Nothing,+          codeChallenge = pkceChallengeFor <$> verifier,           authTime = fixedTime,           createdAt = fixedTime,           expiresAt = addUTCTime 60 fixedTime@@ -120,7 +131,7 @@             clientSecret = Just testClientSecret,             code = rawCode,             redirectUri = callback,-            codeVerifier = Nothing+            codeVerifier = verifier           }   pure (() <$ result) @@ -145,3 +156,18 @@   case result of     Left err -> assertFailure ("login-id-only account was refused: " <> show err)     Right () -> pure ()++testVerifierShape :: IO ()+testVerifierShape = do+  forM_ [Text.replicate 42 "a", Text.replicate 129 "a", Text.replicate 43 "é", Text.replicate 42 "a" <> "+", Text.replicate 42 "a" <> "="] \verifier -> do+    result <- exchangeForVerifier baseCfg NoEmail (Just verifier)+    result @?= Left (GrantInvalidGrant "code_verifier has invalid length or alphabet")+  forM_ [Text.replicate 43 "a", Text.replicate 128 "Z", Text.replicate 40 "a" <> "-._~", "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-._~"] \verifier -> do+    result <- exchangeForVerifier baseCfg NoEmail (Just verifier)+    assertBool "legal verifier succeeds" (isRight result)++testBearerShape :: IO ()+testBearerShape = do+  parseBearer "bEaReR   abc.def-_/+~==" @?= Just "abc.def-_/+~=="+  forM_ ["Bearer", "Bearer ", "Bearer a b", "Bearer a,b", "Bearer a\tb", "Bearer\tabc", " Bearer abc", "Bearer abc ", "Bearer a=b", "Bearer é"] \header ->+    parseBearer header @?= Nothing

@@ -29,7 +29,6 @@ import Shomei.OAuth.AuthorizationCode.Store   ( bindAuthorizationCodeSession,     consumeAuthorizationCode,-    deleteExpiredAuthorizationCodes,     findConsumedAuthorizationCode,     putAuthorizationCode,   )@@ -58,8 +57,7 @@         [ 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+          testCase "an unknown code hash consumes to Nothing" unknownConsumes         ],       testGroup         "authorize (workflow policy)"@@ -201,18 +199,6 @@   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.@@ -234,7 +220,8 @@             oauthClientId = Nothing,             kind = InteractiveSession,             grantedScopes = Set.empty,-            authenticatedAt = t0+            authenticatedAt = t0,+            remembered = False           }     ocid <- genOAuthClientId     client <-

@@ -11,18 +11,23 @@ -- @shomei-servant@ end-to-end test. module Shomei.Passkey.WorkflowSpec (tests) where +import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar, takeMVar)+import Control.Monad (forM, forM_) import Data.Aeson (Value, object, (.=)) import Data.Aeson.Types (parseMaybe, withObject, (.:)) import Data.ByteString (ByteString)-import Data.IORef (IORef, newIORef)+import Data.Either (isRight)+import Data.IORef (IORef, newIORef, readIORef) import Data.Text (Text)+import Data.Text qualified as 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.Audit.Event.Domain qualified as Event import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..))-import Shomei.Config (ShomeiConfig, defaultShomeiConfig)+import Shomei.Config (ShomeiConfig (..), defaultShomeiConfig) import Shomei.Error (AuthError (..)) import Shomei.Id (PasskeyId, UserId, genCeremonyId, genUserId) import Shomei.Passkey.Ceremony.Port (WebAuthnError (..))@@ -38,7 +43,7 @@     listPasskeys,     removePasskey,   )-import Shomei.Test.InMemory (World, emptyWorld, runInMemory)+import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) @@ -46,11 +51,13 @@ tests =   testGroup     "Shomei.Passkey.Workflow"-    [ testCase "begin then complete stores a passkey; list returns it; remove deletes it" enrollListRemove,+    [ testCase "label boundary rejects before consuming the pending ceremony" labelBoundary,+      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+      testCase "a credential the verifier rejects yields WebAuthnCeremonyError" rejectedCredential,+      testCase "two completions for the last passkey slot produce one credential and one audit" quotaRace     ]  cfg :: ShomeiConfig@@ -153,3 +160,40 @@   -- 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)++quotaRace :: IO ()+quotaRace = do+  ref <- newWorld+  uid <- seedUser ref+  let limited = cfg {maxPasskeysPerUser = 1}+  ceremonies <- forM [1 .. 2 :: Int] \_ -> mustRight =<< runInMemory ref (beginPasskeyRegistration limited uid)+  gate <- newEmptyMVar+  results <- forM ceremonies \(cid, opts) -> do+    done <- newEmptyMVar+    _ <- forkIO do+      readMVar gate+      putMVar done =<< runInMemory ref (completePasskeyRegistration limited uid cid (credentialJson (challengeOf opts)) Nothing)+    pure done+  putMVar gate ()+  outcomes <- mapM takeMVar results+  length (filter isRight outcomes) @?= 1+  length [() | Left PasskeyLimitReached <- outcomes] @?= 1+  listed <- runInMemory ref (listPasskeys uid)+  length listed @?= 1+  world <- readIORef ref+  length [() | Event.PasskeyRegistered _ <- world.publishedEvents] @?= 1+  -- Lowering a ceiling never removes existing credentials; removal still works.+  forM_ listed \pk -> do+    _ <- mustRight =<< runInMemory ref (removePasskey uid (pkPasskeyId pk))+    pure ()++labelBoundary :: IO ()+labelBoundary = do+  ref <- newWorld+  uid <- seedUser ref+  (cid, opts) <- mustRight =<< runInMemory ref (beginPasskeyRegistration cfg uid)+  let credential = credentialJson (challengeOf opts)+  bad <- runInMemory ref (completePasskeyRegistration cfg uid cid credential (Just (Text.replicate 129 "🔑")))+  bad @?= Left InvalidInput+  good <- mustRight =<< runInMemory ref (completePasskeyRegistration cfg uid cid credential (Just (Text.replicate 128 "🔑")))+  pkLabel good @?= Just (Text.replicate 128 "🔑")

@@ -125,7 +125,7 @@   ref <- newWorld   uid <- genUserId   (created, byUser, byCred, byHandle) <- runInMemory ref do-    created <- createPasskey (sampleNew uid)+    created <- either (error . show) pure =<< createPasskey 20 (sampleNew uid)     byUser <- findPasskeysByUser uid     byCred <- findPasskeyByCredentialId (WebAuthnCredentialId cid1)     byHandle <- findPasskeysByUserHandle (UserHandle uh1)@@ -146,7 +146,7 @@   ref <- newWorld   uid <- genUserId   (advanced, replayed, older, found) <- runInMemory ref do-    created <- createPasskey (sampleNew uid)+    created <- either (error . show) pure =<< createPasskey 20 (sampleNew uid)     advanced <- updatePasskeySignCounter (pkPasskeyId created) (SignatureCounter 7) t1     replayed <- updatePasskeySignCounter (pkPasskeyId created) (SignatureCounter 7) t1     older <- updatePasskeySignCounter (pkPasskeyId created) (SignatureCounter 6) t1@@ -162,11 +162,11 @@   uid <- genUserId   otherUid <- genUserId   n <- runInMemory ref do-    _ <- createPasskey (sampleNew uid)+    _ <- createPasskey 20 (sampleNew uid)     -- a second passkey for the same user (distinct credential id)-    _ <- createPasskey (sampleNewWithCred uid "cred-2")+    _ <- createPasskey 20 (sampleNewWithCred uid "cred-2")     -- a third for a different user-    _ <- createPasskey (sampleNewWithCred otherUid "cred-3")+    _ <- createPasskey 20 (sampleNewWithCred otherUid "cred-3")     countPasskeysByUser uid   n @?= 2 @@ -176,7 +176,7 @@   uid <- genUserId   otherUid <- genUserId   (afterWrongUser, afterOwner) <- runInMemory ref do-    created <- createPasskey (sampleNew uid)+    created <- either (error . show) pure =<< createPasskey 20 (sampleNew uid)     let pid = pkPasskeyId created     deletePasskey otherUid pid -- wrong user: no-op     afterWrongUser <- findPasskeyByCredentialId (WebAuthnCredentialId cid1)

@@ -6,6 +6,7 @@ -- must not be able to tell them apart. module Shomei.ServiceAccount.ClientCredentials.WorkflowSpec (tests) where +import Control.Concurrent.Async (mapConcurrently) import Data.Aeson (eitherDecode) import Data.Generics.Labels () import Data.IORef (IORef, newIORef, readIORef)@@ -32,6 +33,7 @@ import Shomei.ServiceAccount.Store (createServiceAccount, revokeServiceAccount) import Shomei.Session.Authentication.Workflow (signup) import Shomei.Session.Command (SignupCommand (..))+import Shomei.Session.Domain (Session (..), SessionKind (..)) import Shomei.Session.RefreshToken.Domain (PersistedRefreshToken (..)) import Shomei.Session.Token.Domain (AccessToken (..)) import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory)@@ -127,7 +129,8 @@ tests =   testGroup     "Shomei.ServiceAccount.ClientCredentials.Workflow"-    [ testOmittedScopeGrantsAll,+    [ testQuotaRace,+      testOmittedScopeGrantsAll,       testRequestedScopeSubset,       testUnknownClient,       testWrongSecret,@@ -234,3 +237,16 @@     isServiceTokenIssued = \case       Event.ServiceTokenIssued _ -> True       _ -> False++testQuotaRace :: TestTree+testQuotaRace = testCase "machine quota has one racing workflow winner and one success audit" do+  ref <- newIORef (emptyWorld fixedTime)+  user <- seedUser ref "quota-service"+  account <- seedAccount ref user.userId+  let cfg = baseCfg {maxActiveNonInteractiveSessions = 1}+  results <- mapConcurrently (\_ -> runInMemory ref (grantClientCredentials cfg (grantFor account))) [1 .. 8 :: Int]+  length [() | Right _ <- results] @?= 1+  length [() | Left SessionLimitReached <- results] @?= 7+  world <- readIORef ref+  length [() | s <- Map.elems world.sessions, s.kind == MachineSession] @?= 1+  length [() | Event.ServiceTokenIssued _ <- world.publishedEvents] @?= 1

@@ -23,6 +23,7 @@ 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@@ -199,7 +200,7 @@             }         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"))+        wrongLogin = login raceCfg ctx (LoginCommand lid (PlainPassword "wrong password") False)     _ <-       expectRight         =<< runInMemory@@ -279,7 +280,7 @@     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))+      result <- expectRight =<< runInMemory ref (login raceCfg ctx (LoginCommand lid strongPw False))       case result of         MfaRequired MfaChallenge {ceremonyId} -> pure ceremonyId         LoginComplete _ _ -> assertFailure "expected a TOTP MFA challenge"

@@ -21,6 +21,7 @@ import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import Data.Map.Strict qualified as Map import Data.Text (Text)+import Data.Text qualified as Text import Data.Time (UTCTime (..), fromGregorian) import Effectful (Eff, IOE, liftIO, runEff, (:>)) import Effectful.Dispatch.Dynamic (interpret_)@@ -40,7 +41,7 @@ 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.Error (AuthError (InvalidCredentials, UserNotActive, WeakPassword), PasswordPolicyViolation (PasswordTooLong)) import Shomei.Mfa.RecoveryCode.Store (RecoveryCodeStore) import Shomei.Mfa.Totp.Store (TotpCredentialStore) import Shomei.Passkey.Ceremony.Port (WebAuthnCeremony)@@ -92,7 +93,24 @@ tests =   testGroup     "Shomei.Session.Authentication.Workflow login timing"-    [ testCase "unknown login id still verifies a password (dummy hash)" do+    [ testCase "oversized passwords reject known and unknown accounts without proof work or state changes" do+        mapM_+          ( \email -> do+              (_, hashCalls) <- withWorld \ref counter -> do+                _ <- runCounting ref counter (signup cfg (SignupCommand (either (error . show) id (mkLoginId (emailText aliceEmail))) (Just aliceEmail) strongPw Nothing))+                writeIORef counter 0+                before <- readIORef ref+                result <- runCounting ref counter (login cfg (ctxFor email) (loginEmail email (PlainPassword (Text.replicate 257 "🔐"))))+                expectLeft (WeakPassword (PasswordTooLong 256)) result+                after <- readIORef ref+                after.loginAttempts @?= before.loginAttempts+                after.accountLockouts @?= before.accountLockouts+                after.publishedEvents @?= before.publishedEvents+                pure result+              hashCalls @?= 0+          )+          [aliceEmail, unknownEmail],+      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@@ -264,7 +282,7 @@   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}+loginEmail e pw = LoginCommand {loginId = either (error . show) id (mkLoginId (emailText e)), password = pw, remember = False}  ctxForLogin :: LoginId -> ClientContext ctxForLogin l = ClientContext (ClientIp "test-ip") (AccountKey (loginIdText l))

@@ -7,6 +7,7 @@ -- 'Either' and, for state-changing cases, on the 'World' read back from the 'IORef'. module Shomei.Session.Authentication.WorkflowSpec (tests) where +import Control.Monad (foldM, forM_) import Data.Aeson qualified as Aeson import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL@@ -15,19 +16,24 @@ import Data.Maybe (isJust) import Data.Set qualified as Set import Data.Text (Text)+import Data.Text qualified as 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.Credential.Store (createPasswordCredential)+import Shomei.Account.Email.Domain (Email, emailText, mkEmail, parseStoredEmail)+import Shomei.Account.LoginId.Domain (LoginId, loginIdText, mkLoginId, parseLoginIdForAuthentication) import Shomei.Account.Password.Domain (PasswordPolicy (..), PlainPassword (..))-import Shomei.Account.User.Domain (User (..))+import Shomei.Account.Password.Hash.Store (hashPassword)+import Shomei.Account.User.Domain (NewUser (..), User (..))+import Shomei.Account.User.Store (createUser) import Shomei.Audit.Event.Domain qualified as Event-import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Scope (..))+import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Role (..), 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@@ -35,9 +41,9 @@ 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.Domain (PersistedRefreshToken (..), RefreshToken (..), RefreshTokenStatus (..)) import Shomei.Session.RefreshToken.Store (markRefreshTokenUsed)-import Shomei.Session.Token.Domain (TokenPair (..))+import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..)) import Shomei.Session.Workflow (SessionOptions (..), issueSessionWith) import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory) import Test.Tasty (TestTree, testGroup)@@ -81,7 +87,7 @@  -- | 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}+loginEmail e pw = LoginCommand {loginId = either (error . show) id (mkLoginId (emailText e)), password = pw, remember = False}  -- | 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).@@ -112,12 +118,24 @@ tests =   testGroup     "Shomei.Session.Authentication.Workflow"-    [ testSignupLogin,+    [ testCase "refresh token and nested token-pair diagnostics redact credentials" do+        show (RefreshToken "refresh-secret-fixture") @?= "RefreshToken <redacted>"+        let pair = TokenPair (AccessToken "access-secret-fixture") (RefreshToken "refresh-secret-fixture") 900 False+            rendered = Text.pack (show pair)+        assertBool "nested diagnostics omit the refresh credential" (not ("refresh-secret-fixture" `Text.isInfixOf` rendered))+        assertBool "nested diagnostics omit the access credential" (not ("access-secret-fixture" `Text.isInfixOf` rendered)),+      testLegacyIdentity,+      testInputBudgets,+      testSignupLogin,       testSignupLoginByIdentifierNoEmail,       testRefreshRotates,       testBespokeRefreshRejectsOAuthSession,       testRefreshRejectsExpiredSession,       testSlidingRefreshStillDiesAtDeadline,+      testRememberedSessionLastsAYear,+      testUnrememberedSessionKeepsSessionTTL,+      testRememberedSessionSlidesPastSessionTTL,+      testSignupIsNotRemembered,       testVerifyTokenRejectsExpiredSession,       testMarkUsedIsCompareAndSwap,       testReuseDetected,@@ -169,7 +187,7 @@   user.email @?= Nothing   user.loginId @?= agentLogin   loginRes <--    expectRight =<< runInMemory ref (login cfg (ctxForLogin agentLogin) (LoginCommand agentLogin strongPw))+    expectRight =<< runInMemory ref (login cfg (ctxForLogin agentLogin) (LoginCommand agentLogin strongPw False))   case loginRes of     LoginComplete u _ -> u.userId @?= user.userId     MfaRequired _ -> assertFailure "expected LoginComplete (agent has no passkey), got MfaRequired"@@ -202,7 +220,8 @@           cfg           SessionOptions             { oauthClientId = Just "oauthclient_test",-              extraScopes = granted+              extraScopes = granted,+              remember = False             }           user           fixedTime@@ -260,6 +279,83 @@       advanceTo ref delta       expectRight =<< runInMemory ref (refresh longTokenCfg (RefreshCommand tok)) +-- | Log alice in with the given @remember@ choice and return the token pair and the session+-- row it created.+loginRemembering :: IORef World -> Bool -> IO (TokenPair, Session)+loginRemembering ref remember = do+  result <- expectRight =<< runInMemory ref (login cfg (ctxFor aliceEmail) (loginEmail aliceEmail strongPw) {remember})+  pair <- case result of+    LoginComplete _ p -> pure p+    MfaRequired _ -> assertFailure "expected LoginComplete (alice has no second factor), got MfaRequired"+  claims <- expectRight =<< runInMemory ref (verifyToken cfg pair.accessToken)+  w <- readIORef ref+  case Map.lookup claims.sessionId w.sessions of+    Just s -> pure (pair, s)+    Nothing -> assertFailure "the login's access token names no session"++-- | Every refresh token of the session expires no later than the session itself.+assertTokensWithinSession :: IORef World -> Session -> IO ()+assertTokensWithinSession ref session = do+  w <- readIORef ref+  let tokens = filter ((== session.sessionId) . (.sessionId)) (Map.elems w.refreshTokens)+  assertBool "the session has refresh tokens" (not (null tokens))+  assertBool "no refresh token outlives its session" (all (\t -> t.expiresAt <= session.expiresAt) tokens)++testRememberedSessionLastsAYear :: TestTree+testRememberedSessionLastsAYear = testCase "a remembered login lasts rememberedSessionTTL and reports remembered on refresh" do+  ref <- newIORef (emptyWorld fixedTime)+  _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))+  (pair, session) <- loginRemembering ref True+  session.expiresAt @?= addUTCTime (365 * day) fixedTime+  pair.remembered @?= True+  advanceTo ref 60+  refreshed <- expectRight =<< runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken))+  refreshed.remembered @?= True+  assertTokensWithinSession ref session+  where+    day = 24 * 60 * 60 :: NominalDiffTime++testUnrememberedSessionKeepsSessionTTL :: TestTree+testUnrememberedSessionKeepsSessionTTL = testCase "a login without remember lasts sessionTTL and reports not remembered" do+  ref <- newIORef (emptyWorld fixedTime)+  _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))+  (pair, session) <- loginRemembering ref False+  session.expiresAt @?= addUTCTime cfg.sessionTTL fixedTime+  pair.remembered @?= False+  advanceTo ref 60+  refreshed <- expectRight =<< runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken))+  refreshed.remembered @?= False+  assertTokensWithinSession ref session++testRememberedSessionSlidesPastSessionTTL :: TestTree+testRememberedSessionSlidesPastSessionTTL = testCase "a remembered session keeps refreshing past sessionTTL and dies at its own deadline" do+  ref <- newIORef (emptyWorld fixedTime)+  _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))+  (pair, session) <- loginRemembering ref True+  -- One rotation every 25 days stays inside the 30-day refresh window and walks well past the+  -- 30-day sessionTTL.+  let rotateAt tok delta = do+        advanceTo ref delta+        p <- expectRight =<< runInMemory ref (refresh cfg (RefreshCommand tok))+        p.remembered @?= True+        pure p.refreshToken+  final <- foldM rotateAt pair.refreshToken [25 * day, 50 * day .. 350 * day]+  w <- readIORef ref+  refreshedSession <- maybe (assertFailure "the session disappeared") pure (Map.lookup session.sessionId w.sessions)+  refreshedSession.status @?= SessionActive+  assertTokensWithinSession ref session+  advanceTo ref (cfg.rememberedSessionTTL + 1)+  res <- runInMemory ref (refresh cfg (RefreshCommand final))+  res @?= Left Err.SessionExpired+  where+    day = 24 * 60 * 60 :: NominalDiffTime++testSignupIsNotRemembered :: TestTree+testSignupIsNotRemembered = testCase "the session signup starts is not remembered" do+  ref <- newIORef (emptyWorld fixedTime)+  (_, pair) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))+  pair.remembered @?= False+ testVerifyTokenRejectsExpiredSession :: TestTree testVerifyTokenRejectsExpiredSession = testCase "verifyToken (token+session) rejects an expired session" do   let checkCfg = longTokenCfg {sessionCheckMode = VerifyTokenAndSession}@@ -375,3 +471,53 @@         "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))++-- Seed through the migration/testing store seam to model data written by an older release.+testLegacyIdentity :: TestTree+testLegacyIdentity = testCase "legacy identity snapshots and password login survive new-write limits" do+  ref <- newIORef (emptyWorld fixedTime)+  let legacyText = Text.replicate 257 "界"+      legacyLogin = either (error . show) id (parseLoginIdForAuthentication legacyText)+      legacyEmail = either (error . show) id (parseStoredEmail (legacyText <> "@example.com"))+      new = NewUser legacyLogin (Just legacyEmail) (Just legacyText)+  user <- runInMemory ref do+    user <- createUser new+    hash <- hashPassword strongPw+    _ <- createPasswordCredential user.userId legacyLogin (Just legacyEmail) hash+    pure user+  Aeson.eitherDecode (Aeson.encode user) @?= Right user+  assertBool "new-value JSON refuses legacy login" (case Aeson.fromJSON (Aeson.toJSON legacyText) :: Aeson.Result LoginId of Aeson.Error _ -> True; _ -> False)+  assertBool "new-user JSON refuses legacy sizes" (case Aeson.eitherDecode (Aeson.encode new) :: Either String NewUser of Left _ -> True; _ -> False)+  result <- expectRight =<< runInMemory ref (login cfg (ctxForLogin legacyLogin) (LoginCommand legacyLogin strongPw False))+  case result of+    LoginComplete loggedIn _ -> loggedIn.userId @?= user.userId+    _ -> assertFailure "legacy account unexpectedly required MFA"+  rejected <- runInMemory ref (signup cfg (SignupCommand legacyLogin (Just legacyEmail) strongPw Nothing))+  rejected @?= Left Err.InvalidLoginId++testInputBudgets :: TestTree+testInputBudgets = testCase "new identity limits count Unicode code points and email UTF-8 bytes" do+  let loginAt = Text.replicate 256 "🔑"+      emailAt = Text.replicate 122 "界" -- oversized in bytes, short in characters+  assertBool "256 code points accepted" (case mkLoginId loginAt of Right _ -> True; _ -> False)+  mkLoginId (loginAt <> "a") @?= Left Err.InvalidLoginId+  mkEmail (emailAt <> "@a.b") @?= Left Err.InvalidEmail+  let exactEmail = Text.replicate 125 "é" <> "@a.b"+  assertBool "254 bytes accepted" (case mkEmail exactEmail of Right _ -> True; _ -> False)+  mkEmail ("a" <> exactEmail) @?= Left Err.InvalidEmail+  forM_ [128, 129] \n -> do+    let scope = Scope (Text.replicate n "界")+        role = Role (Text.replicate n "界")+        succeeds value = case value of Aeson.Success _ -> True; Aeson.Error _ -> False+    succeeds (Aeson.fromJSON (Aeson.toJSON scope) :: Aeson.Result Scope) @?= (n == 128)+    succeeds (Aeson.fromJSON (Aeson.toJSON role) :: Aeson.Result Role) @?= (n == 128)+  forM_ [256, 257] \n -> do+    ref <- newIORef (emptyWorld fixedTime)+    result <- runInMemory ref (signup cfg (signupEmail aliceEmail strongPw (Just (Text.replicate n "🔑"))))+    if n == 256+      then assertBool "display boundary accepted" (case result of Right _ -> True; _ -> False)+      else do+        result @?= Left Err.InvalidInput+        world <- readIORef ref+        Map.null world.users @?= True+        world.publishedEvents @?= []

@@ -117,8 +117,7 @@     @?= Right       VerifiedAuthentication         { credentialId = WebAuthnCredentialId cidBytes,-          newSignCounter = SignatureCounter 1,-          cloneWarning = False+          newSignCounter = SignatureCounter 1         }  configHasWebAuthnDefault :: IO ()