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

-- | Stability: experimental
-- This module implements the
-- [FIDO U2F Attestation Statement Format](https://www.w3.org/TR/webauthn-2/#sctn-fido-u2f-attestation).
module Crypto.WebAuthn.AttestationStatementFormat.FidoU2F
  ( format,
    Format (..),
    VerificationError (..),
  )
where

import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Term as CBOR
import Control.Exception (Exception)
import Control.Monad (unless)
import Crypto.PubKey.ECC.Types (CurveName (SEC_p256r1))
import qualified Crypto.WebAuthn.Cose.PublicKeyWithSignAlg as Cose
import Crypto.WebAuthn.Internal.Utils (failure)
import qualified Crypto.WebAuthn.Model.Types as M
import Data.Aeson (ToJSON, object, toJSON, (.=))
import Data.Bifunctor (first)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.HashMap.Strict ((!?))
import qualified Data.Text as Text
import qualified Data.X509 as X509
import qualified Data.X509.EC as X509
import qualified Data.X509.Validation as X509

-- | The Fido U2F 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

-- | Verification errors specific to Fido U2F attestation
data VerificationError
  = -- | The public key in the certificate was not an EC Key or the curve was not the p256 curve
    CertificatePublicKeyInvalid X509.PubKey
  | -- | The COSE encoding of the credential public key does not have key type EC2
    CredentialPublicKeyNotCoseEC2 Cose.CosePublicKey
  | -- | The x and/or y coordinates of the credential public key are longer than 32 bytes
    CoordinateSizeInvalid
      { -- | Actual length in bytes of the x coordinate
        VerificationError -> Int
xLength :: Int,
        -- | Actual length in bytes of the y coordinate
        VerificationError -> Int
yLength :: Int
      }
  | -- | The provided public key cannot validate the signature over the verification data
    SignatureInvalid X509.SignatureFailure
  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)

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-fido-u2f-attestation)
data Statement = Statement
  { Statement -> ByteString
sig :: BS.ByteString,
    Statement -> SignedCertificate
attCert :: X509.SignedCertificate
  }
  deriving (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, 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)

instance ToJSON Statement where
  toJSON :: Statement -> Value
toJSON Statement {ByteString
SignedCertificate
attCert :: SignedCertificate
sig :: ByteString
attCert :: Statement -> SignedCertificate
sig :: Statement -> ByteString
..} =
    [Pair] -> Value
object
      [ Key
"attestnCert" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= SignedCertificate
attCert,
        Key
"sig" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString
sig
      ]

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

  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
"sig", HashMap Text Term
xs forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"x5c") of
    (Just (CBOR.TBytes ByteString
sig), Just (CBOR.TList [CBOR.TBytes ByteString
certBytes])) -> do
      SignedCertificate
attCert <- 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)
      pure $ ByteString -> SignedCertificate -> Statement
Statement ByteString
sig SignedCertificate
attCert
    (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 (sig: bytes, x5c: one-element 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 {ByteString
SignedCertificate
attCert :: SignedCertificate
sig :: ByteString
attCert :: Statement -> SignedCertificate
sig :: Statement -> ByteString
..} =
    [(Term, Term)] -> Term
CBOR.TMap
      [ (Text -> Term
CBOR.TString Text
"sig", ByteString -> Term
CBOR.TBytes ByteString
sig),
        (Text -> Term
CBOR.TString Text
"x5c", [Term] -> Term
CBOR.TList [ByteString -> Term
CBOR.TBytes forall a b. (a -> b) -> a -> b
$ forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> ByteString
X509.encodeSignedObject SignedCertificate
attCert])
      ]

  type AttStmtVerificationError Format = VerificationError

  asfVerify :: Format
-> DateTime
-> AttStmt Format
-> AuthenticatorData 'Registration 'True
-> ClientDataHash
-> Validation
     (NonEmpty (AttStmtVerificationError Format)) SomeAttestationType
asfVerify
    Format
_
    DateTime
_
    Statement {ByteString
SignedCertificate
attCert :: SignedCertificate
sig :: ByteString
attCert :: Statement -> SignedCertificate
sig :: Statement -> ByteString
..}
    M.AuthenticatorData
      { adAttestedCredentialData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AttestedCredentialData c raw
M.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
..},
        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. Verify that attStmt is valid CBOR conforming to the syntax defined above
      -- and perform CBOR decoding on it to extract the contained fields.
      -- NOTE: The validity of the data is already checked during decoding.

      -- 2.a Check that x5c has exactly one element and let attCert be that element.
      -- NOTE: This has already been done during decoding

      -- 2.b Let certificate public key be the public key conveyed by attCert. If
      -- certificate public key is not an Elliptic Curve (EC) public key over the
      -- P-256 curve, terminate this algorithm and return an appropriate error.
      let certPubKey :: PubKey
certPubKey = Certificate -> PubKey
X509.certPubKey forall a b. (a -> b) -> a -> b
$ SignedCertificate -> Certificate
X509.getCertificate SignedCertificate
attCert
      case PubKey
certPubKey of
        X509.PubKeyEC PubKeyEC
pk ->
          case PubKeyEC -> Maybe CurveName
X509.ecPubKeyCurveName PubKeyEC
pk of
            Just CurveName
SEC_p256r1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Maybe CurveName
_ -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ PubKey -> VerificationError
CertificatePublicKeyInvalid PubKey
certPubKey
        PubKey
_ -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ PubKey -> VerificationError
CertificatePublicKeyInvalid PubKey
certPubKey

      -- 3. Extract the claimed rpIdHash from authenticatorData, and the claimed
      -- credentialId and credentialPublicKey from authenticatorData.attestedCredentialData.
      -- NOTE: Done in patternmatch

      -- 4. Convert the COSE_KEY formatted credentialPublicKey (see Section 7 of
      -- [RFC8152]) to Raw ANSI X9.62 public key format (see ALG_KEY_ECC_X962_RAW in
      -- Section 3.6.2 Public Key Representation Formats of [FIDO-Registry]).

      -- 4.a Let x be the value corresponding to the "-2" key (representing x
      -- coordinate) in credentialPublicKey, and confirm its size to be of 32 bytes.
      -- If size differs or "-2" key is not found, terminate this algorithm and
      -- return an appropriate error.
      -- 4.b Let y be the value corresponding to the "-3" key (representing y
      -- coordinate) in credentialPublicKey, and confirm its size to be of 32 bytes.
      -- If size differs or "-3" key is not found, terminate this algorithm and
      -- return an appropriate error.
      -- NOTE: Already done during decoding of the COSE public key
      case ByteString -> Maybe (ByteString, ByteString)
extractPublicKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawField 'True -> ByteString
M.unRaw forall a b. (a -> b) -> a -> b
$ RawField 'True
acdCredentialPublicKeyBytes of
        Maybe (ByteString, ByteString)
Nothing -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ CosePublicKey -> VerificationError
CredentialPublicKeyNotCoseEC2 CosePublicKey
acdCredentialPublicKey
        Just (ByteString
xb, ByteString
yb) -> do
          -- We decode the x and y values in an earlier stage of the process. In order to construct the publicKeyU2F, we have to reencode the value.
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int
BS.length ByteString
xb forall a. Eq a => a -> a -> Bool
== Int
32 Bool -> Bool -> Bool
&& ByteString -> Int
BS.length ByteString
yb forall a. Eq a => a -> a -> Bool
== Int
32) forall a b. (a -> b) -> a -> b
$
            forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$
              Int -> Int -> VerificationError
CoordinateSizeInvalid (ByteString -> Int
BS.length ByteString
xb) (ByteString -> Int
BS.length ByteString
yb)
          -- 4.c Let publicKeyU2F be the concatenation 0x04 || x || y.
          let publicKeyU2F :: ByteString
publicKeyU2F = Word8 -> ByteString
BS.singleton Word8
0x04 forall a. Semigroup a => a -> a -> a
<> ByteString
xb forall a. Semigroup a => a -> a -> a
<> ByteString
yb

          -- 5. Let verificationData be the concatenation of (0x00 || rpIdHash ||
          -- clientDataHash || credentialId || publicKeyU2F) (see Section 4.3 of
          -- [FIDO-U2F-Message-Formats]).
          let credId :: ByteString
credId = CredentialId -> ByteString
M.unCredentialId CredentialId
acdCredentialId
              verificationData :: ByteString
verificationData =
                Word8 -> ByteString
BS.singleton Word8
0x00
                  forall a. Semigroup a => a -> a -> a
<> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (RpIdHash -> Digest SHA256
M.unRpIdHash RpIdHash
adRpIdHash)
                  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)
                  forall a. Semigroup a => a -> a -> a
<> ByteString
credId
                  forall a. Semigroup a => a -> a -> a
<> ByteString
publicKeyU2F

          -- 6. Verify the sig using verificationData and the certificate public key per
          -- section 4.1.4 of [SEC1] with SHA-256 as the hash function used in step two.
          case SignatureALG
-> PubKey -> ByteString -> ByteString -> SignatureVerification
X509.verifySignature (HashALG -> PubKeyALG -> SignatureALG
X509.SignatureALG HashALG
X509.HashSHA256 PubKeyALG
X509.PubKeyALG_EC) PubKey
certPubKey ByteString
verificationData ByteString
sig of
            SignatureVerification
X509.SignaturePass -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            X509.SignatureFailed SignatureFailure
e -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ SignatureFailure -> VerificationError
SignatureInvalid SignatureFailure
e
          pure ()

      -- 7. Optionally, inspect x5c and consult externally provided knowledge to
      -- determine whether attStmt conveys a Basic or AttCA attestation.
      -- 8. If successful, return implementation-specific values representing
      -- attestation type Basic, AttCA or uncertainty, 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.VerifiableAttestationTypeUncertain (SignedCertificate -> AttestationChain 'FidoU2F
M.FidoU2FCert SignedCertificate
attCert)

  asfTrustAnchors :: Format -> VerifiableAttestationType -> CertificateStore
asfTrustAnchors Format
_ VerifiableAttestationType
_ = forall a. Monoid a => a
mempty

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

-- [(spec)](https://www.iana.org/assignments/cose/cose.xhtml)
-- This function assumes the provided key is an ECC key, which is a valid
-- assumption as we have already verified that in step 2.b
-- Any non ECC key would result in another error here, which is fine.
extractPublicKey :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)
extractPublicKey :: ByteString -> Maybe (ByteString, ByteString)
extractPublicKey ByteString
keyBS = do
  (ByteString
rest, Term
result) <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes forall s. Decoder s Term
CBOR.decodeTerm forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
keyBS
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
LBS.null ByteString
rest) forall a. Maybe a
Nothing
  [(Term, Term)]
pairs <- case Term
result of
    CBOR.TMap [(Term, Term)]
pairs -> forall (m :: * -> *) a. Monad m => a -> m a
return [(Term, Term)]
pairs
    Term
_ -> forall a. Maybe a
Nothing
  let xKey :: Int
xKey = -Int
2
  let yKey :: Int
yKey = -Int
3
  case (Int -> Term
CBOR.TInt Int
xKey forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Term, Term)]
pairs, Int -> Term
CBOR.TInt Int
yKey forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Term, Term)]
pairs) of
    (Just (CBOR.TBytes ByteString
x), Just (CBOR.TBytes ByteString
y)) -> do
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
x, ByteString
y)
    (Maybe Term, Maybe Term)
_ -> forall a. Maybe a
Nothing