{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

-- | Stability: experimental
-- This module implements attestation of the received authenticator response.
-- See the WebAuthn
-- [specification](https://www.w3.org/TR/webauthn-2/#sctn-registering-a-new-credential)
-- for the algorithm implemented in this module.
-- Assertion is typically represented as a "register" action
-- in the front-end.
-- [Section 7 of the specification](https://www.w3.org/TR/webauthn-2/#sctn-rp-operations)
-- describes when the relying party must perform attestation. Another relevant
-- section is
-- [Section 1.3.1](https://www.w3.org/TR/webauthn-2/#sctn-sample-registration)
-- which is a high level overview of the registration procedure.
module Crypto.WebAuthn.Operation.Registration
  ( verifyRegistrationResponse,
    RegistrationError (..),
    RegistrationResult (..),
    AuthenticatorModel (..),
    SomeAttestationStatement (..),
  )
where

import Control.Exception (Exception)
import Control.Monad (unless)
import qualified Crypto.Hash as Hash
import qualified Crypto.WebAuthn.Cose.PublicKeyWithSignAlg as Cose
import qualified Crypto.WebAuthn.Cose.SignAlg as Cose
import Crypto.WebAuthn.Internal.Utils (certificateSubjectKeyIdentifier, failure)
import Crypto.WebAuthn.Metadata.Service.Processing (queryMetadata)
import qualified Crypto.WebAuthn.Metadata.Service.Types as Meta
import qualified Crypto.WebAuthn.Metadata.Statement.Types as Meta
import qualified Crypto.WebAuthn.Model as M
import Crypto.WebAuthn.Model.Identifier (AuthenticatorIdentifier (AuthenticatorIdentifierFido2, AuthenticatorIdentifierFidoU2F))
import Crypto.WebAuthn.Operation.CredentialEntry
  ( CredentialEntry
      ( CredentialEntry,
        ceCredentialId,
        cePublicKeyBytes,
        ceSignCounter,
        ceTransports,
        ceUserHandle
      ),
  )
import Data.Aeson (ToJSON, Value (String), object, toJSON, (.=))
import Data.Hourglass (DateTime)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Validation (Validation (Failure, Success))
import qualified Data.X509 as X509
import qualified Data.X509.CertificateStore as X509
import qualified Data.X509.Validation as X509
import GHC.Generics (Generic)

-- | All the errors that can result from a call to 'verifyRegistrationResponse'
data RegistrationError
  = -- | The received challenge does not match the originally created
    -- challenge
    RegistrationChallengeMismatch
      { -- | The challenge created by the relying party and part of the
        -- `M.CredentialOptions`
        RegistrationError -> Challenge
reCreatedChallenge :: M.Challenge,
        -- | The challenge received from the client, part of the response
        RegistrationError -> Challenge
reReceivedChallenge :: M.Challenge
      }
  | -- | The returned origin does not match the relying party's origin
    RegistrationOriginMismatch
      { -- | The origin explicitly passed to the `verifyRegistrationResponse`
        -- response, set by the RP
        RegistrationError -> Origin
reExpectedOrigin :: M.Origin,
        -- | The origin received from the client as part of the client data
        RegistrationError -> Origin
reReceivedOrigin :: M.Origin
      }
  | -- | The rpIdHash in the authData is not a valid hash over the RpId
    -- expected by the Relying party
    RegistrationRpIdHashMismatch
      { -- | The RP ID hash explicitly passed to the
        -- `verifyRegistrationResponse` response, set by the RP
        RegistrationError -> RpIdHash
reExpectedRpIdHash :: M.RpIdHash,
        -- | The RP ID hash received from the client as part of the authenticator
        -- data
        RegistrationError -> RpIdHash
reReceivedRpIdHash :: M.RpIdHash
      }
  | -- | The userpresent bit in the authdata was not set
    RegistrationUserNotPresent
  | -- | The userverified bit in the authdata was not set
    RegistrationUserNotVerified
  | -- | The algorithm received from the client was not one of the algorithms
    -- we (the relying party) requested from the client.
    RegistrationPublicKeyAlgorithmDisallowed
      { -- | The signing algorithms requested by the RP
        RegistrationError -> [CoseSignAlg]
reAllowedSigningAlgorithms :: [Cose.CoseSignAlg],
        -- | The signing algorithm received from the client
        RegistrationError -> CoseSignAlg
reReceivedSigningAlgorithm :: Cose.CoseSignAlg
      }
  | -- | There was some exception in the statement format specific section
    forall a. M.AttestationStatementFormat a => RegistrationAttestationFormatError a (NonEmpty (M.AttStmtVerificationError a))

deriving instance Show RegistrationError

deriving instance Exception RegistrationError

-- | Information about the [authenticator](https://www.w3.org/TR/webauthn-2/#authenticator)
-- model that created the [public key credential](https://www.w3.org/TR/webauthn-2/#public-key-credential).
-- Depending on the constructor, this information can be used to base security
-- decisions.
data AuthenticatorModel k where
  -- | An unknown authenticator, meaning that we received no information about
  -- what authenticator model was used to generate the public key credential.
  -- We therefore also cannot assume any security guarantees regarding how the
  -- key is stored and other properties of the authenticator.
  -- This is expected to be the case when the ["none"](https://www.w3.org/TR/webauthn-2/#dom-attestationconveyancepreference-none)
  -- [Attestation Conveyance Preference](https://www.w3.org/TR/webauthn-2/#enum-attestation-convey)
  -- was selected.
  UnknownAuthenticator :: AuthenticatorModel 'M.Unverifiable
  -- | An [authenticator](https://www.w3.org/TR/webauthn-2/#authenticator) that
  -- provided a verifiable [attestation type](https://www.w3.org/TR/webauthn-2/#sctn-attestation-types),
  -- see 'M.Verifiable', but the certificate chain in the attestation statement
  -- failed to be verified. This is an indication that the 'uaIdentifier' and
  -- 'uaMetadata' fields cannot be trusted currently. This can happen when the
  -- root certificate of the chain is not trusted or known. Root certificates
  -- are discovered using both the 'M.AttestationStatementFormat's 'M.asfTrustAnchors'
  -- method, and the passed 'Meta.MetadataServiceRegistry'. The relying party
  -- can decide what to do in such a case, for example:
  --
  -- 1. Treating it as if it was an 'UnknownAuthenticator', but logging the
  --   'SomeAttestationStatement' structure, so that the admin can be informed of this
  --   and perhaps add custom entries to the 'Meta.MetadataServiceRegistry' to
  --   allow such authenticators to be verified in the future
  -- 2. Only using the 'uaIdentifier' and 'uaMetadata' for non-security-critical
  --   decisions. For example in order to show the user which authenticator they
  --   used to register.
  UnverifiedAuthenticator ::
    { -- | The failures that occurred when trying to validate the certificate
      -- chain
      forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> NonEmpty FailedReason
uaFailures :: NonEmpty X509.FailedReason,
      -- | The identifier for the authenticator model
      forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> AuthenticatorIdentifier p
uaIdentifier :: AuthenticatorIdentifier p,
      -- | The metadata looked up in the provided 'Meta.MetadataServiceRegistry'
      -- This field is always equal to 'Meta.queryMetadata registry vaIdentifier',
      -- and is only provided for convenience and because the implementation
      -- already has to look it up
      forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> Maybe (MetadataEntry p)
uaMetadata :: Maybe (Meta.MetadataEntry p)
    } ->
    AuthenticatorModel ('M.Verifiable p)
  -- | An [authenticator](https://www.w3.org/TR/webauthn-2/#authenticator) that
  -- provided a verifiable [attestation type](https://www.w3.org/TR/webauthn-2/#sctn-attestation-types),
  -- see 'M.Verifiable' and whose certificate chain in the attestation statement
  -- could successfully be verified. This is an indication that the 'uaIdentifier'
  -- and 'uaMetadata' fields can be trusted, meaning that we can be sure that
  -- the 'M.CredentialEntry' was created from the authenticator model with
  -- these fields as properties. In this case, the Relying Party can reasonably
  -- do the following:
  --
  -- * Persistently store the 'vaIdentifier' alongside 'CredentialEntry', such
  --   that even after the registration is complete, the 'vaMetadata' entry
  --   from the 'Meta.MetadataServiceRegistry' can be accessed. This also
  --   allows getting more up-to-date metadata (or at all if 'vaMetadata' was
  --   'Nothing') on an authenticator over time.
  -- * The 'vaMetadata' may be used to determine whether this authenticator
  --   model is trustful enough to be allowed for registration. For example,
  --   'Meta.srStatus' in 'Meta.meStatusReports' may be inspected for the
  --   authenticator being 'Meta.FIDO_CERTIFIED', aka that it passed the FIDO
  --   Alliances [Functional Certification](https://fidoalliance.org/certification/functional-certification/)
  -- * It is encouraged to persistently store the certificate chain from the
  --   'M.AttestationType' and check CRLs for revocations of any certificates
  --   in the chain. See [here](https://www.w3.org/TR/webauthn-2/#sctn-ca-compromise)
  --   for more information
  VerifiedAuthenticator ::
    { -- | The identifier for the authenticator model
      forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> AuthenticatorIdentifier p
vaIdentifier :: AuthenticatorIdentifier p,
      -- | The metadata looked up in the provided 'Meta.MetadataServiceRegistry'
      -- This field is always equal to 'Meta.queryMetadata registry vaIdentifier',
      -- and is only provided for convenience and because the implementation
      -- already has to look it up
      forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> Maybe (MetadataEntry p)
vaMetadata :: Maybe (Meta.MetadataEntry p)
    } ->
    AuthenticatorModel ('M.Verifiable p)

deriving instance Show (AuthenticatorModel k)

deriving instance Eq (AuthenticatorModel k)

instance ToJSON (AuthenticatorModel k) where
  toJSON :: AuthenticatorModel k -> Value
toJSON AuthenticatorModel k
UnknownAuthenticator =
    [Pair] -> Value
object
      [ Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"unknown"
      ]
  toJSON UnverifiedAuthenticator {Maybe (MetadataEntry p)
NonEmpty FailedReason
AuthenticatorIdentifier p
uaMetadata :: Maybe (MetadataEntry p)
uaIdentifier :: AuthenticatorIdentifier p
uaFailures :: NonEmpty FailedReason
uaMetadata :: forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> Maybe (MetadataEntry p)
uaIdentifier :: forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> AuthenticatorIdentifier p
uaFailures :: forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> NonEmpty FailedReason
..} =
    [Pair] -> Value
object
      [ Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"unverified",
        Key
"uaFailures" Key -> NonEmpty FailedReason -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty FailedReason
uaFailures,
        Key
"uaIdentifier" Key -> AuthenticatorIdentifier p -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthenticatorIdentifier p
uaIdentifier,
        Key
"uaMetadata" Key -> Maybe (MetadataEntry p) -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (MetadataEntry p)
uaMetadata
      ]
  toJSON VerifiedAuthenticator {Maybe (MetadataEntry p)
AuthenticatorIdentifier p
vaMetadata :: Maybe (MetadataEntry p)
vaIdentifier :: AuthenticatorIdentifier p
vaMetadata :: forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> Maybe (MetadataEntry p)
vaIdentifier :: forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> AuthenticatorIdentifier p
..} =
    [Pair] -> Value
object
      [ Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"verified",
        Key
"vaIdentifier" Key -> AuthenticatorIdentifier p -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthenticatorIdentifier p
vaIdentifier,
        Key
"vaMetadata" Key -> Maybe (MetadataEntry p) -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (MetadataEntry p)
vaMetadata
      ]

-- | Some attestation statement that represents both the [attestation type](https://www.w3.org/TR/webauthn-2/#sctn-attestation-types)
-- that was returned along with information about the [authenticator](https://www.w3.org/TR/webauthn-2/#authenticator)
-- model that created it. This result may be inspected to enforce relying party
-- policy, see the individual fields for more information.
data SomeAttestationStatement = forall k.
  SomeAttestationStatement
  { -- | The [attestation type](https://www.w3.org/TR/webauthn-2/#sctn-attestation-types)
    -- of the attestation statement. This could be used to only allow specific
    -- attestation types. E.g. disallowing [Basic](https://www.w3.org/TR/webauthn-2/#basic-attestation)
    -- and [Self](https://www.w3.org/TR/webauthn-2/#self-attestation) attestation,
    -- or marking those specially in the database.
    ()
asType :: M.AttestationType k,
    -- | The [authenticator](https://www.w3.org/TR/webauthn-2/#authenticator)
    -- model that produced the attestation statement. Relying Party policy could
    -- accept this credential based on properties of this field:
    --
    -- * Disallowing unverified authenticators by checking whether
    --   it is an 'UnverifiedAuthenticator'
    --
    -- * Disallowing authenticators that don't meet the required security level by
    --   inspecting the 'vaMetadata' of a 'VerifiedAuthenticator'
    --
    -- * Only allowing a very specific authenticator to be used by looking at
    --   'vaIdentifier' of a 'VerifiedAuthenticator'
    ()
asModel :: AuthenticatorModel k
  }

deriving instance Show SomeAttestationStatement

instance ToJSON SomeAttestationStatement where
  toJSON :: SomeAttestationStatement -> Value
toJSON SomeAttestationStatement {AttestationType k
AuthenticatorModel k
asModel :: AuthenticatorModel k
asType :: AttestationType k
asModel :: ()
asType :: ()
..} =
    [Pair] -> Value
object
      [ Key
"asType" Key -> AttestationType k -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AttestationType k
asType,
        Key
"asModel" Key -> AuthenticatorModel k -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthenticatorModel k
asModel
      ]

-- | The result returned from 'verifyRegistrationResponse'. It indicates that
-- the operation of [registering a new credential](https://www.w3.org/TR/webauthn-2/#sctn-registering-a-new-credential)
-- didn't fail.
data RegistrationResult = RegistrationResult
  { -- | The entry to insert into the database
    RegistrationResult -> CredentialEntry
rrEntry :: CredentialEntry,
    -- | Information about the attestation statement
    RegistrationResult -> SomeAttestationStatement
rrAttestationStatement :: SomeAttestationStatement
  }
  deriving (Int -> RegistrationResult -> ShowS
[RegistrationResult] -> ShowS
RegistrationResult -> String
(Int -> RegistrationResult -> ShowS)
-> (RegistrationResult -> String)
-> ([RegistrationResult] -> ShowS)
-> Show RegistrationResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RegistrationResult] -> ShowS
$cshowList :: [RegistrationResult] -> ShowS
show :: RegistrationResult -> String
$cshow :: RegistrationResult -> String
showsPrec :: Int -> RegistrationResult -> ShowS
$cshowsPrec :: Int -> RegistrationResult -> ShowS
Show, (forall x. RegistrationResult -> Rep RegistrationResult x)
-> (forall x. Rep RegistrationResult x -> RegistrationResult)
-> Generic RegistrationResult
forall x. Rep RegistrationResult x -> RegistrationResult
forall x. RegistrationResult -> Rep RegistrationResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RegistrationResult x -> RegistrationResult
$cfrom :: forall x. RegistrationResult -> Rep RegistrationResult x
Generic, [RegistrationResult] -> Encoding
[RegistrationResult] -> Value
RegistrationResult -> Encoding
RegistrationResult -> Value
(RegistrationResult -> Value)
-> (RegistrationResult -> Encoding)
-> ([RegistrationResult] -> Value)
-> ([RegistrationResult] -> Encoding)
-> ToJSON RegistrationResult
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RegistrationResult] -> Encoding
$ctoEncodingList :: [RegistrationResult] -> Encoding
toJSONList :: [RegistrationResult] -> Value
$ctoJSONList :: [RegistrationResult] -> Value
toEncoding :: RegistrationResult -> Encoding
$ctoEncoding :: RegistrationResult -> Encoding
toJSON :: RegistrationResult -> Value
$ctoJSON :: RegistrationResult -> Value
ToJSON)

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-registering-a-new-credential)
-- The resulting 'rrEntry' of this call should be stored in a database by the
-- Relying Party. The 'rrAttestationStatement' contains the result of the
-- attempted attestation, allowing the Relying Party to reject certain
-- authenticators/attempted entry creations based on policy.
verifyRegistrationResponse ::
  -- | The origin of the server
  M.Origin ->
  -- | The relying party id
  M.RpIdHash ->
  -- | The metadata registry, used for verifying the validity of the
  -- attestation by looking up root certificates
  Meta.MetadataServiceRegistry ->
  -- | The current time, used for verifying the validity of the attestation
  -- statement certificate chain
  DateTime ->
  -- | The options passed to the create() method
  M.CredentialOptions 'M.Registration ->
  -- | The response from the authenticator
  M.Credential 'M.Registration 'True ->
  -- | Either a nonempty list of validation errors in case the attestation FailedReason
  -- Or () in case of a result.
  Validation (NonEmpty RegistrationError) RegistrationResult
verifyRegistrationResponse :: Origin
-> RpIdHash
-> MetadataServiceRegistry
-> DateTime
-> CredentialOptions 'Registration
-> Credential 'Registration 'True
-> Validation (NonEmpty RegistrationError) RegistrationResult
verifyRegistrationResponse
  Origin
rpOrigin
  RpIdHash
rpIdHash
  MetadataServiceRegistry
registry
  DateTime
currentTime
  options :: CredentialOptions 'Registration
options@M.CredentialOptionsRegistration {[CredentialDescriptor]
[CredentialParameters]
Maybe AuthenticatorSelectionCriteria
Maybe AuthenticationExtensionsClientInputs
Maybe Timeout
CredentialUserEntity
CredentialRpEntity
Challenge
AttestationConveyancePreference
corExtensions :: CredentialOptions 'Registration
-> Maybe AuthenticationExtensionsClientInputs
corAttestation :: CredentialOptions 'Registration -> AttestationConveyancePreference
corAuthenticatorSelection :: CredentialOptions 'Registration
-> Maybe AuthenticatorSelectionCriteria
corExcludeCredentials :: CredentialOptions 'Registration -> [CredentialDescriptor]
corTimeout :: CredentialOptions 'Registration -> Maybe Timeout
corPubKeyCredParams :: CredentialOptions 'Registration -> [CredentialParameters]
corChallenge :: CredentialOptions 'Registration -> Challenge
corUser :: CredentialOptions 'Registration -> CredentialUserEntity
corRp :: CredentialOptions 'Registration -> CredentialRpEntity
corExtensions :: Maybe AuthenticationExtensionsClientInputs
corAttestation :: AttestationConveyancePreference
corAuthenticatorSelection :: Maybe AuthenticatorSelectionCriteria
corExcludeCredentials :: [CredentialDescriptor]
corTimeout :: Maybe Timeout
corPubKeyCredParams :: [CredentialParameters]
corChallenge :: Challenge
corUser :: CredentialUserEntity
corRp :: CredentialRpEntity
..}
  credential :: Credential 'Registration 'True
credential@M.Credential
    { cResponse :: forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> AuthenticatorResponse c raw
M.cResponse =
        M.AuthenticatorResponseRegistration
          { arrClientData :: forall (raw :: Bool).
AuthenticatorResponse 'Registration raw
-> CollectedClientData 'Registration raw
arrClientData = CollectedClientData 'Registration 'True
c,
            arrAttestationObject :: forall (raw :: Bool).
AuthenticatorResponse 'Registration raw -> AttestationObject raw
arrAttestationObject =
              M.AttestationObject
                { aoAuthData :: forall (raw :: Bool).
AttestationObject raw -> AuthenticatorData 'Registration raw
aoAuthData = authData :: AuthenticatorData 'Registration 'True
authData@M.AuthenticatorData {adAttestedCredentialData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AttestedCredentialData c raw
adAttestedCredentialData = M.AttestedCredentialData {CosePublicKey
AAGUID
CredentialId
RawField 'True
acdCredentialPublicKeyBytes :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> RawField raw
acdCredentialPublicKey :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CosePublicKey
acdCredentialId :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CredentialId
acdAaguid :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> AAGUID
acdCredentialPublicKeyBytes :: RawField 'True
acdCredentialPublicKey :: CosePublicKey
acdCredentialId :: CredentialId
acdAaguid :: AAGUID
..}},
                  a
AttStmt a
aoAttStmt :: ()
aoFmt :: ()
aoAttStmt :: AttStmt a
aoFmt :: a
..
                }
          }
    } =
    do
      -- 1. Let options be a new PublicKeyCredentialCreationOptions structure
      -- configured to the Relying Party's needs for the ceremony.
      -- NOTE: Implemented by caller

      -- 2. Call navigator.credentials.create() and pass options as the publicKey
      -- option. Let credential be the result of the successfully resolved
      -- promise. If the promise is rejected, abort the ceremony with a
      -- user-visible error, or otherwise guide the user experience as might be
      -- determinable from the context available in the rejected promise. For
      -- example if the promise is rejected with an error code equivalent to
      -- "InvalidStateError", the user might be instructed to use a different
      -- authenticator. For information on different error contexts and the
      -- circumstances leading to them, see § 6.3.2 The
      -- authenticatorMakeCredential Operation.
      -- NOTE: Implemented by caller

      -- 3. Let response be credential.response. If response is not an instance
      -- of AuthenticatorAttestationResponse, abort the ceremony with a
      -- user-visible error.
      -- NOTE: Already done as part of decoding

      -- 4. Let clientExtensionResults be the result of calling
      -- credential.getClientExtensionResults().
      -- TODO: Extensions are not implemented by this library, see the TODO in the
      -- module documentation of `Crypto.WebAuthn.Model` for more information.

      -- 5. Let JSONtext be the result of running UTF-8 decode on the value of
      -- response.clientDataJSON.
      -- NOTE: Done as part of decoding

      -- 6. Let C, the client data claimed as collected during the credential
      -- creation, be the result of running an implementation-specific JSON
      -- parser on JSONtext.
      -- NOTE: Done as part of decoding

      -- 7. Verify that the value of C.type is webauthn.create.
      -- NOTE: Done as part of decoding

      -- 8. Verify that the value of C.challenge equals the base64url encoding of
      -- options.challenge.
      Bool
-> Validation (NonEmpty RegistrationError) ()
-> Validation (NonEmpty RegistrationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Challenge
corChallenge Challenge -> Challenge -> Bool
forall a. Eq a => a -> a -> Bool
== CollectedClientData 'Registration 'True -> Challenge
forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Challenge
M.ccdChallenge CollectedClientData 'Registration 'True
c) (Validation (NonEmpty RegistrationError) ()
 -> Validation (NonEmpty RegistrationError) ())
-> Validation (NonEmpty RegistrationError) ()
-> Validation (NonEmpty RegistrationError) ()
forall a b. (a -> b) -> a -> b
$
        RegistrationError -> Validation (NonEmpty RegistrationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (RegistrationError -> Validation (NonEmpty RegistrationError) ())
-> RegistrationError -> Validation (NonEmpty RegistrationError) ()
forall a b. (a -> b) -> a -> b
$ Challenge -> Challenge -> RegistrationError
RegistrationChallengeMismatch Challenge
corChallenge (CollectedClientData 'Registration 'True -> Challenge
forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Challenge
M.ccdChallenge CollectedClientData 'Registration 'True
c)

      -- 9. Verify that the value of C.origin matches the Relying Party's origin.
      Bool
-> Validation (NonEmpty RegistrationError) ()
-> Validation (NonEmpty RegistrationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Origin
rpOrigin Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== CollectedClientData 'Registration 'True -> Origin
forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Origin
M.ccdOrigin CollectedClientData 'Registration 'True
c) (Validation (NonEmpty RegistrationError) ()
 -> Validation (NonEmpty RegistrationError) ())
-> Validation (NonEmpty RegistrationError) ()
-> Validation (NonEmpty RegistrationError) ()
forall a b. (a -> b) -> a -> b
$
        RegistrationError -> Validation (NonEmpty RegistrationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (RegistrationError -> Validation (NonEmpty RegistrationError) ())
-> RegistrationError -> Validation (NonEmpty RegistrationError) ()
forall a b. (a -> b) -> a -> b
$ Origin -> Origin -> RegistrationError
RegistrationOriginMismatch Origin
rpOrigin (CollectedClientData 'Registration 'True -> Origin
forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Origin
M.ccdOrigin CollectedClientData 'Registration 'True
c)

      -- 10. Verify that the value of C.tokenBinding.status matches the state of
      -- Token Binding for the TLS connection over which the assertion was
      -- obtained. If Token Binding was used on that TLS connection, also verify
      -- that C.tokenBinding.id matches the base64url encoding of the Token
      -- Binding ID for the connection.
      -- TODO: We do not implement TokenBinding, see the documentation of
      -- `CollectedClientData` for more information.

      -- 11. Let hash be the result of computing a hash over
      -- response.clientDataJSON using SHA-256.
      -- NOTE: Done on raw data from decoding so that we don't need to encode again
      -- here and so that we use the exact some serialization
      let hash :: ClientDataHash
hash = Digest SHA256 -> ClientDataHash
M.ClientDataHash (Digest SHA256 -> ClientDataHash)
-> Digest SHA256 -> ClientDataHash
forall a b. (a -> b) -> a -> b
$ ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash (ByteString -> Digest SHA256) -> ByteString -> Digest SHA256
forall a b. (a -> b) -> a -> b
$ RawField 'True -> ByteString
M.unRaw (RawField 'True -> ByteString) -> RawField 'True -> ByteString
forall a b. (a -> b) -> a -> b
$ CollectedClientData 'Registration 'True -> RawField 'True
forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> RawField raw
M.ccdRawData CollectedClientData 'Registration 'True
c

      -- 12. Perform CBOR decoding on the attestationObject field of the
      -- AuthenticatorAttestationResponse structure to obtain the attestation
      -- statement format fmt, the authenticator data authData, and the attestation
      -- statement attStmt.
      -- NOTE: Already done as part of decoding

      -- 13. Verify that the rpIdHash in authData is the SHA-256 hash of the RP
      -- ID expected by the Relying Party.
      Bool
-> Validation (NonEmpty RegistrationError) ()
-> Validation (NonEmpty RegistrationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RpIdHash
rpIdHash RpIdHash -> RpIdHash -> Bool
forall a. Eq a => a -> a -> Bool
== AuthenticatorData 'Registration 'True -> RpIdHash
forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
M.adRpIdHash AuthenticatorData 'Registration 'True
authData) (Validation (NonEmpty RegistrationError) ()
 -> Validation (NonEmpty RegistrationError) ())
-> Validation (NonEmpty RegistrationError) ()
-> Validation (NonEmpty RegistrationError) ()
forall a b. (a -> b) -> a -> b
$
        RegistrationError -> Validation (NonEmpty RegistrationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (RegistrationError -> Validation (NonEmpty RegistrationError) ())
-> RegistrationError -> Validation (NonEmpty RegistrationError) ()
forall a b. (a -> b) -> a -> b
$ RpIdHash -> RpIdHash -> RegistrationError
RegistrationRpIdHashMismatch RpIdHash
rpIdHash (AuthenticatorData 'Registration 'True -> RpIdHash
forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
M.adRpIdHash AuthenticatorData 'Registration 'True
authData)

      -- 14. Verify that the User Present bit of the flags in authData is set.
      Bool
-> Validation (NonEmpty RegistrationError) ()
-> Validation (NonEmpty RegistrationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AuthenticatorDataFlags -> Bool
M.adfUserPresent (AuthenticatorData 'Registration 'True -> AuthenticatorDataFlags
forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
M.adFlags AuthenticatorData 'Registration 'True
authData)) (Validation (NonEmpty RegistrationError) ()
 -> Validation (NonEmpty RegistrationError) ())
-> Validation (NonEmpty RegistrationError) ()
-> Validation (NonEmpty RegistrationError) ()
forall a b. (a -> b) -> a -> b
$
        RegistrationError -> Validation (NonEmpty RegistrationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure RegistrationError
RegistrationUserNotPresent

      -- 15. If user verification is required for this registration, verify that
      -- the User Verified bit of the flags in authData is set.
      -- NOTE: The spec is interpreted to mean that the userVerification option
      -- from authenticatorSelection being set to "required" is what is meant by
      -- whether user verification is required
      case ( AuthenticatorSelectionCriteria -> UserVerificationRequirement
M.ascUserVerification (AuthenticatorSelectionCriteria -> UserVerificationRequirement)
-> Maybe AuthenticatorSelectionCriteria
-> Maybe UserVerificationRequirement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CredentialOptions 'Registration
-> Maybe AuthenticatorSelectionCriteria
M.corAuthenticatorSelection CredentialOptions 'Registration
options,
             AuthenticatorDataFlags -> Bool
M.adfUserVerified (AuthenticatorData 'Registration 'True -> AuthenticatorDataFlags
forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
M.adFlags AuthenticatorData 'Registration 'True
authData)
           ) of
        (Maybe UserVerificationRequirement
Nothing, Bool
_) -> () -> Validation (NonEmpty RegistrationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (Just UserVerificationRequirement
M.UserVerificationRequirementRequired, Bool
True) -> () -> Validation (NonEmpty RegistrationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (Just UserVerificationRequirement
M.UserVerificationRequirementRequired, Bool
False) -> RegistrationError -> Validation (NonEmpty RegistrationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure RegistrationError
RegistrationUserNotVerified
        (Just UserVerificationRequirement
M.UserVerificationRequirementPreferred, Bool
True) -> () -> Validation (NonEmpty RegistrationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (Just UserVerificationRequirement
M.UserVerificationRequirementPreferred, Bool
False) -> () -> Validation (NonEmpty RegistrationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (Just UserVerificationRequirement
M.UserVerificationRequirementDiscouraged, Bool
True) -> () -> Validation (NonEmpty RegistrationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (Just UserVerificationRequirement
M.UserVerificationRequirementDiscouraged, Bool
False) -> () -> Validation (NonEmpty RegistrationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      -- 16. Verify that the "alg" parameter in the credential public key in
      -- authData matches the alg attribute of one of the items in
      -- options.pubKeyCredParams.
      let acdAlg :: CoseSignAlg
acdAlg = CosePublicKey -> CoseSignAlg
Cose.signAlg CosePublicKey
acdCredentialPublicKey
          desiredAlgs :: [CoseSignAlg]
desiredAlgs = (CredentialParameters -> CoseSignAlg)
-> [CredentialParameters] -> [CoseSignAlg]
forall a b. (a -> b) -> [a] -> [b]
map CredentialParameters -> CoseSignAlg
M.cpAlg [CredentialParameters]
corPubKeyCredParams
      Bool
-> Validation (NonEmpty RegistrationError) ()
-> Validation (NonEmpty RegistrationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CoseSignAlg
acdAlg CoseSignAlg -> [CoseSignAlg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CoseSignAlg]
desiredAlgs) (Validation (NonEmpty RegistrationError) ()
 -> Validation (NonEmpty RegistrationError) ())
-> Validation (NonEmpty RegistrationError) ()
-> Validation (NonEmpty RegistrationError) ()
forall a b. (a -> b) -> a -> b
$
        RegistrationError -> Validation (NonEmpty RegistrationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (RegistrationError -> Validation (NonEmpty RegistrationError) ())
-> RegistrationError -> Validation (NonEmpty RegistrationError) ()
forall a b. (a -> b) -> a -> b
$ [CoseSignAlg] -> CoseSignAlg -> RegistrationError
RegistrationPublicKeyAlgorithmDisallowed [CoseSignAlg]
desiredAlgs CoseSignAlg
acdAlg

      -- 17. Verify that the values of the client extension outputs in
      -- clientExtensionResults and the authenticator extension outputs in the
      -- extensions in authData are as expected, considering the client extension
      -- input values that were given in options.extensions and any specific
      -- policy of the Relying Party regarding unsolicited extensions, i.e.,
      -- those that were not specified as part of options.extensions. In the
      -- general case, the meaning of "are as expected" is specific to the
      -- Relying Party and which extensions are in use.
      -- TODO: Extensions are not implemented by this library, see the TODO in the
      -- module documentation of `Crypto.WebAuthn.Model` for more information.

      -- 18. Determine the attestation statement format by performing a USASCII
      -- case-sensitive match on fmt against the set of supported WebAuthn
      -- Attestation Statement Format Identifier values. An up-to-date list of
      -- registered WebAuthn Attestation Statement Format Identifier values is
      -- maintained in the IANA "WebAuthn Attestation Statement Format Identifiers"
      -- registry [IANA-WebAuthn-Registries] established by [RFC8809].
      -- NOTE: This check is done during decoding and enforced by the type-system

      -- 19. Verify that attStmt is a correct attestation statement, conveying a
      -- valid attestation signature, by using the attestation statement format
      -- fmt’s verification procedure given attStmt, authData and hash.
      SomeAttestationStatement
attStmt <- case a
-> DateTime
-> AttStmt a
-> AuthenticatorData 'Registration 'True
-> ClientDataHash
-> Validation
     (NonEmpty (AttStmtVerificationError a)) SomeAttestationType
forall a.
AttestationStatementFormat a =>
a
-> DateTime
-> AttStmt a
-> AuthenticatorData 'Registration 'True
-> ClientDataHash
-> Validation
     (NonEmpty (AttStmtVerificationError a)) SomeAttestationType
M.asfVerify a
aoFmt DateTime
currentTime AttStmt a
aoAttStmt AuthenticatorData 'Registration 'True
authData ClientDataHash
hash of
        Failure NonEmpty (AttStmtVerificationError a)
err -> RegistrationError
-> Validation (NonEmpty RegistrationError) SomeAttestationStatement
forall e a. e -> Validation (NonEmpty e) a
failure (RegistrationError
 -> Validation
      (NonEmpty RegistrationError) SomeAttestationStatement)
-> RegistrationError
-> Validation (NonEmpty RegistrationError) SomeAttestationStatement
forall a b. (a -> b) -> a -> b
$ a -> NonEmpty (AttStmtVerificationError a) -> RegistrationError
forall a.
AttestationStatementFormat a =>
a -> NonEmpty (AttStmtVerificationError a) -> RegistrationError
RegistrationAttestationFormatError a
aoFmt NonEmpty (AttStmtVerificationError a)
err
        Success (M.SomeAttestationType AttestationType k
M.AttestationTypeNone) ->
          SomeAttestationStatement
-> Validation (NonEmpty RegistrationError) SomeAttestationStatement
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeAttestationStatement
 -> Validation
      (NonEmpty RegistrationError) SomeAttestationStatement)
-> SomeAttestationStatement
-> Validation (NonEmpty RegistrationError) SomeAttestationStatement
forall a b. (a -> b) -> a -> b
$ AttestationType 'Unverifiable
-> AuthenticatorModel 'Unverifiable -> SomeAttestationStatement
forall (k :: AttestationKind).
AttestationType k
-> AuthenticatorModel k -> SomeAttestationStatement
SomeAttestationStatement AttestationType 'Unverifiable
M.AttestationTypeNone AuthenticatorModel 'Unverifiable
UnknownAuthenticator
        Success (M.SomeAttestationType AttestationType k
M.AttestationTypeSelf) ->
          SomeAttestationStatement
-> Validation (NonEmpty RegistrationError) SomeAttestationStatement
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeAttestationStatement
 -> Validation
      (NonEmpty RegistrationError) SomeAttestationStatement)
-> SomeAttestationStatement
-> Validation (NonEmpty RegistrationError) SomeAttestationStatement
forall a b. (a -> b) -> a -> b
$ AttestationType 'Unverifiable
-> AuthenticatorModel 'Unverifiable -> SomeAttestationStatement
forall (k :: AttestationKind).
AttestationType k
-> AuthenticatorModel k -> SomeAttestationStatement
SomeAttestationStatement AttestationType 'Unverifiable
M.AttestationTypeSelf AuthenticatorModel 'Unverifiable
UnknownAuthenticator
        Success (M.SomeAttestationType attType :: AttestationType k
attType@M.AttestationTypeVerifiable {}) ->
          SomeAttestationStatement
-> Validation (NonEmpty RegistrationError) SomeAttestationStatement
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeAttestationStatement
 -> Validation
      (NonEmpty RegistrationError) SomeAttestationStatement)
-> SomeAttestationStatement
-> Validation (NonEmpty RegistrationError) SomeAttestationStatement
forall a b. (a -> b) -> a -> b
$ Credential 'Registration 'True
-> a
-> AttestationType ('Verifiable p)
-> MetadataServiceRegistry
-> DateTime
-> SomeAttestationStatement
forall (raw :: Bool) (p :: ProtocolKind) a.
AttestationStatementFormat a =>
Credential 'Registration raw
-> a
-> AttestationType ('Verifiable p)
-> MetadataServiceRegistry
-> DateTime
-> SomeAttestationStatement
validateAttestationChain Credential 'Registration 'True
credential a
aoFmt AttestationType k
AttestationType ('Verifiable p)
attType MetadataServiceRegistry
registry DateTime
currentTime
      pure $
        RegistrationResult :: CredentialEntry -> SomeAttestationStatement -> RegistrationResult
RegistrationResult
          { rrEntry :: CredentialEntry
rrEntry =
              CredentialEntry :: CredentialId
-> UserHandle
-> PublicKeyBytes
-> SignatureCounter
-> [AuthenticatorTransport]
-> CredentialEntry
CredentialEntry
                { ceUserHandle :: UserHandle
ceUserHandle = CredentialUserEntity -> UserHandle
M.cueId (CredentialUserEntity -> UserHandle)
-> CredentialUserEntity -> UserHandle
forall a b. (a -> b) -> a -> b
$ CredentialOptions 'Registration -> CredentialUserEntity
M.corUser CredentialOptions 'Registration
options,
                  ceCredentialId :: CredentialId
ceCredentialId = Credential 'Registration 'True -> CredentialId
forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> CredentialId
M.cIdentifier Credential 'Registration 'True
credential,
                  cePublicKeyBytes :: PublicKeyBytes
cePublicKeyBytes = ByteString -> PublicKeyBytes
M.PublicKeyBytes (ByteString -> PublicKeyBytes) -> ByteString -> PublicKeyBytes
forall a b. (a -> b) -> a -> b
$ RawField 'True -> ByteString
M.unRaw RawField 'True
acdCredentialPublicKeyBytes,
                  ceSignCounter :: SignatureCounter
ceSignCounter = AuthenticatorData 'Registration 'True -> SignatureCounter
forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> SignatureCounter
M.adSignCount AuthenticatorData 'Registration 'True
authData,
                  ceTransports :: [AuthenticatorTransport]
ceTransports = AuthenticatorResponse 'Registration 'True
-> [AuthenticatorTransport]
forall (raw :: Bool).
AuthenticatorResponse 'Registration raw -> [AuthenticatorTransport]
M.arrTransports (AuthenticatorResponse 'Registration 'True
 -> [AuthenticatorTransport])
-> AuthenticatorResponse 'Registration 'True
-> [AuthenticatorTransport]
forall a b. (a -> b) -> a -> b
$ Credential 'Registration 'True
-> AuthenticatorResponse 'Registration 'True
forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> AuthenticatorResponse c raw
M.cResponse Credential 'Registration 'True
credential
                },
            rrAttestationStatement :: SomeAttestationStatement
rrAttestationStatement = SomeAttestationStatement
attStmt
          }

-- | Performs step 20 and 21 of attestation for verifieable attestation types.
-- Results in the type of attestation and the model.
validateAttestationChain ::
  forall raw p a.
  M.AttestationStatementFormat a =>
  M.Credential 'M.Registration raw ->
  a ->
  M.AttestationType ('M.Verifiable p) ->
  Meta.MetadataServiceRegistry ->
  DateTime ->
  SomeAttestationStatement
validateAttestationChain :: forall (raw :: Bool) (p :: ProtocolKind) a.
AttestationStatementFormat a =>
Credential 'Registration raw
-> a
-> AttestationType ('Verifiable p)
-> MetadataServiceRegistry
-> DateTime
-> SomeAttestationStatement
validateAttestationChain
  Credential 'Registration raw
credential
  a
fmt
  M.AttestationTypeVerifiable {VerifiableAttestationType
AttestationChain p
atvChain :: forall (p :: ProtocolKind).
AttestationType ('Verifiable p) -> AttestationChain p
atvType :: forall (p :: ProtocolKind).
AttestationType ('Verifiable p) -> VerifiableAttestationType
atvChain :: AttestationChain p
atvType :: VerifiableAttestationType
..}
  MetadataServiceRegistry
registry
  DateTime
currentTime =
    AttestationType ('Verifiable p)
-> AuthenticatorModel ('Verifiable p) -> SomeAttestationStatement
forall (k :: AttestationKind).
AttestationType k
-> AuthenticatorModel k -> SomeAttestationStatement
SomeAttestationStatement AttestationType ('Verifiable p)
attestationType AuthenticatorModel ('Verifiable p)
AuthenticatorModel ('Verifiable p)
authenticator
    where
      attestationType :: AttestationType ('Verifiable p)
attestationType =
        AttestationTypeVerifiable :: forall (p :: ProtocolKind).
VerifiableAttestationType
-> AttestationChain p -> AttestationType ('Verifiable p)
M.AttestationTypeVerifiable
          { atvType :: VerifiableAttestationType
M.atvType = VerifiableAttestationType
-> (MetadataStatement -> VerifiableAttestationType)
-> Maybe MetadataStatement
-> VerifiableAttestationType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe VerifiableAttestationType
atvType (VerifiableAttestationType
-> MetadataStatement -> VerifiableAttestationType
fixupVerifiableAttestationType VerifiableAttestationType
atvType) Maybe MetadataStatement
metadataStatement,
            atvChain :: AttestationChain p
M.atvChain = AttestationChain p
atvChain
          }
      authenticator :: AuthenticatorModel ('Verifiable p)
authenticator = case [FailedReason] -> Maybe (NonEmpty FailedReason)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [FailedReason]
chainValidationFailures of
        Maybe (NonEmpty FailedReason)
Nothing ->
          VerifiedAuthenticator :: forall (p :: ProtocolKind).
AuthenticatorIdentifier p
-> Maybe (MetadataEntry p) -> AuthenticatorModel ('Verifiable p)
VerifiedAuthenticator
            { vaIdentifier :: AuthenticatorIdentifier p
vaIdentifier = AuthenticatorIdentifier p
identifier,
              vaMetadata :: Maybe (MetadataEntry p)
vaMetadata = Maybe (MetadataEntry p)
metadataEntry
            }
        Just NonEmpty FailedReason
failures ->
          UnverifiedAuthenticator :: forall (p :: ProtocolKind).
NonEmpty FailedReason
-> AuthenticatorIdentifier p
-> Maybe (MetadataEntry p)
-> AuthenticatorModel ('Verifiable p)
UnverifiedAuthenticator
            { uaFailures :: NonEmpty FailedReason
uaFailures = NonEmpty FailedReason
failures,
              uaIdentifier :: AuthenticatorIdentifier p
uaIdentifier = AuthenticatorIdentifier p
identifier,
              uaMetadata :: Maybe (MetadataEntry p)
uaMetadata = Maybe (MetadataEntry p)
metadataEntry
            }

      chain :: X509.CertificateChain
      identifier :: AuthenticatorIdentifier p
      (CertificateChain
chain, AuthenticatorIdentifier p
identifier) = case AttestationChain p
atvChain of
        M.Fido2Chain NonEmpty SignedCertificate
cs ->
          ( [SignedCertificate] -> CertificateChain
X509.CertificateChain ([SignedCertificate] -> CertificateChain)
-> [SignedCertificate] -> CertificateChain
forall a b. (a -> b) -> a -> b
$ NonEmpty SignedCertificate -> [SignedCertificate]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty SignedCertificate
cs,
            AAGUID -> AuthenticatorIdentifier 'Fido2
AuthenticatorIdentifierFido2
              (AAGUID -> AuthenticatorIdentifier 'Fido2)
-> (Credential 'Registration raw -> AAGUID)
-> Credential 'Registration raw
-> AuthenticatorIdentifier 'Fido2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttestedCredentialData 'Registration raw -> AAGUID
forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> AAGUID
M.acdAaguid
              (AttestedCredentialData 'Registration raw -> AAGUID)
-> (Credential 'Registration raw
    -> AttestedCredentialData 'Registration raw)
-> Credential 'Registration raw
-> AAGUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthenticatorData 'Registration raw
-> AttestedCredentialData 'Registration raw
forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AttestedCredentialData c raw
M.adAttestedCredentialData
              (AuthenticatorData 'Registration raw
 -> AttestedCredentialData 'Registration raw)
-> (Credential 'Registration raw
    -> AuthenticatorData 'Registration raw)
-> Credential 'Registration raw
-> AttestedCredentialData 'Registration raw
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttestationObject raw -> AuthenticatorData 'Registration raw
forall (raw :: Bool).
AttestationObject raw -> AuthenticatorData 'Registration raw
M.aoAuthData
              (AttestationObject raw -> AuthenticatorData 'Registration raw)
-> (Credential 'Registration raw -> AttestationObject raw)
-> Credential 'Registration raw
-> AuthenticatorData 'Registration raw
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthenticatorResponse 'Registration raw -> AttestationObject raw
forall (raw :: Bool).
AuthenticatorResponse 'Registration raw -> AttestationObject raw
M.arrAttestationObject
              (AuthenticatorResponse 'Registration raw -> AttestationObject raw)
-> (Credential 'Registration raw
    -> AuthenticatorResponse 'Registration raw)
-> Credential 'Registration raw
-> AttestationObject raw
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential 'Registration raw
-> AuthenticatorResponse 'Registration raw
forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> AuthenticatorResponse c raw
M.cResponse
              (Credential 'Registration raw -> AuthenticatorIdentifier 'Fido2)
-> Credential 'Registration raw -> AuthenticatorIdentifier 'Fido2
forall a b. (a -> b) -> a -> b
$ Credential 'Registration raw
credential
          )
        M.FidoU2FCert SignedCertificate
c ->
          ( [SignedCertificate] -> CertificateChain
X509.CertificateChain [SignedCertificate
c],
            SubjectKeyIdentifier -> AuthenticatorIdentifier 'FidoU2F
AuthenticatorIdentifierFidoU2F
              (SubjectKeyIdentifier -> AuthenticatorIdentifier 'FidoU2F)
-> (SignedCertificate -> SubjectKeyIdentifier)
-> SignedCertificate
-> AuthenticatorIdentifier 'FidoU2F
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Certificate -> SubjectKeyIdentifier
certificateSubjectKeyIdentifier
              (Certificate -> SubjectKeyIdentifier)
-> (SignedCertificate -> Certificate)
-> SignedCertificate
-> SubjectKeyIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedCertificate -> Certificate
X509.getCertificate
              (SignedCertificate -> AuthenticatorIdentifier 'FidoU2F)
-> SignedCertificate -> AuthenticatorIdentifier 'FidoU2F
forall a b. (a -> b) -> a -> b
$ SignedCertificate
c
          )
      metadataEntry :: Maybe (MetadataEntry p)
metadataEntry = MetadataServiceRegistry
-> AuthenticatorIdentifier p -> Maybe (MetadataEntry p)
forall (p :: ProtocolKind).
MetadataServiceRegistry
-> AuthenticatorIdentifier p -> Maybe (MetadataEntry p)
queryMetadata MetadataServiceRegistry
registry AuthenticatorIdentifier p
identifier
      metadataStatement :: Maybe MetadataStatement
metadataStatement = Maybe (MetadataEntry p)
metadataEntry Maybe (MetadataEntry p)
-> (MetadataEntry p -> Maybe MetadataStatement)
-> Maybe MetadataStatement
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MetadataEntry p -> Maybe MetadataStatement
forall (p :: ProtocolKind).
MetadataEntry p -> Maybe MetadataStatement
Meta.meMetadataStatement

      -- 20. If validation is successful, obtain a list of acceptable trust
      -- anchors (i.e. attestation root certificates) for that attestation type
      -- and attestation statement format fmt, from a trusted source or from
      -- policy. For example, the FIDO Metadata Service [FIDOMetadataService]
      -- provides one way to obtain such information, using the aaguid in the
      -- attestedCredentialData in authData.
      formatRootCerts :: CertificateStore
formatRootCerts = a -> VerifiableAttestationType -> CertificateStore
forall a.
AttestationStatementFormat a =>
a -> VerifiableAttestationType -> CertificateStore
M.asfTrustAnchors a
fmt VerifiableAttestationType
atvType
      metadataRootCerts :: CertificateStore
metadataRootCerts = case Maybe MetadataStatement
metadataStatement of
        Maybe MetadataStatement
Nothing -> CertificateStore
forall a. Monoid a => a
mempty
        Just MetadataStatement
statement -> [SignedCertificate] -> CertificateStore
X509.makeCertificateStore ([SignedCertificate] -> CertificateStore)
-> [SignedCertificate] -> CertificateStore
forall a b. (a -> b) -> a -> b
$ NonEmpty SignedCertificate -> [SignedCertificate]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty SignedCertificate -> [SignedCertificate])
-> NonEmpty SignedCertificate -> [SignedCertificate]
forall a b. (a -> b) -> a -> b
$ MetadataStatement -> NonEmpty SignedCertificate
Meta.msAttestationRootCertificates MetadataStatement
statement

      -- 21. Assess the attestation trustworthiness using the outputs of the
      -- verification procedure in step 19, as follows:
      --
      -- -> If no attestation was provided, verify that None attestation is
      --    acceptable under Relying Party policy.
      --    NOTE: Can be decided from the return type
      -- -> If self attestation was used, verify that self attestation is
      --    acceptable under Relying Party policy.
      --    NOTE: Can be decided from the return type
      -- -> Otherwise, use the X.509 certificates returned as the attestation
      --    trust path from the verification procedure to verify that the
      --    attestation public key either correctly chains up to an acceptable
      --    root certificate, or is itself an acceptable certificate (i.e., it
      --    and the root certificate obtained in Step 20 may be the same).
      --    NOTE: We are only returning the errors, which can be used to either
      --    fail or still allow it
      chainValidationFailures :: [FailedReason]
chainValidationFailures =
        DateTime
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ServiceID
-> CertificateChain
-> [FailedReason]
X509.validatePure
          DateTime
currentTime
          ValidationHooks
X509.defaultHooks
            { hookValidateName :: String -> Certificate -> [FailedReason]
X509.hookValidateName = \String
_fqhn Certificate
_cert -> []
            }
          ValidationChecks
X509.defaultChecks
          (CertificateStore
formatRootCerts CertificateStore -> CertificateStore -> CertificateStore
forall a. Semigroup a => a -> a -> a
<> CertificateStore
metadataRootCerts)
          (String
"", ByteString
forall a. Monoid a => a
mempty)
          CertificateChain
chain

-- | Metadata statements can convey multiple attestation types.
-- In such a case we choose to result in the Uncertain type.
-- Otherwise, we results in the only one available.
fixupVerifiableAttestationType :: M.VerifiableAttestationType -> Meta.MetadataStatement -> M.VerifiableAttestationType
fixupVerifiableAttestationType :: VerifiableAttestationType
-> MetadataStatement -> VerifiableAttestationType
fixupVerifiableAttestationType VerifiableAttestationType
M.VerifiableAttestationTypeUncertain MetadataStatement
statement =
  case MetadataStatement -> NonEmpty WebauthnAttestationType
Meta.msAttestationTypes MetadataStatement
statement of
    -- If there are multiple types we can't know which one it is
    (WebauthnAttestationType
_ :| (WebauthnAttestationType
_ : [WebauthnAttestationType]
_)) -> VerifiableAttestationType
M.VerifiableAttestationTypeUncertain
    (WebauthnAttestationType
Meta.WebauthnAttestationBasic :| []) -> VerifiableAttestationType
M.VerifiableAttestationTypeBasic
    (WebauthnAttestationType
Meta.WebauthnAttestationAttCA :| []) -> VerifiableAttestationType
M.VerifiableAttestationTypeAttCA
fixupVerifiableAttestationType VerifiableAttestationType
certain MetadataStatement
_ = VerifiableAttestationType
certain