{-# 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
.= 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
]
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" 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
]
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
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)
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
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 (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 ()
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
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
}
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
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