{-# 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 =
  [Text] -> Set Text
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 -> FilePath
(Int -> TPMAlgId -> ShowS)
-> (TPMAlgId -> FilePath) -> ([TPMAlgId] -> ShowS) -> Show TPMAlgId
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TPMAlgId] -> ShowS
$cshowList :: [TPMAlgId] -> ShowS
show :: TPMAlgId -> FilePath
$cshow :: TPMAlgId -> FilePath
showsPrec :: Int -> TPMAlgId -> ShowS
$cshowsPrec :: Int -> TPMAlgId -> ShowS
Show, TPMAlgId -> TPMAlgId -> Bool
(TPMAlgId -> TPMAlgId -> Bool)
-> (TPMAlgId -> TPMAlgId -> Bool) -> Eq TPMAlgId
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. TPMAlgId -> Rep TPMAlgId x)
-> (forall x. Rep TPMAlgId x -> TPMAlgId) -> Generic TPMAlgId
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
(TPMAlgId -> Value)
-> (TPMAlgId -> Encoding)
-> ([TPMAlgId] -> Value)
-> ([TPMAlgId] -> Encoding)
-> ToJSON TPMAlgId
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 = TPMAlgId -> m TPMAlgId
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgRSA
toTPMAlgId Word16
0x0004 = TPMAlgId -> m TPMAlgId
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgSHA1
toTPMAlgId Word16
0x000B = TPMAlgId -> m TPMAlgId
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgSHA256
toTPMAlgId Word16
0x0023 = TPMAlgId -> m TPMAlgId
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgECC
toTPMAlgId Word16
_ = FilePath -> m TPMAlgId
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"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 = CoseCurveECDSA -> m CoseCurveECDSA
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoseCurveECDSA
Cose.CoseCurveP256
toCurveId Word16
0x0004 = CoseCurveECDSA -> m CoseCurveECDSA
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoseCurveECDSA
Cose.CoseCurveP384
toCurveId Word16
0x0005 = CoseCurveECDSA -> m CoseCurveECDSA
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoseCurveECDSA
Cose.CoseCurveP521
toCurveId Word16
_ = FilePath -> m CoseCurveECDSA
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"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
(TPMSClockInfo -> TPMSClockInfo -> Bool)
-> (TPMSClockInfo -> TPMSClockInfo -> Bool) -> Eq TPMSClockInfo
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 -> FilePath
(Int -> TPMSClockInfo -> ShowS)
-> (TPMSClockInfo -> FilePath)
-> ([TPMSClockInfo] -> ShowS)
-> Show TPMSClockInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TPMSClockInfo] -> ShowS
$cshowList :: [TPMSClockInfo] -> ShowS
show :: TPMSClockInfo -> FilePath
$cshow :: TPMSClockInfo -> FilePath
showsPrec :: Int -> TPMSClockInfo -> ShowS
$cshowsPrec :: Int -> TPMSClockInfo -> ShowS
Show, (forall x. TPMSClockInfo -> Rep TPMSClockInfo x)
-> (forall x. Rep TPMSClockInfo x -> TPMSClockInfo)
-> Generic TPMSClockInfo
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
(TPMSClockInfo -> Value)
-> (TPMSClockInfo -> Encoding)
-> ([TPMSClockInfo] -> Value)
-> ([TPMSClockInfo] -> Encoding)
-> ToJSON TPMSClockInfo
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
(TPMSCertifyInfo -> TPMSCertifyInfo -> Bool)
-> (TPMSCertifyInfo -> TPMSCertifyInfo -> Bool)
-> Eq TPMSCertifyInfo
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 -> FilePath
(Int -> TPMSCertifyInfo -> ShowS)
-> (TPMSCertifyInfo -> FilePath)
-> ([TPMSCertifyInfo] -> ShowS)
-> Show TPMSCertifyInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TPMSCertifyInfo] -> ShowS
$cshowList :: [TPMSCertifyInfo] -> ShowS
show :: TPMSCertifyInfo -> FilePath
$cshow :: TPMSCertifyInfo -> FilePath
showsPrec :: Int -> TPMSCertifyInfo -> ShowS
$cshowsPrec :: Int -> TPMSCertifyInfo -> ShowS
Show, (forall x. TPMSCertifyInfo -> Rep TPMSCertifyInfo x)
-> (forall x. Rep TPMSCertifyInfo x -> TPMSCertifyInfo)
-> Generic TPMSCertifyInfo
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
(TPMSCertifyInfo -> Value)
-> (TPMSCertifyInfo -> Encoding)
-> ([TPMSCertifyInfo] -> Value)
-> ([TPMSCertifyInfo] -> Encoding)
-> ToJSON TPMSCertifyInfo
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
(TPMSAttest -> TPMSAttest -> Bool)
-> (TPMSAttest -> TPMSAttest -> Bool) -> Eq TPMSAttest
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 -> FilePath
(Int -> TPMSAttest -> ShowS)
-> (TPMSAttest -> FilePath)
-> ([TPMSAttest] -> ShowS)
-> Show TPMSAttest
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TPMSAttest] -> ShowS
$cshowList :: [TPMSAttest] -> ShowS
show :: TPMSAttest -> FilePath
$cshow :: TPMSAttest -> FilePath
showsPrec :: Int -> TPMSAttest -> ShowS
$cshowsPrec :: Int -> TPMSAttest -> ShowS
Show, (forall x. TPMSAttest -> Rep TPMSAttest x)
-> (forall x. Rep TPMSAttest x -> TPMSAttest) -> Generic TPMSAttest
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
(TPMSAttest -> Value)
-> (TPMSAttest -> Encoding)
-> ([TPMSAttest] -> Value)
-> ([TPMSAttest] -> Encoding)
-> ToJSON TPMSAttest
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
(TPMUPublicParms -> TPMUPublicParms -> Bool)
-> (TPMUPublicParms -> TPMUPublicParms -> Bool)
-> Eq TPMUPublicParms
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 -> FilePath
(Int -> TPMUPublicParms -> ShowS)
-> (TPMUPublicParms -> FilePath)
-> ([TPMUPublicParms] -> ShowS)
-> Show TPMUPublicParms
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TPMUPublicParms] -> ShowS
$cshowList :: [TPMUPublicParms] -> ShowS
show :: TPMUPublicParms -> FilePath
$cshow :: TPMUPublicParms -> FilePath
showsPrec :: Int -> TPMUPublicParms -> ShowS
$cshowsPrec :: Int -> TPMUPublicParms -> ShowS
Show, (forall x. TPMUPublicParms -> Rep TPMUPublicParms x)
-> (forall x. Rep TPMUPublicParms x -> TPMUPublicParms)
-> Generic TPMUPublicParms
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
(TPMUPublicParms -> Value)
-> (TPMUPublicParms -> Encoding)
-> ([TPMUPublicParms] -> Value)
-> ([TPMUPublicParms] -> Encoding)
-> ToJSON TPMUPublicParms
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
(TPMUPublicId -> TPMUPublicId -> Bool)
-> (TPMUPublicId -> TPMUPublicId -> Bool) -> Eq TPMUPublicId
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 -> FilePath
(Int -> TPMUPublicId -> ShowS)
-> (TPMUPublicId -> FilePath)
-> ([TPMUPublicId] -> ShowS)
-> Show TPMUPublicId
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TPMUPublicId] -> ShowS
$cshowList :: [TPMUPublicId] -> ShowS
show :: TPMUPublicId -> FilePath
$cshow :: TPMUPublicId -> FilePath
showsPrec :: Int -> TPMUPublicId -> ShowS
$cshowsPrec :: Int -> TPMUPublicId -> ShowS
Show, (forall x. TPMUPublicId -> Rep TPMUPublicId x)
-> (forall x. Rep TPMUPublicId x -> TPMUPublicId)
-> Generic TPMUPublicId
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
(TPMUPublicId -> Value)
-> (TPMUPublicId -> Encoding)
-> ([TPMUPublicId] -> Value)
-> ([TPMUPublicId] -> Encoding)
-> ToJSON TPMUPublicId
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
(TPMTPublic -> TPMTPublic -> Bool)
-> (TPMTPublic -> TPMTPublic -> Bool) -> Eq TPMTPublic
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 -> FilePath
(Int -> TPMTPublic -> ShowS)
-> (TPMTPublic -> FilePath)
-> ([TPMTPublic] -> ShowS)
-> Show TPMTPublic
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TPMTPublic] -> ShowS
$cshowList :: [TPMTPublic] -> ShowS
show :: TPMTPublic -> FilePath
$cshow :: TPMTPublic -> FilePath
showsPrec :: Int -> TPMTPublic -> ShowS
$cshowsPrec :: Int -> TPMTPublic -> ShowS
Show, (forall x. TPMTPublic -> Rep TPMTPublic x)
-> (forall x. Rep TPMTPublic x -> TPMTPublic) -> Generic TPMTPublic
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
(TPMTPublic -> Value)
-> (TPMTPublic -> Encoding)
-> ([TPMTPublic] -> Value)
-> ([TPMTPublic] -> Encoding)
-> ToJSON TPMTPublic
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 -> FilePath
show = Text -> FilePath
Text.unpack (Text -> FilePath) -> (Format -> Text) -> Format -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> Text
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
(SubjectAlternativeName -> SubjectAlternativeName -> Bool)
-> (SubjectAlternativeName -> SubjectAlternativeName -> Bool)
-> Eq SubjectAlternativeName
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 -> FilePath
(Int -> SubjectAlternativeName -> ShowS)
-> (SubjectAlternativeName -> FilePath)
-> ([SubjectAlternativeName] -> ShowS)
-> Show SubjectAlternativeName
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [SubjectAlternativeName] -> ShowS
$cshowList :: [SubjectAlternativeName] -> ShowS
show :: SubjectAlternativeName -> FilePath
$cshow :: SubjectAlternativeName -> FilePath
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
(Statement -> Statement -> Bool)
-> (Statement -> Statement -> Bool) -> Eq Statement
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 -> FilePath
(Int -> Statement -> ShowS)
-> (Statement -> FilePath)
-> ([Statement] -> ShowS)
-> Show Statement
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Statement] -> ShowS
$cshowList :: [Statement] -> ShowS
show :: Statement -> FilePath
$cshow :: Statement -> FilePath
showsPrec :: Int -> Statement -> ShowS
$cshowsPrec :: Int -> Statement -> ShowS
Show)

instance ToJSON Statement where
  toJSON :: Statement -> Value
toJSON Statement {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
ByteString
NonEmpty SignedCertificate
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" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"2.0",
        Key
"alg" Key -> CoseSignAlg -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= PublicKeyWithSignAlg -> CoseSignAlg
Cose.signAlg PublicKeyWithSignAlg
aikPubKeyAndAlg,
        Key
"x5c" Key -> NonEmpty SignedCertificate -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty SignedCertificate
x5c,
        Key
"sig" Key -> ByteString -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString
sig,
        Key
"certInfo" Key -> TPMSAttest -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TPMSAttest
certInfo,
        Key
"pubArea" Key -> TPMTPublic -> Pair
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 -> FilePath
(Int -> VerificationError -> ShowS)
-> (VerificationError -> FilePath)
-> ([VerificationError] -> ShowS)
-> Show VerificationError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [VerificationError] -> ShowS
$cshowList :: [VerificationError] -> ShowS
show :: VerificationError -> FilePath
$cshow :: VerificationError -> FilePath
showsPrec :: Int -> VerificationError -> ShowS
$cshowsPrec :: Int -> VerificationError -> ShowS
Show, Show VerificationError
Typeable VerificationError
Typeable VerificationError
-> Show VerificationError
-> (VerificationError -> SomeException)
-> (SomeException -> Maybe VerificationError)
-> (VerificationError -> FilePath)
-> Exception VerificationError
SomeException -> Maybe VerificationError
VerificationError -> FilePath
VerificationError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> FilePath)
-> Exception e
displayException :: VerificationError -> FilePath
$cdisplayException :: VerificationError -> FilePath
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 = OID -> SubjectAlternativeName -> OID
forall a b. a -> b -> a
const [Integer
2, Integer
5, Integer
29, Integer
17]
  extHasNestedASN1 :: Proxy SubjectAlternativeName -> Bool
extHasNestedASN1 = Bool -> Proxy SubjectAlternativeName -> Bool
forall a b. a -> b -> a
const Bool
True
  extEncode :: SubjectAlternativeName -> [ASN1]
extEncode = FilePath -> SubjectAlternativeName -> [ASN1]
forall a. HasCallStack => FilePath -> a
error FilePath
"Unimplemented: This library does not implement encoding the SubjectAlternativeName extension"
  extDecode :: [ASN1] -> Either FilePath SubjectAlternativeName
extDecode [ASN1]
asn1 =
    ShowS
-> Either FilePath SubjectAlternativeName
-> Either FilePath SubjectAlternativeName
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilePath
"Could not decode ASN1 subject-alternative-name extension: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++) (Either FilePath SubjectAlternativeName
 -> Either FilePath SubjectAlternativeName)
-> Either FilePath SubjectAlternativeName
-> Either FilePath SubjectAlternativeName
forall a b. (a -> b) -> a -> b
$
      ParseASN1 SubjectAlternativeName
-> [ASN1] -> Either FilePath SubjectAlternativeName
forall a. ParseASN1 a -> [ASN1] -> Either FilePath a
runParseASN1 ParseASN1 SubjectAlternativeName
decodeSubjectAlternativeName [ASN1]
asn1
    where
      decodeSubjectAlternativeName :: ParseASN1 SubjectAlternativeName
      decodeSubjectAlternativeName :: ParseASN1 SubjectAlternativeName
decodeSubjectAlternativeName =
        do
          Map OID Text
map <- [(OID, Text)] -> Map OID Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(OID, Text)] -> Map OID Text)
-> ParseASN1 [(OID, Text)] -> ParseASN1 (Map OID Text)
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 <- ParseASN1 Text
-> (Text -> ParseASN1 Text) -> Maybe Text -> ParseASN1 Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> ParseASN1 Text
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"manufacturer field not found in subject alternative name") Text -> ParseASN1 Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> ParseASN1 Text) -> Maybe Text -> ParseASN1 Text
forall a b. (a -> b) -> a -> b
$ OID -> Map OID Text -> Maybe Text
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 <- ParseASN1 Text
-> (Text -> ParseASN1 Text) -> Maybe Text -> ParseASN1 Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> ParseASN1 Text
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"model field not found in subject alternative name") Text -> ParseASN1 Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> ParseASN1 Text) -> Maybe Text -> ParseASN1 Text
forall a b. (a -> b) -> a -> b
$ OID -> Map OID Text -> Maybe Text
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 <- ParseASN1 Text
-> (Text -> ParseASN1 Text) -> Maybe Text -> ParseASN1 Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> ParseASN1 Text
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"version field not found in subject alternative name") Text -> ParseASN1 Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> ParseASN1 Text) -> Maybe Text -> ParseASN1 Text
forall a b. (a -> b) -> a -> b
$ OID -> Map OID Text -> Maybe Text
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 -> Text -> Text -> SubjectAlternativeName
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 (ByteString -> Text) -> ByteString -> Text
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) (OID, Text) -> [(OID, Text)] -> [(OID, Text)]
forall a. a -> [a] -> [a]
: [(OID, Text)]
fields)
                  ASN1
_ -> ParseASN1 [(OID, Text)]
decodeFields
              ASN1
_ -> ParseASN1 [(OID, Text)]
decodeFields
          else [(OID, Text)] -> ParseASN1 [(OID, Text)]
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 HashMap Text Term -> Text -> Maybe Term
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"ver", HashMap Text Term
xs HashMap Text Term -> Text -> Maybe Term
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"alg", HashMap Text Term
xs HashMap Text Term -> Text -> Maybe Term
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"x5c", HashMap Text Term
xs HashMap Text Term -> Text -> Maybe Term
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"sig", HashMap Text Term
xs HashMap Text Term -> Text -> Maybe Term
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"certInfo", HashMap Text Term
xs HashMap Text Term -> Text -> Maybe Term
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 ([Term] -> Maybe (NonEmpty Term)
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]
_) <- NonEmpty Term
-> (Term -> Either Text SignedCertificate)
-> Either Text (NonEmpty SignedCertificate)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty Term
x5cRaw ((Term -> Either Text SignedCertificate)
 -> Either Text (NonEmpty SignedCertificate))
-> (Term -> Either Text SignedCertificate)
-> Either Text (NonEmpty SignedCertificate)
forall a b. (a -> b) -> a -> b
$ \case
            CBOR.TBytes ByteString
certBytes ->
              (FilePath -> Text)
-> Either FilePath SignedCertificate
-> Either Text SignedCertificate
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"Failed to decode signed certificate: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack) (ByteString -> Either FilePath SignedCertificate
X509.decodeSignedCertificate ByteString
certBytes)
            Term
cert ->
              Text -> Either Text SignedCertificate
forall a b. a -> Either a b
Left (Text -> Either Text SignedCertificate)
-> Text -> Either Text SignedCertificate
forall a b. (a -> b) -> a -> b
$ Text
"Certificate CBOR value is not bytes: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (Term -> FilePath
forall a. Show a => a -> FilePath
show Term
cert)
          CoseSignAlg
alg <- Int -> Either Text CoseSignAlg
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 Get TPMSAttest
-> ByteString
-> Either
     (ByteString, ByteOffset, FilePath)
     (ByteString, ByteOffset, TPMSAttest)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, FilePath) (ByteString, ByteOffset, a)
Get.runGetOrFail Get TPMSAttest
getTPMAttest (ByteString -> ByteString
LBS.fromStrict ByteString
certInfoRaw) of
            Left (ByteString
_, ByteOffset
_, FilePath
err) -> Text -> Either Text TPMSAttest
forall a b. a -> Either a b
Left (Text -> Either Text TPMSAttest) -> Text -> Either Text TPMSAttest
forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode certInfo: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (ShowS
forall a. Show a => a -> FilePath
show FilePath
err)
            Right (ByteString
_, ByteOffset
_, TPMSAttest
res) -> TPMSAttest -> Either Text TPMSAttest
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMSAttest
res
          TPMTPublic
pubArea <- case Get TPMTPublic
-> ByteString
-> Either
     (ByteString, ByteOffset, FilePath)
     (ByteString, ByteOffset, TPMTPublic)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, FilePath) (ByteString, ByteOffset, a)
Get.runGetOrFail Get TPMTPublic
getTPMTPublic (ByteString -> ByteString
LBS.fromStrict ByteString
pubAreaRaw) of
            Left (ByteString
_, ByteOffset
_, FilePath
err) -> Text -> Either Text TPMTPublic
forall a b. a -> Either a b
Left (Text -> Either Text TPMTPublic) -> Text -> Either Text TPMTPublic
forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode pubArea: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (ShowS
forall a. Show a => a -> FilePath
show FilePath
err)
            Right (ByteString
_, ByteOffset
_, TPMTPublic
res) -> TPMTPublic -> Either Text TPMTPublic
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 (PubKey -> Either Text PublicKey)
-> PubKey -> Either Text PublicKey
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 Extensions -> Maybe (Either FilePath SubjectAlternativeName)
forall a. Extension a => Extensions -> Maybe (Either FilePath a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
            Just (Right SubjectAlternativeName
ext) -> SubjectAlternativeName -> Either Text SubjectAlternativeName
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectAlternativeName
ext
            Just (Left FilePath
err) -> Text -> Either Text SubjectAlternativeName
forall a b. a -> Either a b
Left (Text -> Either Text SubjectAlternativeName)
-> Text -> Either Text SubjectAlternativeName
forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode certificate subject alternative name extension: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
err
            Maybe (Either FilePath SubjectAlternativeName)
Nothing -> Text -> Either Text SubjectAlternativeName
forall a b. a -> Either a b
Left Text
"Certificate subject alternative name extension is missing"
          Maybe IdFidoGenCeAAGUID
aaguidExt <- case Extensions -> Maybe (Either FilePath IdFidoGenCeAAGUID)
forall a. Extension a => Extensions -> Maybe (Either FilePath a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
            Just (Right IdFidoGenCeAAGUID
ext) -> Maybe IdFidoGenCeAAGUID -> Either Text (Maybe IdFidoGenCeAAGUID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe IdFidoGenCeAAGUID -> Either Text (Maybe IdFidoGenCeAAGUID))
-> Maybe IdFidoGenCeAAGUID -> Either Text (Maybe IdFidoGenCeAAGUID)
forall a b. (a -> b) -> a -> b
$ IdFidoGenCeAAGUID -> Maybe IdFidoGenCeAAGUID
forall a. a -> Maybe a
Just IdFidoGenCeAAGUID
ext
            Just (Left FilePath
err) -> Text -> Either Text (Maybe IdFidoGenCeAAGUID)
forall a b. a -> Either a b
Left (Text -> Either Text (Maybe IdFidoGenCeAAGUID))
-> Text -> Either Text (Maybe IdFidoGenCeAAGUID)
forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode certificate aaguid extension: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
err
            Maybe (Either FilePath IdFidoGenCeAAGUID)
Nothing -> Maybe IdFidoGenCeAAGUID -> Either Text (Maybe IdFidoGenCeAAGUID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IdFidoGenCeAAGUID
forall a. Maybe a
Nothing
          X509.ExtExtendedKeyUsage [ExtKeyUsagePurpose]
extendedKeyUsage <- case Extensions -> Maybe (Either FilePath ExtExtendedKeyUsage)
forall a. Extension a => Extensions -> Maybe (Either FilePath a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
            Just (Right ExtExtendedKeyUsage
ext) -> ExtExtendedKeyUsage -> Either Text ExtExtendedKeyUsage
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtExtendedKeyUsage
ext
            Just (Left FilePath
err) -> Text -> Either Text ExtExtendedKeyUsage
forall a b. a -> Either a b
Left (Text -> Either Text ExtExtendedKeyUsage)
-> Text -> Either Text ExtExtendedKeyUsage
forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode certificate extended key usage extension: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
err
            Maybe (Either FilePath ExtExtendedKeyUsage)
Nothing -> Text -> Either Text ExtExtendedKeyUsage
forall a b. a -> Either a b
Left Text
"Certificate extended key usage extension is missing"
          X509.ExtBasicConstraints Bool
basicConstraintsCA Maybe Integer
_ <- case Extensions -> Maybe (Either FilePath ExtBasicConstraints)
forall a. Extension a => Extensions -> Maybe (Either FilePath a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
            Just (Right ExtBasicConstraints
ext) -> ExtBasicConstraints -> Either Text ExtBasicConstraints
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtBasicConstraints
ext
            Just (Left FilePath
err) -> Text -> Either Text ExtBasicConstraints
forall a b. a -> Either a b
Left (Text -> Either Text ExtBasicConstraints)
-> Text -> Either Text ExtBasicConstraints
forall a b. (a -> b) -> a -> b
$ Text
"Failed to decode certificate basic constraints extension: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
err
            Maybe (Either FilePath ExtBasicConstraints)
Nothing -> Text -> Either Text ExtBasicConstraints
forall a b. a -> Either a b
Left Text
"Certificate basic constraints extension is missing"
          Statement -> Either Text Statement
forall a b. b -> Either a b
Right (Statement -> Either Text Statement)
-> Statement -> Either Text Statement
forall a b. (a -> b) -> a -> b
$ Statement :: NonEmpty SignedCertificate
-> Certificate
-> PublicKeyWithSignAlg
-> SubjectAlternativeName
-> Maybe IdFidoGenCeAAGUID
-> [ExtKeyUsagePurpose]
-> Bool
-> ByteString
-> TPMSAttest
-> ByteString
-> TPMTPublic
-> ByteString
-> PublicKey
-> Statement
Statement {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
ByteString
NonEmpty SignedCertificate
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)
_ -> Text -> Either Text Statement
forall a b. a -> Either a b
Left (Text -> Either Text Statement) -> Text -> Either Text Statement
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): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (HashMap Text Term -> FilePath
forall a. Show a => a -> FilePath
show HashMap Text Term
xs)
    where
      getTPMAttest :: Get.Get TPMSAttest
      getTPMAttest :: Get TPMSAttest
getTPMAttest = do
        TPMAObject
tpmsaMagic <- Get TPMAObject
Get.getWord32be
        Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TPMAObject
tpmsaMagic TPMAObject -> TPMAObject -> Bool
forall a. Eq a => a -> a -> Bool
== TPMAObject
tpmGeneratedValue) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Get ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"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
        TPMSAttest -> Get TPMSAttest
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMSAttest :: TPMAObject
-> Word16
-> ByteString
-> ByteString
-> TPMSClockInfo
-> Word64
-> TPMSCertifyInfo
-> TPMSAttest
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 <- (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
1) (Word8 -> Bool) -> Get Word8 -> Get Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
Get.getWord8
        pure TPMSClockInfo :: Word64 -> TPMAObject -> TPMAObject -> Bool -> TPMSClockInfo
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 -> ByteString -> TPMSCertifyInfo
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 (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
size)

      getTPMTPublic :: Get.Get TPMTPublic
      getTPMTPublic :: Get TPMTPublic
getTPMTPublic = do
        TPMAlgId
tpmtpType <- Word16 -> Get TPMAlgId
forall (m :: * -> *). MonadFail m => Word16 -> m TPMAlgId
toTPMAlgId (Word16 -> Get TPMAlgId) -> Get Word16 -> Get TPMAlgId
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 <- Word16 -> Get TPMAlgId
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
        TPMTPublic -> Get TPMTPublic
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMTPublic :: TPMAlgId
-> TPMAlgId
-> Word16
-> TPMAObject
-> ByteString
-> TPMUPublicParms
-> TPMUPublicId
-> TPMTPublic
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 TPMAObject -> TPMAObject -> Bool
forall a. Eq a => a -> a -> Bool
== TPMAObject
0 then TPMAObject
65537 else TPMAObject
e) (TPMAObject -> TPMAObject) -> Get TPMAObject -> Get TPMAObject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get TPMAObject
Get.getWord32be
        pure TPMSRSAParms :: Word16 -> Word16 -> Word16 -> TPMAObject -> TPMUPublicParms
TPMSRSAParms {Word16
TPMAObject
tpmsrpExponent :: TPMAObject
tpmsrpKeyBits :: Word16
tpmsrpScheme :: Word16
tpmsrpSymmetric :: Word16
tpmsrpExponent :: TPMAObject
tpmsrpKeyBits :: Word16
tpmsrpScheme :: Word16
tpmsrpSymmetric :: Word16
..}
      getTPMUPublicParms TPMAlgId
TPMAlgSHA1 = FilePath -> Get TPMUPublicParms
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"SHA1 does not have public key parameters"
      getTPMUPublicParms TPMAlgId
TPMAlgSHA256 = FilePath -> Get TPMUPublicParms
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"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 <- Word16 -> Get CoseCurveECDSA
forall (m :: * -> *). MonadFail m => Word16 -> m CoseCurveECDSA
toCurveId (Word16 -> Get CoseCurveECDSA) -> Get Word16 -> Get CoseCurveECDSA
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 -> Word16 -> CoseCurveECDSA -> Word16 -> TPMUPublicParms
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 (ByteString -> TPMUPublicId) -> Get ByteString -> Get TPMUPublicId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getTPMByteString
      getTPMUPublicId TPMAlgId
TPMAlgSHA1 = FilePath -> Get TPMUPublicId
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"SHA1 does not have a public id"
      getTPMUPublicId TPMAlgId
TPMAlgSHA256 = FilePath -> Get TPMUPublicId
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"SHA256 does not have a public id"
      getTPMUPublicId TPMAlgId
TPMAlgECC = do
        ByteString
tpmseX <- Get ByteString
getTPMByteString
        ByteString
tpmseY <- Get ByteString
getTPMByteString
        pure TPMSECCPoint :: ByteString -> ByteString -> TPMUPublicId
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
            PublicKeyRSA :: Integer -> Integer -> UncheckedPublicKey
Cose.PublicKeyRSA
              { rsaN :: Integer
rsaN = ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
nb,
                rsaE :: Integer
rsaE = TPMAObject -> Integer
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
            PublicKeyECDSA :: CoseCurveECDSA -> Integer -> Integer -> UncheckedPublicKey
Cose.PublicKeyECDSA
              { ecdsaCurve :: CoseCurveECDSA
ecdsaCurve = CoseCurveECDSA
tpmsepCurveId,
                ecdsaX :: Integer
ecdsaX = ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
tpmseX,
                ecdsaY :: Integer
ecdsaY = ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
tpmseY
              }
      extractPublicKey TPMTPublic
key = Text -> Either Text PublicKey
forall a b. a -> Either a b
Left (Text -> Either Text PublicKey) -> Text -> Either Text PublicKey
forall a b. (a -> b) -> a -> b
$ Text
"Unsupported TPM public key: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (TPMTPublic -> FilePath
forall a. Show a => a -> FilePath
show TPMTPublic
key)

  asfEncode :: Format -> AttStmt Format -> Term
asfEncode Format
_ Statement {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
ByteString
NonEmpty SignedCertificate
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 (Int -> Term) -> Int -> Term
forall a b. (a -> b) -> a -> b
$ CoseSignAlg -> Int
forall p. Num p => CoseSignAlg -> p
Cose.fromCoseSignAlg (CoseSignAlg -> Int) -> CoseSignAlg -> Int
forall a b. (a -> b) -> a -> b
$ PublicKeyWithSignAlg -> CoseSignAlg
Cose.signAlg PublicKeyWithSignAlg
aikPubKeyAndAlg),
        ( Text -> Term
CBOR.TString Text
"x5c",
          [Term] -> Term
CBOR.TList ([Term] -> Term) -> [Term] -> Term
forall a b. (a -> b) -> a -> b
$ (SignedCertificate -> Term) -> [SignedCertificate] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Term
CBOR.TBytes (ByteString -> Term)
-> (SignedCertificate -> ByteString) -> SignedCertificate -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedCertificate -> ByteString
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> ByteString
X509.encodeSignedObject) ([SignedCertificate] -> [Term]) -> [SignedCertificate] -> [Term]
forall a b. (a -> b) -> a -> b
$ NonEmpty SignedCertificate -> [SignedCertificate]
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
ByteString
NonEmpty SignedCertificate
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 (PublicKeyWithSignAlg -> PublicKey)
-> PublicKeyWithSignAlg -> PublicKey
forall a b. (a -> b) -> a -> b
$ AttestedCredentialData 'Registration 'True -> PublicKeyWithSignAlg
forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> PublicKeyWithSignAlg
M.acdCredentialPublicKey AttestedCredentialData 'Registration 'True
adAttestedCredentialData
      Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PublicKey
pubAreaKey PublicKey -> PublicKey -> Bool
forall a. Eq a => a -> a -> Bool
== PublicKey
pubKey) (Validation (NonEmpty VerificationError) ()
 -> Validation (NonEmpty VerificationError) ())
-> (VerificationError
    -> Validation (NonEmpty VerificationError) ())
-> VerificationError
-> Validation (NonEmpty VerificationError) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (VerificationError -> Validation (NonEmpty VerificationError) ())
-> VerificationError -> Validation (NonEmpty VerificationError) ()
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 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Digest SHA256 -> ByteString
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
      Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TPMAObject
magic TPMAObject -> TPMAObject -> Bool
forall a. Eq a => a -> a -> Bool
== TPMAObject
tpmGeneratedValue) (Validation (NonEmpty VerificationError) ()
 -> Validation (NonEmpty VerificationError) ())
-> (VerificationError
    -> Validation (NonEmpty VerificationError) ())
-> VerificationError
-> Validation (NonEmpty VerificationError) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (VerificationError -> Validation (NonEmpty VerificationError) ())
-> VerificationError -> Validation (NonEmpty VerificationError) ()
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
      Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word16
typ Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
tpmStAttestCertify) (Validation (NonEmpty VerificationError) ()
 -> Validation (NonEmpty VerificationError) ())
-> (VerificationError
    -> Validation (NonEmpty VerificationError) ())
-> VerificationError
-> Validation (NonEmpty VerificationError) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (VerificationError -> Validation (NonEmpty VerificationError) ())
-> VerificationError -> Validation (NonEmpty VerificationError) ()
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 CoseSignAlg -> ByteString -> Maybe ByteString
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
          Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
attHash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
extraData) (Validation (NonEmpty VerificationError) ()
 -> Validation (NonEmpty VerificationError) ())
-> (VerificationError
    -> Validation (NonEmpty VerificationError) ())
-> VerificationError
-> Validation (NonEmpty VerificationError) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (VerificationError -> Validation (NonEmpty VerificationError) ())
-> VerificationError -> Validation (NonEmpty VerificationError) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> VerificationError
HashMismatch ByteString
attHash ByteString
extraData
          pure ()
        Maybe ByteString
Nothing -> VerificationError -> Validation (NonEmpty VerificationError) ()
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 -> ByteString -> Either TPMAlgId ByteString
forall a b. b -> Either a b
Right (ByteString -> Either TPMAlgId ByteString)
-> ByteString -> Either TPMAlgId ByteString
forall a b. (a -> b) -> a -> b
$ Digest SHA1 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest SHA1 -> ByteString) -> Digest SHA1 -> ByteString
forall a b. (a -> b) -> a -> b
$ SHA1 -> ByteString -> Digest SHA1
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA1
SHA1 ByteString
pubAreaRaw
            TPMAlgId
TPMAlgSHA256 -> ByteString -> Either TPMAlgId ByteString
forall a b. b -> Either a b
Right (ByteString -> Either TPMAlgId ByteString)
-> ByteString -> Either TPMAlgId ByteString
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (Digest SHA256 -> ByteString) -> Digest SHA256 -> ByteString
forall a b. (a -> b) -> a -> b
$ SHA256 -> ByteString -> Digest SHA256
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA256
SHA256 ByteString
pubAreaRaw
            TPMAlgId
TPMAlgECC -> TPMAlgId -> Either TPMAlgId ByteString
forall a b. a -> Either a b
Left TPMAlgId
TPMAlgECC
            TPMAlgId
TPMAlgRSA -> TPMAlgId -> Either TPMAlgId ByteString
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 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
                Put -> ByteString
Put.runPut (Put -> ByteString) -> Put -> ByteString
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)
          Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
pubName) (Validation (NonEmpty VerificationError) ()
 -> Validation (NonEmpty VerificationError) ())
-> (VerificationError
    -> Validation (NonEmpty VerificationError) ())
-> VerificationError
-> Validation (NonEmpty VerificationError) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (VerificationError -> Validation (NonEmpty VerificationError) ())
-> VerificationError -> Validation (NonEmpty VerificationError) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> VerificationError
NameMismatch ByteString
pubName ByteString
name
          pure ()
        Left TPMAlgId
alg -> VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (VerificationError -> Validation (NonEmpty VerificationError) ())
-> VerificationError -> Validation (NonEmpty VerificationError) ()
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 () -> () -> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Left Text
err -> VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (VerificationError -> Validation (NonEmpty VerificationError) ())
-> VerificationError -> Validation (NonEmpty VerificationError) ()
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
      Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
version Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Validation (NonEmpty VerificationError) ()
 -> Validation (NonEmpty VerificationError) ())
-> (VerificationError
    -> Validation (NonEmpty VerificationError) ())
-> VerificationError
-> Validation (NonEmpty VerificationError) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (VerificationError -> Validation (NonEmpty VerificationError) ())
-> VerificationError -> Validation (NonEmpty VerificationError) ()
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 (DistinguishedName -> [(OID, ASN1CharacterString)])
-> DistinguishedName -> [(OID, ASN1CharacterString)]
forall a b. (a -> b) -> a -> b
$ Certificate -> DistinguishedName
X509.certSubjectDN Certificate
aikCert
      Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(OID, ASN1CharacterString)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(OID, ASN1CharacterString)]
subject) (Validation (NonEmpty VerificationError) ()
 -> Validation (NonEmpty VerificationError) ())
-> (VerificationError
    -> Validation (NonEmpty VerificationError) ())
-> VerificationError
-> Validation (NonEmpty VerificationError) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (VerificationError -> Validation (NonEmpty VerificationError) ())
-> VerificationError -> Validation (NonEmpty VerificationError) ()
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
      Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
vendor Set Text
tpmManufacturers) (Validation (NonEmpty VerificationError) ()
 -> Validation (NonEmpty VerificationError) ())
-> (VerificationError
    -> Validation (NonEmpty VerificationError) ())
-> VerificationError
-> Validation (NonEmpty VerificationError) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (VerificationError -> Validation (NonEmpty VerificationError) ())
-> VerificationError -> Validation (NonEmpty VerificationError) ()
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)").
      Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (OID -> ExtKeyUsagePurpose
X509.KeyUsagePurpose_Unknown [Integer
2, Integer
23, Integer
133, Integer
8, Integer
3] ExtKeyUsagePurpose -> [ExtKeyUsagePurpose] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ExtKeyUsagePurpose]
extendedKeyUsage) (Validation (NonEmpty VerificationError) ()
 -> Validation (NonEmpty VerificationError) ())
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall a b. (a -> b) -> a -> b
$ VerificationError -> Validation (NonEmpty VerificationError) ()
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.
      Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
basicConstraintsCA (Validation (NonEmpty VerificationError) ()
 -> Validation (NonEmpty VerificationError) ())
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall a b. (a -> b) -> a -> b
$ VerificationError -> Validation (NonEmpty VerificationError) ()
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 = AttestedCredentialData 'Registration 'True -> AAGUID
forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> AAGUID
M.acdAaguid AttestedCredentialData 'Registration 'True
adAttestedCredentialData
      case Maybe IdFidoGenCeAAGUID
aaguidExt of
        Just (IdFidoGenCeAAGUID AAGUID
aaguid) -> do
          Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AAGUID
aaguid AAGUID -> AAGUID -> Bool
forall a. Eq a => a -> a -> Bool
== AAGUID
credentialAAGUID) (Validation (NonEmpty VerificationError) ()
 -> Validation (NonEmpty VerificationError) ())
-> (VerificationError
    -> Validation (NonEmpty VerificationError) ())
-> VerificationError
-> Validation (NonEmpty VerificationError) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (VerificationError -> Validation (NonEmpty VerificationError) ())
-> VerificationError -> Validation (NonEmpty VerificationError) ()
forall a b. (a -> b) -> a -> b
$ AAGUID -> AAGUID -> VerificationError
CertificateAAGUIDMismatch AAGUID
aaguid AAGUID
credentialAAGUID
        Maybe IdFidoGenCeAAGUID
Nothing -> () -> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      pure $
        AttestationType ('Verifiable 'Fido2) -> SomeAttestationType
forall (k :: AttestationKind).
AttestationType k -> SomeAttestationType
M.SomeAttestationType (AttestationType ('Verifiable 'Fido2) -> SomeAttestationType)
-> AttestationType ('Verifiable 'Fido2) -> SomeAttestationType
forall a b. (a -> b) -> a -> b
$
          VerifiableAttestationType
-> AttestationChain 'Fido2 -> AttestationType ('Verifiable 'Fido2)
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
_ =
          Maybe bout
forall a. Maybe a
Nothing
        hashWithCorrectAlgorithm (Cose.CoseSignAlgECDSA CoseHashAlgECDSA
Cose.CoseHashAlgECDSASHA256) ba
bytes =
          bout -> Maybe bout
forall (f :: * -> *) a. Applicative f => a -> f a
pure (bout -> Maybe bout) -> bout -> Maybe bout
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SHA256 -> ba -> Digest SHA256
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 =
          bout -> Maybe bout
forall (f :: * -> *) a. Applicative f => a -> f a
pure (bout -> Maybe bout) -> bout -> Maybe bout
forall a b. (a -> b) -> a -> b
$ Digest SHA384 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SHA384 -> ba -> Digest SHA384
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 =
          bout -> Maybe bout
forall (f :: * -> *) a. Applicative f => a -> f a
pure (bout -> Maybe bout) -> bout -> Maybe bout
forall a b. (a -> b) -> a -> b
$ Digest SHA512 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SHA512 -> ba -> Digest SHA512
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 =
          bout -> Maybe bout
forall (f :: * -> *) a. Applicative f => a -> f a
pure (bout -> Maybe bout) -> bout -> Maybe bout
forall a b. (a -> b) -> a -> b
$ Digest SHA1 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SHA1 -> ba -> Digest SHA1
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 =
          bout -> Maybe bout
forall (f :: * -> *) a. Applicative f => a -> f a
pure (bout -> Maybe bout) -> bout -> Maybe bout
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SHA256 -> ba -> Digest SHA256
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 =
          bout -> Maybe bout
forall (f :: * -> *) a. Applicative f => a -> f a
pure (bout -> Maybe bout) -> bout -> Maybe bout
forall a b. (a -> b) -> a -> b
$ Digest SHA384 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SHA384 -> ba -> Digest SHA384
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 =
          bout -> Maybe bout
forall (f :: * -> *) a. Applicative f => a -> f a
pure (bout -> Maybe bout) -> bout -> Maybe bout
forall a b. (a -> b) -> a -> b
$ Digest SHA512 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SHA512 -> ba -> Digest SHA512
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 ([SignedCertificate] -> CertificateStore)
-> [SignedCertificate] -> CertificateStore
forall a b. (a -> b) -> a -> b
$ ((Text, SignedCertificate) -> SignedCertificate)
-> [(Text, SignedCertificate)] -> [SignedCertificate]
forall a b. (a -> b) -> [a] -> [b]
map (Text, SignedCertificate) -> SignedCertificate
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 = (FilePath, ByteString) -> (Text, SignedCertificate)
processEntry ((FilePath, ByteString) -> (Text, SignedCertificate))
-> [(FilePath, ByteString)] -> [(Text, SignedCertificate)]
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 :: (FilePath, ByteString) -> (Text, SignedCertificate)
processEntry (FilePath
path, ByteString
bytes) = case ByteString -> Either FilePath SignedCertificate
X509.decodeSignedCertificate ByteString
bytes of
      Right SignedCertificate
cert -> ((Char -> Bool) -> Text -> Text
Text.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') (FilePath -> Text
Text.pack FilePath
path), SignedCertificate
cert)
      Left FilePath
err -> FilePath -> (Text, SignedCertificate)
forall a. HasCallStack => FilePath -> a
error (FilePath -> (Text, SignedCertificate))
-> FilePath -> (Text, SignedCertificate)
forall a b. (a -> b) -> a -> b
$ FilePath
"Error while decoding certificate " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
path FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
": " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
err

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