WorkflowSpec.hs

-- | Behavioral tests for the impersonation token-exchange workflow
-- ('Shomei.Delegation.Workflow'), run entirely through the in-memory interpreter
-- ('Shomei.Test.InMemory.runInMemory'). No cryptography, no database, no network.
--
-- The in-memory 'Shomei.SigningKey.Signer' fake renders 'AuthClaims' as JSON, so a
-- minted access token decodes straight back to 'AuthClaims' for inspection.
module Shomei.Delegation.WorkflowSpec (tests) where

import Data.Aeson (eitherDecode)
import Data.IORef (IORef, newIORef, readIORef)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TLE
import Data.Time (UTCTime (..), addUTCTime, fromGregorian)
import Shomei.Account.Email.Domain (Email, emailText, mkEmail)
import Shomei.Account.LoginId.Domain (mkLoginId)
import Shomei.Account.Password.Domain (PlainPassword (..))
import Shomei.Account.User.Domain (User (..), UserStatus (UserActive, UserSuspended))
import Shomei.Account.User.Store (updateUserStatus)
import Shomei.Audit.Event.Domain qualified as Event
import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Scope (..))
import Shomei.Config (ImpersonationConfig (..), ShomeiConfig (..), defaultShomeiConfig)
import Shomei.Delegation.Workflow (StartImpersonation (..), startImpersonation, stopImpersonation)
import Shomei.Error (AuthError (ImpersonationForbidden, ImpersonationTargetInvalid))
import Shomei.Id (SessionId, UserId, genUserId)
import Shomei.Session.Authentication.Workflow (signup)
import Shomei.Session.Command (SignupCommand (..))
import Shomei.Session.Domain (Session (..), SessionStatus (SessionRevoked))
import Shomei.Session.RefreshToken.Domain (PersistedRefreshToken (..))
import Shomei.Session.Store (revokeSession)
import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..))
import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))

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

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

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

impScope :: Scope
impScope = cfg.impersonationConfig.impersonateScope

customerEmail :: Email
customerEmail = mkEmail' "customer@example.com"

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

mkEmail' :: Text -> Email
mkEmail' t = either (\e -> error ("bad test email: " <> show e)) id (mkEmail t)

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

-- | Caller (operator) claims with the given scopes, issued at @iat@. The caller need
-- not be a stored user — the workflow only reads scopes/issuedAt/subject from the token.
callerClaims :: UserId -> SessionId -> Set Scope -> UTCTime -> AuthClaims
callerClaims uid sid scs iat =
  AuthClaims
    { subject = uid,
      sessionId = sid,
      issuer = cfg.issuer,
      audience = cfg.audience,
      issuedAt = iat,
      expiresAt = addUTCTime 900 iat,
      authTime = iat,
      scopes = scs,
      roles = Set.empty,
      permissions = Set.empty,
      actor = Nothing,
      extraClaims = mempty
    }

-- | Sign up the customer and return their (active) user id.
seedCustomer :: IORef World -> IO UserId
seedCustomer ref = do
  (user, _) <- expectRight =<< runInMemory ref (signup cfg (SignupCommand {loginId = either (error . show) id (mkLoginId (emailText customerEmail)), email = Just customerEmail, password = strongPw, displayName = Just "Customer"}))
  pure user.userId

-- | A real, live operator session with caller-selected claims.
operatorClaims :: IORef World -> Set Scope -> UTCTime -> IO AuthClaims
operatorClaims ref scopes issuedAt = do
  let email = mkEmail' "operator@example.com"
  (operator, pair) <- expectRight =<< runInMemory ref (signup cfg (SignupCommand {loginId = either (error . show) id (mkLoginId (emailText email)), email = Just email, password = strongPw, displayName = Just "Operator"}))
  signed <- decodeAccess pair.accessToken
  pure (callerClaims operator.userId signed.sessionId scopes issuedAt)

freshOperator :: IORef World -> IO AuthClaims
freshOperator ref = operatorClaims ref (Set.singleton impScope) fixedTime

mkStart :: AuthClaims -> UserId -> StartImpersonation
mkStart caller target =
  StartImpersonation
    { actorClaims = caller,
      targetUserId = target,
      reason = "Debugging support issue",
      ticketId = Just "SUP-1234",
      clientIp = Just "203.0.113.7"
    }

-- | Decode the JSON the in-memory signer renders back into 'AuthClaims'.
decodeAccess :: AccessToken -> IO AuthClaims
decodeAccess (AccessToken t) =
  either
    (\e -> assertFailure ("could not decode access token: " <> e))
    pure
    (eitherDecode (TLE.encodeUtf8 (TL.fromStrict t)))

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

tests :: TestTree
tests =
  testGroup
    "Shomei.Delegation.Workflow"
    [ testHappyPath,
      testMissingScope,
      testStaleCaller,
      testRevokedCaller,
      testSuspendedCaller,
      testSelfTarget,
      testUnknownTarget,
      testInactiveTarget,
      testStop
    ]

testHappyPath :: TestTree
testHappyPath = testCase "fresh scoped caller impersonating an active target succeeds" do
  ref <- newIORef (emptyWorld fixedTime)
  target <- seedCustomer ref
  caller <- freshOperator ref
  (session, access) <- expectRight =<< runInMemory ref (startImpersonation cfg (mkStart caller target))
  -- the delegated session records the operator as actor
  session.actor @?= Just caller.subject
  session.userId @?= target
  -- the token names the customer as subject and the operator as actor
  claims <- decodeAccess access
  claims.subject @?= target
  claims.actor @?= Just caller.subject
  -- no refresh token was minted for the delegated session
  world <- readIORef ref
  let refsForSession = filter (\PersistedRefreshToken {sessionId = s} -> s == session.sessionId) (Map.elems world.refreshTokens)
  assertBool "delegated session has no refresh token" (null refsForSession)
  -- an ImpersonationStarted event carrying both ids + the reason was published
  assertBool "ImpersonationStarted published" (any (matchesStarted caller.subject target) world.publishedEvents)
  where
    matchesStarted actorId subj = \case
      Event.ImpersonationStarted d ->
        d.actorUserId == actorId
          && d.subjectUserId == subj
          && d.reason == "Debugging support issue"
      _ -> False

testMissingScope :: TestTree
testMissingScope = testCase "caller without the impersonate scope is forbidden" do
  ref <- newIORef (emptyWorld fixedTime)
  target <- seedCustomer ref
  caller <- operatorClaims ref Set.empty fixedTime
  res <- runInMemory ref (startImpersonation cfg (mkStart caller target))
  fmap (const ()) res @?= Left ImpersonationForbidden

testStaleCaller :: TestTree
testStaleCaller = testCase "caller whose token predates the freshness window is forbidden" do
  ref <- newIORef (emptyWorld fixedTime)
  target <- seedCustomer ref
  -- issued one second before the freshness window opens
  let stale = addUTCTime (negate (cfg.impersonationConfig.actorFreshnessWindow + 1)) fixedTime
  caller <- operatorClaims ref (Set.singleton impScope) stale
  res <- runInMemory ref (startImpersonation cfg (mkStart caller target))
  fmap (const ()) res @?= Left ImpersonationForbidden

testRevokedCaller :: TestTree
testRevokedCaller = testCase "caller with a revoked session is forbidden" do
  ref <- newIORef (emptyWorld fixedTime)
  target <- seedCustomer ref
  caller <- freshOperator ref
  runInMemory ref (revokeSession caller.sessionId fixedTime)
  res <- runInMemory ref (startImpersonation cfg (mkStart caller target))
  fmap (const ()) res @?= Left ImpersonationForbidden

testSuspendedCaller :: TestTree
testSuspendedCaller = testCase "suspended caller is forbidden" do
  ref <- newIORef (emptyWorld fixedTime)
  target <- seedCustomer ref
  caller <- freshOperator ref
  _ <- runInMemory ref (updateUserStatus caller.subject [UserActive] UserSuspended fixedTime)
  res <- runInMemory ref (startImpersonation cfg (mkStart caller target))
  fmap (const ()) res @?= Left ImpersonationForbidden

testSelfTarget :: TestTree
testSelfTarget = testCase "impersonating yourself is an invalid target" do
  ref <- newIORef (emptyWorld fixedTime)
  caller <- freshOperator ref
  res <- runInMemory ref (startImpersonation cfg (mkStart caller caller.subject))
  fmap (const ()) res @?= Left ImpersonationTargetInvalid

testUnknownTarget :: TestTree
testUnknownTarget = testCase "unknown target is an invalid target" do
  ref <- newIORef (emptyWorld fixedTime)
  caller <- freshOperator ref
  ghost <- genUserId
  res <- runInMemory ref (startImpersonation cfg (mkStart caller ghost))
  fmap (const ()) res @?= Left ImpersonationTargetInvalid

testInactiveTarget :: TestTree
testInactiveTarget = testCase "suspended target is an invalid target" do
  ref <- newIORef (emptyWorld fixedTime)
  target <- seedCustomer ref
  _ <- runInMemory ref (updateUserStatus target [UserActive] UserSuspended fixedTime)
  caller <- freshOperator ref
  res <- runInMemory ref (startImpersonation cfg (mkStart caller target))
  fmap (const ()) res @?= Left ImpersonationTargetInvalid

testStop :: TestTree
testStop = testCase "stopImpersonation revokes the delegated session and audits the stop" do
  ref <- newIORef (emptyWorld fixedTime)
  target <- seedCustomer ref
  caller <- freshOperator ref
  (session, access) <- expectRight =<< runInMemory ref (startImpersonation cfg (mkStart caller target))
  delegatedClaims <- decodeAccess access
  _ <- expectRight =<< runInMemory ref (stopImpersonation delegatedClaims)
  world <- readIORef ref
  -- the delegated session is now revoked
  case Map.lookup session.sessionId world.sessions of
    Just s -> s.status @?= SessionRevoked
    Nothing -> assertFailure "delegated session vanished"
  assertBool "ImpersonationStopped published" (any (matchesStopped caller.subject target) world.publishedEvents)
  where
    matchesStopped actorId subj = \case
      Event.ImpersonationStopped d -> d.actorUserId == actorId && d.subjectUserId == subj
      _ -> False