Implement ClaimSet subtypes

server/src/Main.hs

@@ -19,6 +19,7 @@ import qualified Data.ByteString.Base64.URL as Base64
 import qualified Data.ByteString.Builder as Builder
 import qualified Data.ByteString.Lazy as LBS
 import Data.List.NonEmpty (NonEmpty ((:|)))
+import qualified Data.List.NonEmpty as NE
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Data.Text.Encoding (decodeUtf8)
@@ -47,7 +48,6 @@ import System.Hourglass (dateCurrent)
 import qualified Web.Cookie as Cookie
 import Web.Scotty (ScottyM)
 import qualified Web.Scotty as Scotty
-import qualified Data.List.NonEmpty as NE
 
 data RegisterBeginReq = RegisterBeginReq
   { accountName :: Text,

src/Crypto/WebAuthn/Metadata.hs

@@ -9,6 +9,7 @@ module Crypto.WebAuthn.Metadata
   )
 where
 
+import qualified Crypto.WebAuthn.Metadata.Service.Decode as Service
 import qualified Crypto.WebAuthn.Metadata.Service.Processing as Service
 import qualified Crypto.WebAuthn.Metadata.Service.Types as Service
 import Data.Bifunctor (Bifunctor (second), first)
@@ -30,6 +31,6 @@ metadataBlobToRegistry ::
   -- | Either a certifcate error or a list of errors, a registry of metadata entries or both where the MDS has bad entries
   Either Text (These (NE.NonEmpty Text) Service.MetadataServiceRegistry)
 metadataBlobToRegistry bytes now = do
-  json <- first (Text.pack . show) (Service.jwtToJson bytes Service.fidoAllianceRootCertificate now)
-  let payload = Service.jsonToPayload json
+  metadataPayload <- first (Text.pack . show) (Service.jwtToAdditionalData bytes Service.fidoAllianceRootCertificate now)
+  let payload = Service.decodeMetadataPayload metadataPayload
   pure $ second (Service.createMetadataRegistry . Service.mpEntries) payload

src/Crypto/WebAuthn/Metadata/Service/Processing.hs

@@ -15,13 +15,12 @@ module Crypto.WebAuthn.Metadata.Service.Processing
     ProcessingError (..),
     createMetadataRegistry,
     queryMetadata,
-    jwtToJson,
-    jsonToPayload,
+    jwtToAdditionalData,
     fidoAllianceRootCertificate,
   )
 where
 
-import Control.Lens ((^.), (^?), _Just)
+import Control.Lens ((^?), _Just)
 import Control.Lens.Combinators (makeClassyPrisms)
 import Control.Monad.Except (MonadError, runExcept, throwError)
 import Control.Monad.Reader (MonadReader, ask, runReaderT)
@@ -38,37 +37,27 @@ import Crypto.JWT
     decodeCompact,
     defaultJWTValidationSettings,
     param,
-    unregisteredClaims,
-    verifyClaims,
+    verifyJWT,
   )
 import Crypto.WebAuthn.Internal.DateOrphans ()
-import Crypto.WebAuthn.Metadata.Service.Decode (decodeMetadataPayload)
 import qualified Crypto.WebAuthn.Metadata.Service.Types as Service
-import qualified Crypto.WebAuthn.Metadata.Service.WebIDL as ServiceIDL
 import qualified Crypto.WebAuthn.Model as M
 import Crypto.WebAuthn.Model.Identifier
   ( AAGUID,
     AuthenticatorIdentifier (AuthenticatorIdentifierFido2, AuthenticatorIdentifierFidoU2F),
     SubjectKeyIdentifier,
   )
-import Data.Aeson (Value)
 import qualified Data.Aeson.Types as Aeson
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 import Data.Either (partitionEithers)
 import Data.FileEmbed (embedFile)
-import Data.HashMap.Strict (HashMap, (!?))
 import qualified Data.HashMap.Strict as HashMap
 import Data.Hourglass (DateTime)
-import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NE
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Data.These (These (This))
 import qualified Data.X509 as X509
 import qualified Data.X509.CertificateStore as X509
 import qualified Data.X509.Validation as X509
-import GHC.Exts (fromList, toList)
 
 -- | A root certificate along with the host it should be verified against
 data RootCertificate = RootCertificate
@@ -164,41 +153,20 @@ instance (MonadError ProcessingError m, MonadReader DateTime m) => VerificationK
       Just errors ->
         throwError $ ProcessingValidationErrors errors
 
--- | Extracts a FIDO Metadata payload JSON value from a JWT bytestring according to https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html
-jwtToJson ::
+-- | Extracts additional data from a JWT bytestring
+jwtToAdditionalData ::
+  (Aeson.FromJSON addData) =>
   -- | The bytes of the JWT blob
   BS.ByteString ->
   -- | The root certificate the blob is signed with
   RootCertificate ->
   -- | The current time for which to validate the JWT blob
   DateTime ->
-  Either ProcessingError (HashMap Text Value)
-jwtToJson blob rootCert now = runExcept $ do
+  Either ProcessingError addData
+jwtToAdditionalData blob rootCert now = runExcept $ do
   jwt <- decodeCompact $ LBS.fromStrict blob
-  claims <- runReaderT (verifyClaims (defaultJWTValidationSettings (const True)) rootCert jwt) now
-  return . fromList . toList $ claims ^. unregisteredClaims
-
--- | Decodes a FIDO Metadata payload JSON value to a 'Service.MetadataPayload',
--- returning an error when the JSON is invalid, and ignoring any entries not
--- relevant for webauthn. For the purposes of implementing the
--- relying party the `Crypto.WebAuthn.Metadata.Service.Types.mpNextUpdate`
--- and `Crypto.WebAuthn.Metadata.Service.Types.mpEntries` fields are most
--- important.
-jsonToPayload :: HashMap Text Value -> These (NonEmpty Text) Service.MetadataPayload
-jsonToPayload value = case Aeson.parseEither metadataPayloadParser value of
-  Left err -> This (Text.pack err NE.:| [])
-  Right payload -> decodeMetadataPayload payload
-
-metadataPayloadParser :: HashMap Text Aeson.Value -> Aeson.Parser ServiceIDL.MetadataBLOBPayload
-metadataPayloadParser hm = case (hm !? "legalHeader", hm !? "no", hm !? "nextUpdate", hm !? "entries") of
-  (Just legalHeader, Just no, Just nextUpdate, Just entries) -> do
-    legalHeader <- Aeson.parseJSON legalHeader
-    no <- Aeson.parseJSON no
-    nextUpdate <- Aeson.parseJSON nextUpdate
-    entries <- Aeson.parseJSON entries
-    pure $
-      ServiceIDL.MetadataBLOBPayload {..}
-  _ -> fail "Could not decode MetadataBLOB: missing fields"
+  payload <- runReaderT (verifyJWT (defaultJWTValidationSettings (const True)) rootCert jwt) now
+  return $ Service.additionalData payload
 
 -- | Creates a 'Service.MetadataServiceRegistry' from a list of
 -- 'Service.SomeMetadataEntry', which can either be obtained from a

src/Crypto/WebAuthn/Metadata/Service/Types.hs

@@ -13,14 +13,16 @@ module Crypto.WebAuthn.Metadata.Service.Types
     MetadataEntry (..),
     SomeMetadataEntry (..),
     StatusReport (..),
+    ClaimSetSubtype (..),
   )
 where
 
+import qualified Crypto.JWT as JWT
 import qualified Crypto.WebAuthn.Metadata.Service.WebIDL as ServiceIDL
 import Crypto.WebAuthn.Metadata.Statement.Types (MetadataStatement)
 import qualified Crypto.WebAuthn.Model as M
 import Crypto.WebAuthn.Model.Identifier (AAGUID, AuthenticatorIdentifier, SubjectKeyIdentifier)
-import Data.Aeson (ToJSON)
+import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
 import Data.Hourglass (Date)
 import Data.List.NonEmpty (NonEmpty)
@@ -93,7 +95,7 @@ data MetadataEntry (p :: M.ProtocolKind) = MetadataEntry
 -- | An arbitrary and potentially unstable JSON encoding, only intended for
 -- logging purposes. To actually encode and decode structures, use the
 -- "Crypto.WebAuthn.Encoding" modules
-deriving instance ToJSON (MetadataEntry p)
+deriving instance Aeson.ToJSON (MetadataEntry p)
 
 -- | Same as 'MetadataEntry', but with its type parameter erased
 data SomeMetadataEntry = forall p. (SingI p) => SomeMetadataEntry (MetadataEntry p)
@@ -125,4 +127,18 @@ data StatusReport = StatusReport
 -- | An arbitrary and potentially unstable JSON encoding, only intended for
 -- logging purposes. To actually encode and decode structures, use the
 -- "Crypto.WebAuthn.Encoding" modules
-deriving instance ToJSON StatusReport
+deriving instance Aeson.ToJSON StatusReport
+
+data ClaimSetSubtype addData = ClaimSetSubtype
+  { additionalData :: addData,
+    claimSet :: JWT.ClaimsSet
+  }
+
+instance (Aeson.FromJSON addData) => Aeson.FromJSON (ClaimSetSubtype addData) where
+  parseJSON = Aeson.withObject "ClaimSetSubtype" $ \o ->
+    ClaimSetSubtype
+      <$> Aeson.parseJSON (Aeson.Object o)
+      <*> Aeson.parseJSON (Aeson.Object o)
+
+instance JWT.HasClaimsSet (ClaimSetSubtype a) where
+  claimsSet f s = fmap (\cs -> s {claimSet = cs}) (f (claimSet s))

src/Crypto/WebAuthn/Operation/Authentication.hs

@@ -34,9 +34,9 @@ import Crypto.WebAuthn.Operation.CredentialEntry (CredentialEntry (cePublicKeyBy
 import Data.ByteArray (convert)
 import qualified Data.ByteString.Lazy as LBS
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NE
 import Data.Text (Text)
 import Data.Validation (Validation)
-import qualified Data.List.NonEmpty as NE
 
 -- | Errors that may occur during [assertion](https://www.w3.org/TR/webauthn-2/#sctn-verifying-assertion)
 data AuthenticationError
@@ -164,7 +164,7 @@ newtype AuthenticationResult = AuthenticationResult
 --
 -- Though this library implements the WebAuthn L2 spec, for origin validation we
 -- follow the L3 draft. This is because allowing multiple origins is often
--- needed in the wild. See [Validating the origin of a credential](https://www.w3.org/tr/webauthn-3/#sctn-validating-origin) 
+-- needed in the wild. See [Validating the origin of a credential](https://www.w3.org/tr/webauthn-3/#sctn-validating-origin)
 -- more details.
 -- In the simplest case, just a single origin is allowed and this is the 'M.RpId' with @https://@ prepended:
 --

src/Crypto/WebAuthn/Operation/Registration.hs

@@ -264,7 +264,7 @@ data RegistrationResult = RegistrationResult
 deriving instance ToJSON RegistrationResult
 
 -- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-registering-a-new-credential)
--- Verifies a 'M.Credential' response for a [registration ceremony](https://www.w3.org/TR/webauthn-2/#registration-ceremony). 
+-- Verifies a 'M.Credential' response for a [registration ceremony](https://www.w3.org/TR/webauthn-2/#registration-ceremony).
 --
 -- The resulting 'rrEntry' of this call should be stored in a database by the
 -- Relying Party. The 'rrAttestationStatement' contains the result of the
@@ -273,7 +273,7 @@ deriving instance ToJSON RegistrationResult
 --
 -- Though this library implements the WebAuthn L2 spec, for origin validation we
 -- follow the L3 draft. This is because allowing multiple origins is often
--- needed in the wild. See [Validating the origin of a credential](https://www.w3.org/TR/webauthn-3/#sctn-validating-origin) 
+-- needed in the wild. See [Validating the origin of a credential](https://www.w3.org/TR/webauthn-3/#sctn-validating-origin)
 -- more details.
 -- In the simplest case, just a single origin is allowed and this is the 'M.RpId' with @https://@ prepended:
 --

tests/Emulation.hs

@@ -121,61 +121,64 @@ login ao allowedOrigins conformance authenticator [email protected] {..} = do
 spec :: SpecWith ()
 spec =
   describe "None" $ do
-    it "rejects unknown origin during registration" $  do
-      property $ \seed authenticator allowedOrigins' origin' -> not (null allowedOrigins') && origin' `notElem` allowedOrigins' ==> do
-        let origin = M.Origin origin'
-        let allowedOrigins = M.Origin <$> NE.fromList allowedOrigins'
-        let annotatedOrigin = AnnotatedOrigin { aoRpId = M.RpId "localhost", aoOrigin = origin }
-        let registry = mempty
-        let userAgentConformance = mempty
-        let Right (registerResult, _, _) = runApp seed (register annotatedOrigin allowedOrigins userAgentConformance authenticator registry predeterminedDateTime)
-        registerResult `shouldSatisfy` \case
-          Left errors -> any (\case O.RegistrationOriginMismatch _ _ -> True; _ -> False) errors
-          Right _ -> False
+    it "rejects unknown origin during registration" $ do
+      property $ \seed authenticator allowedOrigins' origin' ->
+        not (null allowedOrigins') && origin' `notElem` allowedOrigins' ==> do
+          let origin = M.Origin origin'
+          let allowedOrigins = M.Origin <$> NE.fromList allowedOrigins'
+          let annotatedOrigin = AnnotatedOrigin {aoRpId = M.RpId "localhost", aoOrigin = origin}
+          let registry = mempty
+          let userAgentConformance = mempty
+          let Right (registerResult, _, _) = runApp seed (register annotatedOrigin allowedOrigins userAgentConformance authenticator registry predeterminedDateTime)
+          registerResult `shouldSatisfy` \case
+            Left errors -> any (\case O.RegistrationOriginMismatch _ _ -> True; _ -> False) errors
+            Right _ -> False
     it "rejects unknown origin during login" $ do
-      property $ \seed authenticator allowedOrigins' origin' -> not (null allowedOrigins') && origin' `notElem` allowedOrigins'  ==> do
-        let allowedOrigins = M.Origin <$> NE.fromList allowedOrigins'
-        let origin = NE.head allowedOrigins
-        let wrongOrigin = M.Origin origin'
-        let annotatedOrigin = AnnotatedOrigin { aoRpId = M.RpId "localhost", aoOrigin = origin }
-        let wrongAnnotatedOrigin = AnnotatedOrigin { aoRpId = M.RpId "localhost", aoOrigin = wrongOrigin }
-        let registry = mempty
-        let userAgentConformance = mempty
-        let Right (registerResult, authenticator', options) = runApp seed (register annotatedOrigin allowedOrigins userAgentConformance authenticator registry predeterminedDateTime)
-        let registerResult' = second O.rrEntry registerResult
-        registerResult' `shouldSatisfy` validAttestationResult authenticator userAgentConformance options
-        case registerResult' of
-          Right credentialEntry -> do
-            let Right loginResult = runApp (seed + 1) (login wrongAnnotatedOrigin allowedOrigins userAgentConformance authenticator' credentialEntry)
-            loginResult `shouldSatisfy` \case
-              Left errors -> any (\case O.AuthenticationOriginMismatch _ _ -> True; _ -> False) errors
-              Right _ -> False
-          _ -> pure ()
+      property $ \seed authenticator allowedOrigins' origin' ->
+        not (null allowedOrigins') && origin' `notElem` allowedOrigins' ==> do
+          let allowedOrigins = M.Origin <$> NE.fromList allowedOrigins'
+          let origin = NE.head allowedOrigins
+          let wrongOrigin = M.Origin origin'
+          let annotatedOrigin = AnnotatedOrigin {aoRpId = M.RpId "localhost", aoOrigin = origin}
+          let wrongAnnotatedOrigin = AnnotatedOrigin {aoRpId = M.RpId "localhost", aoOrigin = wrongOrigin}
+          let registry = mempty
+          let userAgentConformance = mempty
+          let Right (registerResult, authenticator', options) = runApp seed (register annotatedOrigin allowedOrigins userAgentConformance authenticator registry predeterminedDateTime)
+          let registerResult' = second O.rrEntry registerResult
+          registerResult' `shouldSatisfy` validAttestationResult authenticator userAgentConformance options
+          case registerResult' of
+            Right credentialEntry -> do
+              let Right loginResult = runApp (seed + 1) (login wrongAnnotatedOrigin allowedOrigins userAgentConformance authenticator' credentialEntry)
+              loginResult `shouldSatisfy` \case
+                Left errors -> any (\case O.AuthenticationOriginMismatch _ _ -> True; _ -> False) errors
+                Right _ -> False
+            _ -> pure ()
 
     it "succeeds" $
-      property $ \seed authenticator userAgentConformance  allowedOrigins' -> length allowedOrigins' > 1 ==> do
-        let allowedOrigins = M.Origin <$> NE.fromList allowedOrigins'
-        let annotatedOrigin =
-              AnnotatedOrigin
-                { aoRpId = M.RpId "localhost",
-                  aoOrigin = NE.head allowedOrigins
-                }
-
-        -- Since our emulator only supports None attestation the registry can be left empty.
-        let registry = mempty
-        -- We are not currently interested in client or authenticator fails, we
-        -- only wish to test our relying party implementation and are thus only
-        -- interested in its errors.
-        let Right (registerResult, authenticator', options) = runApp seed (register annotatedOrigin allowedOrigins userAgentConformance authenticator registry predeterminedDateTime)
-        -- Since we only do None attestation, we only care about the resulting entry
-        let registerResult' = second O.rrEntry registerResult
-        registerResult' `shouldSatisfy` validAttestationResult authenticator userAgentConformance options
-        -- Only if attestation succeeded can we continue with assertion
-        case registerResult' of
-          Right credentialEntry -> do
-            let Right loginResult = runApp (seed + 1) (login annotatedOrigin allowedOrigins userAgentConformance authenticator' credentialEntry)
-            loginResult `shouldSatisfy` validAssertionResult authenticator userAgentConformance
-          _ -> pure ()
+      property $ \seed authenticator userAgentConformance allowedOrigins' ->
+        length allowedOrigins' > 1 ==> do
+          let allowedOrigins = M.Origin <$> NE.fromList allowedOrigins'
+          let annotatedOrigin =
+                AnnotatedOrigin
+                  { aoRpId = M.RpId "localhost",
+                    aoOrigin = NE.head allowedOrigins
+                  }
+
+          -- Since our emulator only supports None attestation the registry can be left empty.
+          let registry = mempty
+          -- We are not currently interested in client or authenticator fails, we
+          -- only wish to test our relying party implementation and are thus only
+          -- interested in its errors.
+          let Right (registerResult, authenticator', options) = runApp seed (register annotatedOrigin allowedOrigins userAgentConformance authenticator registry predeterminedDateTime)
+          -- Since we only do None attestation, we only care about the resulting entry
+          let registerResult' = second O.rrEntry registerResult
+          registerResult' `shouldSatisfy` validAttestationResult authenticator userAgentConformance options
+          -- Only if attestation succeeded can we continue with assertion
+          case registerResult' of
+            Right credentialEntry -> do
+              let Right loginResult = runApp (seed + 1) (login annotatedOrigin allowedOrigins userAgentConformance authenticator' credentialEntry)
+              loginResult `shouldSatisfy` validAssertionResult authenticator userAgentConformance
+            _ -> pure ()
 
 -- | Validates the result of attestation. Ensures that the proper errors are
 -- resulted in if the authenticator exhibits nonconforming behaviour, and