{-# 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 Data.List.NonEmpty (NonEmpty, singleton)
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)
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
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
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 = forall r. AsProcessingError r => Prism' r Error
_ProcessingJWSError
instance AsJWTError ProcessingError where
_JWTError :: Prism' ProcessingError JWTError
_JWTError = forall r. AsProcessingError r => Prism' r JWTError
_ProcessingJWTError
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 -> 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 forall s a. s -> Getting (First a) s a -> Maybe a
^? forall (a :: * -> *) p.
HasX5u a =>
Lens' (a p) (Maybe (HeaderParam p URI))
x5u forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. Lens' (HeaderParam p a) a
param of
Maybe URI
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just URI
uri -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ URI -> ProcessingError
ProcessingX5UPresent URI
uri
NonEmpty SignedCertificate
chain <- case JWSHeader ()
header forall s a. s -> Getting (First a) s a -> Maybe a
^? forall (a :: * -> *) p.
HasX5c a =>
Lens' (a p) (Maybe (HeaderParam p (NonEmpty SignedCertificate)))
x5c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. Lens' (HeaderParam p a) a
param of
Maybe (NonEmpty SignedCertificate)
Nothing ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ProcessingError
ProcessingMissingX5CHeader
Just NonEmpty SignedCertificate
chain -> forall (m :: * -> *) a. Monad m => a -> m a
return NonEmpty SignedCertificate
chain
DateTime
now <- 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 (forall a. NonEmpty a -> [a]
NE.toList NonEmpty SignedCertificate
chain))
case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [FailedReason]
validationErrors of
Maybe (NonEmpty FailedReason)
Nothing -> do
JWK
jwk <- forall e (m :: * -> *).
(AsError e, MonadError e m) =>
SignedCertificate -> m JWK
fromX509Certificate (forall a. NonEmpty a -> a
NE.head NonEmpty SignedCertificate
chain)
forall (m :: * -> *) a. Monad m => a -> m a
return [JWK
jwk]
Just NonEmpty FailedReason
errors ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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 = forall e a. Except e a -> Either e a
runExcept forall a b. (a -> b) -> a -> b
$ do
SignedJWT
jwt <- forall a e (m :: * -> *).
(FromCompact a, AsError e, MonadError e m) =>
ByteString -> m a
decodeCompact forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
blob
ClaimsSet
claims <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 (forall a b. a -> b -> a
const Bool
True)) RootCertificate
rootCert SignedJWT
jwt) DateTime
now
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
toList forall a b. (a -> b) -> a -> b
$ ClaimsSet
claims forall s a. s -> Getting a s a -> a
^. Lens' ClaimsSet (Map Text Value)
unregisteredClaims
jsonToPayload :: HashMap Text Value -> These (NonEmpty Text) Service.MetadataPayload
jsonToPayload :: HashMap Text Value -> These (NonEmpty Text) MetadataPayload
jsonToPayload HashMap Text Value
value = case 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 -> forall a b. a -> These a b
This (forall a. a -> NonEmpty a
singleton forall a b. (a -> b) -> a -> b
$ HostName -> Text
Text.pack HostName
err)
Right MetadataBLOBPayload
payload -> MetadataBLOBPayload -> These (NonEmpty Text) MetadataPayload
decodeMetadataPayload MetadataBLOBPayload
payload
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 forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"legalHeader", HashMap Text Value
hm forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"no", HashMap Text Value
hm forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"nextUpdate", HashMap Text Value
hm 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 <- forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
legalHeader
Int
no <- forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
no
Text
nextUpdate <- forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
nextUpdate
[MetadataBLOBPayloadEntry]
entries <- forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
entries
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
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)
_ -> 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 = 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 = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(AAGUID, MetadataEntry 'Fido2)]
fido2Pairs
fidoU2FEntries :: HashMap SubjectKeyIdentifier (MetadataEntry 'FidoU2F)
fidoU2FEntries = 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) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ 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 -> forall a b. a -> Either a b
Left (AAGUID
aaguid, MetadataEntry p
entry)
AuthenticatorIdentifierFidoU2F SubjectKeyIdentifier
subjectKeyIdentifier -> 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) =
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) =
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)