{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Stability: experimental
-- This module exposes functions for processing and querying
-- [FIDO Metadata Service](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html)
-- blobs and entries.
module Crypto.WebAuthn.Metadata.Service.Processing
  ( RootCertificate (..),
    ProcessingError (..),
    createMetadataRegistry,
    queryMetadata,
    jwtToAdditionalData,
    fidoAllianceRootCertificate,
  )
where

import Control.Lens ((^?), _Just)
import Control.Lens.Combinators (makeClassyPrisms)
import Control.Monad.Except (MonadError, runExcept, throwError)
import Control.Monad.Reader (MonadReader, ask, runReaderT)
import Crypto.JOSE (AsError (_Error), fromX509Certificate)
import Crypto.JOSE.JWK.Store (VerificationKeyStore (getVerificationKeys))
import Crypto.JOSE.Types (URI)
import Crypto.JWT
  ( AsJWTError (_JWTError),
    Error,
    HasX5c (x5c),
    HasX5u (x5u),
    JWSHeader,
    JWTError,
    decodeCompact,
    defaultJWTValidationSettings,
    param,
    verifyJWT,
  )
import Crypto.WebAuthn.Internal.DateOrphans ()
import qualified Crypto.WebAuthn.Metadata.Service.Types as Service
import qualified Crypto.WebAuthn.Model as M
import Crypto.WebAuthn.Model.Identifier
  ( AAGUID,
    AuthenticatorIdentifier (AuthenticatorIdentifierFido2, AuthenticatorIdentifierFidoU2F),
    SubjectKeyIdentifier,
  )
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 qualified Data.HashMap.Strict as HashMap
import Data.Hourglass (DateTime)
import qualified Data.List.NonEmpty as NE
import qualified Data.X509 as X509
import qualified Data.X509.CertificateStore as X509
import qualified Data.X509.Validation as X509

-- | A root certificate along with the host it should be verified against
data RootCertificate = RootCertificate
  { -- | The root certificate itself
    RootCertificate -> CertificateStore
rootCertificateStore :: X509.CertificateStore,
    -- | The hostname it is for
    RootCertificate -> HostName
rootCertificateHostName :: X509.HostName
  }

-- | Errors related to the processing of the metadata
data ProcessingError
  = -- | An error wrapping the errors encountered by the X509 Validation
    ProcessingValidationErrors (NE.NonEmpty X509.FailedReason)
  | -- | There was no x5c header present in the metadata JWT
    ProcessingMissingX5CHeader
  | -- | An error wrapping the general Errors from the JOSE library
    ProcessingJWSError Error
  | -- | An error wrapping the JWT specific Errors from the JOSE library
    ProcessingJWTError JWTError
  | -- | There was a x5u header present in the metadata JWT but this is unimplemented
    -- TODO: Implement step 4 of the
    -- [(spec)](https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#metadata-blob-object-processing-rules)
    ProcessingX5UPresent URI
  deriving (Int -> ProcessingError -> ShowS
[ProcessingError] -> ShowS
ProcessingError -> HostName
(Int -> ProcessingError -> ShowS)
-> (ProcessingError -> HostName)
-> ([ProcessingError] -> ShowS)
-> Show ProcessingError
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProcessingError -> ShowS
showsPrec :: Int -> ProcessingError -> ShowS
$cshow :: ProcessingError -> HostName
show :: ProcessingError -> HostName
$cshowList :: [ProcessingError] -> ShowS
showList :: [ProcessingError] -> ShowS
Show, ProcessingError -> ProcessingError -> Bool
(ProcessingError -> ProcessingError -> Bool)
-> (ProcessingError -> ProcessingError -> Bool)
-> Eq ProcessingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProcessingError -> ProcessingError -> Bool
== :: ProcessingError -> ProcessingError -> Bool
$c/= :: ProcessingError -> ProcessingError -> Bool
/= :: ProcessingError -> ProcessingError -> Bool
Eq)

-- | Create Prisms for the error type, used in the AsError and AsJWTError
-- instances below
makeClassyPrisms ''ProcessingError

-- | Instantiate JOSE's AsError typeclass as a simple cast to our own error
-- type. This allows using our own error type in JOSE operations.
instance AsError ProcessingError where
  _Error :: Prism' ProcessingError Error
_Error = p Error (f Error) -> p ProcessingError (f ProcessingError)
forall r. AsProcessingError r => Prism' r Error
Prism' ProcessingError Error
_ProcessingJWSError

-- | Instantiate JOSE's AsJWTError typeclass as a simple cast to our own error
-- type. This allows using our own error type in JWT operations.
instance AsJWTError ProcessingError where
  _JWTError :: Prism' ProcessingError JWTError
_JWTError = p JWTError (f JWTError) -> p ProcessingError (f ProcessingError)
forall r. AsProcessingError r => Prism' r JWTError
Prism' ProcessingError JWTError
_ProcessingJWTError

-- | The root certificate used for the blob downloaded from <https://mds.fidoalliance.org/>,
-- which can be found in [here](https://valid.r3.roots.globalsign.com/),
-- see also <https://fidoalliance.org/metadata/>
fidoAllianceRootCertificate :: RootCertificate
fidoAllianceRootCertificate :: RootCertificate
fidoAllianceRootCertificate =
  RootCertificate
    { rootCertificateStore :: CertificateStore
rootCertificateStore = [SignedCertificate] -> CertificateStore
X509.makeCertificateStore [SignedCertificate
rootCert],
      rootCertificateHostName :: HostName
rootCertificateHostName = HostName
"mds.fidoalliance.org"
    }
  where
    bytes :: BS.ByteString
    bytes :: ByteString
bytes = $(embedFile "root-certs/metadata/root.crt")
    rootCert :: X509.SignedCertificate
    rootCert :: SignedCertificate
rootCert = case ByteString -> Either HostName SignedCertificate
X509.decodeSignedCertificate ByteString
bytes of
      Left HostName
err -> HostName -> SignedCertificate
forall a. HasCallStack => HostName -> a
error HostName
err
      Right SignedCertificate
cert -> SignedCertificate
cert

instance (MonadError ProcessingError m, MonadReader DateTime m) => VerificationKeyStore m (JWSHeader ()) p RootCertificate where
  getVerificationKeys :: JWSHeader () -> p -> RootCertificate -> m [JWK]
getVerificationKeys JWSHeader ()
header p
_ (RootCertificate CertificateStore
rootStore HostName
hostName) = do
    -- TODO: Implement step 4 of the spec, which says to try to get the chain
    -- from x5u first before trying x5c. See:
    -- <https://fidoalliance.org/specs/mds/fido-metadata-service-v3.0-ps-20210518.html#metadata-blob-object-processing-rules>
    -- and <https://github.com/tweag/webauthn/issues/23>
    --
    -- In order to prevent issues due to the lack of an implementation for x5u,
    -- we do check if it is empty before continuing. If not empty, we result in
    -- an error instead.
    case JWSHeader ()
header JWSHeader () -> Getting (First URI) (JWSHeader ()) URI -> Maybe URI
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Maybe (HeaderParam () URI)
 -> Const (First URI) (Maybe (HeaderParam () URI)))
-> JWSHeader () -> Const (First URI) (JWSHeader ())
forall p. Lens' (JWSHeader p) (Maybe (HeaderParam p URI))
forall (a :: * -> *) p.
HasX5u a =>
Lens' (a p) (Maybe (HeaderParam p URI))
x5u ((Maybe (HeaderParam () URI)
  -> Const (First URI) (Maybe (HeaderParam () URI)))
 -> JWSHeader () -> Const (First URI) (JWSHeader ()))
-> ((URI -> Const (First URI) URI)
    -> Maybe (HeaderParam () URI)
    -> Const (First URI) (Maybe (HeaderParam () URI)))
-> Getting (First URI) (JWSHeader ()) URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderParam () URI -> Const (First URI) (HeaderParam () URI))
-> Maybe (HeaderParam () URI)
-> Const (First URI) (Maybe (HeaderParam () URI))
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((HeaderParam () URI -> Const (First URI) (HeaderParam () URI))
 -> Maybe (HeaderParam () URI)
 -> Const (First URI) (Maybe (HeaderParam () URI)))
-> ((URI -> Const (First URI) URI)
    -> HeaderParam () URI -> Const (First URI) (HeaderParam () URI))
-> (URI -> Const (First URI) URI)
-> Maybe (HeaderParam () URI)
-> Const (First URI) (Maybe (HeaderParam () URI))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (URI -> Const (First URI) URI)
-> HeaderParam () URI -> Const (First URI) (HeaderParam () URI)
forall p a (f :: * -> *).
Functor f =>
(a -> f a) -> HeaderParam p a -> f (HeaderParam p a)
param of
      Maybe URI
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just URI
uri -> ProcessingError -> m ()
forall a. ProcessingError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ProcessingError -> m ()) -> ProcessingError -> m ()
forall a b. (a -> b) -> a -> b
$ URI -> ProcessingError
ProcessingX5UPresent URI
uri

    NonEmpty SignedCertificate
chain <- case JWSHeader ()
header JWSHeader ()
-> Getting
     (First (NonEmpty SignedCertificate))
     (JWSHeader ())
     (NonEmpty SignedCertificate)
-> Maybe (NonEmpty SignedCertificate)
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Maybe (HeaderParam () (NonEmpty SignedCertificate))
 -> Const
      (First (NonEmpty SignedCertificate))
      (Maybe (HeaderParam () (NonEmpty SignedCertificate))))
-> JWSHeader ()
-> Const (First (NonEmpty SignedCertificate)) (JWSHeader ())
forall p.
Lens'
  (JWSHeader p) (Maybe (HeaderParam p (NonEmpty SignedCertificate)))
forall (a :: * -> *) p.
HasX5c a =>
Lens' (a p) (Maybe (HeaderParam p (NonEmpty SignedCertificate)))
x5c ((Maybe (HeaderParam () (NonEmpty SignedCertificate))
  -> Const
       (First (NonEmpty SignedCertificate))
       (Maybe (HeaderParam () (NonEmpty SignedCertificate))))
 -> JWSHeader ()
 -> Const (First (NonEmpty SignedCertificate)) (JWSHeader ()))
-> ((NonEmpty SignedCertificate
     -> Const
          (First (NonEmpty SignedCertificate)) (NonEmpty SignedCertificate))
    -> Maybe (HeaderParam () (NonEmpty SignedCertificate))
    -> Const
         (First (NonEmpty SignedCertificate))
         (Maybe (HeaderParam () (NonEmpty SignedCertificate))))
-> Getting
     (First (NonEmpty SignedCertificate))
     (JWSHeader ())
     (NonEmpty SignedCertificate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderParam () (NonEmpty SignedCertificate)
 -> Const
      (First (NonEmpty SignedCertificate))
      (HeaderParam () (NonEmpty SignedCertificate)))
-> Maybe (HeaderParam () (NonEmpty SignedCertificate))
-> Const
     (First (NonEmpty SignedCertificate))
     (Maybe (HeaderParam () (NonEmpty SignedCertificate)))
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((HeaderParam () (NonEmpty SignedCertificate)
  -> Const
       (First (NonEmpty SignedCertificate))
       (HeaderParam () (NonEmpty SignedCertificate)))
 -> Maybe (HeaderParam () (NonEmpty SignedCertificate))
 -> Const
      (First (NonEmpty SignedCertificate))
      (Maybe (HeaderParam () (NonEmpty SignedCertificate))))
-> ((NonEmpty SignedCertificate
     -> Const
          (First (NonEmpty SignedCertificate)) (NonEmpty SignedCertificate))
    -> HeaderParam () (NonEmpty SignedCertificate)
    -> Const
         (First (NonEmpty SignedCertificate))
         (HeaderParam () (NonEmpty SignedCertificate)))
-> (NonEmpty SignedCertificate
    -> Const
         (First (NonEmpty SignedCertificate)) (NonEmpty SignedCertificate))
-> Maybe (HeaderParam () (NonEmpty SignedCertificate))
-> Const
     (First (NonEmpty SignedCertificate))
     (Maybe (HeaderParam () (NonEmpty SignedCertificate)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty SignedCertificate
 -> Const
      (First (NonEmpty SignedCertificate)) (NonEmpty SignedCertificate))
-> HeaderParam () (NonEmpty SignedCertificate)
-> Const
     (First (NonEmpty SignedCertificate))
     (HeaderParam () (NonEmpty SignedCertificate))
forall p a (f :: * -> *).
Functor f =>
(a -> f a) -> HeaderParam p a -> f (HeaderParam p a)
param of
      Maybe (NonEmpty SignedCertificate)
Nothing ->
        ProcessingError -> m (NonEmpty SignedCertificate)
forall a. ProcessingError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ProcessingError
ProcessingMissingX5CHeader
      Just NonEmpty SignedCertificate
chain -> NonEmpty SignedCertificate -> m (NonEmpty SignedCertificate)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return NonEmpty SignedCertificate
chain

    DateTime
now <- m DateTime
forall r (m :: * -> *). MonadReader r m => m r
ask

    -- TODO: Check CRLs, see <https://github.com/tweag/haskell-fido2/issues/23>
    let validationErrors :: [FailedReason]
validationErrors =
          DateTime
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ServiceID
-> CertificateChain
-> [FailedReason]
X509.validatePure
            DateTime
now
            ValidationHooks
X509.defaultHooks
            ValidationChecks
X509.defaultChecks
            CertificateStore
rootStore
            (HostName
hostName, ByteString
"")
            ([SignedCertificate] -> CertificateChain
X509.CertificateChain (NonEmpty SignedCertificate -> [SignedCertificate]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty SignedCertificate
chain))

    case [FailedReason] -> Maybe (NonEmpty FailedReason)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [FailedReason]
validationErrors of
      Maybe (NonEmpty FailedReason)
Nothing -> do
        -- Create a JWK from the leaf certificate, which is used to sign the payload
        JWK
jwk <- SignedCertificate -> m JWK
forall e (m :: * -> *).
(AsError e, MonadError e m) =>
SignedCertificate -> m JWK
fromX509Certificate (NonEmpty SignedCertificate -> SignedCertificate
forall a. NonEmpty a -> a
NE.head NonEmpty SignedCertificate
chain)
        [JWK] -> m [JWK]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [JWK
jwk]
      Just NonEmpty FailedReason
errors ->
        ProcessingError -> m [JWK]
forall a. ProcessingError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ProcessingError -> m [JWK]) -> ProcessingError -> m [JWK]
forall a b. (a -> b) -> a -> b
$ NonEmpty FailedReason -> ProcessingError
ProcessingValidationErrors NonEmpty FailedReason
errors

-- | 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 addData
jwtToAdditionalData :: forall addData.
FromJSON addData =>
ByteString
-> RootCertificate -> DateTime -> Either ProcessingError addData
jwtToAdditionalData ByteString
blob RootCertificate
rootCert DateTime
now = Except ProcessingError addData -> Either ProcessingError addData
forall e a. Except e a -> Either e a
runExcept (Except ProcessingError addData -> Either ProcessingError addData)
-> Except ProcessingError addData -> Either ProcessingError addData
forall a b. (a -> b) -> a -> b
$ do
  SignedJWT
jwt <- ByteString -> ExceptT ProcessingError Identity SignedJWT
forall a e (m :: * -> *).
(FromCompact a, AsError e, MonadError e m) =>
ByteString -> m a
decodeCompact (ByteString -> ExceptT ProcessingError Identity SignedJWT)
-> ByteString -> ExceptT ProcessingError Identity SignedJWT
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
blob
  ClaimSetSubtype addData
payload <- ReaderT
  DateTime
  (ExceptT ProcessingError Identity)
  (ClaimSetSubtype addData)
-> DateTime
-> ExceptT ProcessingError Identity (ClaimSetSubtype addData)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (JWTValidationSettings
-> RootCertificate
-> SignedJWT
-> ReaderT
     DateTime
     (ExceptT ProcessingError Identity)
     (ClaimSetSubtype addData)
forall (m :: * -> *) a e payload k.
(MonadTime m, HasAllowedSkew a, HasAudiencePredicate a,
 HasIssuerPredicate a, HasCheckIssuedAt a, HasValidationSettings a,
 AsError e, AsJWTError e, MonadError e m,
 VerificationKeyStore m (JWSHeader ()) payload k,
 HasClaimsSet payload, FromJSON payload) =>
a -> k -> SignedJWT -> m payload
verifyJWT ((StringOrURI -> Bool) -> JWTValidationSettings
defaultJWTValidationSettings (Bool -> StringOrURI -> Bool
forall a b. a -> b -> a
const Bool
True)) RootCertificate
rootCert SignedJWT
jwt) DateTime
now
  addData -> Except ProcessingError addData
forall a. a -> ExceptT ProcessingError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (addData -> Except ProcessingError addData)
-> addData -> Except ProcessingError addData
forall a b. (a -> b) -> a -> b
$ ClaimSetSubtype addData -> addData
forall addData. ClaimSetSubtype addData -> addData
Service.additionalData ClaimSetSubtype addData
payload

-- | Creates a 'Service.MetadataServiceRegistry' from a list of
-- 'Service.SomeMetadataEntry', which can either be obtained from a
-- 'Service.MetadataPayload's 'Service.mpEntries' field, or be constructed
-- directly
--
-- The resulting structure can be queried efficiently for
-- 'Service.MetadataEntry' using 'queryMetadata'
createMetadataRegistry :: [Service.SomeMetadataEntry] -> Service.MetadataServiceRegistry
createMetadataRegistry :: [SomeMetadataEntry] -> MetadataServiceRegistry
createMetadataRegistry [SomeMetadataEntry]
entries = Service.MetadataServiceRegistry {HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
HashMap AAGUID (MetadataEntry 'Fido2)
fido2Entries :: HashMap AAGUID (MetadataEntry 'Fido2)
fidoU2FEntries :: HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
fido2Entries :: HashMap AAGUID (MetadataEntry 'Fido2)
fidoU2FEntries :: HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
..}
  where
    fido2Entries :: HashMap AAGUID (MetadataEntry 'Fido2)
fido2Entries = [(AAGUID, MetadataEntry 'Fido2)]
-> HashMap AAGUID (MetadataEntry 'Fido2)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(AAGUID, MetadataEntry 'Fido2)]
fido2Pairs
    fidoU2FEntries :: HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
fidoU2FEntries = [(SubjectKeyIdentifier, MetadataEntry 'FidoU2F)]
-> HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(SubjectKeyIdentifier, MetadataEntry 'FidoU2F)]
fidoU2FPairs
    ([(AAGUID, MetadataEntry 'Fido2)]
fido2Pairs, [(SubjectKeyIdentifier, MetadataEntry 'FidoU2F)]
fidoU2FPairs) = [Either
   (AAGUID, MetadataEntry 'Fido2)
   (SubjectKeyIdentifier, MetadataEntry 'FidoU2F)]
-> ([(AAGUID, MetadataEntry 'Fido2)],
    [(SubjectKeyIdentifier, MetadataEntry 'FidoU2F)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either
    (AAGUID, MetadataEntry 'Fido2)
    (SubjectKeyIdentifier, MetadataEntry 'FidoU2F)]
 -> ([(AAGUID, MetadataEntry 'Fido2)],
     [(SubjectKeyIdentifier, MetadataEntry 'FidoU2F)]))
-> [Either
      (AAGUID, MetadataEntry 'Fido2)
      (SubjectKeyIdentifier, MetadataEntry 'FidoU2F)]
-> ([(AAGUID, MetadataEntry 'Fido2)],
    [(SubjectKeyIdentifier, MetadataEntry 'FidoU2F)])
forall a b. (a -> b) -> a -> b
$ (SomeMetadataEntry
 -> Either
      (AAGUID, MetadataEntry 'Fido2)
      (SubjectKeyIdentifier, MetadataEntry 'FidoU2F))
-> [SomeMetadataEntry]
-> [Either
      (AAGUID, MetadataEntry 'Fido2)
      (SubjectKeyIdentifier, MetadataEntry 'FidoU2F)]
forall a b. (a -> b) -> [a] -> [b]
map SomeMetadataEntry
-> Either
     (AAGUID, MetadataEntry 'Fido2)
     (SubjectKeyIdentifier, MetadataEntry 'FidoU2F)
fromSomeMetadataEntry [SomeMetadataEntry]
entries

    fromSomeMetadataEntry :: Service.SomeMetadataEntry -> Either (AAGUID, Service.MetadataEntry 'M.Fido2) (SubjectKeyIdentifier, Service.MetadataEntry 'M.FidoU2F)
    fromSomeMetadataEntry :: SomeMetadataEntry
-> Either
     (AAGUID, MetadataEntry 'Fido2)
     (SubjectKeyIdentifier, MetadataEntry 'FidoU2F)
fromSomeMetadataEntry (Service.SomeMetadataEntry entry :: MetadataEntry p
entry@Service.MetadataEntry {Maybe MetadataStatement
NonEmpty StatusReport
Date
AuthenticatorIdentifier p
meIdentifier :: AuthenticatorIdentifier p
meMetadataStatement :: Maybe MetadataStatement
meStatusReports :: NonEmpty StatusReport
meTimeOfLastStatusChange :: Date
meIdentifier :: forall (p :: ProtocolKind).
MetadataEntry p -> AuthenticatorIdentifier p
meMetadataStatement :: forall (p :: ProtocolKind).
MetadataEntry p -> Maybe MetadataStatement
meStatusReports :: forall (p :: ProtocolKind).
MetadataEntry p -> NonEmpty StatusReport
meTimeOfLastStatusChange :: forall (p :: ProtocolKind). MetadataEntry p -> Date
..}) = case AuthenticatorIdentifier p
meIdentifier of
      AuthenticatorIdentifierFido2 AAGUID
aaguid -> (AAGUID, MetadataEntry 'Fido2)
-> Either
     (AAGUID, MetadataEntry 'Fido2)
     (SubjectKeyIdentifier, MetadataEntry 'FidoU2F)
forall a b. a -> Either a b
Left (AAGUID
aaguid, MetadataEntry p
MetadataEntry 'Fido2
entry)
      AuthenticatorIdentifierFidoU2F SubjectKeyIdentifier
subjectKeyIdentifier -> (SubjectKeyIdentifier, MetadataEntry 'FidoU2F)
-> Either
     (AAGUID, MetadataEntry 'Fido2)
     (SubjectKeyIdentifier, MetadataEntry 'FidoU2F)
forall a b. b -> Either a b
Right (SubjectKeyIdentifier
subjectKeyIdentifier, MetadataEntry p
MetadataEntry 'FidoU2F
entry)

-- | Query a 'Service.MetadataEntry' for an 'M.AuthenticatorIdentifier'
queryMetadata ::
  Service.MetadataServiceRegistry ->
  AuthenticatorIdentifier p ->
  Maybe (Service.MetadataEntry p)
queryMetadata :: forall (p :: ProtocolKind).
MetadataServiceRegistry
-> AuthenticatorIdentifier p -> Maybe (MetadataEntry p)
queryMetadata MetadataServiceRegistry
registry (AuthenticatorIdentifierFido2 AAGUID
aaguid) =
  AAGUID
-> HashMap AAGUID (MetadataEntry p) -> Maybe (MetadataEntry p)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup AAGUID
aaguid (MetadataServiceRegistry -> HashMap AAGUID (MetadataEntry 'Fido2)
Service.fido2Entries MetadataServiceRegistry
registry)
queryMetadata MetadataServiceRegistry
registry (AuthenticatorIdentifierFidoU2F SubjectKeyIdentifier
subjectKeyIdentifier) =
  SubjectKeyIdentifier
-> HashMap SubjectKeyIdentifier (MetadataEntry p)
-> Maybe (MetadataEntry p)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup SubjectKeyIdentifier
subjectKeyIdentifier (MetadataServiceRegistry
-> HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
Service.fidoU2FEntries MetadataServiceRegistry
registry)