shomei-core-0.3.0.0: test/Shomei/Session/Authentication/WorkflowSpec.hs

-- | Behavioral tests for the auth workflows, run entirely through the in-memory port
-- interpreter ('Shomei.Test.InMemory.runInMemory'). No PostgreSQL, no JWT library, no
-- network: a green run proves the security-critical workflow logic in isolation.
--
-- Each case builds a fresh 'World' in an 'IORef' (so there is no cross-test
-- contamination) and runs one or more workflows against it, then asserts on the returned
-- 'Either' and, for state-changing cases, on the 'World' read back from the 'IORef'.
module Shomei.Session.Authentication.WorkflowSpec (tests) where

import Control.Monad (foldM, forM_)
import Data.Aeson qualified as Aeson
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.Map.Strict qualified as Map
import Data.Maybe (isJust)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as TE
import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, fromGregorian)
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.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 (..), 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
import Shomei.Session.Authentication.Workflow (LoginResult (..), Refreshed (..), login, logout, refresh, refreshFrom, signup, verifyToken)
import Shomei.Session.Command (ClientContext (..), LoginCommand (..), LogoutCommand (..), RefreshCommand (..), RefreshOrigin (..), SignupCommand (..))
import Shomei.Session.Domain (Session (..), SessionStatus (..))
import Shomei.Session.LoginAttempt.Domain (AccountKey (..), ClientIp (..))
import Shomei.Session.RefreshToken.Domain (PersistedRefreshToken (..), RefreshToken (..), RefreshTokenStatus (..))
import Shomei.Session.RefreshToken.Store (markRefreshTokenUsed)
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)
import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))

-- Fixtures -------------------------------------------------------------------

fixedTime :: UTCTime
fixedTime = UTCTime (fromGregorian 2026 1 1) 0

cfg :: ShomeiConfig
cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")

aliceEmail :: Email
aliceEmail = mkEmail' "alice@example.com"

unknownEmail :: Email
unknownEmail = mkEmail' "nobody@example.com"

strongPw :: PlainPassword
strongPw = PlainPassword "correct horse battery staple"

wrongPw :: PlainPassword
wrongPw = PlainPassword "totally the wrong password"

mkEmail' :: Text -> Email
mkEmail' t = case mkEmail t of
  Right e -> e
  Left err -> error ("bad test email: " <> show err)

mkLoginId' :: Text -> LoginId
mkLoginId' t = case mkLoginId t of
  Right l -> l
  Left err -> error ("bad test login id: " <> show err)

-- | An email-first signup command: the principal login id defaults to the email text
-- (the compatibility rule), and the optional email is carried through.
signupEmail :: Email -> PlainPassword -> Maybe Text -> SignupCommand
signupEmail e pw dn =
  SignupCommand {loginId = either (error . show) id (mkLoginId (emailText e)), email = Just e, password = pw, displayName = dn}

-- | An email-first login command keyed on the email-derived login id.
loginEmail :: Email -> PlainPassword -> LoginCommand
loginEmail e pw = LoginCommand {loginId = either (error . show) id (mkLoginId (emailText e)), password = pw, 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).
ctxForLogin :: LoginId -> ClientContext
ctxForLogin l = ClientContext (ClientIp "test-ip") (AccountKey (loginIdText l))

-- | The email-keyed convenience: derive the login id from the email, then the context.
ctxFor :: Email -> ClientContext
ctxFor email = ctxForLogin (either (error . show) id (mkLoginId (emailText email)))

expectRight :: (Show e) => Either e a -> IO a
expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure

-- | Move the in-memory clock to @fixedTime + delta@. The interpreters read 'World.clock' on
-- every 'Shomei.Time.Store.now', so this is how a test travels forward in time.
advanceTo :: IORef World -> NominalDiffTime -> IO ()
advanceTo ref delta = modifyIORef' ref \w -> w {clock = addUTCTime delta fixedTime}

-- | A config whose refresh tokens outlive the session, so a token minted at signup is still
-- unexpired when the session's absolute deadline passes. Without it the two deadlines
-- coincide and 'SessionExpired' would be masked by 'RefreshTokenExpired'.
longTokenCfg :: ShomeiConfig
longTokenCfg = cfg {refreshTokenTTL = 61 * 24 * 60 * 60}

-- Tests ----------------------------------------------------------------------

tests :: TestTree
tests =
  testGroup
    "Shomei.Session.Authentication.Workflow"
    [ 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,
      testReuseRevokesSession,
      testLogoutRevokes,
      testRefreshAfterLogoutIsSessionRevoked,
      testFailClosed,
      testNoAccountLeak,
      testSignupRejectsCommon,
      testSignupRejectsIdentity
    ]

-- | A policy with a small minimum length so identity-derived passwords (e.g. "alice",
-- shorter than the default 12) reach the contextual check instead of failing on length.
smallMinCfg :: ShomeiConfig
smallMinCfg = cfg {passwordPolicy = cfg.passwordPolicy {minLength = 4}}

testSignupRejectsCommon :: TestTree
testSignupRejectsCommon = testCase "signup rejects a common password" do
  ref <- newIORef (emptyWorld fixedTime)
  -- "passwordpassword" is in the bundled dictionary and is long enough to pass minLength.
  res <- runInMemory ref (signup cfg (signupEmail aliceEmail (PlainPassword "passwordpassword") Nothing))
  res @?= Left (WeakPassword PasswordTooCommon)

testSignupRejectsIdentity :: TestTree
testSignupRejectsIdentity = testCase "signup rejects the email local-part as password" do
  ref <- newIORef (emptyWorld fixedTime)
  res <- runInMemory ref (signup smallMinCfg (signupEmail aliceEmail (PlainPassword "alice") Nothing))
  res @?= Left (WeakPassword PasswordResemblesIdentity)

testSignupLogin :: TestTree
testSignupLogin = testCase "signup then login round-trips" do
  ref <- newIORef (emptyWorld fixedTime)
  (user, pair) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw (Just "Alice")))
  loginRes <- expectRight =<< runInMemory ref (login cfg (ctxFor aliceEmail) (loginEmail aliceEmail strongPw))
  (user2, pair2) <- case loginRes of
    LoginComplete u p -> pure (u, p)
    MfaRequired _ -> assertFailure "expected LoginComplete (alice has no passkey), got MfaRequired"
  user2.userId @?= user.userId
  assertBool "login issues a different refresh token" (pair2.refreshToken /= pair.refreshToken)

testSignupLoginByIdentifierNoEmail :: TestTree
testSignupLoginByIdentifierNoEmail = testCase "signup+login by identifier with no email" do
  ref <- newIORef (emptyWorld fixedTime)
  let agentLogin = mkLoginId' "agent-4815162342"
      signupCmd =
        SignupCommand {loginId = agentLogin, email = Nothing, password = strongPw, displayName = Nothing}
  (user, _pair) <- expectRight =<< runInMemory ref (signup cfg signupCmd)
  user.email @?= Nothing
  user.loginId @?= agentLogin
  loginRes <-
    expectRight =<< runInMemory ref (login cfg (ctxForLogin agentLogin) (LoginCommand agentLogin strongPw False))
  case loginRes of
    LoginComplete u _ -> u.userId @?= user.userId
    MfaRequired _ -> assertFailure "expected LoginComplete (agent has no passkey), got MfaRequired"

testRefreshRotates :: TestTree
testRefreshRotates = testCase "refresh rotates token and old token becomes Used" do
  ref <- newIORef (emptyWorld fixedTime)
  (_, pair) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))
  originalClaims <- expectRight =<< runInMemory ref (verifyToken cfg pair.accessToken)
  advanceTo ref 60
  pair2 <- expectRight =<< runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken))
  refreshedClaims <- expectRight =<< runInMemory ref (verifyToken cfg pair2.accessToken)
  assertBool "rotated token differs from the original" (pair2.refreshToken /= pair.refreshToken)
  refreshedClaims.authTime @?= originalClaims.authTime
  refreshedClaims.issuedAt @?= addUTCTime 60 originalClaims.issuedAt
  w <- readIORef ref
  let toks = Map.elems w.refreshTokens
  assertBool "exactly one token is marked Used" (length (filter (\t -> t.status == RefreshTokenUsed) toks) == 1)
  assertBool "the rotated token links to its parent" (any (\t -> isJust t.parentTokenId) toks)

testBespokeRefreshRejectsOAuthSession :: TestTree
testBespokeRefreshRejectsOAuthSession = testCase "bespoke refresh refuses a client-bound session without spending its token" do
  ref <- newIORef (emptyWorld fixedTime)
  (user, _) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))
  let granted = Set.fromList [Scope "openid", Scope "kawa:read"]
  (_, oauthPair, _) <-
    runInMemory
      ref
      ( issueSessionWith
          cfg
          SessionOptions
            { oauthClientId = Just "oauthclient_test",
              extraScopes = granted,
              remember = False
            }
          user
          fixedTime
      )
  result <- runInMemory ref (refresh cfg (RefreshCommand oauthPair.refreshToken))
  result @?= Left Err.RefreshTokenInvalid
  wrongClient <- runInMemory ref (refreshFrom (OAuthClientRefresh "oauthclient_other") cfg (RefreshCommand oauthPair.refreshToken))
  case wrongClient of
    Left err -> err @?= Err.RefreshTokenInvalid
    Right _ -> assertFailure "a different OAuth client rotated the session"
  world <- readIORef ref
  assertBool
    "the refused binding mismatch leaves every token active"
    (all ((== RefreshTokenActive) . (.status)) (Map.elems world.refreshTokens))
  refreshed <-
    expectRight
      =<< runInMemory ref (refreshFrom (OAuthClientRefresh "oauthclient_test") cfg (RefreshCommand oauthPair.refreshToken))
  refreshed.grantedScopes @?= granted
  claims <- expectRight =<< runInMemory ref (verifyToken cfg refreshed.tokens.accessToken)
  claims.scopes @?= granted

testRefreshRejectsExpiredSession :: TestTree
testRefreshRejectsExpiredSession = testCase "refresh rejects a session past its absolute expiry" do
  ref <- newIORef (emptyWorld fixedTime)
  (_, pair) <- expectRight =<< runInMemory ref (signup longTokenCfg (signupEmail aliceEmail strongPw Nothing))
  advanceTo ref (longTokenCfg.sessionTTL + 1)
  res <- runInMemory ref (refresh longTokenCfg (RefreshCommand pair.refreshToken))
  res @?= Left Err.SessionExpired

testSlidingRefreshStillDiesAtDeadline :: TestTree
testSlidingRefreshStillDiesAtDeadline = testCase "sliding refresh still dies at the session deadline" do
  ref <- newIORef (emptyWorld fixedTime)
  (_, pair) <- expectRight =<< runInMemory ref (signup longTokenCfg (signupEmail aliceEmail strongPw Nothing))
  -- Two successful rotations well inside the 30-day session lifetime.
  pair1 <- rotateAt ref (10 * day) pair.refreshToken
  pair2 <- rotateAt ref (20 * day) pair1.refreshToken
  -- Every *rotated* token is capped at the session deadline, so refreshing buys no extra
  -- lifetime. (The token minted at signup is uncapped — see this plan's Surprises.)
  w <- readIORef ref
  session <- case Map.elems w.sessions of
    (s : _) -> pure s
    [] -> assertFailure "expected a session"
  let rotated = filter (isJust . (.parentTokenId)) (Map.elems w.refreshTokens)
  length rotated @?= 2
  assertBool
    "no rotated refresh token expires after the session"
    (all (\t -> t.expiresAt <= session.expiresAt) rotated)
  -- Past the deadline the freshest token still cannot buy another rotation.
  advanceTo ref (longTokenCfg.sessionTTL + 1)
  res <- runInMemory ref (refresh longTokenCfg (RefreshCommand pair2.refreshToken))
  res @?= Left Err.SessionExpired
  where
    day = 24 * 60 * 60 :: NominalDiffTime
    rotateAt ref delta tok = do
      advanceTo ref delta
      expectRight =<< runInMemory ref (refresh longTokenCfg (RefreshCommand tok))

-- | 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}
  ref <- newIORef (emptyWorld fixedTime)
  (_, pair) <- expectRight =<< runInMemory ref (signup checkCfg (signupEmail aliceEmail strongPw Nothing))
  ok <- runInMemory ref (verifyToken checkCfg pair.accessToken)
  assertBool "the fresh access token verifies" (isRight ok)
  advanceTo ref (checkCfg.sessionTTL + 1)
  res <- runInMemory ref (verifyToken checkCfg pair.accessToken)
  res @?= Left Err.SessionExpired
  where
    isRight = either (const False) (const True)

testMarkUsedIsCompareAndSwap :: TestTree
testMarkUsedIsCompareAndSwap = testCase "mark-used CAS: the second sequential mark returns False" do
  ref <- newIORef (emptyWorld fixedTime)
  _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))
  w <- readIORef ref
  rid <- case Map.keys w.refreshTokens of
    (r : _) -> pure r
    [] -> assertFailure "expected a refresh token to exist after signup"
  first <- runInMemory ref (markRefreshTokenUsed rid fixedTime)
  second <- runInMemory ref (markRefreshTokenUsed rid fixedTime)
  first @?= True
  second @?= False

testReuseDetected :: TestTree
testReuseDetected = testCase "presenting an already-used refresh token detects reuse" do
  ref <- newIORef (emptyWorld fixedTime)
  (_, pair) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))
  _ <- expectRight =<< runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken))
  reused <- runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken))
  reused @?= Left RefreshTokenReuseDetected

testReuseRevokesSession :: TestTree
testReuseRevokesSession = testCase "reuse detection revokes the session and family" do
  ref <- newIORef (emptyWorld fixedTime)
  (_, pair) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))
  _ <- expectRight =<< runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken))
  _ <- runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken))
  w <- readIORef ref
  assertBool "session is revoked" (all (\s -> s.status == SessionRevoked) (Map.elems w.sessions))
  assertBool "whole refresh-token family is revoked" (all (\t -> t.status == RefreshTokenRevoked) (Map.elems w.refreshTokens))
  assertBool "a reuse event was published" (any isReuse w.publishedEvents)
  where
    isReuse (Event.RefreshTokenReuseDetected _) = True
    isReuse _ = False

testLogoutRevokes :: TestTree
testLogoutRevokes = testCase "logout revokes the session" do
  ref <- newIORef (emptyWorld fixedTime)
  _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))
  w0 <- readIORef ref
  sid <- case Map.keys w0.sessions of
    (s : _) -> pure s
    [] -> assertFailure "expected a session to exist after signup"
  result <- runInMemory ref (logout cfg (LogoutCommand sid))
  result @?= Right ()
  w <- readIORef ref
  assertBool "session is revoked" (all (\s -> s.status == SessionRevoked) (Map.elems w.sessions))
  assertBool "session refresh tokens are revoked" (all (\t -> t.status == RefreshTokenRevoked) (Map.elems w.refreshTokens))
  assertBool "a session-revoked event was published" (any isRevoked w.publishedEvents)
  where
    isRevoked (Event.SessionRevoked _) = True
    isRevoked _ = False

testRefreshAfterLogoutIsSessionRevoked :: TestTree
testRefreshAfterLogoutIsSessionRevoked = testCase "a refresh token revoked by logout is not reported as theft" do
  ref <- newIORef (emptyWorld fixedTime)
  (_, pair) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))
  w0 <- readIORef ref
  sid <- case Map.keys w0.sessions of
    (s : _) -> pure s
    [] -> assertFailure "expected a session to exist after signup"
  _ <- expectRight =<< runInMemory ref (logout cfg (LogoutCommand sid))
  result <- runInMemory ref (refresh cfg (RefreshCommand pair.refreshToken))
  result @?= Left Err.SessionRevoked
  w <- readIORef ref
  length [() | Event.RefreshTokenReuseDetected _ <- w.publishedEvents] @?= 0

testFailClosed :: TestTree
testFailClosed = testCase "wrong-password audit identifies the hashed account and resolved user" do
  ref <- newIORef (emptyWorld fixedTime)
  (alice, _) <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))
  let ctx = ClientContext (ClientIp "test-ip") (AccountKey "sha256-alice")
      cmd = loginEmail aliceEmail wrongPw
  result <- runInMemory ref (login cfg ctx cmd)
  result @?= Left InvalidCredentials
  w <- readIORef ref
  case [d | Event.LoginFailed d <- w.publishedEvents] of
    [d] -> do
      d.accountKey @?= Just ctx.accountKey
      d.userId @?= Just alice.userId
      assertBool
        "the submitted identifier is absent from the encoded audit event"
        (not (TE.encodeUtf8 (loginIdText cmd.loginId) `BS.isInfixOf` BSL.toStrict (Aeson.encode (Event.LoginFailed d))))
    ds -> assertFailure ("expected exactly one login-failed event, got " <> show (length ds))

testNoAccountLeak :: TestTree
testNoAccountLeak = testCase "unknown email yields the same generic error as a wrong password" do
  ref <- newIORef (emptyWorld fixedTime)
  _ <- expectRight =<< runInMemory ref (signup cfg (signupEmail aliceEmail strongPw Nothing))
  wrong <- runInMemory ref (login cfg (ctxFor aliceEmail) (loginEmail aliceEmail wrongPw))
  let unknownCtx = ClientContext (ClientIp "test-ip") (AccountKey "sha256-unknown")
  unknown <- runInMemory ref (login cfg unknownCtx (loginEmail unknownEmail strongPw))
  wrong @?= unknown
  unknown @?= Left InvalidCredentials
  w <- readIORef ref
  case [d | Event.LoginFailed d <- w.publishedEvents, d.accountKey == Just unknownCtx.accountKey] of
    [d] -> do
      d.userId @?= Nothing
      assertBool
        "the unknown submitted identifier is absent from the encoded audit event"
        (not (TE.encodeUtf8 (emailText unknownEmail) `BS.isInfixOf` BSL.toStrict (Aeson.encode (Event.LoginFailed d))))
    ds -> assertFailure ("expected one unknown-login audit event, got " <> show (length ds))

-- 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 @?= []