{-# 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" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"unknown"
]
toJSON UnverifiedAuthenticator {Maybe (MetadataEntry p)
NonEmpty FailedReason
AuthenticatorIdentifier p
uaIdentifier :: forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> AuthenticatorIdentifier p
uaMetadata :: forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> Maybe (MetadataEntry p)
uaFailures :: forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> NonEmpty FailedReason
uaFailures :: NonEmpty FailedReason
uaIdentifier :: AuthenticatorIdentifier p
uaMetadata :: Maybe (MetadataEntry p)
..} =
[Pair] -> Value
object
[ Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"unverified",
Key
"uaFailures" Key -> NonEmpty FailedReason -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= NonEmpty FailedReason
uaFailures,
Key
"uaIdentifier" Key -> AuthenticatorIdentifier p -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= AuthenticatorIdentifier p
uaIdentifier,
Key
"uaMetadata" Key -> Maybe (MetadataEntry p) -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Maybe (MetadataEntry p)
uaMetadata
]
toJSON VerifiedAuthenticator {Maybe (MetadataEntry p)
AuthenticatorIdentifier p
vaIdentifier :: forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> AuthenticatorIdentifier p
vaMetadata :: forall (p :: ProtocolKind).
AuthenticatorModel ('Verifiable p) -> Maybe (MetadataEntry p)
vaIdentifier :: AuthenticatorIdentifier p
vaMetadata :: Maybe (MetadataEntry p)
..} =
[Pair] -> Value
object
[ Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"verified",
Key
"vaIdentifier" Key -> AuthenticatorIdentifier p -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= AuthenticatorIdentifier p
vaIdentifier,
Key
"vaMetadata" Key -> Maybe (MetadataEntry p) -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= 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
asType :: ()
asModel :: ()
asType :: AttestationType k
asModel :: AuthenticatorModel k
..} =
[Pair] -> Value
object
[ Key
"asType" Key -> AttestationType k -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= AttestationType k
asType,
Key
"asModel" Key -> AuthenticatorModel k -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= AuthenticatorModel k
asModel
]
data RegistrationResult = RegistrationResult
{
RegistrationResult -> CredentialEntry
rrEntry :: CredentialEntry,
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
$cshowsPrec :: Int -> RegistrationResult -> ShowS
showsPrec :: Int -> RegistrationResult -> ShowS
$cshow :: RegistrationResult -> String
show :: RegistrationResult -> String
$cshowList :: [RegistrationResult] -> ShowS
showList :: [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
$cfrom :: forall x. RegistrationResult -> Rep RegistrationResult x
from :: forall x. RegistrationResult -> Rep RegistrationResult x
$cto :: forall x. Rep RegistrationResult x -> RegistrationResult
to :: forall x. Rep RegistrationResult x -> RegistrationResult
Generic)
deriving instance ToJSON RegistrationResult
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
corRp :: CredentialRpEntity
corUser :: CredentialUserEntity
corChallenge :: Challenge
corPubKeyCredParams :: [CredentialParameters]
corTimeout :: Maybe Timeout
corExcludeCredentials :: [CredentialDescriptor]
corAuthenticatorSelection :: Maybe AuthenticatorSelectionCriteria
corAttestation :: AttestationConveyancePreference
corExtensions :: Maybe AuthenticationExtensionsClientInputs
corRp :: CredentialOptions 'Registration -> CredentialRpEntity
corUser :: CredentialOptions 'Registration -> CredentialUserEntity
corChallenge :: CredentialOptions 'Registration -> Challenge
corPubKeyCredParams :: CredentialOptions 'Registration -> [CredentialParameters]
corTimeout :: CredentialOptions 'Registration -> Maybe Timeout
corExcludeCredentials :: CredentialOptions 'Registration -> [CredentialDescriptor]
corAuthenticatorSelection :: CredentialOptions 'Registration
-> Maybe AuthenticatorSelectionCriteria
corAttestation :: CredentialOptions 'Registration -> AttestationConveyancePreference
corExtensions :: CredentialOptions 'Registration
-> Maybe AuthenticationExtensionsClientInputs
..}
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
acdAaguid :: AAGUID
acdCredentialId :: CredentialId
acdCredentialPublicKey :: CosePublicKey
acdCredentialPublicKeyBytes :: RawField 'True
acdAaguid :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> AAGUID
acdCredentialId :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CredentialId
acdCredentialPublicKey :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CosePublicKey
acdCredentialPublicKeyBytes :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> RawField raw
..}},
a
AttStmt a
aoFmt :: a
aoAttStmt :: AttStmt a
aoFmt :: ()
aoAttStmt :: ()
..
}
}
} =
do
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)
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)
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
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)
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
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 a. a -> Validation (NonEmpty RegistrationError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just UserVerificationRequirement
M.UserVerificationRequirementRequired, Bool
True) -> () -> Validation (NonEmpty RegistrationError) ()
forall a. a -> Validation (NonEmpty RegistrationError) a
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 a. a -> Validation (NonEmpty RegistrationError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just UserVerificationRequirement
M.UserVerificationRequirementPreferred, Bool
False) -> () -> Validation (NonEmpty RegistrationError) ()
forall a. a -> Validation (NonEmpty RegistrationError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just UserVerificationRequirement
M.UserVerificationRequirementDiscouraged, Bool
True) -> () -> Validation (NonEmpty RegistrationError) ()
forall a. a -> Validation (NonEmpty RegistrationError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just UserVerificationRequirement
M.UserVerificationRequirementDiscouraged, Bool
False) -> () -> Validation (NonEmpty RegistrationError) ()
forall a. a -> Validation (NonEmpty RegistrationError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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 a. Eq a => a -> [a] -> 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
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 a. a -> Validation (NonEmpty RegistrationError) a
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 a. a -> Validation (NonEmpty RegistrationError) a
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 a. a -> Validation (NonEmpty RegistrationError) a
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
{ rrEntry :: CredentialEntry
rrEntry =
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
}
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
atvType :: VerifiableAttestationType
atvChain :: AttestationChain p
atvType :: forall (p :: ProtocolKind).
AttestationType ('Verifiable p) -> VerifiableAttestationType
atvChain :: forall (p :: ProtocolKind).
AttestationType ('Verifiable p) -> AttestationChain p
..}
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 =
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
{ 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 ([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 p
AAGUID -> AuthenticatorIdentifier 'Fido2
AuthenticatorIdentifierFido2
(AAGUID -> AuthenticatorIdentifier p)
-> (Credential 'Registration raw -> AAGUID)
-> Credential 'Registration raw
-> AuthenticatorIdentifier p
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 p)
-> Credential 'Registration raw -> AuthenticatorIdentifier p
forall a b. (a -> b) -> a -> b
$ Credential 'Registration raw
credential
)
M.FidoU2FCert SignedCertificate
c ->
( [SignedCertificate] -> CertificateChain
X509.CertificateChain [SignedCertificate
c],
SubjectKeyIdentifier -> AuthenticatorIdentifier p
SubjectKeyIdentifier -> AuthenticatorIdentifier 'FidoU2F
AuthenticatorIdentifierFidoU2F
(SubjectKeyIdentifier -> AuthenticatorIdentifier p)
-> (SignedCertificate -> SubjectKeyIdentifier)
-> SignedCertificate
-> AuthenticatorIdentifier p
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 p)
-> SignedCertificate -> AuthenticatorIdentifier p
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 a b. Maybe a -> (a -> Maybe b) -> Maybe b
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
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
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
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