Implement ClaimSet subtypes

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,17 @@ 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))

tests/MetadataSpec.hs

@@ -4,21 +4,20 @@
 module MetadataSpec (spec) where
 
 import Crypto.WebAuthn.Metadata (metadataBlobToRegistry)
-import Crypto.WebAuthn.Metadata.Service.Processing (RootCertificate (RootCertificate), fidoAllianceRootCertificate, jsonToPayload, jwtToJson)
-import Crypto.WebAuthn.Metadata.Service.WebIDL (MetadataBLOBPayload, entries, legalHeader, nextUpdate, no)
+import Crypto.WebAuthn.Metadata.Service.Processing (RootCertificate (RootCertificate), ProcessingError, fidoAllianceRootCertificate, jwtToAdditionalData)
+import Crypto.WebAuthn.Metadata.Service.WebIDL (MetadataBLOBPayload)
 import Data.Aeson (Result (Success), ToJSON (toJSON), decodeFileStrict, fromJSON)
 import Data.Aeson.Types (Result (Error))
 import qualified Data.ByteString as BS
 import Data.Either (isRight)
-import Data.HashMap.Strict ((!), (!?))
 import qualified Data.PEM as PEM
 import qualified Data.Text as Text
 import Data.Text.Encoding (decodeUtf8)
-import Data.These (These (That, These, This))
+import Data.These (These (These))
 import qualified Data.X509 as X509
 import qualified Data.X509.CertificateStore as X509
 import Spec.Util (predeterminedDateTime)
-import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy)
+import Test.Hspec (SpecWith, describe, it, shouldSatisfy)
 import Test.Hspec.Expectations.Json (shouldBeUnorderedJson)
 
 golden :: FilePath -> SpecWith ()
@@ -32,14 +31,11 @@ golden subdir = describe subdir $ do
         store = X509.makeCertificateStore [cert]
 
     blobBytes <- BS.readFile $ "tests/golden-metadata/" <> subdir <> "/blob.jwt"
-    let Right result = jwtToJson blobBytes (RootCertificate store origin) predeterminedDateTime
+    let Right result = jwtToAdditionalData blobBytes (RootCertificate store origin) predeterminedDateTime
 
     Just expectedPayload <- decodeFileStrict $ "tests/golden-metadata/" <> subdir <> "/payload.json"
 
-    (result !? "legalHeader") `shouldBe` toJSON <$> legalHeader expectedPayload
-    (result !? "no") `shouldBe` Just (toJSON (no expectedPayload))
-    (result !? "nextUpdate") `shouldBe` Just (toJSON (nextUpdate expectedPayload))
-    (result ! "entries") `shouldBeUnorderedJson` toJSON (entries expectedPayload)
+    toJSON (result :: MetadataBLOBPayload) `shouldBeUnorderedJson` expectedPayload
 
   it "can decode and reencode the payload to the partially parsed JSON" $ do
     Just payload <- decodeFileStrict $ "tests/golden-metadata/" <> subdir <> "/payload.json"
@@ -48,13 +44,6 @@ golden subdir = describe subdir $ do
       Success (value :: MetadataBLOBPayload) ->
         toJSON value `shouldBeUnorderedJson` payload
 
-  it "can decode and reencode the payload to the partially parsed JSON" $ do
-    Just value <- decodeFileStrict $ "tests/golden-metadata/" <> subdir <> "/payload.json"
-    case jsonToPayload value of
-      This err -> fail $ show err
-      These err _result -> fail $ show err
-      That _result -> pure ()
-
 spec :: SpecWith ()
 spec = do
   describe "Golden" $ do
@@ -63,7 +52,8 @@ spec = do
   describe "fidoAllianceRootCertificate" $ do
     it "can validate the payload" $ do
       blobBytes <- BS.readFile "tests/golden-metadata/big/blob.jwt"
-      jwtToJson blobBytes fidoAllianceRootCertificate predeterminedDateTime `shouldSatisfy` isRight
+      let metadata = jwtToAdditionalData blobBytes fidoAllianceRootCertificate predeterminedDateTime :: Either ProcessingError MetadataBLOBPayload
+      metadata `shouldSatisfy` isRight
   describe "MDS with errors" $ do
     it "can process an MDS file with errors" $ do
       blobBytes <- BS.readFile "tests/golden-metadata/big/blob-with-errors.jwt"