{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
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)
data RegistrationError
=
RegistrationChallengeMismatch
{
RegistrationError -> Challenge
reCreatedChallenge :: M.Challenge,
RegistrationError -> Challenge
reReceivedChallenge :: M.Challenge
}
|
RegistrationOriginMismatch
{
RegistrationError -> Origin
reExpectedOrigin :: M.Origin,
RegistrationError -> Origin
reReceivedOrigin :: M.Origin
}
|
RegistrationRpIdHashMismatch
{
RegistrationError -> RpIdHash
reExpectedRpIdHash :: M.RpIdHash,
RegistrationError -> RpIdHash
reReceivedRpIdHash :: M.RpIdHash
}
|
RegistrationUserNotPresent
|
RegistrationUserNotVerified
|
RegistrationPublicKeyAlgorithmDisallowed
{
RegistrationError -> [CoseSignAlg]
reAllowedSigningAlgorithms :: [Cose.CoseSignAlg],
RegistrationError -> CoseSignAlg
reReceivedSigningAlgorithm :: Cose.CoseSignAlg
}
|
forall a. M.AttestationStatementFormat a => RegistrationAttestationFormatError a (NonEmpty (M.AttStmtVerificationError a))
deriving instance Show RegistrationError
deriving instance Exception RegistrationError
data AuthenticatorModel k where
UnknownAuthenticator :: AuthenticatorModel 'M.Unverifiable
UnverifiedAuthenticator ::
{
forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> NonEmpty FailedReason
uaFailures :: NonEmpty X509.FailedReason,
forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> AuthenticatorIdentifier p
uaIdentifier :: AuthenticatorIdentifier p,
forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> Maybe (MetadataEntry p)
uaMetadata :: Maybe (Meta.MetadataEntry p)
} ->
AuthenticatorModel ('M.Verifiable p)
VerifiedAuthenticator ::
{
forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> AuthenticatorIdentifier p
vaIdentifier :: AuthenticatorIdentifier p,
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" 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"unverified",
Key
"uaFailures" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty FailedReason
uaFailures,
Key
"uaIdentifier" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthenticatorIdentifier p
uaIdentifier,
Key
"uaMetadata" 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"verified",
Key
"vaIdentifier" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthenticatorIdentifier p
vaIdentifier,
Key
"vaMetadata" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (MetadataEntry p)
vaMetadata
]
data SomeAttestationStatement = forall k.
SomeAttestationStatement
{
()
asType :: M.AttestationType k,
()
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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AttestationType k
asType,
Key
"asModel" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthenticatorModel k
asModel
]
data RegistrationResult = RegistrationResult
{
RegistrationResult -> CredentialEntry
rrEntry :: CredentialEntry,
RegistrationResult -> SomeAttestationStatement
rrAttestationStatement :: SomeAttestationStatement
}
deriving (Int -> RegistrationResult -> ShowS
[RegistrationResult] -> ShowS
RegistrationResult -> String
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. 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
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)
verifyRegistrationResponse ::
M.Origin ->
M.RpIdHash ->
Meta.MetadataServiceRegistry ->
DateTime ->
M.CredentialOptions 'M.Registration ->
M.Credential 'M.Registration 'True ->
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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Challenge
corChallenge forall a. Eq a => a -> a -> Bool
== forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Challenge
M.ccdChallenge CollectedClientData 'Registration 'True
c) forall a b. (a -> b) -> a -> b
$
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$
Challenge -> Challenge -> RegistrationError
RegistrationChallengeMismatch Challenge
corChallenge (forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Challenge
M.ccdChallenge CollectedClientData 'Registration 'True
c)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Origin
rpOrigin forall a. Eq a => a -> a -> Bool
== forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Origin
M.ccdOrigin CollectedClientData 'Registration 'True
c) forall a b. (a -> b) -> a -> b
$
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$
Origin -> Origin -> RegistrationError
RegistrationOriginMismatch Origin
rpOrigin (forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Origin
M.ccdOrigin CollectedClientData 'Registration 'True
c)
let hash :: ClientDataHash
hash = Digest SHA256 -> ClientDataHash
M.ClientDataHash forall a b. (a -> b) -> a -> b
$ forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash forall a b. (a -> b) -> a -> b
$ RawField 'True -> ByteString
M.unRaw forall a b. (a -> b) -> a -> b
$ forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> RawField raw
M.ccdRawData CollectedClientData 'Registration 'True
c
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RpIdHash
rpIdHash forall a. Eq a => a -> a -> Bool
== forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
M.adRpIdHash AuthenticatorData 'Registration 'True
authData) forall a b. (a -> b) -> a -> b
$
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$
RpIdHash -> RpIdHash -> RegistrationError
RegistrationRpIdHashMismatch RpIdHash
rpIdHash (forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
M.adRpIdHash AuthenticatorData 'Registration 'True
authData)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AuthenticatorDataFlags -> Bool
M.adfUserPresent (forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
M.adFlags AuthenticatorData 'Registration 'True
authData)) forall a b. (a -> b) -> a -> b
$
forall e a. e -> Validation (NonEmpty e) a
failure RegistrationError
RegistrationUserNotPresent
case ( AuthenticatorSelectionCriteria -> UserVerificationRequirement
M.ascUserVerification 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 (forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
M.adFlags AuthenticatorData 'Registration 'True
authData)
) of
(Maybe UserVerificationRequirement
Nothing, Bool
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just UserVerificationRequirement
M.UserVerificationRequirementRequired, Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just UserVerificationRequirement
M.UserVerificationRequirementRequired, Bool
False) -> forall e a. e -> Validation (NonEmpty e) a
failure RegistrationError
RegistrationUserNotVerified
(Just UserVerificationRequirement
M.UserVerificationRequirementPreferred, Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just UserVerificationRequirement
M.UserVerificationRequirementPreferred, Bool
False) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just UserVerificationRequirement
M.UserVerificationRequirementDiscouraged, Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just UserVerificationRequirement
M.UserVerificationRequirementDiscouraged, Bool
False) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let acdAlg :: CoseSignAlg
acdAlg = CosePublicKey -> CoseSignAlg
Cose.signAlg CosePublicKey
acdCredentialPublicKey
desiredAlgs :: [CoseSignAlg]
desiredAlgs = forall a b. (a -> b) -> [a] -> [b]
map CredentialParameters -> CoseSignAlg
M.cpAlg [CredentialParameters]
corPubKeyCredParams
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CoseSignAlg
acdAlg forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CoseSignAlg]
desiredAlgs) forall a b. (a -> b) -> a -> b
$
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$
[CoseSignAlg] -> CoseSignAlg -> RegistrationError
RegistrationPublicKeyAlgorithmDisallowed [CoseSignAlg]
desiredAlgs CoseSignAlg
acdAlg
SomeAttestationStatement
attStmt <- case 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 -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ forall a.
AttestationStatementFormat a =>
a -> NonEmpty (AttStmtVerificationError a) -> RegistrationError
RegistrationAttestationFormatError a
aoFmt NonEmpty (AttStmtVerificationError a)
err
Success (M.SomeAttestationType AttestationType k
M.AttestationTypeNone) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (k :: AttestationKind).
AttestationType k
-> AuthenticatorModel k -> SomeAttestationStatement
SomeAttestationStatement AttestationType 'Unverifiable
M.AttestationTypeNone AuthenticatorModel 'Unverifiable
UnknownAuthenticator
Success (M.SomeAttestationType AttestationType k
M.AttestationTypeSelf) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 {}) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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
attType MetadataServiceRegistry
registry DateTime
currentTime
pure $
RegistrationResult
{ rrEntry :: CredentialEntry
rrEntry =
CredentialEntry
{ ceUserHandle :: UserHandle
ceUserHandle = CredentialUserEntity -> UserHandle
M.cueId forall a b. (a -> b) -> a -> b
$ CredentialOptions 'Registration -> CredentialUserEntity
M.corUser CredentialOptions 'Registration
options,
ceCredentialId :: CredentialId
ceCredentialId = forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> CredentialId
M.cIdentifier Credential 'Registration 'True
credential,
cePublicKeyBytes :: PublicKeyBytes
cePublicKeyBytes = ByteString -> PublicKeyBytes
M.PublicKeyBytes forall a b. (a -> b) -> a -> b
$ RawField 'True -> ByteString
M.unRaw RawField 'True
acdCredentialPublicKeyBytes,
ceSignCounter :: SignatureCounter
ceSignCounter = forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> SignatureCounter
M.adSignCount AuthenticatorData 'Registration 'True
authData,
ceTransports :: [AuthenticatorTransport]
ceTransports = forall (raw :: Bool).
AuthenticatorResponse 'Registration raw -> [AuthenticatorTransport]
M.arrTransports forall a b. (a -> b) -> a -> b
$ forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> AuthenticatorResponse c raw
M.cResponse Credential 'Registration 'True
credential
},
rrAttestationStatement :: SomeAttestationStatement
rrAttestationStatement = SomeAttestationStatement
attStmt
}
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 =
forall (k :: AttestationKind).
AttestationType k
-> AuthenticatorModel k -> SomeAttestationStatement
SomeAttestationStatement AttestationType ('Verifiable p)
attestationType AuthenticatorModel ('Verifiable p)
authenticator
where
attestationType :: AttestationType ('Verifiable p)
attestationType =
M.AttestationTypeVerifiable
{ atvType :: VerifiableAttestationType
M.atvType = 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 forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [FailedReason]
chainValidationFailures of
Maybe (NonEmpty FailedReason)
Nothing ->
VerifiedAuthenticator
{ vaIdentifier :: AuthenticatorIdentifier p
vaIdentifier = AuthenticatorIdentifier p
identifier,
vaMetadata :: Maybe (MetadataEntry p)
vaMetadata = Maybe (MetadataEntry p)
metadataEntry
}
Just NonEmpty FailedReason
failures ->
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 forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty SignedCertificate
cs,
AAGUID -> AuthenticatorIdentifier 'Fido2
AuthenticatorIdentifierFido2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> AAGUID
M.acdAaguid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AttestedCredentialData c raw
M.adAttestedCredentialData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (raw :: Bool).
AttestationObject raw -> AuthenticatorData 'Registration raw
M.aoAuthData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (raw :: Bool).
AuthenticatorResponse 'Registration raw -> AttestationObject raw
M.arrAttestationObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> AuthenticatorResponse c raw
M.cResponse
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
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Certificate -> SubjectKeyIdentifier
certificateSubjectKeyIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedCertificate -> Certificate
X509.getCertificate
forall a b. (a -> b) -> a -> b
$ SignedCertificate
c
)
metadataEntry :: Maybe (MetadataEntry p)
metadataEntry = forall (p :: ProtocolKind).
MetadataServiceRegistry
-> AuthenticatorIdentifier p -> Maybe (MetadataEntry p)
queryMetadata MetadataServiceRegistry
registry AuthenticatorIdentifier p
identifier
metadataStatement :: Maybe MetadataStatement
metadataStatement = Maybe (MetadataEntry p)
metadataEntry forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (p :: ProtocolKind).
MetadataEntry p -> Maybe MetadataStatement
Meta.meMetadataStatement
formatRootCerts :: CertificateStore
formatRootCerts = forall a.
AttestationStatementFormat a =>
a -> VerifiableAttestationType -> CertificateStore
M.asfTrustAnchors a
fmt VerifiableAttestationType
atvType
metadataRootCerts :: CertificateStore
metadataRootCerts = case Maybe MetadataStatement
metadataStatement of
Maybe MetadataStatement
Nothing -> forall a. Monoid a => a
mempty
Just MetadataStatement
statement -> [SignedCertificate] -> CertificateStore
X509.makeCertificateStore forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ MetadataStatement -> NonEmpty SignedCertificate
Meta.msAttestationRootCertificates MetadataStatement
statement
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 forall a. Semigroup a => a -> a -> a
<> CertificateStore
metadataRootCerts)
(String
"", forall a. Monoid a => a
mempty)
CertificateChain
chain
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
(WebauthnAttestationType
_ :| (WebauthnAttestationType
_ : [WebauthnAttestationType]
_)) -> VerifiableAttestationType
M.VerifiableAttestationTypeUncertain
(WebauthnAttestationType
Meta.WebauthnAttestationBasic :| []) -> VerifiableAttestationType
M.VerifiableAttestationTypeBasic
(WebauthnAttestationType
Meta.WebauthnAttestationAttCA :| []) -> VerifiableAttestationType
M.VerifiableAttestationTypeAttCA
fixupVerifiableAttestationType VerifiableAttestationType
certain MetadataStatement
_ = VerifiableAttestationType
certain