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

-- | Stability: experimental
-- This module implements the
-- [Apple Anonymous Attestation Statement Format](https://www.w3.org/TR/webauthn-2/#sctn-apple-anonymous-attestation).
-- Note that this attestation statement format is currently not registered in the
-- [WebAuthn Attestation Statement Format Identifiers IANA registry](https://www.iana.org/assignments/webauthn/webauthn.xhtml#webauthn-attestation-statement-format-ids).
module Crypto.WebAuthn.AttestationStatementFormat.Apple
  ( format,
    Format (..),
    VerificationError (..),
  )
where

import qualified Codec.CBOR.Term as CBOR
import Control.Exception (Exception)
import Control.Monad (forM, unless)
import Crypto.Hash (Digest, SHA256, digestFromByteString, hash)
import qualified Crypto.WebAuthn.Cose.Internal.Verify as Cose
import qualified Crypto.WebAuthn.Cose.PublicKey as Cose
import qualified Crypto.WebAuthn.Cose.PublicKeyWithSignAlg as Cose
import Crypto.WebAuthn.Internal.Utils (failure)
import qualified Crypto.WebAuthn.Model.Types as M
import qualified Data.ASN1.Parse as ASN1
import qualified Data.ASN1.Types as ASN1
import Data.Aeson (ToJSON, object, toJSON, (.=))
import Data.Bifunctor (first)
import qualified Data.ByteArray as BA
import Data.FileEmbed (embedFile)
import Data.HashMap.Strict ((!?))
import Data.List.NonEmpty (NonEmpty ((:|)), toList)
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as Text
import qualified Data.X509 as X509
import qualified Data.X509.CertificateStore as X509

-- | The Apple format. The sole purpose of this type is to instantiate the
-- AttestationStatementFormat typeclass below.
data Format = Format

instance Show Format where
  show :: Format -> [Char]
show = Text -> [Char]
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AttestationStatementFormat a => a -> Text
M.asfIdentifier

-- | Verification errors specific to Apple attestation
data VerificationError
  = -- | The nonce found in the certificate extension does not match the
    -- expected nonce
    NonceMismatch
      { -- | The SHA256 hash of the concatenation of the @authenticatorData@
        -- and @clientDataHash@
        VerificationError -> Digest SHA256
calculatedNonce :: Digest SHA256,
        -- | The nonce from the Apple nonce certificate extension
        -- (1.2.840.113635.100.8.2)
        VerificationError -> Digest SHA256
receivedNonce :: Digest SHA256
      }
  | -- | The public Key found in the certificate does not match the
    -- credential's public key.
    PublicKeyMismatch
      { -- | The public key part of the credential data
        VerificationError -> PublicKey
credentialDataPublicKey :: Cose.PublicKey,
        -- | The public key extracted from the signed certificate
        VerificationError -> PublicKey
certificatePublicKey :: Cose.PublicKey
      }
  deriving (Int -> VerificationError -> ShowS
[VerificationError] -> ShowS
VerificationError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VerificationError] -> ShowS
$cshowList :: [VerificationError] -> ShowS
show :: VerificationError -> [Char]
$cshow :: VerificationError -> [Char]
showsPrec :: Int -> VerificationError -> ShowS
$cshowsPrec :: Int -> VerificationError -> ShowS
Show, Show VerificationError
Typeable VerificationError
SomeException -> Maybe VerificationError
VerificationError -> [Char]
VerificationError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> [Char])
-> Exception e
displayException :: VerificationError -> [Char]
$cdisplayException :: VerificationError -> [Char]
fromException :: SomeException -> Maybe VerificationError
$cfromException :: SomeException -> Maybe VerificationError
toException :: VerificationError -> SomeException
$ctoException :: VerificationError -> SomeException
Exception)

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-apple-anonymous-attestation)
-- We extend the statement to include values we would further have to decode
-- during the verification procedure.
data Statement = Statement
  { Statement -> NonEmpty SignedCertificate
x5c :: NE.NonEmpty X509.SignedCertificate,
    Statement -> Digest SHA256
sNonce :: Digest SHA256,
    Statement -> PublicKey
pubKey :: Cose.PublicKey
  }
  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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Statement] -> ShowS
$cshowList :: [Statement] -> ShowS
show :: Statement -> [Char]
$cshow :: Statement -> [Char]
showsPrec :: Int -> Statement -> ShowS
$cshowsPrec :: Int -> Statement -> ShowS
Show)

instance ToJSON Statement where
  toJSON :: Statement -> Value
toJSON Statement {NonEmpty SignedCertificate
Digest SHA256
PublicKey
pubKey :: PublicKey
sNonce :: Digest SHA256
x5c :: NonEmpty SignedCertificate
pubKey :: Statement -> PublicKey
sNonce :: Statement -> Digest SHA256
x5c :: Statement -> NonEmpty SignedCertificate
..} =
    [Pair] -> Value
object
      [ Key
"x5c" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty SignedCertificate
x5c
      ]

-- | Undocumented, but the Apple Nonce Extension should only contain the nonce
newtype AppleNonceExtension = AppleNonceExtension
  { AppleNonceExtension -> Digest SHA256
nonce :: Digest SHA256
  }
  deriving (AppleNonceExtension -> AppleNonceExtension -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AppleNonceExtension -> AppleNonceExtension -> Bool
$c/= :: AppleNonceExtension -> AppleNonceExtension -> Bool
== :: AppleNonceExtension -> AppleNonceExtension -> Bool
$c== :: AppleNonceExtension -> AppleNonceExtension -> Bool
Eq, Int -> AppleNonceExtension -> ShowS
[AppleNonceExtension] -> ShowS
AppleNonceExtension -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AppleNonceExtension] -> ShowS
$cshowList :: [AppleNonceExtension] -> ShowS
show :: AppleNonceExtension -> [Char]
$cshow :: AppleNonceExtension -> [Char]
showsPrec :: Int -> AppleNonceExtension -> ShowS
$cshowsPrec :: Int -> AppleNonceExtension -> ShowS
Show)

instance X509.Extension AppleNonceExtension where
  extOID :: AppleNonceExtension -> OID
extOID = forall a b. a -> b -> a
const [Integer
1, Integer
2, Integer
840, Integer
113635, Integer
100, Integer
8, Integer
2]
  extHasNestedASN1 :: Proxy AppleNonceExtension -> Bool
extHasNestedASN1 = forall a b. a -> b -> a
const Bool
False
  extEncode :: AppleNonceExtension -> [ASN1]
extEncode = forall a. HasCallStack => [Char] -> a
error [Char]
"extEncode for AppleNonceExtension is unimplemented"
  extDecode :: [ASN1] -> Either [Char] AppleNonceExtension
extDecode = forall a. ParseASN1 a -> [ASN1] -> Either [Char] a
ASN1.runParseASN1 ParseASN1 AppleNonceExtension
decode
    where
      decode :: ASN1.ParseASN1 AppleNonceExtension
      decode :: ParseASN1 AppleNonceExtension
decode = do
        ASN1.OctetString ByteString
nonce <-
          forall a. ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a
ASN1.onNextContainer ASN1ConstructionType
ASN1.Sequence forall a b. (a -> b) -> a -> b
$
            forall a. ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a
ASN1.onNextContainer (ASN1Class -> Int -> ASN1ConstructionType
ASN1.Container ASN1Class
ASN1.Context Int
1) ParseASN1 ASN1
ASN1.getNext
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"The nonce in the Extention was not a valid SHA256 hash")
          (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> AppleNonceExtension
AppleNonceExtension)
          (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString ByteString
nonce)

instance M.AttestationStatementFormat Format where
  type AttStmt Format = Statement
  asfIdentifier :: Format -> Text
asfIdentifier Format
_ = Text
"apple"

  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
"x5c" of
    Just (CBOR.TList (forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty -> Just NonEmpty Term
x5cRaw)) -> do
      x5c :: NonEmpty SignedCertificate
x5c@(SignedCertificate
credCert :| [SignedCertificate]
_) <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty Term
x5cRaw 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
. [Char] -> Text
Text.pack) (ByteString -> Either [Char] 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
<> [Char] -> Text
Text.pack (forall a. Show a => a -> [Char]
show Term
cert)

      let cert :: Certificate
cert = SignedCertificate -> Certificate
X509.getCertificate SignedCertificate
credCert

      PublicKey
pubKey <- PubKey -> Either Text PublicKey
Cose.fromX509 forall a b. (a -> b) -> a -> b
$ Certificate -> PubKey
X509.certPubKey Certificate
cert

      AppleNonceExtension {Digest SHA256
nonce :: Digest SHA256
nonce :: AppleNonceExtension -> Digest SHA256
..} <- case forall a. Extension a => Extensions -> Maybe (Either [Char] a)
X509.extensionGetE forall a b. (a -> b) -> a -> b
$ Certificate -> Extensions
X509.certExtensions Certificate
cert of
        Just (Right AppleNonceExtension
ext) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure AppleNonceExtension
ext
        Just (Left [Char]
err) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode certificate apple nonce extension: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
err
        Maybe (Either [Char] AppleNonceExtension)
Nothing -> forall a b. a -> Either a b
Left Text
"Certificate apple nonce extension is missing"

      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NonEmpty SignedCertificate
-> Digest SHA256 -> PublicKey -> Statement
Statement NonEmpty SignedCertificate
x5c Digest SHA256
nonce PublicKey
pubKey
    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 (x5c: nonempty list): " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. Show a => a -> [Char]
show HashMap Text Term
xs)

  asfEncode :: Format -> AttStmt Format -> Term
asfEncode Format
_ Statement {NonEmpty SignedCertificate
Digest SHA256
PublicKey
pubKey :: PublicKey
sNonce :: Digest SHA256
x5c :: NonEmpty SignedCertificate
pubKey :: Statement -> PublicKey
sNonce :: Statement -> Digest SHA256
x5c :: Statement -> NonEmpty SignedCertificate
..} =
    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
x5c
     in [(Term, Term)] -> Term
CBOR.TMap
          [ (Text -> Term
CBOR.TString Text
"x5c", [Term] -> Term
CBOR.TList [Term]
encodedx5c)
          ]

  type AttStmtVerificationError Format = VerificationError

  -- https://www.w3.org/TR/webauthn-2/#sctn-apple-anonymous-attestation
  asfVerify :: Format
-> DateTime
-> AttStmt Format
-> AuthenticatorData 'Registration 'True
-> ClientDataHash
-> Validation
     (NonEmpty (AttStmtVerificationError Format)) SomeAttestationType
asfVerify
    Format
_
    DateTime
_
    Statement {NonEmpty SignedCertificate
Digest SHA256
PublicKey
pubKey :: PublicKey
sNonce :: Digest SHA256
x5c :: NonEmpty SignedCertificate
pubKey :: Statement -> PublicKey
sNonce :: Statement -> Digest SHA256
x5c :: Statement -> NonEmpty SignedCertificate
..}
    M.AuthenticatorData {adAttestedCredentialData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AttestedCredentialData c raw
adAttestedCredentialData = AttestedCredentialData 'Registration 'True
credData, Maybe AuthenticatorExtensionOutputs
AuthenticatorDataFlags
SignatureCounter
RpIdHash
RawField 'True
adRawData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RawField raw
adExtensions :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> Maybe AuthenticatorExtensionOutputs
adSignCount :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> SignatureCounter
adFlags :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
adRpIdHash :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
adRawData :: RawField 'True
adExtensions :: Maybe AuthenticatorExtensionOutputs
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
..}
    ClientDataHash
clientDataHash = do
      -- 1. Let authenticatorData denote the authenticator data for the
      -- attestation, and let clientDataHash denote the hash of the serialized
      -- client data.
      -- NOTE: Done in decoding

      -- 2. Concatenate authenticatorData and clientDataHash to form
      -- nonceToHash.
      let nonceToHash :: ByteString
nonceToHash = RawField 'True -> ByteString
M.unRaw RawField 'True
adRawData forall a. Semigroup a => a -> a -> a
<> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (ClientDataHash -> Digest SHA256
M.unClientDataHash ClientDataHash
clientDataHash)

      -- 3. Perform SHA-256 hash of nonceToHash to produce nonce.
      let nonce :: Digest SHA256
nonce = forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash ByteString
nonceToHash

      -- 4. Verify that nonce equals the value of the extension with OID
      -- 1.2.840.113635.100.8.2 in credCert.
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Digest SHA256
nonce forall a. Eq a => a -> a -> Bool
== Digest SHA256
sNonce) 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
$ Digest SHA256 -> Digest SHA256 -> VerificationError
NonceMismatch Digest SHA256
nonce Digest SHA256
sNonce

      -- 5. Verify that the credential public key equals the Subject Public Key
      -- of credCert.
      let credentialPublicKey :: PublicKey
credentialPublicKey = PublicKeyWithSignAlg -> PublicKey
Cose.publicKey forall a b. (a -> b) -> a -> b
$ forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> PublicKeyWithSignAlg
M.acdCredentialPublicKey AttestedCredentialData 'Registration 'True
credData
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PublicKey
credentialPublicKey forall a. Eq a => a -> a -> Bool
== PublicKey
pubKey) 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
$ PublicKey -> PublicKey -> VerificationError
PublicKeyMismatch PublicKey
credentialPublicKey PublicKey
pubKey

      -- 6. If successful, return implementation-specific values representing
      -- attestation type Anonymization CA and attestation trust path x5c.
      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.VerifiableAttestationTypeAnonCA (NonEmpty SignedCertificate -> AttestationChain 'Fido2
M.Fido2Chain NonEmpty SignedCertificate
x5c)

  asfTrustAnchors :: Format -> VerifiableAttestationType -> CertificateStore
asfTrustAnchors Format
_ VerifiableAttestationType
_ = CertificateStore
rootCertificateStore

rootCertificateStore :: X509.CertificateStore
rootCertificateStore :: CertificateStore
rootCertificateStore = [SignedCertificate] -> CertificateStore
X509.makeCertificateStore [SignedCertificate
rootCertificate]

-- | The root certificate used for apple attestation formats
rootCertificate :: X509.SignedCertificate
rootCertificate :: SignedCertificate
rootCertificate = case ByteString -> Either [Char] SignedCertificate
X509.decodeSignedCertificate $(embedFile "root-certs/apple/Apple_WebAuthn_Root_CA.crt") of
  Left [Char]
err -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Error while decoding Apple root certificate: " forall a. Semigroup a => a -> a -> a
<> [Char]
err
  Right SignedCertificate
cert -> SignedCertificate
cert

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