{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Crypto.WebAuthn.Metadata.Service.Processing
( RootCertificate (..),
ProcessingError (..),
createMetadataRegistry,
queryMetadata,
jwtToJson,
jsonToPayload,
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,
unregisteredClaims,
verifyClaims,
)
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 qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import qualified Data.Text as Text
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)
data RootCertificate = RootCertificate
{
RootCertificate -> CertificateStore
rootCertificateStore :: X509.CertificateStore,
RootCertificate -> HostName
rootCertificateHostName :: X509.HostName
}
data ProcessingError
=
ProcessingValidationErrors (NE.NonEmpty X509.FailedReason)
|
|
ProcessingJWSError Error
|
ProcessingJWTError JWTError
|
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
showList :: [ProcessingError] -> ShowS
$cshowList :: [ProcessingError] -> ShowS
show :: ProcessingError -> HostName
$cshow :: ProcessingError -> HostName
showsPrec :: Int -> ProcessingError -> ShowS
$cshowsPrec :: Int -> ProcessingError -> ShowS
Show, ProcessingError -> ProcessingError -> Bool
(ProcessingError -> ProcessingError -> Bool)
-> (ProcessingError -> ProcessingError -> Bool)
-> Eq ProcessingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProcessingError -> ProcessingError -> Bool
$c/= :: ProcessingError -> ProcessingError -> Bool
== :: ProcessingError -> ProcessingError -> Bool
$c== :: ProcessingError -> ProcessingError -> Bool
Eq)
instance AsError ProcessingError where
_Error :: Prism' ProcessingError Error
_Error = p Error (f Error) -> p ProcessingError (f ProcessingError)
forall r. AsProcessingError r => Prism' r Error
_ProcessingJWSError
instance AsJWTError ProcessingError where
_JWTError :: Prism' ProcessingError JWTError
_JWTError = p JWTError (f JWTError) -> p ProcessingError (f ProcessingError)
forall r. AsProcessingError r => Prism' r JWTError
_ProcessingJWTError
fidoAllianceRootCertificate :: RootCertificate
fidoAllianceRootCertificate :: RootCertificate
fidoAllianceRootCertificate =
RootCertificate :: CertificateStore -> HostName -> RootCertificate
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
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 (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. Prism (Maybe a) (Maybe b) a 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. Lens' (HeaderParam p a) a
param of
Maybe URI
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just URI
uri -> ProcessingError -> m ()
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 (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. Prism (Maybe a) (Maybe b) a 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. Lens' (HeaderParam p a) a
param of
Maybe (NonEmpty SignedCertificate)
Nothing ->
ProcessingError -> m (NonEmpty SignedCertificate)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ProcessingError
ProcessingMissingX5CHeader
Just NonEmpty SignedCertificate
chain -> NonEmpty SignedCertificate -> m (NonEmpty SignedCertificate)
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
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
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 (m :: * -> *) a. Monad m => a -> m a
return [JWK
jwk]
Just NonEmpty FailedReason
errors ->
ProcessingError -> m [JWK]
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
jwtToJson ::
BS.ByteString ->
RootCertificate ->
DateTime ->
Either ProcessingError (HashMap Text Value)
jwtToJson :: ByteString
-> RootCertificate
-> DateTime
-> Either ProcessingError (HashMap Text Value)
jwtToJson ByteString
blob RootCertificate
rootCert DateTime
now = Except ProcessingError (HashMap Text Value)
-> Either ProcessingError (HashMap Text Value)
forall e a. Except e a -> Either e a
runExcept (Except ProcessingError (HashMap Text Value)
-> Either ProcessingError (HashMap Text Value))
-> Except ProcessingError (HashMap Text Value)
-> Either ProcessingError (HashMap Text Value)
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
ClaimsSet
claims <- ReaderT DateTime (ExceptT ProcessingError Identity) ClaimsSet
-> DateTime -> ExceptT ProcessingError Identity ClaimsSet
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (JWTValidationSettings
-> RootCertificate
-> SignedJWT
-> ReaderT DateTime (ExceptT ProcessingError Identity) ClaimsSet
forall (m :: * -> *) a e k.
(MonadTime m, HasAllowedSkew a, HasAudiencePredicate a,
HasIssuerPredicate a, HasCheckIssuedAt a, HasValidationSettings a,
AsError e, AsJWTError e, MonadError e m,
VerificationKeyStore m (JWSHeader ()) ClaimsSet k) =>
a -> k -> SignedJWT -> m ClaimsSet
verifyClaims ((StringOrURI -> Bool) -> JWTValidationSettings
defaultJWTValidationSettings (Bool -> StringOrURI -> Bool
forall a b. a -> b -> a
const Bool
True)) RootCertificate
rootCert SignedJWT
jwt) DateTime
now
HashMap Text Value -> Except ProcessingError (HashMap Text Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap Text Value -> Except ProcessingError (HashMap Text Value))
-> (Map Text Value -> HashMap Text Value)
-> Map Text Value
-> Except ProcessingError (HashMap Text Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> HashMap Text Value
forall l. IsList l => [Item l] -> l
fromList ([(Text, Value)] -> HashMap Text Value)
-> (Map Text Value -> [(Text, Value)])
-> Map Text Value
-> HashMap Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Value -> [(Text, Value)]
forall l. IsList l => l -> [Item l]
toList (Map Text Value -> Except ProcessingError (HashMap Text Value))
-> Map Text Value -> Except ProcessingError (HashMap Text Value)
forall a b. (a -> b) -> a -> b
$ ClaimsSet
claims ClaimsSet
-> Getting (Map Text Value) ClaimsSet (Map Text Value)
-> Map Text Value
forall s a. s -> Getting a s a -> a
^. Getting (Map Text Value) ClaimsSet (Map Text Value)
Lens' ClaimsSet (Map Text Value)
unregisteredClaims
jsonToPayload :: HashMap Text Value -> Either Text Service.MetadataPayload
jsonToPayload :: HashMap Text Value -> Either Text MetadataPayload
jsonToPayload HashMap Text Value
value = case (HashMap Text Value -> Parser MetadataBLOBPayload)
-> HashMap Text Value -> Either HostName MetadataBLOBPayload
forall a b. (a -> Parser b) -> a -> Either HostName b
Aeson.parseEither HashMap Text Value -> Parser MetadataBLOBPayload
metadataPayloadParser HashMap Text Value
value of
Left HostName
err -> Text -> Either Text MetadataPayload
forall a b. a -> Either a b
Left (Text -> Either Text MetadataPayload)
-> Text -> Either Text MetadataPayload
forall a b. (a -> b) -> a -> b
$ HostName -> Text
Text.pack HostName
err
Right MetadataBLOBPayload
payload -> case MetadataBLOBPayload -> Either Text MetadataPayload
decodeMetadataPayload MetadataBLOBPayload
payload of
Left Text
err -> Text -> Either Text MetadataPayload
forall a b. a -> Either a b
Left Text
err
Right MetadataPayload
result -> MetadataPayload -> Either Text MetadataPayload
forall (f :: * -> *) a. Applicative f => a -> f a
pure MetadataPayload
result
metadataPayloadParser :: HashMap Text Aeson.Value -> Aeson.Parser ServiceIDL.MetadataBLOBPayload
metadataPayloadParser :: HashMap Text Value -> Parser MetadataBLOBPayload
metadataPayloadParser HashMap Text Value
hm = case (HashMap Text Value
hm HashMap Text Value -> Text -> Maybe Value
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"legalHeader", HashMap Text Value
hm HashMap Text Value -> Text -> Maybe Value
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"no", HashMap Text Value
hm HashMap Text Value -> Text -> Maybe Value
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"nextUpdate", HashMap Text Value
hm HashMap Text Value -> Text -> Maybe Value
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"entries") of
(Just Value
legalHeader, Just Value
no, Just Value
nextUpdate, Just Value
entries) -> do
Maybe Text
legalHeader <- Value -> Parser (Maybe Text)
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
legalHeader
Int
no <- Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
no
Text
nextUpdate <- Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
nextUpdate
[MetadataBLOBPayloadEntry]
entries <- Value -> Parser [MetadataBLOBPayloadEntry]
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
entries
MetadataBLOBPayload -> Parser MetadataBLOBPayload
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetadataBLOBPayload -> Parser MetadataBLOBPayload)
-> MetadataBLOBPayload -> Parser MetadataBLOBPayload
forall a b. (a -> b) -> a -> b
$
MetadataBLOBPayload :: Maybe Text
-> Int -> Text -> [MetadataBLOBPayloadEntry] -> MetadataBLOBPayload
ServiceIDL.MetadataBLOBPayload {Int
[MetadataBLOBPayloadEntry]
Maybe Text
Text
$sel:entries:MetadataBLOBPayload :: [MetadataBLOBPayloadEntry]
$sel:nextUpdate:MetadataBLOBPayload :: Text
$sel:no:MetadataBLOBPayload :: Int
$sel:legalHeader:MetadataBLOBPayload :: Maybe Text
entries :: [MetadataBLOBPayloadEntry]
nextUpdate :: Text
no :: Int
legalHeader :: Maybe Text
..}
(Maybe Value, Maybe Value, Maybe Value, Maybe Value)
_ -> HostName -> Parser MetadataBLOBPayload
forall (m :: * -> *) a. MonadFail m => HostName -> m a
fail HostName
"Could not decode MetadataBLOB: missing fields"
createMetadataRegistry :: [Service.SomeMetadataEntry] -> Service.MetadataServiceRegistry
createMetadataRegistry :: [SomeMetadataEntry] -> MetadataServiceRegistry
createMetadataRegistry [SomeMetadataEntry]
entries = MetadataServiceRegistry :: HashMap AAGUID (MetadataEntry 'Fido2)
-> HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
-> MetadataServiceRegistry
Service.MetadataServiceRegistry {HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
HashMap AAGUID (MetadataEntry 'Fido2)
fidoU2FEntries :: HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
fido2Entries :: HashMap AAGUID (MetadataEntry 'Fido2)
fidoU2FEntries :: HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
fido2Entries :: HashMap AAGUID (MetadataEntry 'Fido2)
..}
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
meTimeOfLastStatusChange :: forall (p :: ProtocolKind). MetadataEntry p -> Date
meStatusReports :: forall (p :: ProtocolKind).
MetadataEntry p -> NonEmpty StatusReport
meMetadataStatement :: forall (p :: ProtocolKind).
MetadataEntry p -> Maybe MetadataStatement
meIdentifier :: forall (p :: ProtocolKind).
MetadataEntry p -> AuthenticatorIdentifier p
meTimeOfLastStatusChange :: Date
meStatusReports :: NonEmpty StatusReport
meMetadataStatement :: Maybe MetadataStatement
meIdentifier :: AuthenticatorIdentifier p
..}) = case AuthenticatorIdentifier p
meIdentifier of
AuthenticatorIdentifierFido2 AAGUID
aaguid -> (AAGUID, MetadataEntry p)
-> Either
(AAGUID, MetadataEntry p)
(SubjectKeyIdentifier, MetadataEntry 'FidoU2F)
forall a b. a -> Either a b
Left (AAGUID
aaguid, MetadataEntry p
entry)
AuthenticatorIdentifierFidoU2F SubjectKeyIdentifier
subjectKeyIdentifier -> (SubjectKeyIdentifier, MetadataEntry p)
-> Either
(AAGUID, MetadataEntry 'Fido2)
(SubjectKeyIdentifier, MetadataEntry p)
forall a b. b -> Either a b
Right (SubjectKeyIdentifier
subjectKeyIdentifier, MetadataEntry p
entry)
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 'Fido2)
-> Maybe (MetadataEntry 'Fido2)
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 'FidoU2F)
-> Maybe (MetadataEntry 'FidoU2F)
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)