WorkflowSpec.hs

{-# LANGUAGE DataKinds #-}

-- | Pure tests for the EP-3 passkey enrollment workflows ('Shomei.Passkey.Workflow'),
-- driven over EP-2's in-memory stores and EP-1's deterministic fake 'WebAuthnCeremony'
-- interpreter via 'Shomei.Test.InMemory.runInMemory'. No HTTP, no cryptography.
--
-- The fake's @completeRegistrationCeremony@ accepts a credential JSON whose @challenge@
-- echoes the begin step's options blob and returns the credential id / user handle / public
-- key carried in that JSON, so each test extracts the challenge from the begin response and
-- crafts a matching credential. The same behavior is re-proven over HTTP by the
-- @shomei-servant@ end-to-end test.
module Shomei.Passkey.WorkflowSpec (tests) where

import 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.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.Error (AuthError (..))
import Shomei.Id (PasskeyId, UserId, genCeremonyId, genUserId)
import Shomei.Passkey.Ceremony.Port (WebAuthnError (..))
import Shomei.Passkey.Domain
  ( PasskeyCredential (..),
    PublicKeyBytes (..),
    UserHandle (..),
    WebAuthnCredentialId (..),
  )
import Shomei.Passkey.Workflow
  ( beginPasskeyRegistration,
    completePasskeyRegistration,
    listPasskeys,
    removePasskey,
  )
import Shomei.Test.InMemory (World (..), emptyWorld, runInMemory)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertFailure, testCase, (@?=))

tests :: TestTree
tests =
  testGroup
    "Shomei.Passkey.Workflow"
    [ testCase "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 "two completions for the last passkey slot produce one credential and one audit" quotaRace
    ]

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

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

aliceEmail :: Email
aliceEmail = case mkEmail "alice@example.com" of
  Right e -> e
  Left err -> error ("bad test email: " <> show err)

newWorld :: IO (IORef World)
newWorld = newIORef (emptyWorld t0)

seedUser :: IORef World -> IO UserId
seedUser ref = runInMemory ref do
  User {userId} <- createUser NewUser {loginId = either (error . show) id (mkLoginId (emailText aliceEmail)), email = Just aliceEmail, displayName = Just "Ada"}
  pure userId

-- Field accessors (OverloadedRecordDot is unreliable for these EP-1 records).
pkPasskeyId :: PasskeyCredential -> PasskeyId
pkPasskeyId PasskeyCredential {passkeyId} = passkeyId

pkLabel :: PasskeyCredential -> Maybe Text
pkLabel PasskeyCredential {label} = label

-- | The challenge the fake baked into a begin step's options JSON (we echo it back).
challengeOf :: Value -> Text
challengeOf v = case parseMaybe (withObject "options" (.: "challenge")) v of
  Just c -> c
  Nothing -> error "challengeOf: no challenge in options"

cid1, uh1, pk1 :: ByteString
cid1 = "passkey-cred-1"
uh1 = "passkey-uh-1"
pk1 = "passkey-pk-1"

-- | A credential JSON the fake accepts: it echoes the challenge and carries base64url bytes.
credentialJson :: Text -> Value
credentialJson chal =
  object
    [ "challenge" .= chal,
      "credentialId" .= WebAuthnCredentialId cid1,
      "userHandle" .= UserHandle uh1,
      "publicKey" .= PublicKeyBytes pk1
    ]

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

enrollListRemove :: IO ()
enrollListRemove = do
  ref <- newWorld
  uid <- seedUser ref
  (cid, opts) <- mustRight =<< runInMemory ref (beginPasskeyRegistration cfg uid)
  pk <- mustRight =<< runInMemory ref (completePasskeyRegistration cfg uid cid (credentialJson (challengeOf opts)) (Just "YubiKey"))
  pkLabel pk @?= Just "YubiKey"
  -- list returns exactly the enrolled passkey
  listed <- runInMemory ref (listPasskeys uid)
  map pkPasskeyId listed @?= [pkPasskeyId pk]
  -- remove deletes it
  _ <- mustRight =<< runInMemory ref (removePasskey uid (pkPasskeyId pk))
  listed2 <- runInMemory ref (listPasskeys uid)
  map pkPasskeyId listed2 @?= []

wrongUserComplete :: IO ()
wrongUserComplete = do
  ref <- newWorld
  uid <- seedUser ref
  otherUid <- genUserId
  (cid, opts) <- mustRight =<< runInMemory ref (beginPasskeyRegistration cfg uid)
  result <- runInMemory ref (completePasskeyRegistration cfg otherUid cid (credentialJson (challengeOf opts)) Nothing)
  result @?= Left PendingCeremonyNotFound

absentCeremony :: IO ()
absentCeremony = do
  ref <- newWorld
  uid <- seedUser ref
  bogusCid <- genCeremonyId
  result <- runInMemory ref (completePasskeyRegistration cfg uid bogusCid (credentialJson "anything") Nothing)
  result @?= Left PendingCeremonyNotFound

consumedCeremony :: IO ()
consumedCeremony = do
  ref <- newWorld
  uid <- seedUser ref
  (cid, opts) <- mustRight =<< runInMemory ref (beginPasskeyRegistration cfg uid)
  _ <- mustRight =<< runInMemory ref (completePasskeyRegistration cfg uid cid (credentialJson (challengeOf opts)) Nothing)
  -- the ceremony was consumed by the first complete; a second is rejected
  again <- runInMemory ref (completePasskeyRegistration cfg uid cid (credentialJson (challengeOf opts)) Nothing)
  again @?= Left PendingCeremonyNotFound

rejectedCredential :: IO ()
rejectedCredential = do
  ref <- newWorld
  uid <- seedUser ref
  (cid, _opts) <- mustRight =<< runInMemory ref (beginPasskeyRegistration cfg uid)
  -- a credential whose challenge does not match the ceremony fails verification
  result <- runInMemory ref (completePasskeyRegistration cfg uid cid (credentialJson "not-the-challenge") Nothing)
  result @?= Left (WebAuthnCeremonyError WebAuthnChallengeMismatch)

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 "🔑")