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

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

    -- 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 (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
        -- Create a JWK from the leaf certificate, which is used to sign the payload
        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

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

-- | 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 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 -> Either a b
Left 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 -> forall a b. a -> Either a b
Left Text
err
    Right MetadataPayload
result -> 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 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"

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

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