{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Crypto.WebAuthn.AttestationStatementFormat.Packed
( format,
Format (..),
VerificationError (..),
)
where
import qualified Codec.CBOR.Term as CBOR
import Control.Exception (Exception)
import Control.Monad (forM, unless, when)
import qualified Crypto.WebAuthn.Cose.Internal.Verify as Cose
import qualified Crypto.WebAuthn.Cose.PublicKeyWithSignAlg as Cose
import qualified Crypto.WebAuthn.Cose.SignAlg as Cose
import Crypto.WebAuthn.Internal.Utils (IdFidoGenCeAAGUID (IdFidoGenCeAAGUID), failure)
import Crypto.WebAuthn.Model (AAGUID)
import qualified Crypto.WebAuthn.Model.Types as M
import qualified Data.ASN1.OID as OID
import Data.Aeson (ToJSON, object, toJSON, (.=))
import Data.Bifunctor (first)
import Data.ByteArray (convert)
import qualified Data.ByteString as BS
import Data.HashMap.Strict ((!?))
import Data.List.NonEmpty (NonEmpty ((:|)), toList)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.X509 as X509
import qualified Data.X509.Validation as X509
data Format = Format
instance Show Format where
show :: Format -> String
show = Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AttestationStatementFormat a => a -> Text
M.asfIdentifier
data Statement = Statement
{ Statement -> CoseSignAlg
alg :: Cose.CoseSignAlg,
Statement -> ByteString
sig :: BS.ByteString,
Statement -> Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
x5c :: Maybe (NE.NonEmpty X509.SignedCertificate, IdFidoGenCeAAGUID)
}
deriving (Statement -> Statement -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Statement -> Statement -> Bool
$c/= :: Statement -> Statement -> Bool
== :: Statement -> Statement -> Bool
$c== :: Statement -> Statement -> Bool
Eq, Int -> Statement -> ShowS
[Statement] -> ShowS
Statement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Statement] -> ShowS
$cshowList :: [Statement] -> ShowS
show :: Statement -> String
$cshow :: Statement -> String
showsPrec :: Int -> Statement -> ShowS
$cshowsPrec :: Int -> Statement -> ShowS
Show)
instance ToJSON Statement where
toJSON :: Statement -> Value
toJSON Statement {Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
ByteString
CoseSignAlg
x5c :: Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
sig :: ByteString
alg :: CoseSignAlg
x5c :: Statement -> Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
sig :: Statement -> ByteString
alg :: Statement -> CoseSignAlg
..} =
[Pair] -> Value
object
( [ Key
"alg" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= CoseSignAlg
alg,
Key
"sig" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString
sig
]
forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(NonEmpty SignedCertificate
x5c', IdFidoGenCeAAGUID
_) -> [Key
"x5c" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty SignedCertificate
x5c']) Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
x5c
)
data VerificationError
=
AlgorithmMismatch
{
VerificationError -> CoseSignAlg
statementAlg :: Cose.CoseSignAlg,
VerificationError -> CoseSignAlg
credentialAlg :: Cose.CoseSignAlg
}
|
InvalidSignature Text
|
VerificationFailure X509.SignatureFailure
|
CertificateRequirementsUnmet
|
CertificateAAGUIDMismatch
{
VerificationError -> AAGUID
certificateExtensionAAGUID :: AAGUID,
VerificationError -> AAGUID
attestedCredentialDataAAGUID :: AAGUID
}
deriving (Int -> VerificationError -> ShowS
[VerificationError] -> ShowS
VerificationError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VerificationError] -> ShowS
$cshowList :: [VerificationError] -> ShowS
show :: VerificationError -> String
$cshow :: VerificationError -> String
showsPrec :: Int -> VerificationError -> ShowS
$cshowsPrec :: Int -> VerificationError -> ShowS
Show, Show VerificationError
Typeable VerificationError
SomeException -> Maybe VerificationError
VerificationError -> String
VerificationError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: VerificationError -> String
$cdisplayException :: VerificationError -> String
fromException :: SomeException -> Maybe VerificationError
$cfromException :: SomeException -> Maybe VerificationError
toException :: VerificationError -> SomeException
$ctoException :: VerificationError -> SomeException
Exception)
instance M.AttestationStatementFormat Format where
type AttStmt Format = Statement
asfIdentifier :: Format -> Text
asfIdentifier Format
_ = Text
"packed"
asfDecode :: Format -> HashMap Text Term -> Either Text (AttStmt Format)
asfDecode Format
_ HashMap Text Term
xs =
case (HashMap Text Term
xs forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"alg", HashMap Text Term
xs forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"sig", HashMap Text Term
xs forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"x5c") of
(Just (CBOR.TInt Int
algId), Just (CBOR.TBytes ByteString
sig), Maybe Term
mx5c) -> do
CoseSignAlg
alg <- forall a. (Eq a, Num a, Show a) => a -> Either Text CoseSignAlg
Cose.toCoseSignAlg Int
algId
Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
x5c <- case Maybe Term
mx5c of
Maybe Term
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just (CBOR.TList [Term]
x5cRaw) -> case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Term]
x5cRaw of
Maybe (NonEmpty Term)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just NonEmpty Term
x5cBytes -> do
x5c :: NonEmpty SignedCertificate
x5c@(SignedCertificate
signedCert :| [SignedCertificate]
_) <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty Term
x5cBytes forall a b. (a -> b) -> a -> b
$ \case
CBOR.TBytes ByteString
certBytes ->
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"Failed to decode signed certificate: " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) (ByteString -> Either String SignedCertificate
X509.decodeSignedCertificate ByteString
certBytes)
Term
cert ->
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Certificate CBOR value is not bytes: " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show Term
cert)
let cert :: Certificate
cert = SignedCertificate -> Certificate
X509.getCertificate SignedCertificate
signedCert
IdFidoGenCeAAGUID
aaguidExt <- case forall a. Extension a => Extensions -> Maybe (Either String a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
cert) of
Just (Right IdFidoGenCeAAGUID
ext) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure IdFidoGenCeAAGUID
ext
Just (Left String
err) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode certificate aaguid extension: " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
err
Maybe (Either String IdFidoGenCeAAGUID)
Nothing -> forall a b. a -> Either a b
Left Text
"Certificate aaguid extension is missing"
pure $ forall a. a -> Maybe a
Just (NonEmpty SignedCertificate
x5c, IdFidoGenCeAAGUID
aaguidExt)
Just Term
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"CBOR map didn't have expected value types (alg: int, sig: bytes, [optional] x5c: non-empty list): " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show HashMap Text Term
xs)
pure $ Statement {Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
ByteString
CoseSignAlg
x5c :: Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
alg :: CoseSignAlg
sig :: ByteString
x5c :: Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
sig :: ByteString
alg :: CoseSignAlg
..}
(Maybe Term, Maybe Term, Maybe Term)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"CBOR map didn't have expected value types (alg: int, sig: bytes, [optional] x5c: non-empty list): " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show HashMap Text Term
xs)
asfEncode :: Format -> AttStmt Format -> Term
asfEncode Format
_ Statement {Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
ByteString
CoseSignAlg
x5c :: Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
sig :: ByteString
alg :: CoseSignAlg
x5c :: Statement -> Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
sig :: Statement -> ByteString
alg :: Statement -> CoseSignAlg
..} =
[(Term, Term)] -> Term
CBOR.TMap
( [ (Text -> Term
CBOR.TString Text
"sig", ByteString -> Term
CBOR.TBytes ByteString
sig),
(Text -> Term
CBOR.TString Text
"alg", Int -> Term
CBOR.TInt forall a b. (a -> b) -> a -> b
$ forall p. Num p => CoseSignAlg -> p
Cose.fromCoseSignAlg CoseSignAlg
alg)
]
forall a. [a] -> [a] -> [a]
++ case Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
x5c of
Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
Nothing -> []
Just (NonEmpty SignedCertificate
certChain, IdFidoGenCeAAGUID
_) ->
let encodedx5c :: [Term]
encodedx5c = forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Term
CBOR.TBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> ByteString
X509.encodeSignedObject) forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
toList NonEmpty SignedCertificate
certChain
in [ (Text -> Term
CBOR.TString Text
"x5c", [Term] -> Term
CBOR.TList [Term]
encodedx5c)
]
)
type AttStmtVerificationError Format = VerificationError
asfVerify :: Format
-> DateTime
-> AttStmt Format
-> AuthenticatorData 'Registration 'True
-> ClientDataHash
-> Validation
(NonEmpty (AttStmtVerificationError Format)) SomeAttestationType
asfVerify
Format
_
DateTime
_
Statement {alg :: Statement -> CoseSignAlg
alg = CoseSignAlg
stmtAlg, sig :: Statement -> ByteString
sig = ByteString
stmtSig, x5c :: Statement -> Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
x5c = Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
stmtx5c}
M.AuthenticatorData {adRawData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RawField raw
M.adRawData = M.WithRaw ByteString
rawData, adAttestedCredentialData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AttestedCredentialData c raw
M.adAttestedCredentialData = AttestedCredentialData 'Registration 'True
credData}
ClientDataHash
clientDataHash = do
let signedData :: ByteString
signedData = ByteString
rawData forall a. Semigroup a => a -> a -> a
<> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (ClientDataHash -> Digest SHA256
M.unClientDataHash ClientDataHash
clientDataHash)
case Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
stmtx5c of
Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
Nothing -> do
let key :: CosePublicKey
key = forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CosePublicKey
M.acdCredentialPublicKey AttestedCredentialData 'Registration 'True
credData
signAlg :: CoseSignAlg
signAlg = CosePublicKey -> CoseSignAlg
Cose.signAlg CosePublicKey
key
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CoseSignAlg
stmtAlg forall a. Eq a => a -> a -> Bool
/= CoseSignAlg
signAlg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ CoseSignAlg -> CoseSignAlg -> VerificationError
AlgorithmMismatch CoseSignAlg
stmtAlg CoseSignAlg
signAlg
case CosePublicKey -> ByteString -> ByteString -> Either Text ()
Cose.verify CosePublicKey
key ByteString
signedData ByteString
stmtSig of
Right () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Left Text
err -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ Text -> VerificationError
InvalidSignature Text
err
pure $ forall (k :: AttestationKind).
AttestationType k -> SomeAttestationType
M.SomeAttestationType AttestationType 'Unverifiable
M.AttestationTypeSelf
Just (x5c :: NonEmpty SignedCertificate
x5c@(SignedCertificate
certCred :| [SignedCertificate]
_), IdFidoGenCeAAGUID AAGUID
certAAGUID) -> do
let cert :: Certificate
cert = SignedCertificate -> Certificate
X509.getCertificate SignedCertificate
certCred
pubKey :: PubKey
pubKey = Certificate -> PubKey
X509.certPubKey Certificate
cert
case SignatureALG
-> PubKey -> ByteString -> ByteString -> SignatureVerification
X509.verifySignature (HashALG -> PubKeyALG -> SignatureALG
X509.SignatureALG HashALG
X509.HashSHA256 PubKeyALG
X509.PubKeyALG_EC) PubKey
pubKey ByteString
signedData ByteString
stmtSig of
SignatureVerification
X509.SignaturePass -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
X509.SignatureFailed SignatureFailure
err -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ SignatureFailure -> VerificationError
VerificationFailure SignatureFailure
err
let dnElements :: [(OID, ASN1CharacterString)]
dnElements = DistinguishedName -> [(OID, ASN1CharacterString)]
X509.getDistinguishedElements forall a b. (a -> b) -> a -> b
$ Certificate -> DistinguishedName
X509.certSubjectDN Certificate
cert
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
( DnElement -> [(OID, ASN1CharacterString)] -> Bool
hasDnElement DnElement
X509.DnCountry [(OID, ASN1CharacterString)]
dnElements
Bool -> Bool -> Bool
&& DnElement -> [(OID, ASN1CharacterString)] -> Bool
hasDnElement DnElement
X509.DnOrganization [(OID, ASN1CharacterString)]
dnElements
Bool -> Bool -> Bool
&& DnElement -> [(OID, ASN1CharacterString)] -> Bool
hasDnElement DnElement
X509.DnCommonName [(OID, ASN1CharacterString)]
dnElements
Bool -> Bool -> Bool
&& DnElement
-> [(OID, ASN1CharacterString)] -> Maybe ASN1CharacterString
findDnElement DnElement
X509.DnOrganizationUnit [(OID, ASN1CharacterString)]
dnElements forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ASN1CharacterString
"Authenticator Attestation"
)
forall a b. (a -> b) -> a -> b
$ forall e a. e -> Validation (NonEmpty e) a
failure VerificationError
CertificateRequirementsUnmet
let aaguid :: AAGUID
aaguid = forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> AAGUID
M.acdAaguid AttestedCredentialData 'Registration 'True
credData
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AAGUID
certAAGUID forall a. Eq a => a -> a -> Bool
== AAGUID
aaguid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ AAGUID -> AAGUID -> VerificationError
CertificateAAGUIDMismatch AAGUID
certAAGUID AAGUID
aaguid
pure $
forall (k :: AttestationKind).
AttestationType k -> SomeAttestationType
M.SomeAttestationType forall a b. (a -> b) -> a -> b
$
forall (p :: ProtocolKind).
VerifiableAttestationType
-> AttestationChain p -> AttestationType ('Verifiable p)
M.AttestationTypeVerifiable VerifiableAttestationType
M.VerifiableAttestationTypeUncertain (NonEmpty SignedCertificate -> AttestationChain 'Fido2
M.Fido2Chain NonEmpty SignedCertificate
x5c)
where
hasDnElement :: X509.DnElement -> [(OID.OID, X509.ASN1CharacterString)] -> Bool
hasDnElement :: DnElement -> [(OID, ASN1CharacterString)] -> Bool
hasDnElement DnElement
el = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. DnElement
-> [(OID, ASN1CharacterString)] -> Maybe ASN1CharacterString
findDnElement DnElement
el
findDnElement :: X509.DnElement -> [(OID.OID, X509.ASN1CharacterString)] -> Maybe X509.ASN1CharacterString
findDnElement :: DnElement
-> [(OID, ASN1CharacterString)] -> Maybe ASN1CharacterString
findDnElement DnElement
dnElementName = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (forall a. OIDable a => a -> OID
OID.getObjectID DnElement
dnElementName)
asfTrustAnchors :: Format -> VerifiableAttestationType -> CertificateStore
asfTrustAnchors Format
_ VerifiableAttestationType
_ = forall a. Monoid a => a
mempty
format :: M.SomeAttestationStatementFormat
format :: SomeAttestationStatementFormat
format = forall a.
AttestationStatementFormat a =>
a -> SomeAttestationStatementFormat
M.SomeAttestationStatementFormat Format
Format