{-# 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,
    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)

-- | 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
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)

-- | 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
_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
_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 :: 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
    -- 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 (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

    -- 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 (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

-- | 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 ::
  -- | 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 :: 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

-- | 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 -> 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"

-- | 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 = 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)

-- | 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 '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)