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

-- | Stability: experimental
-- This module implements the
-- [TPM Attestation Statement Format](https://www.w3.org/TR/webauthn-2/#sctn-tpm-attestation).
module Crypto.WebAuthn.AttestationStatementFormat.TPM
  ( format,
    Format (..),
    VerificationError (..),
    -- Exported because it's part of an error constructor
    TPMAlgId (..),
  )
where

import qualified Codec.CBOR.Term as CBOR
import Control.Exception (Exception)
import Control.Monad (forM, unless, when)
import Crypto.Hash (SHA1 (SHA1), SHA256 (SHA256), hashWith)
import qualified Crypto.Hash as Hash
import Crypto.Number.Serialize (os2ip)
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 qualified Crypto.WebAuthn.Cose.SignAlg as Cose
import Crypto.WebAuthn.Internal.Utils (IdFidoGenCeAAGUID (IdFidoGenCeAAGUID), failure)
import Crypto.WebAuthn.Model.Identifier (AAGUID)
import qualified Crypto.WebAuthn.Model.Types as M
import Data.ASN1.Error (ASN1Error)
import Data.ASN1.OID (OID)
import Data.ASN1.Parse (ParseASN1, getNext, hasNext, runParseASN1)
import Data.ASN1.Prim (ASN1 (ASN1String, OID))
import Data.Aeson (ToJSON, Value (String), object, toJSON, (.=))
import Data.Bifunctor (Bifunctor (first))
import Data.Binary (Word16, Word32, Word64)
import qualified Data.Binary.Get as Get
import qualified Data.Binary.Put as Put
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.FileEmbed (embedDir)
import Data.HashMap.Strict ((!?))
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8)
import qualified Data.X509 as X509
import qualified Data.X509.CertificateStore as X509
import GHC.Generics (Generic)

tpmManufacturers :: Set.Set Text
tpmManufacturers :: Set Text
tpmManufacturers =
  forall a. Ord a => [a] -> Set a
Set.fromList
    [ Text
"id:FFFFF1D0", -- FIDO testing TPM
    -- From https://trustedcomputinggroup.org/wp-content/uploads/TCG-TPM-Vendor-ID-Registry-Version-1.02-Revision-1.00.pdf
      Text
"id:414D4400", -- 'AMD'  AMD
      Text
"id:41544D4C", -- 'ATML' Atmel
      Text
"id:4252434D", -- 'BRCM' Broadcom
      Text
"id:4353434F", -- 'CSCO' Cisco
      Text
"id:464C5953", -- 'FLYS' Flyslice Technologies
      Text
"id:48504500", -- 'HPE'  HPE
      Text
"id:49424d00", -- 'IBM'  IBM
      Text
"id:49465800", -- 'IFX'  Infineon
      Text
"id:494E5443", -- 'INTC' Intel
      Text
"id:4C454E00", -- 'LEN'  Lenovo
      Text
"id:4D534654", -- 'MSFT' Microsoft
      Text
"id:4E534D20", -- 'NSM'  National Semiconductor
      Text
"id:4E545A00", -- 'NTZ'  Nationz
      Text
"id:4E544300", -- 'NTC'  Nuvoton Technology
      Text
"id:51434F4D", -- 'QCOM' Qualcomm
      Text
"id:534D5343", -- 'SMSC' SMSC
      Text
"id:53544D20", -- 'STM ' ST Microelectronics
      Text
"id:534D534E", -- 'SMSN' Samsung
      Text
"id:534E5300", -- 'SNS'  Sinosun
      Text
"id:54584E00", -- 'TXN'  Texas Instruments
      Text
"id:57454300", -- 'WEC'  Winbond
      Text
"id:524F4343", -- 'ROCC' Fuzhou Rockchip
      Text
"id:474F4F47" -- 'GOOG'  Google
    ]

-- | [(spec)](https://trustedcomputinggroup.org/wp-content/uploads/TCG-_Algorithm_Registry_r1p32_pub.pdf)
data TPMAlgId = TPMAlgRSA | TPMAlgSHA1 | TPMAlgSHA256 | TPMAlgECC
  deriving (Int -> TPMAlgId -> ShowS
[TPMAlgId] -> ShowS
TPMAlgId -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TPMAlgId] -> ShowS
$cshowList :: [TPMAlgId] -> ShowS
show :: TPMAlgId -> [Char]
$cshow :: TPMAlgId -> [Char]
showsPrec :: Int -> TPMAlgId -> ShowS
$cshowsPrec :: Int -> TPMAlgId -> ShowS
Show, TPMAlgId -> TPMAlgId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TPMAlgId -> TPMAlgId -> Bool
$c/= :: TPMAlgId -> TPMAlgId -> Bool
== :: TPMAlgId -> TPMAlgId -> Bool
$c== :: TPMAlgId -> TPMAlgId -> Bool
Eq, forall x. Rep TPMAlgId x -> TPMAlgId
forall x. TPMAlgId -> Rep TPMAlgId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TPMAlgId x -> TPMAlgId
$cfrom :: forall x. TPMAlgId -> Rep TPMAlgId x
Generic, [TPMAlgId] -> Encoding
[TPMAlgId] -> Value
TPMAlgId -> Encoding
TPMAlgId -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TPMAlgId] -> Encoding
$ctoEncodingList :: [TPMAlgId] -> Encoding
toJSONList :: [TPMAlgId] -> Value
$ctoJSONList :: [TPMAlgId] -> Value
toEncoding :: TPMAlgId -> Encoding
$ctoEncoding :: TPMAlgId -> Encoding
toJSON :: TPMAlgId -> Value
$ctoJSON :: TPMAlgId -> Value
ToJSON)

-- | [(spec)](https://trustedcomputinggroup.org/wp-content/uploads/TCG-_Algorithm_Registry_r1p32_pub.pdf)
toTPMAlgId :: MonadFail m => Word16 -> m TPMAlgId
toTPMAlgId :: forall (m :: * -> *). MonadFail m => Word16 -> m TPMAlgId
toTPMAlgId Word16
0x0001 = forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgRSA
toTPMAlgId Word16
0x0004 = forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgSHA1
toTPMAlgId Word16
0x000B = forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgSHA256
toTPMAlgId Word16
0x0023 = forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgECC
toTPMAlgId Word16
_ = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unsupported or invalid TPM_ALD_IG"

-- | [(spec)](https://trustedcomputinggroup.org/wp-content/uploads/TCG-_Algorithm_Registry_r1p32_pub.pdf)
toCurveId :: MonadFail m => Word16 -> m Cose.CoseCurveECDSA
toCurveId :: forall (m :: * -> *). MonadFail m => Word16 -> m CoseCurveECDSA
toCurveId Word16
0x0003 = forall (f :: * -> *) a. Applicative f => a -> f a
pure CoseCurveECDSA
Cose.CoseCurveP256
toCurveId Word16
0x0004 = forall (f :: * -> *) a. Applicative f => a -> f a
pure CoseCurveECDSA
Cose.CoseCurveP384
toCurveId Word16
0x0005 = forall (f :: * -> *) a. Applicative f => a -> f a
pure CoseCurveECDSA
Cose.CoseCurveP521
toCurveId Word16
_ = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unsupported Curve ID"

-- | [(spec)](https://trustedcomputinggroup.org/wp-content/uploads/TCG_TPM2_r1p59_Part2_Structures_pub.pdf)
tpmGeneratedValue :: Word32
tpmGeneratedValue :: TPMAObject
tpmGeneratedValue = TPMAObject
0xff544347

-- | [(spec)](https://trustedcomputinggroup.org/wp-content/uploads/TCG_TPM2_r1p59_Part2_Structures_pub.pdf)
tpmStAttestCertify :: Word16
tpmStAttestCertify :: Word16
tpmStAttestCertify = Word16
0x8017

-- | The TPMS_CLOCK_INFO structure as specified in [TPMv2-Part2](https://www.trustedcomputinggroup.org/wp-content/uploads/TPM-Rev-2.0-Part-2-Structures-01.38.pdf)
-- section 10.11.1.
data TPMSClockInfo = TPMSClockInfo
  { TPMSClockInfo -> Word64
tpmsciClock :: Word64,
    TPMSClockInfo -> TPMAObject
tpmsciResetCount :: Word32,
    TPMSClockInfo -> TPMAObject
tpmsciRestartCount :: Word32,
    TPMSClockInfo -> Bool
tpmsciSafe :: Bool
  }
  deriving (TPMSClockInfo -> TPMSClockInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TPMSClockInfo -> TPMSClockInfo -> Bool
$c/= :: TPMSClockInfo -> TPMSClockInfo -> Bool
== :: TPMSClockInfo -> TPMSClockInfo -> Bool
$c== :: TPMSClockInfo -> TPMSClockInfo -> Bool
Eq, Int -> TPMSClockInfo -> ShowS
[TPMSClockInfo] -> ShowS
TPMSClockInfo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TPMSClockInfo] -> ShowS
$cshowList :: [TPMSClockInfo] -> ShowS
show :: TPMSClockInfo -> [Char]
$cshow :: TPMSClockInfo -> [Char]
showsPrec :: Int -> TPMSClockInfo -> ShowS
$cshowsPrec :: Int -> TPMSClockInfo -> ShowS
Show, forall x. Rep TPMSClockInfo x -> TPMSClockInfo
forall x. TPMSClockInfo -> Rep TPMSClockInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TPMSClockInfo x -> TPMSClockInfo
$cfrom :: forall x. TPMSClockInfo -> Rep TPMSClockInfo x
Generic, [TPMSClockInfo] -> Encoding
[TPMSClockInfo] -> Value
TPMSClockInfo -> Encoding
TPMSClockInfo -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TPMSClockInfo] -> Encoding
$ctoEncodingList :: [TPMSClockInfo] -> Encoding
toJSONList :: [TPMSClockInfo] -> Value
$ctoJSONList :: [TPMSClockInfo] -> Value
toEncoding :: TPMSClockInfo -> Encoding
$ctoEncoding :: TPMSClockInfo -> Encoding
toJSON :: TPMSClockInfo -> Value
$ctoJSON :: TPMSClockInfo -> Value
ToJSON)

-- | The TPMS_CERTIFY_INFO structure as specified in [TPMv2-Part2](https://www.trustedcomputinggroup.org/wp-content/uploads/TPM-Rev-2.0-Part-2-Structures-01.38.pdf)
-- section 10.12.3.
data TPMSCertifyInfo = TPMSCertifyInfo
  { TPMSCertifyInfo -> ByteString
tpmsciName :: BS.ByteString,
    TPMSCertifyInfo -> ByteString
tpmsciQualifiedName :: BS.ByteString
  }
  deriving (TPMSCertifyInfo -> TPMSCertifyInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TPMSCertifyInfo -> TPMSCertifyInfo -> Bool
$c/= :: TPMSCertifyInfo -> TPMSCertifyInfo -> Bool
== :: TPMSCertifyInfo -> TPMSCertifyInfo -> Bool
$c== :: TPMSCertifyInfo -> TPMSCertifyInfo -> Bool
Eq, Int -> TPMSCertifyInfo -> ShowS
[TPMSCertifyInfo] -> ShowS
TPMSCertifyInfo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TPMSCertifyInfo] -> ShowS
$cshowList :: [TPMSCertifyInfo] -> ShowS
show :: TPMSCertifyInfo -> [Char]
$cshow :: TPMSCertifyInfo -> [Char]
showsPrec :: Int -> TPMSCertifyInfo -> ShowS
$cshowsPrec :: Int -> TPMSCertifyInfo -> ShowS
Show, forall x. Rep TPMSCertifyInfo x -> TPMSCertifyInfo
forall x. TPMSCertifyInfo -> Rep TPMSCertifyInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TPMSCertifyInfo x -> TPMSCertifyInfo
$cfrom :: forall x. TPMSCertifyInfo -> Rep TPMSCertifyInfo x
Generic, [TPMSCertifyInfo] -> Encoding
[TPMSCertifyInfo] -> Value
TPMSCertifyInfo -> Encoding
TPMSCertifyInfo -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TPMSCertifyInfo] -> Encoding
$ctoEncodingList :: [TPMSCertifyInfo] -> Encoding
toJSONList :: [TPMSCertifyInfo] -> Value
$ctoJSONList :: [TPMSCertifyInfo] -> Value
toEncoding :: TPMSCertifyInfo -> Encoding
$ctoEncoding :: TPMSCertifyInfo -> Encoding
toJSON :: TPMSCertifyInfo -> Value
$ctoJSON :: TPMSCertifyInfo -> Value
ToJSON)

-- | The TPMS_ATTEST structure as specified in
-- [TPMv2-Part2](https://www.trustedcomputinggroup.org/wp-content/uploads/TPM-Rev-2.0-Part-2-Structures-01.38.pdf)
-- section 10.12.8.
data TPMSAttest = TPMSAttest
  { TPMSAttest -> TPMAObject
tpmsaMagic :: Word32,
    TPMSAttest -> Word16
tpmsaType :: Word16,
    TPMSAttest -> ByteString
tpmsaQualifiedSigner :: BS.ByteString,
    TPMSAttest -> ByteString
tpmsaExtraData :: BS.ByteString,
    TPMSAttest -> TPMSClockInfo
tpmsaClockInfo :: TPMSClockInfo,
    TPMSAttest -> Word64
tpmsaFirmwareVersion :: Word64,
    TPMSAttest -> TPMSCertifyInfo
tpmsaAttested :: TPMSCertifyInfo
  }
  deriving (TPMSAttest -> TPMSAttest -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TPMSAttest -> TPMSAttest -> Bool
$c/= :: TPMSAttest -> TPMSAttest -> Bool
== :: TPMSAttest -> TPMSAttest -> Bool
$c== :: TPMSAttest -> TPMSAttest -> Bool
Eq, Int -> TPMSAttest -> ShowS
[TPMSAttest] -> ShowS
TPMSAttest -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TPMSAttest] -> ShowS
$cshowList :: [TPMSAttest] -> ShowS
show :: TPMSAttest -> [Char]
$cshow :: TPMSAttest -> [Char]
showsPrec :: Int -> TPMSAttest -> ShowS
$cshowsPrec :: Int -> TPMSAttest -> ShowS
Show, forall x. Rep TPMSAttest x -> TPMSAttest
forall x. TPMSAttest -> Rep TPMSAttest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TPMSAttest x -> TPMSAttest
$cfrom :: forall x. TPMSAttest -> Rep TPMSAttest x
Generic, [TPMSAttest] -> Encoding
[TPMSAttest] -> Value
TPMSAttest -> Encoding
TPMSAttest -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TPMSAttest] -> Encoding
$ctoEncodingList :: [TPMSAttest] -> Encoding
toJSONList :: [TPMSAttest] -> Value
$ctoJSONList :: [TPMSAttest] -> Value
toEncoding :: TPMSAttest -> Encoding
$ctoEncoding :: TPMSAttest -> Encoding
toJSON :: TPMSAttest -> Value
$ctoJSON :: TPMSAttest -> Value
ToJSON)

-- | The TPMA_OBJECT structure as specified in
-- [TPMv2-Part2](https://www.trustedcomputinggroup.org/wp-content/uploads/TPM-Rev-2.0-Part-2-Structures-01.38.pdf)
-- section 8.3
type TPMAObject = Word32

-- | The TPMU_PUBLIC_PARMS structure as specified in
-- [TPMv2-Part2](https://www.trustedcomputinggroup.org/wp-content/uploads/TPM-Rev-2.0-Part-2-Structures-01.38.pdf)
-- section 12.2.3.7.
data TPMUPublicParms
  = TPMSRSAParms
      { TPMUPublicParms -> Word16
tpmsrpSymmetric :: Word16,
        TPMUPublicParms -> Word16
tpmsrpScheme :: Word16,
        TPMUPublicParms -> Word16
tpmsrpKeyBits :: Word16,
        TPMUPublicParms -> TPMAObject
tpmsrpExponent :: Word32
      }
  | TPMSECCParms
      { TPMUPublicParms -> Word16
tpmsepSymmetric :: Word16,
        TPMUPublicParms -> Word16
tpmsepScheme :: Word16,
        TPMUPublicParms -> CoseCurveECDSA
tpmsepCurveId :: Cose.CoseCurveECDSA,
        TPMUPublicParms -> Word16
tpmsepkdf :: Word16
      }
  deriving (TPMUPublicParms -> TPMUPublicParms -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TPMUPublicParms -> TPMUPublicParms -> Bool
$c/= :: TPMUPublicParms -> TPMUPublicParms -> Bool
== :: TPMUPublicParms -> TPMUPublicParms -> Bool
$c== :: TPMUPublicParms -> TPMUPublicParms -> Bool
Eq, Int -> TPMUPublicParms -> ShowS
[TPMUPublicParms] -> ShowS
TPMUPublicParms -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TPMUPublicParms] -> ShowS
$cshowList :: [TPMUPublicParms] -> ShowS
show :: TPMUPublicParms -> [Char]
$cshow :: TPMUPublicParms -> [Char]
showsPrec :: Int -> TPMUPublicParms -> ShowS
$cshowsPrec :: Int -> TPMUPublicParms -> ShowS
Show, forall x. Rep TPMUPublicParms x -> TPMUPublicParms
forall x. TPMUPublicParms -> Rep TPMUPublicParms x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TPMUPublicParms x -> TPMUPublicParms
$cfrom :: forall x. TPMUPublicParms -> Rep TPMUPublicParms x
Generic, [TPMUPublicParms] -> Encoding
[TPMUPublicParms] -> Value
TPMUPublicParms -> Encoding
TPMUPublicParms -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TPMUPublicParms] -> Encoding
$ctoEncodingList :: [TPMUPublicParms] -> Encoding
toJSONList :: [TPMUPublicParms] -> Value
$ctoJSONList :: [TPMUPublicParms] -> Value
toEncoding :: TPMUPublicParms -> Encoding
$ctoEncoding :: TPMUPublicParms -> Encoding
toJSON :: TPMUPublicParms -> Value
$ctoJSON :: TPMUPublicParms -> Value
ToJSON)

-- | The TPMU_PUBLIC_ID structure as specified in
-- [TPMv2-Part2](https://www.trustedcomputinggroup.org/wp-content/uploads/TPM-Rev-2.0-Part-2-Structures-01.38.pdf)
-- section 12.2.3.2.
data TPMUPublicId
  = TPM2BPublicKeyRSA BS.ByteString
  | TPMSECCPoint
      { TPMUPublicId -> ByteString
tpmseX :: BS.ByteString,
        TPMUPublicId -> ByteString
tpmseY :: BS.ByteString
      }
  deriving (TPMUPublicId -> TPMUPublicId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TPMUPublicId -> TPMUPublicId -> Bool
$c/= :: TPMUPublicId -> TPMUPublicId -> Bool
== :: TPMUPublicId -> TPMUPublicId -> Bool
$c== :: TPMUPublicId -> TPMUPublicId -> Bool
Eq, Int -> TPMUPublicId -> ShowS
[TPMUPublicId] -> ShowS
TPMUPublicId -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TPMUPublicId] -> ShowS
$cshowList :: [TPMUPublicId] -> ShowS
show :: TPMUPublicId -> [Char]
$cshow :: TPMUPublicId -> [Char]
showsPrec :: Int -> TPMUPublicId -> ShowS
$cshowsPrec :: Int -> TPMUPublicId -> ShowS
Show, forall x. Rep TPMUPublicId x -> TPMUPublicId
forall x. TPMUPublicId -> Rep TPMUPublicId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TPMUPublicId x -> TPMUPublicId
$cfrom :: forall x. TPMUPublicId -> Rep TPMUPublicId x
Generic, [TPMUPublicId] -> Encoding
[TPMUPublicId] -> Value
TPMUPublicId -> Encoding
TPMUPublicId -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TPMUPublicId] -> Encoding
$ctoEncodingList :: [TPMUPublicId] -> Encoding
toJSONList :: [TPMUPublicId] -> Value
$ctoJSONList :: [TPMUPublicId] -> Value
toEncoding :: TPMUPublicId -> Encoding
$ctoEncoding :: TPMUPublicId -> Encoding
toJSON :: TPMUPublicId -> Value
$ctoJSON :: TPMUPublicId -> Value
ToJSON)

-- | The TPMT_PUBLIC structure (see [TPMv2-Part2](https://www.trustedcomputinggroup.org/wp-content/uploads/TPM-Rev-2.0-Part-2-Structures-01.38.pdf) section 12.2.4) used by the TPM to represent the credential public key.
data TPMTPublic = TPMTPublic
  { TPMTPublic -> TPMAlgId
tpmtpType :: TPMAlgId,
    TPMTPublic -> TPMAlgId
tpmtpNameAlg :: TPMAlgId,
    TPMTPublic -> Word16
tpmtpNameAlgRaw :: Word16,
    TPMTPublic -> TPMAObject
tpmtpObjectAttributes :: TPMAObject,
    TPMTPublic -> ByteString
tpmtpAuthPolicy :: BS.ByteString,
    TPMTPublic -> TPMUPublicParms
tpmtpParameters :: TPMUPublicParms,
    TPMTPublic -> TPMUPublicId
tpmtpUnique :: TPMUPublicId
  }
  deriving (TPMTPublic -> TPMTPublic -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TPMTPublic -> TPMTPublic -> Bool
$c/= :: TPMTPublic -> TPMTPublic -> Bool
== :: TPMTPublic -> TPMTPublic -> Bool
$c== :: TPMTPublic -> TPMTPublic -> Bool
Eq, Int -> TPMTPublic -> ShowS
[TPMTPublic] -> ShowS
TPMTPublic -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TPMTPublic] -> ShowS
$cshowList :: [TPMTPublic] -> ShowS
show :: TPMTPublic -> [Char]
$cshow :: TPMTPublic -> [Char]
showsPrec :: Int -> TPMTPublic -> ShowS
$cshowsPrec :: Int -> TPMTPublic -> ShowS
Show, forall x. Rep TPMTPublic x -> TPMTPublic
forall x. TPMTPublic -> Rep TPMTPublic x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TPMTPublic x -> TPMTPublic
$cfrom :: forall x. TPMTPublic -> Rep TPMTPublic x
Generic, [TPMTPublic] -> Encoding
[TPMTPublic] -> Value
TPMTPublic -> Encoding
TPMTPublic -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TPMTPublic] -> Encoding
$ctoEncodingList :: [TPMTPublic] -> Encoding
toJSONList :: [TPMTPublic] -> Value
$ctoJSONList :: [TPMTPublic] -> Value
toEncoding :: TPMTPublic -> Encoding
$ctoEncoding :: TPMTPublic -> Encoding
toJSON :: TPMTPublic -> Value
$ctoJSON :: TPMTPublic -> Value
ToJSON)

-- | The TPM 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

-- | TPM Subject Alternative Name as described in section 3.2.9 [here](https://www.trustedcomputinggroup.org/wp-content/uploads/Credential_Profile_EK_V2.0_R14_published.pdf)
data SubjectAlternativeName = SubjectAlternativeName
  { SubjectAlternativeName -> Text
tpmManufacturer :: Text,
    SubjectAlternativeName -> Text
tpmModel :: Text,
    SubjectAlternativeName -> Text
tpmVersion :: Text
  }
  deriving (SubjectAlternativeName -> SubjectAlternativeName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubjectAlternativeName -> SubjectAlternativeName -> Bool
$c/= :: SubjectAlternativeName -> SubjectAlternativeName -> Bool
== :: SubjectAlternativeName -> SubjectAlternativeName -> Bool
$c== :: SubjectAlternativeName -> SubjectAlternativeName -> Bool
Eq, Int -> SubjectAlternativeName -> ShowS
[SubjectAlternativeName] -> ShowS
SubjectAlternativeName -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SubjectAlternativeName] -> ShowS
$cshowList :: [SubjectAlternativeName] -> ShowS
show :: SubjectAlternativeName -> [Char]
$cshow :: SubjectAlternativeName -> [Char]
showsPrec :: Int -> SubjectAlternativeName -> ShowS
$cshowsPrec :: Int -> SubjectAlternativeName -> ShowS
Show)

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-tpm-attestation)
data Statement = Statement
  { Statement -> NonEmpty SignedCertificate
x5c :: NE.NonEmpty X509.SignedCertificate,
    Statement -> Certificate
aikCert :: X509.Certificate,
    -- Combined aikCert public key and the "alg" statement key
    Statement -> PublicKeyWithSignAlg
aikPubKeyAndAlg :: Cose.PublicKeyWithSignAlg,
    Statement -> SubjectAlternativeName
subjectAlternativeName :: SubjectAlternativeName,
    Statement -> Maybe IdFidoGenCeAAGUID
aaguidExt :: Maybe IdFidoGenCeAAGUID,
    Statement -> [ExtKeyUsagePurpose]
extendedKeyUsage :: [X509.ExtKeyUsagePurpose],
    Statement -> Bool
basicConstraintsCA :: Bool,
    Statement -> ByteString
sig :: BS.ByteString,
    Statement -> TPMSAttest
certInfo :: TPMSAttest,
    Statement -> ByteString
certInfoRaw :: BS.ByteString,
    Statement -> TPMTPublic
pubArea :: TPMTPublic,
    Statement -> ByteString
pubAreaRaw :: BS.ByteString,
    Statement -> PublicKey
pubAreaKey :: 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 {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
NonEmpty SignedCertificate
ByteString
Certificate
PublicKey
PublicKeyWithSignAlg
SubjectAlternativeName
TPMTPublic
TPMSAttest
pubAreaKey :: PublicKey
pubAreaRaw :: ByteString
pubArea :: TPMTPublic
certInfoRaw :: ByteString
certInfo :: TPMSAttest
sig :: ByteString
basicConstraintsCA :: Bool
extendedKeyUsage :: [ExtKeyUsagePurpose]
aaguidExt :: Maybe IdFidoGenCeAAGUID
subjectAlternativeName :: SubjectAlternativeName
aikPubKeyAndAlg :: PublicKeyWithSignAlg
aikCert :: Certificate
x5c :: NonEmpty SignedCertificate
pubAreaKey :: Statement -> PublicKey
pubAreaRaw :: Statement -> ByteString
pubArea :: Statement -> TPMTPublic
certInfoRaw :: Statement -> ByteString
certInfo :: Statement -> TPMSAttest
sig :: Statement -> ByteString
basicConstraintsCA :: Statement -> Bool
extendedKeyUsage :: Statement -> [ExtKeyUsagePurpose]
aaguidExt :: Statement -> Maybe IdFidoGenCeAAGUID
subjectAlternativeName :: Statement -> SubjectAlternativeName
aikPubKeyAndAlg :: Statement -> PublicKeyWithSignAlg
aikCert :: Statement -> Certificate
x5c :: Statement -> NonEmpty SignedCertificate
..} =
    [Pair] -> Value
object
      [ Key
"ver" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"2.0",
        Key
"alg" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= PublicKeyWithSignAlg -> CoseSignAlg
Cose.signAlg PublicKeyWithSignAlg
aikPubKeyAndAlg,
        Key
"x5c" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty SignedCertificate
x5c,
        Key
"sig" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString
sig,
        Key
"certInfo" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TPMSAttest
certInfo,
        Key
"pubArea" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TPMTPublic
pubArea
      ]

-- | Verification errors specific to TPM attestation
data VerificationError
  = -- | The public key in the certificate is different from the on in the
    -- attested credential data
    PublicKeyMismatch
      { -- | The public key extracted from the certificate
        VerificationError -> PublicKey
certificatePublicKey :: Cose.PublicKey,
        -- | The public key part of the credential data
        VerificationError -> PublicKey
credentialDataPublicKey :: Cose.PublicKey
      }
  | -- | The magic number in certInfo was not set to TPM_GENERATED_VALUE (0xff544347)
    MagicNumberInvalid Word32
  | -- | The type in certInfo was not set to TPM_ST_ATTEST_CERTIFY (0x8017)
    TypeInvalid Word16
  | -- | The algorithm specified in the nameAlg field is unsupported or is not
    -- a valid name algorithm
    NameAlgorithmInvalid TPMAlgId
  | -- | The calulated name does not match the provided name.
    NameMismatch
      { -- | The name calculated from the TPMT_PUBLIC structure with the name
        -- algorithm.
        VerificationError -> ByteString
pubAreaName :: BS.ByteString,
        -- | The expected name from TPMS_CERTIFY_INFO of the TPMS_ATTEST
        -- structure
        VerificationError -> ByteString
certifyInfoName :: BS.ByteString
      }
  | -- | The public key in the certificate was invalid, either because the it
    -- had an unexpected algorithm, or because it was otherwise malformed
    PublicKeyInvalid Text
  | -- | The certificate didn't have the expected version-value (2)
    CertificateVersionInvalid Int
  | -- | The Public key cannot verify the signature over the authenticatorData
    -- and the clientDataHash.
    VerificationFailure Text
  | -- | The subject field was not empty
    SubjectFieldNotEmpty [(OID, X509.ASN1CharacterString)]
  | -- | The vendor was unknown
    VendorUnknown Text
  | -- | The Extended Key Usage did not contain the 2.23.133.8.3 OID
    ExtKeyOIDMissing
  | -- | The CA component of the basic constraints extension was set to True
    BasicConstraintsTrue
  | -- | The AAGUID in the attested credential data does not match the AAGUID
    -- in the fido certificate extension
    CertificateAAGUIDMismatch
      { -- | AAGUID from the id-fido-gen-ce-aaguid certificate extension
        VerificationError -> AAGUID
certificateExtensionAAGUID :: AAGUID,
        -- | AAGUID from the attested credential data
        VerificationError -> AAGUID
attestedCredentialDataAAGUID :: AAGUID
      }
  | -- | The (supposedly) ASN1 encoded certificate extension could not be
    -- decoded
    ASN1Error ASN1Error
  | -- | The certificate extension does not contain a AAGUID
    CredentialAAGUIDMissing
  | -- | The desired algorithm does not have a known associated hash function
    HashFunctionUnknown
  | -- | The calculated hash over the attToBeSigned does not match the received
    -- hash
    HashMismatch
      { -- | The hash of the concatenation of the @authenticatorData@ and
        -- @clientDataHash@ (@attToBeSigned@) calculated by the @alg@ specified in
        -- the @Statement@.
        VerificationError -> ByteString
calculatedHash :: BS.ByteString,
        -- | The extra data from the TPMS_ATTEST structure.
        VerificationError -> ByteString
extraData :: BS.ByteString
      }
  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.trustedcomputinggroup.org/wp-content/uploads/Credential_Profile_EK_V2.0_R14_published.pdf)
-- The specifications specifies that the inner most objects of the ASN.1
-- encoding are individual sets of sequences. See notably page 35 of the spec.
-- However, in practice, we found that some TPM implementions interpreted this
-- as being a single set of individual sequences. We could attempt to parse
-- both, relying on the Alternative typeclass, or we could write our parser in
-- such a way that it is agnostic to whatever structure is chosen by searching
-- through the ASN.1 encoding for the desired OIDs.
--
-- We chose the second, since it can possibly also handle other interpretations
-- of the spec.
instance X509.Extension SubjectAlternativeName where
  extOID :: SubjectAlternativeName -> OID
extOID = forall a b. a -> b -> a
const [Integer
2, Integer
5, Integer
29, Integer
17]
  extHasNestedASN1 :: Proxy SubjectAlternativeName -> Bool
extHasNestedASN1 = forall a b. a -> b -> a
const Bool
True
  extEncode :: SubjectAlternativeName -> [ASN1]
extEncode = forall a. HasCallStack => [Char] -> a
error [Char]
"Unimplemented: This library does not implement encoding the SubjectAlternativeName extension"
  extDecode :: [ASN1] -> Either [Char] SubjectAlternativeName
extDecode [ASN1]
asn1 =
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Char]
"Could not decode ASN1 subject-alternative-name extension: " forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$
      forall a. ParseASN1 a -> [ASN1] -> Either [Char] a
runParseASN1 ParseASN1 SubjectAlternativeName
decodeSubjectAlternativeName [ASN1]
asn1
    where
      decodeSubjectAlternativeName :: ParseASN1 SubjectAlternativeName
      decodeSubjectAlternativeName :: ParseASN1 SubjectAlternativeName
decodeSubjectAlternativeName =
        do
          Map OID Text
map <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseASN1 [(OID, Text)]
decodeFields
          -- https://www.trustedcomputinggroup.org/wp-content/uploads/Credential_Profile_EK_V2.0_R14_published.pdf
          Text
tpmManufacturer <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"manufacturer field not found in subject alternative name") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Integer
2, Integer
23, Integer
133, Integer
2, Integer
1] Map OID Text
map
          Text
tpmModel <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"model field not found in subject alternative name") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Integer
2, Integer
23, Integer
133, Integer
2, Integer
2] Map OID Text
map
          Text
tpmVersion <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"version field not found in subject alternative name") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Integer
2, Integer
23, Integer
133, Integer
2, Integer
3] Map OID Text
map
          pure SubjectAlternativeName {Text
tpmVersion :: Text
tpmModel :: Text
tpmManufacturer :: Text
tpmVersion :: Text
tpmModel :: Text
tpmManufacturer :: Text
..}

      decodeFields :: ParseASN1 [(OID, Text)]
      decodeFields :: ParseASN1 [(OID, Text)]
decodeFields = do
        Bool
next <- ParseASN1 Bool
hasNext
        if Bool
next
          then do
            ASN1
n <- ParseASN1 ASN1
getNext
            case ASN1
n of
              OID OID
oid -> do
                ASN1
m <- ParseASN1 ASN1
getNext
                case ASN1
m of
                  ASN1String ASN1CharacterString
asnString -> do
                    let text :: Text
text = ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ ASN1CharacterString -> ByteString
X509.getCharacterStringRawData ASN1CharacterString
asnString
                    [(OID, Text)]
fields <- ParseASN1 [(OID, Text)]
decodeFields
                    pure ((OID
oid, Text
text) forall a. a -> [a] -> [a]
: [(OID, Text)]
fields)
                  ASN1
_ -> ParseASN1 [(OID, Text)]
decodeFields
              ASN1
_ -> ParseASN1 [(OID, Text)]
decodeFields
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance M.AttestationStatementFormat Format where
  type AttStmt Format = Statement

  asfIdentifier :: Format -> Text
asfIdentifier Format
_ = Text
"tpm"

  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
"ver", 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
"x5c", 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
"certInfo", HashMap Text Term
xs forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"pubArea") of
      (Just (CBOR.TString Text
"2.0"), Just (CBOR.TInt Int
algId), Just (CBOR.TList (forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty -> Just NonEmpty Term
x5cRaw)), Just (CBOR.TBytes ByteString
sig), Just (CBOR.TBytes ByteString
certInfoRaw), Just (CBOR.TBytes ByteString
pubAreaRaw)) ->
        do
          x5c :: NonEmpty SignedCertificate
x5c@(SignedCertificate
signedAikCert :| [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)
          CoseSignAlg
alg <- forall a. (Eq a, Num a, Show a) => a -> Either Text CoseSignAlg
Cose.toCoseSignAlg Int
algId
          -- The get interface requires lazy bytestrings but we typically use
          -- strict bytestrings in the library, so we have to convert between
          -- them
          TPMSAttest
certInfo <- case forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, [Char]) (ByteString, ByteOffset, a)
Get.runGetOrFail Get TPMSAttest
getTPMAttest (ByteString -> ByteString
LBS.fromStrict ByteString
certInfoRaw) of
            Left (ByteString
_, ByteOffset
_, [Char]
err) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode certInfo: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. Show a => a -> [Char]
show [Char]
err)
            Right (ByteString
_, ByteOffset
_, TPMSAttest
res) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMSAttest
res
          TPMTPublic
pubArea <- case forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, [Char]) (ByteString, ByteOffset, a)
Get.runGetOrFail Get TPMTPublic
getTPMTPublic (ByteString -> ByteString
LBS.fromStrict ByteString
pubAreaRaw) of
            Left (ByteString
_, ByteOffset
_, [Char]
err) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode pubArea: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. Show a => a -> [Char]
show [Char]
err)
            Right (ByteString
_, ByteOffset
_, TPMTPublic
res) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMTPublic
res
          PublicKey
pubAreaKey <- TPMTPublic -> Either Text PublicKey
extractPublicKey TPMTPublic
pubArea

          let aikCert :: Certificate
aikCert = SignedCertificate -> Certificate
X509.getCertificate SignedCertificate
signedAikCert

          PublicKey
aikCertPubKey <- PubKey -> Either Text PublicKey
Cose.fromX509 forall a b. (a -> b) -> a -> b
$ Certificate -> PubKey
X509.certPubKey Certificate
aikCert
          PublicKeyWithSignAlg
aikPubKeyAndAlg <- PublicKey -> CoseSignAlg -> Either Text PublicKeyWithSignAlg
Cose.makePublicKeyWithSignAlg PublicKey
aikCertPubKey CoseSignAlg
alg

          SubjectAlternativeName
subjectAlternativeName <- case forall a. Extension a => Extensions -> Maybe (Either [Char] a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
            Just (Right SubjectAlternativeName
ext) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectAlternativeName
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 subject alternative name extension: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
err
            Maybe (Either [Char] SubjectAlternativeName)
Nothing -> forall a b. a -> Either a b
Left Text
"Certificate subject alternative name extension is missing"
          Maybe IdFidoGenCeAAGUID
aaguidExt <- case forall a. Extension a => Extensions -> Maybe (Either [Char] a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
            Just (Right IdFidoGenCeAAGUID
ext) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just IdFidoGenCeAAGUID
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 aaguid extension: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
err
            Maybe (Either [Char] IdFidoGenCeAAGUID)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          X509.ExtExtendedKeyUsage [ExtKeyUsagePurpose]
extendedKeyUsage <- case forall a. Extension a => Extensions -> Maybe (Either [Char] a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
            Just (Right ExtExtendedKeyUsage
ext) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtExtendedKeyUsage
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 extended key usage extension: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
err
            Maybe (Either [Char] ExtExtendedKeyUsage)
Nothing -> forall a b. a -> Either a b
Left Text
"Certificate extended key usage extension is missing"
          X509.ExtBasicConstraints Bool
basicConstraintsCA Maybe Integer
_ <- case forall a. Extension a => Extensions -> Maybe (Either [Char] a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
            Just (Right ExtBasicConstraints
ext) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtBasicConstraints
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 basic constraints extension: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
err
            Maybe (Either [Char] ExtBasicConstraints)
Nothing -> forall a b. a -> Either a b
Left Text
"Certificate basic constraints extension is missing"
          forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Statement {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
NonEmpty SignedCertificate
ByteString
Certificate
PublicKey
PublicKeyWithSignAlg
SubjectAlternativeName
TPMTPublic
TPMSAttest
basicConstraintsCA :: Bool
extendedKeyUsage :: [ExtKeyUsagePurpose]
aaguidExt :: Maybe IdFidoGenCeAAGUID
subjectAlternativeName :: SubjectAlternativeName
aikPubKeyAndAlg :: PublicKeyWithSignAlg
aikCert :: Certificate
pubAreaKey :: PublicKey
pubArea :: TPMTPublic
certInfo :: TPMSAttest
x5c :: NonEmpty SignedCertificate
pubAreaRaw :: ByteString
certInfoRaw :: ByteString
sig :: ByteString
pubAreaKey :: PublicKey
pubAreaRaw :: ByteString
pubArea :: TPMTPublic
certInfoRaw :: ByteString
certInfo :: TPMSAttest
sig :: ByteString
basicConstraintsCA :: Bool
extendedKeyUsage :: [ExtKeyUsagePurpose]
aaguidExt :: Maybe IdFidoGenCeAAGUID
subjectAlternativeName :: SubjectAlternativeName
aikPubKeyAndAlg :: PublicKeyWithSignAlg
aikCert :: Certificate
x5c :: NonEmpty SignedCertificate
..}
      (Maybe Term, Maybe Term, Maybe Term, 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 (ver: \"2.0\", alg: int, x5c: non-empty list, sig: bytes, certInfo: bytes, pubArea: bytes): " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. Show a => a -> [Char]
show HashMap Text Term
xs)
    where
      getTPMAttest :: Get.Get TPMSAttest
      getTPMAttest :: Get TPMSAttest
getTPMAttest = do
        TPMAObject
tpmsaMagic <- Get TPMAObject
Get.getWord32be
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TPMAObject
tpmsaMagic forall a. Eq a => a -> a -> Bool
== TPMAObject
tpmGeneratedValue) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid magic number"
        Word16
tpmsaType <- Get Word16
Get.getWord16be
        ByteString
tpmsaQualifiedSigner <- Get ByteString
getTPMByteString
        ByteString
tpmsaExtraData <- Get ByteString
getTPMByteString
        TPMSClockInfo
tpmsaClockInfo <- Get TPMSClockInfo
getClockInfo
        Word64
tpmsaFirmwareVersion <- Get Word64
Get.getWord64be
        TPMSCertifyInfo
tpmsaAttested <- Get TPMSCertifyInfo
getCertifyInfo
        Bool
True <- Get Bool
Get.isEmpty
        forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMSAttest {Word16
TPMAObject
Word64
ByteString
TPMSCertifyInfo
TPMSClockInfo
tpmsaAttested :: TPMSCertifyInfo
tpmsaFirmwareVersion :: Word64
tpmsaClockInfo :: TPMSClockInfo
tpmsaExtraData :: ByteString
tpmsaQualifiedSigner :: ByteString
tpmsaType :: Word16
tpmsaMagic :: TPMAObject
tpmsaAttested :: TPMSCertifyInfo
tpmsaFirmwareVersion :: Word64
tpmsaClockInfo :: TPMSClockInfo
tpmsaExtraData :: ByteString
tpmsaQualifiedSigner :: ByteString
tpmsaType :: Word16
tpmsaMagic :: TPMAObject
..}

      getClockInfo :: Get.Get TPMSClockInfo
      getClockInfo :: Get TPMSClockInfo
getClockInfo = do
        Word64
tpmsciClock <- Get Word64
Get.getWord64be
        TPMAObject
tpmsciResetCount <- Get TPMAObject
Get.getWord32be
        TPMAObject
tpmsciRestartCount <- Get TPMAObject
Get.getWord32be
        Bool
tpmsciSafe <- (forall a. Eq a => a -> a -> Bool
== Word8
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
Get.getWord8
        pure TPMSClockInfo {Bool
TPMAObject
Word64
tpmsciSafe :: Bool
tpmsciRestartCount :: TPMAObject
tpmsciResetCount :: TPMAObject
tpmsciClock :: Word64
tpmsciSafe :: Bool
tpmsciRestartCount :: TPMAObject
tpmsciResetCount :: TPMAObject
tpmsciClock :: Word64
..}

      getCertifyInfo :: Get.Get TPMSCertifyInfo
      getCertifyInfo :: Get TPMSCertifyInfo
getCertifyInfo = do
        ByteString
tpmsciName <- Get ByteString
getTPMByteString
        ByteString
tpmsciQualifiedName <- Get ByteString
getTPMByteString
        pure TPMSCertifyInfo {ByteString
tpmsciQualifiedName :: ByteString
tpmsciName :: ByteString
tpmsciQualifiedName :: ByteString
tpmsciName :: ByteString
..}

      getTPMByteString :: Get.Get BS.ByteString
      getTPMByteString :: Get ByteString
getTPMByteString = do
        Word16
size <- Get Word16
Get.getWord16be
        Int -> Get ByteString
Get.getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
size)

      getTPMTPublic :: Get.Get TPMTPublic
      getTPMTPublic :: Get TPMTPublic
getTPMTPublic = do
        TPMAlgId
tpmtpType <- forall (m :: * -> *). MonadFail m => Word16 -> m TPMAlgId
toTPMAlgId forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word16
Get.getWord16be
        Word16
tpmtpNameAlgRaw <- Get Word16
Get.getWord16be
        TPMAlgId
tpmtpNameAlg <- forall (m :: * -> *). MonadFail m => Word16 -> m TPMAlgId
toTPMAlgId Word16
tpmtpNameAlgRaw
        TPMAObject
tpmtpObjectAttributes <- Get TPMAObject
getTPMAObject
        ByteString
tpmtpAuthPolicy <- Get ByteString
getTPMByteString
        TPMUPublicParms
tpmtpParameters <- TPMAlgId -> Get TPMUPublicParms
getTPMUPublicParms TPMAlgId
tpmtpType
        TPMUPublicId
tpmtpUnique <- TPMAlgId -> Get TPMUPublicId
getTPMUPublicId TPMAlgId
tpmtpType
        Bool
True <- Get Bool
Get.isEmpty
        forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMTPublic {Word16
TPMAObject
ByteString
TPMUPublicId
TPMUPublicParms
TPMAlgId
tpmtpUnique :: TPMUPublicId
tpmtpParameters :: TPMUPublicParms
tpmtpAuthPolicy :: ByteString
tpmtpObjectAttributes :: TPMAObject
tpmtpNameAlg :: TPMAlgId
tpmtpNameAlgRaw :: Word16
tpmtpType :: TPMAlgId
tpmtpUnique :: TPMUPublicId
tpmtpParameters :: TPMUPublicParms
tpmtpAuthPolicy :: ByteString
tpmtpObjectAttributes :: TPMAObject
tpmtpNameAlgRaw :: Word16
tpmtpNameAlg :: TPMAlgId
tpmtpType :: TPMAlgId
..}

      -- We don't need to inspect the bits in the object, so we skip parsing it
      getTPMAObject :: Get.Get TPMAObject
      getTPMAObject :: Get TPMAObject
getTPMAObject = Get TPMAObject
Get.getWord32be

      getTPMUPublicParms :: TPMAlgId -> Get.Get TPMUPublicParms
      getTPMUPublicParms :: TPMAlgId -> Get TPMUPublicParms
getTPMUPublicParms TPMAlgId
TPMAlgRSA = do
        Word16
tpmsrpSymmetric <- Get Word16
Get.getWord16be
        Word16
tpmsrpScheme <- Get Word16
Get.getWord16be
        Word16
tpmsrpKeyBits <- Get Word16
Get.getWord16be
        -- An exponent of zero indicates that the exponent is the default of 2^16 + 1
        TPMAObject
tpmsrpExponent <- (\TPMAObject
e -> if TPMAObject
e forall a. Eq a => a -> a -> Bool
== TPMAObject
0 then TPMAObject
65537 else TPMAObject
e) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get TPMAObject
Get.getWord32be
        pure TPMSRSAParms {Word16
TPMAObject
tpmsrpExponent :: TPMAObject
tpmsrpKeyBits :: Word16
tpmsrpScheme :: Word16
tpmsrpSymmetric :: Word16
tpmsrpExponent :: TPMAObject
tpmsrpKeyBits :: Word16
tpmsrpScheme :: Word16
tpmsrpSymmetric :: Word16
..}
      getTPMUPublicParms TPMAlgId
TPMAlgSHA1 = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"SHA1 does not have public key parameters"
      getTPMUPublicParms TPMAlgId
TPMAlgSHA256 = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"SHA256 does not have public key parameters"
      getTPMUPublicParms TPMAlgId
TPMAlgECC = do
        Word16
tpmsepSymmetric <- Get Word16
Get.getWord16be
        Word16
tpmsepScheme <- Get Word16
Get.getWord16be
        CoseCurveECDSA
tpmsepCurveId <- forall (m :: * -> *). MonadFail m => Word16 -> m CoseCurveECDSA
toCurveId forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word16
Get.getWord16be
        Word16
tpmsepkdf <- Get Word16
Get.getWord16be
        pure TPMSECCParms {Word16
CoseCurveECDSA
tpmsepkdf :: Word16
tpmsepCurveId :: CoseCurveECDSA
tpmsepScheme :: Word16
tpmsepSymmetric :: Word16
tpmsepkdf :: Word16
tpmsepCurveId :: CoseCurveECDSA
tpmsepScheme :: Word16
tpmsepSymmetric :: Word16
..}

      getTPMUPublicId :: TPMAlgId -> Get.Get TPMUPublicId
      getTPMUPublicId :: TPMAlgId -> Get TPMUPublicId
getTPMUPublicId TPMAlgId
TPMAlgRSA = ByteString -> TPMUPublicId
TPM2BPublicKeyRSA forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getTPMByteString
      getTPMUPublicId TPMAlgId
TPMAlgSHA1 = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"SHA1 does not have a public id"
      getTPMUPublicId TPMAlgId
TPMAlgSHA256 = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"SHA256 does not have a public id"
      getTPMUPublicId TPMAlgId
TPMAlgECC = do
        ByteString
tpmseX <- Get ByteString
getTPMByteString
        ByteString
tpmseY <- Get ByteString
getTPMByteString
        pure TPMSECCPoint {ByteString
tpmseY :: ByteString
tpmseX :: ByteString
tpmseY :: ByteString
tpmseX :: ByteString
..}

      extractPublicKey :: TPMTPublic -> Either Text Cose.PublicKey
      extractPublicKey :: TPMTPublic -> Either Text PublicKey
extractPublicKey
        TPMTPublic
          { tpmtpType :: TPMTPublic -> TPMAlgId
tpmtpType = TPMAlgId
TPMAlgRSA,
            tpmtpParameters :: TPMTPublic -> TPMUPublicParms
tpmtpParameters = TPMSRSAParms {Word16
TPMAObject
tpmsrpExponent :: TPMAObject
tpmsrpKeyBits :: Word16
tpmsrpScheme :: Word16
tpmsrpSymmetric :: Word16
tpmsrpExponent :: TPMUPublicParms -> TPMAObject
tpmsrpKeyBits :: TPMUPublicParms -> Word16
tpmsrpScheme :: TPMUPublicParms -> Word16
tpmsrpSymmetric :: TPMUPublicParms -> Word16
..},
            tpmtpUnique :: TPMTPublic -> TPMUPublicId
tpmtpUnique = TPM2BPublicKeyRSA ByteString
nb
          } =
          UncheckedPublicKey -> Either Text PublicKey
Cose.checkPublicKey
            Cose.PublicKeyRSA
              { rsaN :: Integer
rsaN = forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
nb,
                rsaE :: Integer
rsaE = forall a. Integral a => a -> Integer
toInteger TPMAObject
tpmsrpExponent
              }
      extractPublicKey
        TPMTPublic
          { tpmtpType :: TPMTPublic -> TPMAlgId
tpmtpType = TPMAlgId
TPMAlgECC,
            tpmtpParameters :: TPMTPublic -> TPMUPublicParms
tpmtpParameters = TPMSECCParms {Word16
CoseCurveECDSA
tpmsepkdf :: Word16
tpmsepCurveId :: CoseCurveECDSA
tpmsepScheme :: Word16
tpmsepSymmetric :: Word16
tpmsepkdf :: TPMUPublicParms -> Word16
tpmsepCurveId :: TPMUPublicParms -> CoseCurveECDSA
tpmsepScheme :: TPMUPublicParms -> Word16
tpmsepSymmetric :: TPMUPublicParms -> Word16
..},
            tpmtpUnique :: TPMTPublic -> TPMUPublicId
tpmtpUnique = TPMSECCPoint {ByteString
tpmseY :: ByteString
tpmseX :: ByteString
tpmseY :: TPMUPublicId -> ByteString
tpmseX :: TPMUPublicId -> ByteString
..}
          } =
          UncheckedPublicKey -> Either Text PublicKey
Cose.checkPublicKey
            Cose.PublicKeyECDSA
              { ecdsaCurve :: CoseCurveECDSA
ecdsaCurve = CoseCurveECDSA
tpmsepCurveId,
                ecdsaX :: Integer
ecdsaX = forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
tpmseX,
                ecdsaY :: Integer
ecdsaY = forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
tpmseY
              }
      extractPublicKey TPMTPublic
key = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Unsupported TPM public key: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. Show a => a -> [Char]
show TPMTPublic
key)

  asfEncode :: Format -> AttStmt Format -> Term
asfEncode Format
_ Statement {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
NonEmpty SignedCertificate
ByteString
Certificate
PublicKey
PublicKeyWithSignAlg
SubjectAlternativeName
TPMTPublic
TPMSAttest
pubAreaKey :: PublicKey
pubAreaRaw :: ByteString
pubArea :: TPMTPublic
certInfoRaw :: ByteString
certInfo :: TPMSAttest
sig :: ByteString
basicConstraintsCA :: Bool
extendedKeyUsage :: [ExtKeyUsagePurpose]
aaguidExt :: Maybe IdFidoGenCeAAGUID
subjectAlternativeName :: SubjectAlternativeName
aikPubKeyAndAlg :: PublicKeyWithSignAlg
aikCert :: Certificate
x5c :: NonEmpty SignedCertificate
pubAreaKey :: Statement -> PublicKey
pubAreaRaw :: Statement -> ByteString
pubArea :: Statement -> TPMTPublic
certInfoRaw :: Statement -> ByteString
certInfo :: Statement -> TPMSAttest
sig :: Statement -> ByteString
basicConstraintsCA :: Statement -> Bool
extendedKeyUsage :: Statement -> [ExtKeyUsagePurpose]
aaguidExt :: Statement -> Maybe IdFidoGenCeAAGUID
subjectAlternativeName :: Statement -> SubjectAlternativeName
aikPubKeyAndAlg :: Statement -> PublicKeyWithSignAlg
aikCert :: Statement -> Certificate
x5c :: Statement -> NonEmpty SignedCertificate
..} =
    [(Term, Term)] -> Term
CBOR.TMap
      [ (Text -> Term
CBOR.TString Text
"ver", Text -> Term
CBOR.TString Text
"2.0"),
        (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 forall a b. (a -> b) -> a -> b
$ PublicKeyWithSignAlg -> CoseSignAlg
Cose.signAlg PublicKeyWithSignAlg
aikPubKeyAndAlg),
        ( Text -> Term
CBOR.TString Text
"x5c",
          [Term] -> Term
CBOR.TList forall a b. (a -> b) -> a -> b
$ 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]
NE.toList NonEmpty SignedCertificate
x5c
        ),
        (Text -> Term
CBOR.TString Text
"sig", ByteString -> Term
CBOR.TBytes ByteString
sig),
        (Text -> Term
CBOR.TString Text
"certInfo", ByteString -> Term
CBOR.TBytes ByteString
certInfoRaw),
        (Text -> Term
CBOR.TString Text
"pubArea", ByteString -> Term
CBOR.TBytes ByteString
pubAreaRaw)
      ]

  type AttStmtVerificationError Format = VerificationError

  asfVerify :: Format
-> DateTime
-> AttStmt Format
-> AuthenticatorData 'Registration 'True
-> ClientDataHash
-> Validation
     (NonEmpty (AttStmtVerificationError Format)) SomeAttestationType
asfVerify
    Format
_
    DateTime
_
    Statement {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
NonEmpty SignedCertificate
ByteString
Certificate
PublicKey
PublicKeyWithSignAlg
SubjectAlternativeName
TPMTPublic
TPMSAttest
pubAreaKey :: PublicKey
pubAreaRaw :: ByteString
pubArea :: TPMTPublic
certInfoRaw :: ByteString
certInfo :: TPMSAttest
sig :: ByteString
basicConstraintsCA :: Bool
extendedKeyUsage :: [ExtKeyUsagePurpose]
aaguidExt :: Maybe IdFidoGenCeAAGUID
subjectAlternativeName :: SubjectAlternativeName
aikPubKeyAndAlg :: PublicKeyWithSignAlg
aikCert :: Certificate
x5c :: NonEmpty SignedCertificate
pubAreaKey :: Statement -> PublicKey
pubAreaRaw :: Statement -> ByteString
pubArea :: Statement -> TPMTPublic
certInfoRaw :: Statement -> ByteString
certInfo :: Statement -> TPMSAttest
sig :: Statement -> ByteString
basicConstraintsCA :: Statement -> Bool
extendedKeyUsage :: Statement -> [ExtKeyUsagePurpose]
aaguidExt :: Statement -> Maybe IdFidoGenCeAAGUID
subjectAlternativeName :: Statement -> SubjectAlternativeName
aikPubKeyAndAlg :: Statement -> PublicKeyWithSignAlg
aikCert :: Statement -> Certificate
x5c :: Statement -> NonEmpty SignedCertificate
..}
    M.AuthenticatorData {adRawData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RawField raw
adRawData = M.WithRaw ByteString
adRawData, Maybe AuthenticatorExtensionOutputs
AttestedCredentialData 'Registration 'True
AuthenticatorDataFlags
SignatureCounter
RpIdHash
adExtensions :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> Maybe AuthenticatorExtensionOutputs
adAttestedCredentialData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AttestedCredentialData c raw
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
adExtensions :: Maybe AuthenticatorExtensionOutputs
adAttestedCredentialData :: AttestedCredentialData 'Registration 'True
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: This is done during decoding

      -- 2. Verify that the public key specified by the parameters and unique
      -- fields of pubArea is identical to the credentialPublicKey in the
      -- attestedCredentialData in authenticatorData.
      let pubKey :: PublicKey
pubKey = PublicKeyWithSignAlg -> PublicKey
Cose.publicKey forall a b. (a -> b) -> a -> b
$ forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> PublicKeyWithSignAlg
M.acdCredentialPublicKey AttestedCredentialData 'Registration 'True
adAttestedCredentialData
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PublicKey
pubAreaKey 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
pubAreaKey PublicKey
pubKey

      -- 3. Concatenate authenticatorData and clientDataHash to form attToBeSigned.
      let attToBeSigned :: ByteString
attToBeSigned = ByteString
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)

      -- 4. Validate that certInfo is valid:
      -- 4.1 Verify that magic is set to TPM_GENERATED_VALUE.
      let magic :: TPMAObject
magic = TPMSAttest -> TPMAObject
tpmsaMagic TPMSAttest
certInfo
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TPMAObject
magic forall a. Eq a => a -> a -> Bool
== TPMAObject
tpmGeneratedValue) 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
$ TPMAObject -> VerificationError
MagicNumberInvalid TPMAObject
magic

      -- 4.2 Verify that type is set to TPM_ST_ATTEST_CERTIFY.
      let typ :: Word16
typ = TPMSAttest -> Word16
tpmsaType TPMSAttest
certInfo
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word16
typ forall a. Eq a => a -> a -> Bool
== Word16
tpmStAttestCertify) 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
$ Word16 -> VerificationError
TypeInvalid Word16
typ

      -- 4.3 Verify that extraData is set to the hash of attToBeSigned using
      -- the hash algorithm employed in "alg".
      case forall ba bout.
(ByteArrayAccess ba, ByteArray bout) =>
CoseSignAlg -> ba -> Maybe bout
hashWithCorrectAlgorithm (PublicKeyWithSignAlg -> CoseSignAlg
Cose.signAlg PublicKeyWithSignAlg
aikPubKeyAndAlg) ByteString
attToBeSigned of
        Just ByteString
attHash -> do
          let extraData :: ByteString
extraData = TPMSAttest -> ByteString
tpmsaExtraData TPMSAttest
certInfo
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
attHash forall a. Eq a => a -> a -> Bool
== ByteString
extraData) 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
$ ByteString -> ByteString -> VerificationError
HashMismatch ByteString
attHash ByteString
extraData
          pure ()
        Maybe ByteString
Nothing -> forall e a. e -> Validation (NonEmpty e) a
failure VerificationError
HashFunctionUnknown

      -- 4.5 Verify that attested contains a TPMS_CERTIFY_INFO structure as
      -- specified in [TPMv2-Part2] section 10.12.3, whose name field contains
      -- a valid Name for pubArea, as computed using the algorithm in the
      -- nameAlg field of pubArea using the procedure specified in
      -- [TPMv2-Part1] section 16.
      let mPubAreaHash :: Either TPMAlgId ByteString
mPubAreaHash = case TPMTPublic -> TPMAlgId
tpmtpNameAlg TPMTPublic
pubArea of
            TPMAlgId
TPMAlgSHA1 -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall a b. (a -> b) -> a -> b
$ forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA1
SHA1 ByteString
pubAreaRaw
            TPMAlgId
TPMAlgSHA256 -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall a b. (a -> b) -> a -> b
$ forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA256
SHA256 ByteString
pubAreaRaw
            TPMAlgId
TPMAlgECC -> forall a b. a -> Either a b
Left TPMAlgId
TPMAlgECC
            TPMAlgId
TPMAlgRSA -> forall a b. a -> Either a b
Left TPMAlgId
TPMAlgRSA

      case Either TPMAlgId ByteString
mPubAreaHash of
        Right ByteString
pubAreaHash -> do
          let pubName :: ByteString
pubName = ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$
                Put -> ByteString
Put.runPut forall a b. (a -> b) -> a -> b
$ do
                  Word16 -> Put
Put.putWord16be (TPMTPublic -> Word16
tpmtpNameAlgRaw TPMTPublic
pubArea)
                  ByteString -> Put
Put.putByteString ByteString
pubAreaHash

          let name :: ByteString
name = TPMSCertifyInfo -> ByteString
tpmsciName (TPMSAttest -> TPMSCertifyInfo
tpmsaAttested TPMSAttest
certInfo)
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
name forall a. Eq a => a -> a -> Bool
== ByteString
pubName) 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
$ ByteString -> ByteString -> VerificationError
NameMismatch ByteString
pubName ByteString
name
          pure ()
        Left TPMAlgId
alg -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ TPMAlgId -> VerificationError
NameAlgorithmInvalid TPMAlgId
alg

      -- 4.6 Verify that x5c is present
      -- NOTE: Done in decoding

      -- 4.7 Note that the remaining fields in the "Standard Attestation Structure"
      -- [TPMv2-Part1] section 31.2, i.e., qualifiedSigner, clockInfo and
      -- firmwareVersion are ignored. These fields MAY be used as an input to
      -- risk engines.
      -- NOTE: We don't implement a risk engine

      -- 4.8 Verify the sig is a valid signature over certInfo using the
      -- attestation public key in aikCert with the algorithm specified in alg.
      case PublicKeyWithSignAlg -> ByteString -> ByteString -> Either Text ()
Cose.verify PublicKeyWithSignAlg
aikPubKeyAndAlg ByteString
certInfoRaw ByteString
sig 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
VerificationFailure Text
err

      -- 4.9 Verify that aikCert meets the requirements in § 8.3.1 TPM Attestation
      -- Statement Certificate Requirements.

      -- 4.9.1 Version MUST be set to 3.
      -- Version ::= INTEGER { v1(0), v2(1), v3(2) }, see https://datatracker.ietf.org/doc/html/rfc5280.html#section-4.1
      let version :: Int
version = Certificate -> Int
X509.certVersion Certificate
aikCert
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
version forall a. Eq a => a -> a -> Bool
== Int
2) 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
$ Int -> VerificationError
CertificateVersionInvalid Int
version
      -- 4.9.2. Subject field MUST be set to empty.
      let subject :: [(OID, ASN1CharacterString)]
subject = DistinguishedName -> [(OID, ASN1CharacterString)]
X509.getDistinguishedElements forall a b. (a -> b) -> a -> b
$ Certificate -> DistinguishedName
X509.certSubjectDN Certificate
aikCert
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(OID, ASN1CharacterString)]
subject) 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
$ [(OID, ASN1CharacterString)] -> VerificationError
SubjectFieldNotEmpty [(OID, ASN1CharacterString)]
subject
      -- 4.9.3 The Subject Alternative Name extension MUST be set as defined in
      -- [TPMv2-EK-Profile] section 3.2.9.
      -- 4.9.3.1 The TPM manufacturer identifies the manufacturer of the TPM. This value MUST be the
      -- vendor ID defined in the TCG Vendor ID Registry[3]
      let vendor :: Text
vendor = SubjectAlternativeName -> Text
tpmManufacturer SubjectAlternativeName
subjectAlternativeName
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Ord a => a -> Set a -> Bool
Set.member Text
vendor Set Text
tpmManufacturers) 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
$ Text -> VerificationError
VendorUnknown Text
vendor

      -- 4.9.4 The Extended Key Usage extension MUST contain the OID
      -- 2.23.133.8.3 ("joint-iso-itu-t(2) internationalorganizations(23) 133
      -- tcg-kp(8) tcg-kp-AIKCertificate(3)").
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (OID -> ExtKeyUsagePurpose
X509.KeyUsagePurpose_Unknown [Integer
2, Integer
23, Integer
133, Integer
8, Integer
3] forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ExtKeyUsagePurpose]
extendedKeyUsage) forall a b. (a -> b) -> a -> b
$ forall e a. e -> Validation (NonEmpty e) a
failure VerificationError
ExtKeyOIDMissing

      -- 4.9.5 The Basic Constraints extension MUST have the CA component set
      -- to false.
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
basicConstraintsCA forall a b. (a -> b) -> a -> b
$ forall e a. e -> Validation (NonEmpty e) a
failure VerificationError
BasicConstraintsTrue

      -- 4.9.6 An Authority Information Access (AIA) extension with entry
      -- id-ad-ocsp and a CRL Distribution Point extension [RFC5280] are both
      -- OPTIONAL as the status of many attestation certificates is available
      -- through metadata services. See, for example, the FIDO Metadata Service
      -- [FIDOMetadataService].
      -- NOTE: CRL checking and AIA can be done in a more general way after
      -- this function. See also <https://github.com/tweag/webauthn/issues/23>

      -- If aikCert 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 credentialAAGUID :: AAGUID
credentialAAGUID = forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> AAGUID
M.acdAaguid AttestedCredentialData 'Registration 'True
adAttestedCredentialData
      case Maybe IdFidoGenCeAAGUID
aaguidExt of
        Just (IdFidoGenCeAAGUID AAGUID
aaguid) -> do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AAGUID
aaguid forall a. Eq a => a -> a -> Bool
== AAGUID
credentialAAGUID) 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
aaguid AAGUID
credentialAAGUID
        Maybe IdFidoGenCeAAGUID
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      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
        hashWithCorrectAlgorithm :: (BA.ByteArrayAccess ba, BA.ByteArray bout) => Cose.CoseSignAlg -> ba -> Maybe bout
        hashWithCorrectAlgorithm :: forall ba bout.
(ByteArrayAccess ba, ByteArray bout) =>
CoseSignAlg -> ba -> Maybe bout
hashWithCorrectAlgorithm CoseSignAlg
Cose.CoseSignAlgEdDSA ba
_ =
          forall a. Maybe a
Nothing
        hashWithCorrectAlgorithm (Cose.CoseSignAlgECDSA CoseHashAlgECDSA
Cose.CoseHashAlgECDSASHA256) ba
bytes =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
Hash.hashWith SHA256
Hash.SHA256 ba
bytes)
        hashWithCorrectAlgorithm (Cose.CoseSignAlgECDSA CoseHashAlgECDSA
Cose.CoseHashAlgECDSASHA384) ba
bytes =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
Hash.hashWith SHA384
Hash.SHA384 ba
bytes)
        hashWithCorrectAlgorithm (Cose.CoseSignAlgECDSA CoseHashAlgECDSA
Cose.CoseHashAlgECDSASHA512) ba
bytes =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
Hash.hashWith SHA512
Hash.SHA512 ba
bytes)
        hashWithCorrectAlgorithm (Cose.CoseSignAlgRSA CoseHashAlgRSA
Cose.CoseHashAlgRSASHA1) ba
bytes =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
Hash.hashWith SHA1
Hash.SHA1 ba
bytes)
        hashWithCorrectAlgorithm (Cose.CoseSignAlgRSA CoseHashAlgRSA
Cose.CoseHashAlgRSASHA256) ba
bytes =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
Hash.hashWith SHA256
Hash.SHA256 ba
bytes)
        hashWithCorrectAlgorithm (Cose.CoseSignAlgRSA CoseHashAlgRSA
Cose.CoseHashAlgRSASHA384) ba
bytes =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
Hash.hashWith SHA384
Hash.SHA384 ba
bytes)
        hashWithCorrectAlgorithm (Cose.CoseSignAlgRSA CoseHashAlgRSA
Cose.CoseHashAlgRSASHA512) ba
bytes =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
Hash.hashWith SHA512
Hash.SHA512 ba
bytes)

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

rootCertificateStore :: X509.CertificateStore
rootCertificateStore :: CertificateStore
rootCertificateStore = [SignedCertificate] -> CertificateStore
X509.makeCertificateStore forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Text, SignedCertificate)]
rootCertificates

-- | All known TPM root certificates along with their vendors
rootCertificates :: [(Text, X509.SignedCertificate)]
rootCertificates :: [(Text, SignedCertificate)]
rootCertificates = ([Char], ByteString) -> (Text, SignedCertificate)
processEntry forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> $(embedDir "root-certs/tpm")
  where
    processEntry :: (FilePath, BS.ByteString) -> (Text, X509.SignedCertificate)
    processEntry :: ([Char], ByteString) -> (Text, SignedCertificate)
processEntry ([Char]
path, ByteString
bytes) = case ByteString -> Either [Char] SignedCertificate
X509.decodeSignedCertificate ByteString
bytes of
      Right SignedCertificate
cert -> ((Char -> Bool) -> Text -> Text
Text.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') ([Char] -> Text
Text.pack [Char]
path), SignedCertificate
cert)
      Left [Char]
err -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Error while decoding certificate " forall a. Semigroup a => a -> a -> a
<> [Char]
path forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<> [Char]
err

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