{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

-- | Stability: experimental
-- This module implements the
-- [Packed Attestation Statement Format](https://www.w3.org/TR/webauthn-2/#sctn-packed-attestation).
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

-- | The Packed format. The sole purpose of this type is to instantiate the
-- AttestationStatementFormat typeclass below.
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

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-packed-attestation)
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
      )

-- | Verification errors specific to Packed attestation
data VerificationError
  = -- | The Algorithm from the attestation format does not match the algorithm
    -- of the key in the credential data
    AlgorithmMismatch
      { -- | The algorithm received in the attestation statement
        VerificationError -> CoseSignAlg
statementAlg :: Cose.CoseSignAlg,
        -- | The algorithm of the credentialPublicKey in authenticatorData
        VerificationError -> CoseSignAlg
credentialAlg :: Cose.CoseSignAlg
      }
  | -- | The statement key cannot verify the signature over the attested
    -- credential data and client data for self attestation
    InvalidSignature Text
  | -- | The statement certificate cannot verify the signature over the attested
    -- credential data and client data for nonself attestation
    VerificationFailure X509.SignatureFailure
  | -- | The certificate does not meet the requirements layed out in the
    -- webauthn specification
    -- https://www.w3.org/TR/webauthn-2/#sctn-packed-attestation-cert-requirements
    CertificateRequirementsUnmet
  | -- | The AAGUID in the certificate extension does not match the AAGUID in
    -- the authenticator data
    CertificateAAGUIDMismatch
      { -- | AAGUID from the id-fido-gen-ce-aaguid certificate extension
        VerificationError -> AAGUID
certificateExtensionAAGUID :: AAGUID,
        -- | A AGUID from the attested credential data in the authenticator
        -- data
        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
        -- Self attestation
        Maybe (NonEmpty SignedCertificate, IdFidoGenCeAAGUID)
Nothing -> do
          -- Validate that alg matches the algorithm of the credentialPublicKey in authenticatorData.
          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

          -- Verify that sig is a valid signature over the concatenation of
          -- authenticatorData and clientDataHash using the credential public key with alg.
          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

        -- Basic, AttCA
        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
          -- Verify that sig is a valid signature over the concatenation of authenticatorData and clientDataHash using
          -- the attestation public key in attestnCert with the algorithm specified in alg.
          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

          -- Verify that attestnCert meets the requirements in § 8.2.1 Packed Attestation Statement Certificate
          -- Requirements.
          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

          -- If attestnCert contains an extension with OID 1.3.6.1.4.1.45724.1.1.4 (id-fido-gen-ce-aaguid) verify that
          -- the value of this extension matches the aaguid in authenticatorData.
          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

-- | Helper function that wraps the Packed format into the general
-- SomeAttestationStatementFormat type.
format :: M.SomeAttestationStatementFormat
format :: SomeAttestationStatementFormat
format = forall a.
AttestationStatementFormat a =>
a -> SomeAttestationStatementFormat
M.SomeAttestationStatementFormat Format
Format