shomei-webauthn (empty) → 0.3.0.0
raw patch · 8 files changed
+931/−0 lines, 8 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, containers, crypton, effectful, effectful-core, mtl, ram, shomei-core, shomei-webauthn, tasty, tasty-hunit, text, time, time-hourglass, validation, webauthn
Files
- CHANGELOG.md +33/−0
- LICENSE +21/−0
- shomei-webauthn.cabal +96/−0
- src/Shomei/WebAuthn/Ceremony.hs +277/−0
- test/Main.hs +8/−0
- test/Shomei/WebAuthn/CeremonySpec.hs +210/−0
- test/Shomei/WebAuthn/SoftwareAuthenticator.hs +141/−0
- test/Shomei/WebAuthn/WorkflowSpec.hs +145/−0
+ CHANGELOG.md view
@@ -0,0 +1,33 @@+# Changelog for shomei-webauthn++All notable changes to `shomei-webauthn` are documented here. This package adheres to the+[PVP](https://pvp.haskell.org/) and is versioned independently of the other+Shōmei packages.++## 0.3.0.0 — 2026-11-05++- **Breaking:** internal dependency bounds follow the 0.3 API series.+- First Hackage publication; earlier version sections describe repository development milestones.+- Require released [`webauthn >=0.12 && <0.13`](mori://tweag/webauthn/packages/webauthn); the compatible upstream release replaces the development fork.+- The workspace permits `time` 1.14 through a version-scoped `allow-newer` override; this project setting is not part of the published package's dependency metadata.++- **Breaking:** remove `VerifiedAuthentication.cloneWarning`; cloned/regressed counters return `WebAuthnCounterCloned` through the MFA failure/audit path.+- Add deterministic signed ES256 registration/assertion wire fixtures and real-verifier workflow tests.+- Document that direct attestation requests evidence without enforcing device trust (ADR-25).++## 0.2.0.0 — 2026-08-27++Not yet published to Hackage: the library depends on a fork of `webauthn`+that builds against GHC 9.12.4, `crypton >= 1.1`, and `jose 0.13`. Upstream+`webauthn` 0.11.0.0 constrains `base < 4.20` and `jose < 0.12`. This package+ships once a compatible `webauthn` is on Hackage.++Initial release contents:++- Empty WebAuthn origin sets fail closed with a typed ceremony error instead of calling the partial+ `NonEmpty.fromList` constructor.+- Interprets Shōmei's passkey ceremony port with the `webauthn` library:+ challenge generation, attestation and assertion verification, origin and+ relying-party checks, and signature-counter handling.+- Backs passkey enrollment, passwordless login, and password-then-passkey+ step-up.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Nadeem Bitar++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ shomei-webauthn.cabal view
@@ -0,0 +1,96 @@+cabal-version: 3.0+name: shomei-webauthn+version: 0.3.0.0+synopsis:+ WebAuthn (passkey) registration/authentication ceremony interpreter++description:+ Interprets Shōmei's passkey ceremony port with the webauthn library. Handles+ the WebAuthn registration and authentication ceremonies that back passkey+ enrollment, passwordless login, and password-then-passkey step-up:+ challenge generation, attestation and assertion verification, origin and+ relying-party checks, and signature-counter handling. Depends only on+ shomei-core.++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++source-repository head+ type: git+ location: https://github.com/shinzui/shomei.git++common warnings+ ghc-options:+ -Wall+ -Wcompat+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wpartial-fields+ -Wredundant-constraints++common shared+ default-language: GHC2024+ default-extensions:+ BlockArguments+ DataKinds+ DeriveAnyClass+ DuplicateRecordFields+ LambdaCase+ OverloadedLabels+ OverloadedRecordDot+ OverloadedStrings++library+ import: warnings, shared+ hs-source-dirs: src+ exposed-modules: Shomei.WebAuthn.Ceremony+ build-depends:+ aeson >=2.1 && <2.3,+ base >=4.18 && <5,+ bytestring >=0.11 && <0.13,+ crypton >=1.1.0 && <1.2,+ effectful >=2.5 && <2.8,+ effectful-core >=2.5 && <2.8,+ mtl >=2.3 && <2.4,+ shomei-core ^>=0.3.0.0,+ text >=2.0 && <2.2,+ time >=1.12 && <1.15,+ time-hourglass >=0.3 && <0.4,+ validation >=1.1 && <1.3,+ webauthn >=0.12 && <0.13,++test-suite shomei-webauthn-test+ import: warnings, shared+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules:+ Shomei.WebAuthn.CeremonySpec+ Shomei.WebAuthn.SoftwareAuthenticator+ Shomei.WebAuthn.WorkflowSpec++ build-depends:+ aeson >=2.1 && <2.3,+ base >=4.18 && <5,+ bytestring >=0.11 && <0.13,+ containers >=0.6 && <0.9,+ crypton >=1.1.0 && <1.2,+ effectful >=2.5 && <2.8,+ effectful-core >=2.5 && <2.8,+ ram >=0.22 && <0.23,+ shomei-core ^>=0.3.0.0,+ shomei-webauthn ^>=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,+ webauthn >=0.12 && <0.13,
+ src/Shomei/WebAuthn/Ceremony.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}++-- | The real 'WebAuthnCeremony' interpreter, backed by the @tweag/webauthn@ library+-- (MasterPlan 3, EP-1 M2).+--+-- This is the infrastructure side of the IP-1 port: it owns every @webauthn@ library type+-- (@shomei-core@ never names one). 'runWebAuthnCeremonyLibrary' closes over the+-- 'WebAuthnConfig' Relying Party identity and:+--+-- * /begin/ steps build the library's 'WA.CredentialOptions', encode them with+-- @webauthn-json@ to the browser-facing JSON ('optionsJson') and to an opaque+-- persisted blob ('optionsBlob', the same JSON as bytes — EP-2 stores it);+-- * /complete/ steps decode the persisted options blob (via the exposed-internal+-- 'WJI.decode'), decode the browser's credential JSON, run the library's+-- 'WA.verifyRegistrationResponse' / 'WA.verifyAuthenticationResponse', and map the+-- result (or the library's error families) to the small closed 'WebAuthnError' set.+--+-- A potentially-cloned signature counter fails closed ('WebAuthnCounterCloned'), per the+-- ADR-25. The Metadata Service registry is empty ('mempty') and the registration trust+-- verdict is not used. @direct@ requests attestation conveyance; it does not require+-- trusted hardware or apply a device allow-list. @none@ remains the default.+--+-- Note: 'WebAuthnConfig' fields are read via their plain selectors (@rpId cfg@, …) rather+-- than @cfg.rpId@ record-dot, because GHC does not derive @HasField@ for these records+-- under @DuplicateRecordFields@.+module Shomei.WebAuthn.Ceremony (runWebAuthnCeremonyLibrary) where++import Control.Monad.Except (runExcept)+import Crypto.Hash (hash)+import Crypto.WebAuthn qualified as WA+import Crypto.WebAuthn.Encoding.Internal.WebAuthnJson qualified as WJI+import Crypto.WebAuthn.Encoding.Strings qualified as WStr+import Crypto.WebAuthn.Encoding.WebAuthnJson qualified as WJ+import Data.Aeson (Value, eitherDecodeStrict', encode, fromJSON, toJSON)+import Data.Aeson qualified as Aeson+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as LBS+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Text qualified as Text+import Data.Text.Encoding (encodeUtf8)+import Data.Time (NominalDiffTime)+import Data.Validation (Validation (Failure, Success))+import Effectful (Eff, IOE, liftIO, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Shomei.Config+ ( AttestationPolicy (..),+ UserVerificationPolicy (..),+ WebAuthnConfig,+ attestation,+ ceremonyTimeout,+ origins,+ rpId,+ rpName,+ userVerification,+ )+import Shomei.Passkey.Ceremony.Port+ ( BeginCeremony (..),+ CredentialUserInfo (..),+ StoredCredentialForVerify (..),+ VerifiedAuthentication (..),+ VerifiedRegistration (..),+ WebAuthnCeremony (..),+ WebAuthnError (..),+ )+import Shomei.Passkey.Domain+ ( PublicKeyBytes (..),+ SignatureCounter (..),+ UserHandle (..),+ WebAuthnCredentialId (..),+ )+import Time.System (dateCurrent)++runWebAuthnCeremonyLibrary :: (IOE :> es) => WebAuthnConfig -> Eff (WebAuthnCeremony : es) a -> Eff es a+runWebAuthnCeremonyLibrary cfg = interpret_ \case+ BeginRegistrationCeremony userInfo excludeIds -> liftIO (beginRegistration cfg userInfo excludeIds)+ CompleteRegistrationCeremony blob credJson -> liftIO (completeRegistration cfg blob credJson)+ BeginAuthenticationCeremony uv allowIds -> liftIO (beginAuthentication cfg uv allowIds)+ CompleteAuthenticationCeremony blob stored credJson ->+ pure (completeAuthentication cfg blob stored credJson)++-- Begin steps -----------------------------------------------------------------++beginRegistration :: WebAuthnConfig -> CredentialUserInfo -> [WebAuthnCredentialId] -> IO BeginCeremony+beginRegistration cfg (CredentialUserInfo uh accountName displayName) excludeIds = do+ challenge <- WA.generateChallenge+ let opts =+ WA.CredentialOptionsRegistration+ { WA.corRp =+ WA.CredentialRpEntity+ { WA.creId = Just (WA.RpId (rpId cfg)),+ WA.creName = WA.RelyingPartyName (rpName cfg)+ },+ WA.corUser =+ WA.CredentialUserEntity+ { WA.cueId = toWAUserHandle uh,+ WA.cueDisplayName = WA.UserAccountDisplayName displayName,+ WA.cueName = WA.UserAccountName accountName+ },+ WA.corChallenge = challenge,+ WA.corPubKeyCredParams =+ [ WA.CredentialParameters {WA.cpTyp = WA.CredentialTypePublicKey, WA.cpAlg = WA.CoseAlgorithmES256},+ WA.CredentialParameters {WA.cpTyp = WA.CredentialTypePublicKey, WA.cpAlg = WA.CoseAlgorithmRS256}+ ],+ WA.corTimeout = Just (mkTimeout (ceremonyTimeout cfg)),+ WA.corExcludeCredentials = map mkDescriptor excludeIds,+ WA.corAuthenticatorSelection =+ Just+ WA.AuthenticatorSelectionCriteria+ { WA.ascAuthenticatorAttachment = Nothing,+ WA.ascResidentKey = WA.ResidentKeyRequirementDiscouraged,+ WA.ascUserVerification = mapUV (userVerification cfg)+ },+ WA.corHints = [],+ WA.corAttestation = mapAttestation (attestation cfg),+ WA.corExtensions = Nothing+ }+ wjOpts = WJ.wjEncodeCredentialOptionsRegistration opts+ pure BeginCeremony {optionsJson = toJSON wjOpts, optionsBlob = LBS.toStrict (encode wjOpts)}++beginAuthentication :: WebAuthnConfig -> UserVerificationPolicy -> [WebAuthnCredentialId] -> IO BeginCeremony+beginAuthentication cfg uv allowIds = do+ challenge <- WA.generateChallenge+ let opts =+ WA.CredentialOptionsAuthentication+ { WA.coaRpId = Just (WA.RpId (rpId cfg)),+ WA.coaTimeout = Just (mkTimeout (ceremonyTimeout cfg)),+ WA.coaChallenge = challenge,+ WA.coaAllowCredentials = map mkDescriptor allowIds,+ WA.coaUserVerification = mapUV uv,+ WA.coaHints = [],+ WA.coaExtensions = Nothing+ }+ wjOpts = WJ.wjEncodeCredentialOptionsAuthentication opts+ pure BeginCeremony {optionsJson = toJSON wjOpts, optionsBlob = LBS.toStrict (encode wjOpts)}++-- Complete steps --------------------------------------------------------------++completeRegistration :: WebAuthnConfig -> ByteString -> Value -> IO (Either WebAuthnError VerifiedRegistration)+completeRegistration cfg blob credJson = do+ now <- dateCurrent+ pure do+ allowed <- maybe (Left (WebAuthnOtherError "no allowed WebAuthn origins are configured")) Right (originsOf cfg)+ opts <- recoverRegistrationOptions blob+ cred <- decodeRegistrationCredential credJson+ case WA.verifyRegistrationResponse allowed (rpIdHashOf cfg) mempty now opts cred of+ Failure errs -> Left (mapRegError (NE.head errs))+ Success result -> Right (entryToRegistration (WA.rrEntry result))++completeAuthentication ::+ WebAuthnConfig ->+ ByteString ->+ StoredCredentialForVerify ->+ Value ->+ Either WebAuthnError VerifiedAuthentication+completeAuthentication cfg blob (StoredCredentialForVerify scid suh spk scnt strans) credJson = do+ allowed <- maybe (Left (WebAuthnOtherError "no allowed WebAuthn origins are configured")) Right (originsOf cfg)+ opts <- recoverAuthenticationOptions blob+ cred <- decodeAuthenticationCredential credJson+ let entry =+ WA.CredentialEntry+ { WA.ceCredentialId = toWACredId scid,+ WA.ceUserHandle = toWAUserHandle suh,+ WA.cePublicKeyBytes = toWAPubKey spk,+ WA.ceSignCounter = toWACounter scnt,+ WA.ceTransports = map WStr.decodeAuthenticatorTransport strans+ }+ case WA.verifyAuthenticationResponse allowed (rpIdHashOf cfg) (Just (toWAUserHandle suh)) entry opts cred of+ Failure errs -> Left (mapAuthError (NE.head errs))+ Success (WA.AuthenticationResult counterResult) -> case counterResult of+ WA.SignatureCounterZero -> Right (verifiedAuth scid scnt)+ WA.SignatureCounterUpdated c -> Right (verifiedAuth scid (SignatureCounter (WA.unSignatureCounter c)))+ WA.SignatureCounterPotentiallyCloned -> Left WebAuthnCounterCloned+ where+ verifiedAuth cid newCounter =+ VerifiedAuthentication {credentialId = cid, newSignCounter = newCounter}++-- Options / credential (de)serialization --------------------------------------++recoverRegistrationOptions :: ByteString -> Either WebAuthnError (WA.CredentialOptions 'WA.Registration)+recoverRegistrationOptions blob = do+ wjOpts <- first (WebAuthnDecodeError . Text.pack) (eitherDecodeStrict' blob)+ first WebAuthnDecodeError (runExcept (WJI.decode (WJ._unWJCredentialOptionsRegistration wjOpts)))++recoverAuthenticationOptions :: ByteString -> Either WebAuthnError (WA.CredentialOptions 'WA.Authentication)+recoverAuthenticationOptions blob = do+ wjOpts <- first (WebAuthnDecodeError . Text.pack) (eitherDecodeStrict' blob)+ first WebAuthnDecodeError (runExcept (WJI.decode (WJ._unWJCredentialOptionsAuthentication wjOpts)))++decodeRegistrationCredential :: Value -> Either WebAuthnError (WA.Credential 'WA.Registration 'True)+decodeRegistrationCredential v = do+ wjCred <- case fromJSON v of+ Aeson.Success c -> Right c+ Aeson.Error e -> Left (WebAuthnDecodeError (Text.pack e))+ first (WebAuthnDecodeError . Text.pack . show) (WJ.wjDecodeCredentialRegistration wjCred)++decodeAuthenticationCredential :: Value -> Either WebAuthnError (WA.Credential 'WA.Authentication 'True)+decodeAuthenticationCredential v = do+ wjCred <- case fromJSON v of+ Aeson.Success c -> Right c+ Aeson.Error e -> Left (WebAuthnDecodeError (Text.pack e))+ first (WebAuthnDecodeError . Text.pack . show) (WJ.wjDecodeCredentialAuthentication wjCred)++entryToRegistration :: WA.CredentialEntry -> VerifiedRegistration+entryToRegistration e =+ VerifiedRegistration+ { credentialId = WebAuthnCredentialId (WA.unCredentialId (WA.ceCredentialId e)),+ userHandle = UserHandle (WA.unUserHandle (WA.ceUserHandle e)),+ publicKey = PublicKeyBytes (WA.unPublicKeyBytes (WA.cePublicKeyBytes e)),+ signCounter = SignatureCounter (WA.unSignatureCounter (WA.ceSignCounter e)),+ transports = map WStr.encodeAuthenticatorTransport (WA.ceTransports e)+ }++-- RP identity / policy mapping ------------------------------------------------++originsOf :: WebAuthnConfig -> Maybe (NonEmpty WA.Origin)+originsOf cfg = NE.nonEmpty (map WA.Origin (origins cfg))++rpIdHashOf :: WebAuthnConfig -> WA.RpIdHash+rpIdHashOf cfg = WA.RpIdHash (hash (encodeUtf8 (rpId cfg)))++mkTimeout :: NominalDiffTime -> WA.Timeout+mkTimeout dt = WA.Timeout (round (realToFrac dt * 1000 :: Double))++mkDescriptor :: WebAuthnCredentialId -> WA.CredentialDescriptor+mkDescriptor cid =+ WA.CredentialDescriptor+ { WA.cdTyp = WA.CredentialTypePublicKey,+ WA.cdId = toWACredId cid,+ WA.cdTransports = Nothing+ }++mapUV :: UserVerificationPolicy -> WA.UserVerificationRequirement+mapUV UVRequired = WA.UserVerificationRequirementRequired+mapUV UVPreferred = WA.UserVerificationRequirementPreferred+mapUV UVDiscouraged = WA.UserVerificationRequirementDiscouraged++mapAttestation :: AttestationPolicy -> WA.AttestationConveyancePreference+mapAttestation AttestationNone = WA.AttestationConveyancePreferenceNone+mapAttestation AttestationDirect = WA.AttestationConveyancePreferenceDirect++-- Type bridges (Shōmei domain <-> webauthn newtypes) --------------------------++toWAUserHandle :: UserHandle -> WA.UserHandle+toWAUserHandle (UserHandle bs) = WA.UserHandle bs++toWACredId :: WebAuthnCredentialId -> WA.CredentialId+toWACredId (WebAuthnCredentialId bs) = WA.CredentialId bs++toWAPubKey :: PublicKeyBytes -> WA.PublicKeyBytes+toWAPubKey (PublicKeyBytes bs) = WA.PublicKeyBytes bs++toWACounter :: SignatureCounter -> WA.SignatureCounter+toWACounter (SignatureCounter w) = WA.SignatureCounter w++-- Error mapping ---------------------------------------------------------------++mapRegError :: WA.RegistrationError -> WebAuthnError+mapRegError = \case+ WA.RegistrationChallengeMismatch {} -> WebAuthnChallengeMismatch+ WA.RegistrationOriginMismatch {} -> WebAuthnOriginMismatch+ WA.RegistrationRpIdHashMismatch {} -> WebAuthnRpIdMismatch+ WA.RegistrationUserNotPresent {} -> WebAuthnUserNotPresent+ WA.RegistrationUserNotVerified {} -> WebAuthnUserNotVerified+ err -> WebAuthnOtherError (Text.pack (show err))++mapAuthError :: WA.AuthenticationError -> WebAuthnError+mapAuthError = \case+ WA.AuthenticationChallengeMismatch {} -> WebAuthnChallengeMismatch+ WA.AuthenticationOriginMismatch {} -> WebAuthnOriginMismatch+ WA.AuthenticationRpIdHashMismatch {} -> WebAuthnRpIdMismatch+ WA.AuthenticationUserNotPresent {} -> WebAuthnUserNotPresent+ WA.AuthenticationUserNotVerified {} -> WebAuthnUserNotVerified+ WA.AuthenticationSignatureInvalid {} -> WebAuthnSignatureInvalid+ err -> WebAuthnOtherError (Text.pack (show err))
+ test/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import Shomei.WebAuthn.CeremonySpec qualified+import Shomei.WebAuthn.WorkflowSpec qualified+import Test.Tasty (defaultMain, testGroup)++main :: IO ()+main = defaultMain (testGroup "shomei-webauthn-test" [Shomei.WebAuthn.CeremonySpec.tests, Shomei.WebAuthn.WorkflowSpec.tests])
+ test/Shomei/WebAuthn/CeremonySpec.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE DataKinds #-}++-- | Tests for the real @tweag/webauthn@ ceremony interpreter+-- ('Shomei.WebAuthn.Ceremony.runWebAuthnCeremonyLibrary').+--+-- Signed wire fixtures exercise the production decoder and verifier without a browser.+module Shomei.WebAuthn.CeremonySpec (tests) where++import Crypto.WebAuthn.Encoding.WebAuthnJson qualified as WJ+import Data.Aeson (Value, eitherDecodeStrict', encode, object)+import Data.Aeson.Types (parseEither, withObject, (.:))+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BC+import Data.ByteString.Lazy qualified as LBS+import Data.Either (isLeft)+import Data.Text (Text)+import Effectful (runEff)+import Shomei.Config+ ( AttestationPolicy (..),+ UserVerificationPolicy (UVDiscouraged, UVRequired),+ WebAuthnConfig (attestation, origins, userVerification),+ defaultWebAuthnConfig,+ )+import Shomei.Passkey.Ceremony.Port+ ( BeginCeremony (..),+ CredentialUserInfo (..),+ StoredCredentialForVerify (..),+ VerifiedAuthentication (..),+ VerifiedRegistration (..),+ WebAuthnError (..),+ beginAuthenticationCeremony,+ beginRegistrationCeremony,+ completeAuthenticationCeremony,+ completeRegistrationCeremony,+ )+import Shomei.Passkey.Domain (SignatureCounter (..), UserHandle (..), b64urlEncode)+import Shomei.WebAuthn.Ceremony (runWebAuthnCeremonyLibrary)+import Shomei.WebAuthn.SoftwareAuthenticator+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++tests :: TestTree+tests =+ testGroup+ "WebAuthn.Ceremony (real interpreter)"+ [ testCase "direct requests evidence without enforcing authenticator trust" directAttestationBoundary,+ testCase "signed ES256 registration then assertion succeeds through the real interpreter" signedRoundTrip,+ testCase "signed policy mutations fail at their intended verifier boundary" signedPolicyNegatives,+ testCase "counterless, advancing, repeated and regressed counters follow policy" signedCounterPolicy,+ testCase "begin registration produces a round-tripping options blob" beginRegistrationRoundTrips,+ testCase "begin authentication produces a round-tripping options blob" beginAuthenticationRoundTrips,+ testCase "passwordless authentication requires UV even when step-up discourages it" passwordlessRequiresUv,+ testCase "complete registration on malformed credential JSON fails closed" completeRejectsGarbage,+ testCase "empty origins fail closed before credential decoding" emptyOriginsFailClosed+ ]++sampleUser :: CredentialUserInfo+sampleUser =+ CredentialUserInfo+ { userHandle = UserHandle (BC.pack "sample-user-handle"),+ accountName = "ada@example.com",+ displayName = "Ada Lovelace"+ }++beginRegistrationRoundTrips :: IO ()+beginRegistrationRoundTrips = do+ BeginCeremony {optionsBlob = blob} <-+ runEff . runWebAuthnCeremonyLibrary defaultWebAuthnConfig $ beginRegistrationCeremony sampleUser []+ assertBool "registration optionsBlob is non-empty" (not (BC.null blob))+ assertBool "registration optionsBlob round-trips through webauthn-json" (registrationBlobRoundTrips blob)++beginAuthenticationRoundTrips :: IO ()+beginAuthenticationRoundTrips = do+ BeginCeremony {optionsBlob = blob} <-+ runEff . runWebAuthnCeremonyLibrary defaultWebAuthnConfig $+ beginAuthenticationCeremony (userVerification defaultWebAuthnConfig) []+ assertBool "authentication optionsBlob is non-empty" (not (BC.null blob))+ assertBool "authentication optionsBlob round-trips through webauthn-json" (authenticationBlobRoundTrips blob)+ decodeUserVerification blob @?= Right "preferred"++passwordlessRequiresUv :: IO ()+passwordlessRequiresUv = do+ let cfg = defaultWebAuthnConfig {userVerification = UVDiscouraged}+ BeginCeremony {optionsBlob = blob} <-+ runEff . runWebAuthnCeremonyLibrary cfg $ beginAuthenticationCeremony UVRequired []+ decodeUserVerification blob @?= Right "required"++completeRejectsGarbage :: IO ()+completeRejectsGarbage = do+ result <- runEff . runWebAuthnCeremonyLibrary defaultWebAuthnConfig $ do+ BeginCeremony {optionsBlob = blob} <- beginRegistrationCeremony sampleUser []+ completeRegistrationCeremony blob (object [])+ assertBool "malformed credential JSON yields a WebAuthnError, not a success" (isLeft result)++emptyOriginsFailClosed :: IO ()+emptyOriginsFailClosed = do+ let cfg = defaultWebAuthnConfig {origins = []}+ result <- runEff . runWebAuthnCeremonyLibrary cfg $ completeRegistrationCeremony "garbage" (object [])+ result @?= Left (WebAuthnOtherError "no allowed WebAuthn origins are configured")++-- | Decode the persisted blob back to the WJ intermediate registration options type+-- and re-encode it; the bytes must be identical (this is the recovery path the+-- interpreter's @completeRegistration@ uses).+registrationBlobRoundTrips :: ByteString -> Bool+registrationBlobRoundTrips blob = case eitherDecodeStrict' blob of+ Right opts -> LBS.toStrict (encode (opts :: WJ.WJCredentialOptionsRegistration)) == blob+ Left _ -> False++authenticationBlobRoundTrips :: ByteString -> Bool+authenticationBlobRoundTrips blob = case eitherDecodeStrict' blob of+ Right opts -> LBS.toStrict (encode (opts :: WJ.WJCredentialOptionsAuthentication)) == blob+ Left _ -> False++decodeUserVerification :: ByteString -> Either String Text+decodeUserVerification blob = do+ value <- eitherDecodeStrict' blob :: Either String Value+ parseEither (withObject "authentication options" (.: "userVerification")) value++signedConfig :: WebAuthnConfig+signedConfig = defaultWebAuthnConfig {origins = ["https://localhost"], userVerification = UVRequired}++fixedRegistration :: IO (Value, VerifiedRegistration)+fixedRegistration = do+ BeginCeremony {optionsJson} <- runEff . runWebAuthnCeremonyLibrary signedConfig $ beginRegistrationCeremony sampleUser []+ let options = freezeChallenge optionsJson+ result <- runEff . runWebAuthnCeremonyLibrary signedConfig $ completeRegistrationCeremony (LBS.toStrict (encode options)) (registrationResponse options goodPolicy {responseCounter = 0})+ case result of+ Left err -> error ("valid registration rejected: " <> show err)+ Right credential -> pure (options, credential)++storedFrom :: VerifiedRegistration -> SignatureCounter -> StoredCredentialForVerify+storedFrom VerifiedRegistration {credentialId, userHandle, publicKey, transports} counter = StoredCredentialForVerify credentialId userHandle publicKey counter transports++assertWith :: VerifiedRegistration -> SignatureCounter -> ResponsePolicy -> IO (Either WebAuthnError VerifiedAuthentication)+assertWith credential counter policy = do+ BeginCeremony {optionsJson} <- runEff . runWebAuthnCeremonyLibrary signedConfig $ beginAuthenticationCeremony UVRequired []+ let options = freezeChallenge optionsJson+ runEff . runWebAuthnCeremonyLibrary signedConfig $ completeAuthenticationCeremony (LBS.toStrict (encode options)) (storedFrom credential counter) (assertionResponse options policy)++signedRoundTrip :: IO ()+signedRoundTrip = do+ (_, credential) <- fixedRegistration+ let VerifiedRegistration {userHandle} = credential+ userHandle @?= UserHandle (BC.pack "sample-user-handle")+ result <- assertWith credential (SignatureCounter 0) goodPolicy {responseHandle = "sample-user-handle"}+ case result of+ Right VerifiedAuthentication {newSignCounter} -> newSignCounter @?= SignatureCounter 1+ Left err -> error (show err)++signedPolicyNegatives :: IO ()+signedPolicyNegatives = do+ (_, credential) <- fixedRegistration+ let valid = goodPolicy {responseHandle = "sample-user-handle"}+ sequence_+ [ assertWith credential (SignatureCounter 0) policy >>= (@?= Left expected)+ | (policy, expected) <-+ [ (valid {responseOrigin = "https://evil.example"}, WebAuthnOriginMismatch),+ (valid {responseRp = "evil.example"}, WebAuthnRpIdMismatch),+ (valid {responseChallenge = Just (b64urlEncode "wrong-challenge")}, WebAuthnChallengeMismatch),+ (valid {responseFlags = 1}, WebAuthnUserNotVerified),+ (valid {responseFlags = 4}, WebAuthnUserNotPresent),+ (valid {corruptSignature = True}, WebAuthnSignatureInvalid)+ ]+ ]+ BeginCeremony {optionsBlob = authBlob} <- runEff . runWebAuthnCeremonyLibrary signedConfig $ beginAuthenticationCeremony UVRequired []+ malformed <- runEff . runWebAuthnCeremonyLibrary signedConfig $ completeAuthenticationCeremony authBlob (storedFrom credential (SignatureCounter 0)) (object [])+ assertBool "malformed assertion fails closed" (isLeft malformed)+ emptyOrigin <- runEff . runWebAuthnCeremonyLibrary signedConfig {origins = []} $ completeAuthenticationCeremony authBlob (storedFrom credential (SignatureCounter 0)) (object [])+ emptyOrigin @?= Left (WebAuthnOtherError "no allowed WebAuthn origins are configured")+ crossUser <- assertWith credential (SignatureCounter 0) valid {responseHandle = "another-user"}+ assertBool "a correctly signed assertion from a different user fails" (isLeft crossUser)+ wrongType <- assertWith credential (SignatureCounter 0) valid {responseType = Just "webauthn.create"}+ assertBool "create client data cannot satisfy get" (isLeft wrongType)+ (options, _) <- fixedRegistration+ let register policy = runEff . runWebAuthnCeremonyLibrary signedConfig $ completeRegistrationCeremony (LBS.toStrict (encode options)) (registrationResponse options policy)+ sequence_+ [ register policy >>= (@?= Left expected)+ | (policy, expected) <-+ [ (valid {responseOrigin = "https://evil.example"}, WebAuthnOriginMismatch),+ (valid {responseRp = "evil.example"}, WebAuthnRpIdMismatch),+ (valid {responseChallenge = Just (b64urlEncode "wrong-challenge")}, WebAuthnChallengeMismatch),+ (valid {responseFlags = 4}, WebAuthnUserNotPresent),+ (valid {responseFlags = 1}, WebAuthnUserNotVerified)+ ]+ ]+ badRegistrationType <- register valid {responseType = Just "webauthn.get"}+ assertBool "get client data cannot satisfy create" (isLeft badRegistrationType)++signedCounterPolicy :: IO ()+signedCounterPolicy = do+ (_, credential) <- fixedRegistration+ let valid = goodPolicy {responseHandle = "sample-user-handle"}+ zero <- assertWith credential (SignatureCounter 0) valid {responseCounter = 0}+ case zero of+ Right VerifiedAuthentication {newSignCounter} -> newSignCounter @?= SignatureCounter 0+ Left err -> error (show err)+ advancing <- assertWith credential (SignatureCounter 3) valid {responseCounter = 4}+ case advancing of+ Right VerifiedAuthentication {newSignCounter} -> newSignCounter @?= SignatureCounter 4+ Left err -> error (show err)+ sequence_ [assertWith credential (SignatureCounter 3) valid {responseCounter = n} >>= (@?= Left WebAuthnCounterCloned) | n <- [3, 2, 0]]++directAttestationBoundary :: IO ()+directAttestationBoundary = do+ (options, _) <- fixedRegistration+ let direct = signedConfig {attestation = AttestationDirect}+ BeginCeremony {optionsJson} <- runEff . runWebAuthnCeremonyLibrary direct $ beginRegistrationCeremony sampleUser []+ parseEither (withObject "options" (.: "attestation")) optionsJson @?= Right ("direct" :: Text)+ result <- runEff . runWebAuthnCeremonyLibrary direct $ completeRegistrationCeremony (LBS.toStrict (encode options)) (registrationResponse options goodPolicy)+ assertBool "direct is a conveyance request, not a device allow-list" (not (isLeft result))
+ test/Shomei/WebAuthn/SoftwareAuthenticator.hs view
@@ -0,0 +1,141 @@+-- | A deliberately tiny test-only ES256 authenticator. The public private scalar (1)+-- and fixed signing nonce (2) MUST NEVER be used for real credentials. Building browser+-- wire data independently exercises production JSON/CBOR decoding as well as verification.+module Shomei.WebAuthn.SoftwareAuthenticator+ ( ResponsePolicy (..),+ goodPolicy,+ credentialBytes,+ fixtureHandle,+ registrationResponse,+ assertionResponse,+ challengeOf,+ freezeChallenge,+ )+where++import Crypto.Hash (Digest, SHA256 (..), hash)+import Crypto.Number.Serialize (i2osp, i2ospOf_)+import Crypto.PubKey.ECC.ECDSA qualified as ECDSA+import Crypto.PubKey.ECC.Prim (pointBaseMul)+import Crypto.PubKey.ECC.Types (CurveName (SEC_p256r1), Point (..), getCurveByName)+import Data.Aeson (Value (..), encode, object, (.=))+import Data.Aeson.KeyMap qualified as KM+import Data.Aeson.Types (parseMaybe, withObject, (.:))+import Data.Bits (shiftR)+import Data.ByteArray (convert)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Data.Word (Word32, Word8)+import Shomei.Passkey.Domain (b64urlEncode)++data ResponsePolicy = ResponsePolicy+ { responseOrigin :: Text,+ responseRp :: Text,+ responseChallenge :: Maybe Text,+ responseType :: Maybe Text,+ responseFlags :: Word8,+ responseCounter :: Word32,+ responseHandle :: ByteString,+ corruptSignature :: Bool+ }++goodPolicy :: ResponsePolicy+goodPolicy = ResponsePolicy "https://localhost" "localhost" Nothing Nothing 5 1 fixtureHandle False++credentialBytes, fixtureHandle :: ByteString+credentialBytes = "test-only-es256-credential"+fixtureHandle = "test-only-user-handle"++challengeOf :: Value -> Text+challengeOf v = maybe (error "fixture options lack challenge") id (parseMaybe (withObject "options" (.: "challenge")) v)++freezeChallenge :: Value -> Value+freezeChallenge (Object o) = Object (KM.insert "challenge" (String (b64urlEncode "fixed-test-challenge-with-32-bytes")) o)+freezeChallenge _ = error "fixture options are not an object"++sha256 :: ByteString -> ByteString+sha256 bytes = convert (hash bytes :: Digest SHA256)++-- Minimal definite-length CBOR for this fixture's byte and text strings.+cbor :: Word8 -> ByteString -> ByteString+cbor major bytes = prefix <> bytes+ where+ n = BS.length bytes+ prefix+ | n < 24 = BS.singleton (major + fromIntegral n)+ | n < 256 = BS.pack [major + 24, fromIntegral n]+ | otherwise = BS.pack [major + 25, fromIntegral (n `shiftR` 8), fromIntegral n]++publicKey :: ByteString+publicKey = case pointBaseMul (getCurveByName SEC_p256r1) 1 of+ Point x y -> BS.pack [0xa5, 1, 2, 3, 0x26, 0x20, 1, 0x21] <> cbor 0x40 (i2ospOf_ 32 x) <> BS.singleton 0x22 <> cbor 0x40 (i2ospOf_ 32 y)+ PointO -> error "invalid fixture point"++authData :: Bool -> ResponsePolicy -> ByteString+authData registration p = sha256 (encodeUtf8 p.responseRp) <> BS.singleton flags <> counter <> attested+ where+ flags = p.responseFlags + if registration then 0x40 else 0+ n = p.responseCounter+ counter = BS.pack [fromIntegral (n `shiftR` bits) | bits <- [24, 16, 8, 0]]+ attested+ | registration = BS.replicate 16 0 <> BS.pack [0, fromIntegral (BS.length credentialBytes)] <> credentialBytes <> publicKey+ | otherwise = BS.empty++clientData :: Text -> Value -> ResponsePolicy -> ByteString+clientData kind options p =+ LBS.toStrict+ ( encode+ ( object+ [ "type" .= maybe kind id p.responseType,+ "challenge" .= maybe (challengeOf options) id p.responseChallenge,+ "origin" .= p.responseOrigin,+ "crossOrigin" .= False+ ]+ )+ )++registrationResponse :: Value -> ResponsePolicy -> Value+registrationResponse options p =+ object+ [ "id" .= b64urlEncode credentialBytes,+ "rawId" .= b64urlEncode credentialBytes,+ "type" .= ("public-key" :: Text),+ "response"+ .= object+ [ "clientDataJSON" .= b64urlEncode (clientData "webauthn.create" options p),+ "attestationObject" .= b64urlEncode attestation,+ "transports" .= ([] :: [Text])+ ],+ "clientExtensionResults" .= object []+ ]+ where+ attestation = BS.singleton 0xa3 <> cbor 0x60 "fmt" <> cbor 0x60 "none" <> cbor 0x60 "attStmt" <> BS.singleton 0xa0 <> cbor 0x60 "authData" <> cbor 0x40 (authData True p)++assertionResponse :: Value -> ResponsePolicy -> Value+assertionResponse options p =+ object+ [ "id" .= b64urlEncode credentialBytes,+ "rawId" .= b64urlEncode credentialBytes,+ "type" .= ("public-key" :: Text),+ "response"+ .= object+ [ "clientDataJSON" .= b64urlEncode client,+ "authenticatorData" .= b64urlEncode authenticator,+ "signature" .= b64urlEncode signature,+ "userHandle" .= b64urlEncode p.responseHandle+ ],+ "clientExtensionResults" .= object []+ ]+ where+ client = clientData "webauthn.get" options p+ authenticator = authData False p+ signature+ | p.corruptSignature = "invalid-signature"+ | otherwise = case ECDSA.signWith 2 (ECDSA.PrivateKey (getCurveByName SEC_p256r1) 1) SHA256 (authenticator <> sha256 client) of+ Just (ECDSA.Signature r s) -> der 0x30 (integer r <> integer s)+ Nothing -> error "fixture signature failed"+ integer n = let bytes = i2osp n; positive = if BS.head bytes >= 128 then BS.cons 0 bytes else bytes in der 2 positive+ der tag bytes = BS.pack [tag, fromIntegral (BS.length bytes)] <> bytes
+ test/Shomei/WebAuthn/WorkflowSpec.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}++module Shomei.WebAuthn.WorkflowSpec (tests) where++import Control.Monad (forM_)+import Data.Aeson (Value, encode)+import Data.Aeson.Types (parseMaybe, withObject, (.:))+import Data.ByteString.Lazy qualified as LBS+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.Map.Strict qualified as Map+import Data.Time (UTCTime (..), addUTCTime, fromGregorian)+import Effectful (Eff, IOE, liftIO, runEff, (:>))+import Effectful.Dispatch.Dynamic (interpose)+import Shomei.Account.LoginId.Domain (LoginId, mkLoginId)+import Shomei.Account.Password.Domain (PlainPassword (..))+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 (..), UserVerificationPolicy (..), WebAuthnConfig (..), defaultShomeiConfig, defaultWebAuthnConfig)+import Shomei.Error (AuthError (..))+import Shomei.Id (genCeremonyId)+import Shomei.Mfa.Workflow (MfaCompletion (..), beginPasswordlessLogin, completeMfa, completePasswordlessLogin)+import Shomei.Passkey.Ceremony.Port+import Shomei.Passkey.Ceremony.Store (putPendingCeremony)+import Shomei.Passkey.Domain (CeremonyKind (..), PasskeyCredential (..), PendingCeremony (..), SignatureCounter (..), b64urlDecode)+import Shomei.Passkey.Workflow (beginPasskeyRegistration, completePasskeyRegistration)+import Shomei.Session.Authentication.Workflow (LoginResult (..), MfaChallenge (..), login, signup)+import Shomei.Session.Command (ClientContext (..), LoginCommand (..), ProofContext (..), SignupCommand (..))+import Shomei.Session.LoginAttempt.Domain (AccountKey (..), ClientIp (..))+import Shomei.Test.InMemory (InMemoryPorts, World (..), emptyWorld, runInMemory)+import Shomei.WebAuthn.Ceremony (runWebAuthnCeremonyLibrary)+import Shomei.WebAuthn.SoftwareAuthenticator+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++-- Storage, Clock, signing and password hashes use the normal fake stack. Only the+-- ceremony effect is interposed, and every completion runs the production verifier.+-- Freeze each challenge after the real begin step so fixture payloads are reproducible.+realCeremonies :: (WebAuthnCeremony :> es, IOE :> es) => WebAuthnConfig -> Eff es a -> Eff es a+realCeremonies cfg = interpose \_ -> \case+ BeginRegistrationCeremony u ids -> liftIO (freeze =<< runEff (runWebAuthnCeremonyLibrary cfg (beginRegistrationCeremony u ids)))+ BeginAuthenticationCeremony uv ids -> liftIO (freeze =<< runEff (runWebAuthnCeremonyLibrary cfg (beginAuthenticationCeremony uv ids)))+ CompleteRegistrationCeremony b v -> liftIO (runEff (runWebAuthnCeremonyLibrary cfg (completeRegistrationCeremony b v)))+ CompleteAuthenticationCeremony b c v -> liftIO (runEff (runWebAuthnCeremonyLibrary cfg (completeAuthenticationCeremony b c v)))+ where+ freeze BeginCeremony {optionsJson} = let v = freezeChallenge optionsJson in pure (BeginCeremony v (LBS.toStrict (encode v)))++cfg :: ShomeiConfig+cfg = (defaultShomeiConfig (Issuer "test") (Audience "test")) {webauthnConfig = defaultWebAuthnConfig {origins = ["https://localhost"], userVerification = UVDiscouraged}}++runHybrid :: IORef World -> Eff InMemoryPorts a -> IO a+runHybrid ref = runInMemory ref . realCeremonies cfg.webauthnConfig++fixedTime :: UTCTime+fixedTime = UTCTime (fromGregorian 2026 1 1) 0++right :: (Show e) => Either e a -> IO a+right = either (assertFailure . show) pure++proof :: ProofContext+proof = ProofContext (ClientIp "fixture") AccountKey++fixtureLoginId :: LoginId+fixtureLoginId = either (error . show) id (mkLoginId "fixture-user")++fixturePassword :: PlainPassword+fixturePassword = PlainPassword "correct horse battery staple"++seed :: IO (IORef World, User, ResponsePolicy)+seed = do+ ref <- newIORef (emptyWorld fixedTime)+ (user, _) <- right =<< runHybrid ref (signup cfg (SignupCommand fixtureLoginId Nothing fixturePassword Nothing))+ (cid, options) <- right =<< runHybrid ref (beginPasskeyRegistration cfg user.userId)+ handle <- case parseMaybe (withObject "options" (\o -> o .: "user" >>= withObject "user" (.: "id"))) options of+ Just value -> right (b64urlDecode value)+ Nothing -> assertFailure "fixture options lack user handle"+ let policy = goodPolicy {responseHandle = handle, responseCounter = 0}+ _ <- right =<< runHybrid ref (completePasskeyRegistration cfg user.userId cid (registrationResponse options policy) Nothing)+ replay <- runHybrid ref (completePasskeyRegistration cfg user.userId cid (registrationResponse options policy) Nothing)+ replay @?= Left PendingCeremonyNotFound+ pure (ref, user, policy)++tests :: TestTree+tests =+ testGroup+ "signed WebAuthn workflows"+ [ testCase "signed enrollment, password step-up and passwordless login persist counters and audit winners" do+ (ref, user, policy) <- seed+ challenge <- right =<< runHybrid ref (login cfg (ClientContext (ClientIp "fixture") (AccountKey "fixture-user")) (LoginCommand fixtureLoginId fixturePassword False))+ case challenge of+ MfaRequired MfaChallenge {ceremonyId, options} -> do+ _ <- right =<< runHybrid ref (completeMfa cfg proof ceremonyId (MfaPasskey (assertionResponse options policy {responseCounter = 1, responseFlags = 1})))+ replay <- runHybrid ref (completeMfa cfg proof ceremonyId (MfaPasskey (assertionResponse options policy {responseCounter = 1})))+ replay @?= Left PendingCeremonyNotFound+ _ -> assertFailure "expected password step-up"+ (cid, options) <- right =<< runHybrid ref (beginPasswordlessLogin cfg)+ (resolved, _) <- right =<< runHybrid ref (completePasswordlessLogin cfg proof cid (assertionResponse options policy {responseCounter = 2}))+ resolved.userId @?= user.userId+ world <- readIORef ref+ map (\PasskeyCredential {signCounter} -> signCounter) (Map.elems world.passkeys) @?= [SignatureCounter 2]+ length [() | Event.MfaSucceeded _ <- world.publishedEvents] @?= 2+ (replayCid, replayOptions) <- right =<< runHybrid ref (beginPasswordlessLogin cfg)+ cloned <- runHybrid ref (completePasswordlessLogin cfg proof replayCid (assertionResponse replayOptions policy {responseCounter = 2}))+ cloned @?= Left MfaAssertionInvalid+ afterClone <- readIORef ref+ length [() | Event.MfaFailed _ <- afterClone.publishedEvents] @?= 1,+ testCase "passwordless always requires UV; signed bad proofs consume once and audit failures" do+ forM_ [UVPreferred, UVDiscouraged] \uv -> do+ (ref, _, policy) <- seed+ let run :: Eff InMemoryPorts a -> IO a+ run = runInMemory ref . realCeremonies cfg.webauthnConfig {userVerification = uv}+ (cid, options) <- right =<< run (beginPasswordlessLogin cfg)+ failed <- run (completePasswordlessLogin cfg proof cid (assertionResponse options policy {responseCounter = 1, responseFlags = 1}))+ failed @?= Left MfaAssertionInvalid+ replay <- run (completePasswordlessLogin cfg proof cid (assertionResponse options policy {responseCounter = 1}))+ replay @?= Left PendingCeremonyNotFound+ world <- readIORef ref+ length [() | Event.MfaFailed _ <- world.publishedEvents] @?= 1+ assertBool "failed proof recorded in shared abuse budget" (not (null world.loginAttempts)),+ testCase "a correctly signed credential owned by another user fails the step-up owner check" do+ (ref, _, policy) <- seed+ let bobLogin = either (error . show) id (mkLoginId "bob-fixture")+ bob <- runHybrid ref (createUser (NewUser bobLogin Nothing Nothing))+ (cid, options) <- runHybrid ref do+ BeginCeremony {optionsJson, optionsBlob} <- beginAuthenticationCeremony UVRequired []+ cid <- genCeremonyId+ putPendingCeremony (PendingCeremony cid (Just bob.userId) AuthenticationCeremony optionsBlob fixedTime (addUTCTime 300 fixedTime))+ pure (cid, optionsJson)+ wrongOwner <- runHybrid ref (completeMfa cfg proof cid (MfaPasskey (assertionResponse options policy {responseCounter = 1})))+ wrongOwner @?= Left MfaAssertionInvalid+ world <- readIORef ref+ length [() | Event.MfaFailed _ <- world.publishedEvents] @?= 1+ length [() | Event.MfaSucceeded _ <- world.publishedEvents] @?= 0,+ testCase "expired signed ceremony fails before minting or counter advancement" do+ (ref, _, policy) <- seed+ (cid, options) <- right =<< runHybrid ref (beginPasswordlessLogin cfg)+ modifyIORef' ref (\w -> w {clock = addUTCTime 301 fixedTime})+ expired <- runHybrid ref (completePasswordlessLogin cfg proof cid (assertionResponse options policy {responseCounter = 1}))+ expired @?= Left PendingCeremonyNotFound+ world <- readIORef ref+ map (\PasskeyCredential {signCounter} -> signCounter) (Map.elems world.passkeys) @?= [SignatureCounter 0]+ ]