{-# 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 (..),
  )
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.Algorithm as Cose
import qualified Crypto.WebAuthn.Cose.Internal.Verify as Cose
import qualified Crypto.WebAuthn.Cose.Key as Cose
import Crypto.WebAuthn.Internal.Utils (IdFidoGenCeAAGUID (IdFidoGenCeAAGUID), failure)
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 -> String
(Int -> TPMAlgId -> ShowS)
-> (TPMAlgId -> String) -> ([TPMAlgId] -> ShowS) -> Show TPMAlgId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TPMAlgId] -> ShowS
$cshowList :: [TPMAlgId] -> ShowS
show :: TPMAlgId -> String
$cshow :: TPMAlgId -> String
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 :: 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
_ = String -> m TPMAlgId
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 :: 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
_ = String -> m CoseCurveECDSA
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported Curve ID"

-- | [(spec)](https://trustedcomputinggroup.org/wp-content/uploads/TCG_TPM2_r1p59_Part2_Structures_pub.pdf)
tpmGeneratedValue :: Word32
tpmGeneratedValue :: Word32
tpmGeneratedValue = Word32
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 -> Word32
tpmsciResetCount :: Word32,
    TPMSClockInfo -> Word32
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 -> String
(Int -> TPMSClockInfo -> ShowS)
-> (TPMSClockInfo -> String)
-> ([TPMSClockInfo] -> ShowS)
-> Show TPMSClockInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TPMSClockInfo] -> ShowS
$cshowList :: [TPMSClockInfo] -> ShowS
show :: TPMSClockInfo -> String
$cshow :: TPMSClockInfo -> String
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 -> String
(Int -> TPMSCertifyInfo -> ShowS)
-> (TPMSCertifyInfo -> String)
-> ([TPMSCertifyInfo] -> ShowS)
-> Show TPMSCertifyInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TPMSCertifyInfo] -> ShowS
$cshowList :: [TPMSCertifyInfo] -> ShowS
show :: TPMSCertifyInfo -> String
$cshow :: TPMSCertifyInfo -> String
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 -> Word32
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 -> String
(Int -> TPMSAttest -> ShowS)
-> (TPMSAttest -> String)
-> ([TPMSAttest] -> ShowS)
-> Show TPMSAttest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TPMSAttest] -> ShowS
$cshowList :: [TPMSAttest] -> ShowS
show :: TPMSAttest -> String
$cshow :: TPMSAttest -> String
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 -> Word32
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 -> String
(Int -> TPMUPublicParms -> ShowS)
-> (TPMUPublicParms -> String)
-> ([TPMUPublicParms] -> ShowS)
-> Show TPMUPublicParms
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TPMUPublicParms] -> ShowS
$cshowList :: [TPMUPublicParms] -> ShowS
show :: TPMUPublicParms -> String
$cshow :: TPMUPublicParms -> String
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 -> String
(Int -> TPMUPublicId -> ShowS)
-> (TPMUPublicId -> String)
-> ([TPMUPublicId] -> ShowS)
-> Show TPMUPublicId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TPMUPublicId] -> ShowS
$cshowList :: [TPMUPublicId] -> ShowS
show :: TPMUPublicId -> String
$cshow :: TPMUPublicId -> String
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 -> Word32
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 -> String
(Int -> TPMTPublic -> ShowS)
-> (TPMTPublic -> String)
-> ([TPMTPublic] -> ShowS)
-> Show TPMTPublic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TPMTPublic] -> ShowS
$cshowList :: [TPMTPublic] -> ShowS
show :: TPMTPublic -> String
$cshow :: TPMTPublic -> String
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 -> String
show = Text -> String
Text.unpack (Text -> String) -> (Format -> Text) -> Format -> String
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 -> String
(Int -> SubjectAlternativeName -> ShowS)
-> (SubjectAlternativeName -> String)
-> ([SubjectAlternativeName] -> ShowS)
-> Show SubjectAlternativeName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SubjectAlternativeName] -> ShowS
$cshowList :: [SubjectAlternativeName] -> ShowS
show :: SubjectAlternativeName -> String
$cshow :: SubjectAlternativeName -> String
showsPrec :: Int -> SubjectAlternativeName -> ShowS
$cshowsPrec :: Int -> SubjectAlternativeName -> ShowS
Show)

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-tpm-attestation)
data Statement = Statement
  { Statement -> CoseSignAlg
alg :: Cose.CoseSignAlg,
    Statement -> NonEmpty SignedCertificate
x5c :: NE.NonEmpty X509.SignedCertificate,
    Statement -> SignedCertificate
aikCert :: X509.SignedCertificate,
    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 -> String
(Int -> Statement -> ShowS)
-> (Statement -> String)
-> ([Statement] -> ShowS)
-> Show Statement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Statement] -> ShowS
$cshowList :: [Statement] -> ShowS
show :: Statement -> String
$cshow :: Statement -> String
showsPrec :: Int -> Statement -> ShowS
$cshowsPrec :: Int -> Statement -> ShowS
Show)

instance ToJSON Statement where
  toJSON :: Statement -> Value
toJSON Statement {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
ByteString
NonEmpty SignedCertificate
SignedCertificate
CoseSignAlg
PublicKey
SubjectAlternativeName
TPMTPublic
TPMSAttest
pubAreaKey :: PublicKey
pubAreaRaw :: ByteString
pubArea :: TPMTPublic
certInfoRaw :: ByteString
certInfo :: TPMSAttest
sig :: ByteString
basicConstraintsCA :: Bool
extendedKeyUsage :: [ExtKeyUsagePurpose]
aaguidExt :: Maybe IdFidoGenCeAAGUID
subjectAlternativeName :: SubjectAlternativeName
aikCert :: SignedCertificate
x5c :: NonEmpty SignedCertificate
alg :: CoseSignAlg
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
aikCert :: Statement -> SignedCertificate
x5c :: Statement -> NonEmpty SignedCertificate
alg :: Statement -> CoseSignAlg
..} =
    [Pair] -> Value
object
      [ Text
"ver" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text -> Value
String Text
"2.0",
        Text
"alg" Text -> CoseSignAlg -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= CoseSignAlg
alg,
        Text
"x5c" Text -> NonEmpty SignedCertificate -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= NonEmpty SignedCertificate
x5c,
        Text
"sig" Text -> ByteString -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ByteString
sig,
        Text
"certInfo" Text -> TPMSAttest -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TPMSAttest
certInfo,
        Text
"pubArea" Text -> TPMTPublic -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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
    VerificationErrorCredentialKeyMismatch
  | -- | The magic number in certInfo was not set to TPM_GENERATED_VALUE
    VerificationErrorInvalidMagicNumber Word32
  | -- | The type in certInfo was not set to TPM_ST_ATTEST_CERTIFY
    VerificationErrorInvalidType Word16
  | -- | The algorithm specified in the nameAlg field is unsupported or is not
    -- a valid name algorithm
    VerificationErrorInvalidNameAlgorithm
  | -- | The calulated name does not match the provided name.
    -- (first: expected, second: received)
    VerificationErrorInvalidName BS.ByteString BS.ByteString
  | -- | The public key in the certificate was invalid, either because the it
    -- had an unexpected algorithm, or because it was otherwise malformed
    VerificationErrorInvalidPublicKey Text
  | -- | The certificate didn't have the expected version-value
    -- (first: expected, second: received)
    VerificationErrorCertificateVersion Int Int
  | -- | The Public key cannot verify the signature over the authenticatorData
    -- and the clientDataHash.
    VerificationErrorVerificationFailure Text
  | -- | The subject field was not empty
    VerificationErrorNonEmptySubjectField
  | -- | The vendor was unknown
    VerificationErrorUnknownVendor
  | -- | The Extended Key Usage did not contain the 2.23.133.8.3 OID
    VerificationErrorExtKeyOIDMissing
  | -- | The CA component of the basic constraints extension was set to True
    VerificationErrorBasicConstraintsTrue
  | -- | The AAGUID in the certificate extension does not match the AAGUID in
    -- the authenticator data
    VerificationErrorCertificateAAGUIDMismatch
  | -- | The (supposedly) ASN1 encoded certificate extension could not be
    -- decoded
    VerificationErrorASN1Error ASN1Error
  | -- | The certificate extension does not contain a AAGUID
    VerificationErrorCredentialAAGUIDMissing
  | -- | The desired algorithm does not have a known associated hash function
    VerificationErrorUnknownHashFunction
  | -- | The calculated hash over the attToBeSigned does not match the received
    -- hash
    -- (first: calculated, second: received)
    VerificationErrorHashMismatch BS.ByteString BS.ByteString
  deriving (Int -> VerificationError -> ShowS
[VerificationError] -> ShowS
VerificationError -> String
(Int -> VerificationError -> ShowS)
-> (VerificationError -> String)
-> ([VerificationError] -> ShowS)
-> Show VerificationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VerificationError] -> ShowS
$cshowList :: [VerificationError] -> ShowS
show :: VerificationError -> String
$cshow :: VerificationError -> String
showsPrec :: Int -> VerificationError -> ShowS
$cshowsPrec :: Int -> VerificationError -> ShowS
Show, Show VerificationError
Typeable VerificationError
Typeable VerificationError
-> Show VerificationError
-> (VerificationError -> SomeException)
-> (SomeException -> Maybe VerificationError)
-> (VerificationError -> String)
-> Exception VerificationError
SomeException -> Maybe VerificationError
VerificationError -> String
VerificationError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: VerificationError -> String
$cdisplayException :: VerificationError -> String
fromException :: SomeException -> Maybe VerificationError
$cfromException :: SomeException -> Maybe VerificationError
toException :: VerificationError -> SomeException
$ctoException :: VerificationError -> SomeException
$cp2Exception :: Show VerificationError
$cp1Exception :: Typeable VerificationError
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 = String -> SubjectAlternativeName -> [ASN1]
forall a. HasCallStack => String -> a
error String
"Unimplemented: This library does not implement encoding the SubjectAlternativeName extension"
  extDecode :: [ASN1] -> Either String SubjectAlternativeName
extDecode [ASN1]
asn1 =
    ShowS
-> Either String SubjectAlternativeName
-> Either String SubjectAlternativeName
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String
"Could not decode ASN1 subject-alternative-name extension: " String -> ShowS
forall a. [a] -> [a] -> [a]
++) (Either String SubjectAlternativeName
 -> Either String SubjectAlternativeName)
-> Either String SubjectAlternativeName
-> Either String SubjectAlternativeName
forall a b. (a -> b) -> a -> b
$
      ParseASN1 SubjectAlternativeName
-> [ASN1] -> Either String SubjectAlternativeName
forall a. ParseASN1 a -> [ASN1] -> Either String 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 (String -> ParseASN1 Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 (String -> ParseASN1 Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 (String -> ParseASN1 Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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
aikCert :| [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 ->
              (String -> Text)
-> Either String 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) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) (ByteString -> Either String 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
<> String -> Text
Text.pack (Term -> String
forall a. Show a => a -> String
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, String)
     (ByteString, ByteOffset, TPMSAttest)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Get.runGetOrFail Get TPMSAttest
getTPMAttest (ByteString -> ByteString
LBS.fromStrict ByteString
certInfoRaw) of
            Left (ByteString
_, ByteOffset
_, String
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
<> String -> Text
Text.pack (ShowS
forall a. Show a => a -> String
show String
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, String)
     (ByteString, ByteOffset, TPMTPublic)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Get.runGetOrFail Get TPMTPublic
getTPMTPublic (ByteString -> ByteString
LBS.fromStrict ByteString
pubAreaRaw) of
            Left (ByteString
_, ByteOffset
_, String
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
<> String -> Text
Text.pack (ShowS
forall a. Show a => a -> String
show String
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 cert :: Certificate
cert = SignedCertificate -> Certificate
X509.getCertificate SignedCertificate
aikCert

          SubjectAlternativeName
subjectAlternativeName <- case Extensions -> Maybe (Either String SubjectAlternativeName)
forall a. Extension a => Extensions -> Maybe (Either String a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
cert) of
            Just (Right SubjectAlternativeName
ext) -> SubjectAlternativeName -> Either Text SubjectAlternativeName
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectAlternativeName
ext
            Just (Left String
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
<> String -> Text
Text.pack String
err
            Maybe (Either String 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 String IdFidoGenCeAAGUID)
forall a. Extension a => Extensions -> Maybe (Either String a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
cert) 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 String
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
<> String -> Text
Text.pack String
err
            Maybe (Either String 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 String ExtExtendedKeyUsage)
forall a. Extension a => Extensions -> Maybe (Either String a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
cert) of
            Just (Right ExtExtendedKeyUsage
ext) -> ExtExtendedKeyUsage -> Either Text ExtExtendedKeyUsage
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtExtendedKeyUsage
ext
            Just (Left String
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
<> String -> Text
Text.pack String
err
            Maybe (Either String 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 String ExtBasicConstraints)
forall a. Extension a => Extensions -> Maybe (Either String a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
cert) of
            Just (Right ExtBasicConstraints
ext) -> ExtBasicConstraints -> Either Text ExtBasicConstraints
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtBasicConstraints
ext
            Just (Left String
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
<> String -> Text
Text.pack String
err
            Maybe (Either String 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 :: CoseSignAlg
-> NonEmpty SignedCertificate
-> SignedCertificate
-> SubjectAlternativeName
-> Maybe IdFidoGenCeAAGUID
-> [ExtKeyUsagePurpose]
-> Bool
-> ByteString
-> TPMSAttest
-> ByteString
-> TPMTPublic
-> ByteString
-> PublicKey
-> Statement
Statement {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
ByteString
NonEmpty SignedCertificate
SignedCertificate
CoseSignAlg
PublicKey
SubjectAlternativeName
TPMTPublic
TPMSAttest
basicConstraintsCA :: Bool
extendedKeyUsage :: [ExtKeyUsagePurpose]
aaguidExt :: Maybe IdFidoGenCeAAGUID
subjectAlternativeName :: SubjectAlternativeName
pubAreaKey :: PublicKey
pubArea :: TPMTPublic
certInfo :: TPMSAttest
alg :: CoseSignAlg
aikCert :: SignedCertificate
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
aikCert :: SignedCertificate
x5c :: NonEmpty SignedCertificate
alg :: CoseSignAlg
..}
      (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
<> String -> Text
Text.pack (HashMap Text Term -> String
forall a. Show a => a -> String
show HashMap Text Term
xs)
    where
      getTPMAttest :: Get.Get TPMSAttest
      getTPMAttest :: Get TPMSAttest
getTPMAttest = do
        Word32
tpmsaMagic <- Get Word32
Get.getWord32be
        Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
tpmsaMagic Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
tpmGeneratedValue) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 :: Word32
-> Word16
-> ByteString
-> ByteString
-> TPMSClockInfo
-> Word64
-> TPMSCertifyInfo
-> TPMSAttest
TPMSAttest {Word16
Word32
Word64
ByteString
TPMSCertifyInfo
TPMSClockInfo
tpmsaAttested :: TPMSCertifyInfo
tpmsaFirmwareVersion :: Word64
tpmsaClockInfo :: TPMSClockInfo
tpmsaExtraData :: ByteString
tpmsaQualifiedSigner :: ByteString
tpmsaType :: Word16
tpmsaMagic :: Word32
tpmsaAttested :: TPMSCertifyInfo
tpmsaFirmwareVersion :: Word64
tpmsaClockInfo :: TPMSClockInfo
tpmsaExtraData :: ByteString
tpmsaQualifiedSigner :: ByteString
tpmsaType :: Word16
tpmsaMagic :: Word32
..}

      getClockInfo :: Get.Get TPMSClockInfo
      getClockInfo :: Get TPMSClockInfo
getClockInfo = do
        Word64
tpmsciClock <- Get Word64
Get.getWord64be
        Word32
tpmsciResetCount <- Get Word32
Get.getWord32be
        Word32
tpmsciRestartCount <- Get Word32
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 -> Word32 -> Word32 -> Bool -> TPMSClockInfo
TPMSClockInfo {Bool
Word32
Word64
tpmsciSafe :: Bool
tpmsciRestartCount :: Word32
tpmsciResetCount :: Word32
tpmsciClock :: Word64
tpmsciSafe :: Bool
tpmsciRestartCount :: Word32
tpmsciResetCount :: Word32
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
        Word32
tpmtpObjectAttributes <- Get Word32
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
-> Word32
-> ByteString
-> TPMUPublicParms
-> TPMUPublicId
-> TPMTPublic
TPMTPublic {Word16
Word32
ByteString
TPMUPublicId
TPMUPublicParms
TPMAlgId
tpmtpUnique :: TPMUPublicId
tpmtpParameters :: TPMUPublicParms
tpmtpAuthPolicy :: ByteString
tpmtpObjectAttributes :: Word32
tpmtpNameAlg :: TPMAlgId
tpmtpNameAlgRaw :: Word16
tpmtpType :: TPMAlgId
tpmtpUnique :: TPMUPublicId
tpmtpParameters :: TPMUPublicParms
tpmtpAuthPolicy :: ByteString
tpmtpObjectAttributes :: Word32
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 Word32
getTPMAObject = Get Word32
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
        Word32
tpmsrpExponent <- (\Word32
e -> if Word32
e Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 then Word32
65537 else Word32
e) (Word32 -> Word32) -> Get Word32 -> Get Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
Get.getWord32be
        pure TPMSRSAParms :: Word16 -> Word16 -> Word16 -> Word32 -> TPMUPublicParms
TPMSRSAParms {Word16
Word32
tpmsrpExponent :: Word32
tpmsrpKeyBits :: Word16
tpmsrpScheme :: Word16
tpmsrpSymmetric :: Word16
tpmsrpExponent :: Word32
tpmsrpKeyBits :: Word16
tpmsrpScheme :: Word16
tpmsrpSymmetric :: Word16
..}
      getTPMUPublicParms TPMAlgId
TPMAlgSHA1 = String -> Get TPMUPublicParms
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"SHA1 does not have public key parameters"
      getTPMUPublicParms TPMAlgId
TPMAlgSHA256 = String -> Get TPMUPublicParms
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 = String -> Get TPMUPublicId
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"SHA1 does not have a public id"
      getTPMUPublicId TPMAlgId
TPMAlgSHA256 = String -> Get TPMUPublicId
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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
Word32
tpmsrpExponent :: Word32
tpmsrpKeyBits :: Word16
tpmsrpScheme :: Word16
tpmsrpSymmetric :: Word16
tpmsrpExponent :: TPMUPublicParms -> Word32
tpmsrpKeyBits :: TPMUPublicParms -> Word16
tpmsrpScheme :: TPMUPublicParms -> Word16
tpmsrpSymmetric :: TPMUPublicParms -> Word16
..},
            tpmtpUnique :: TPMTPublic -> TPMUPublicId
tpmtpUnique = TPM2BPublicKeyRSA ByteString
nb
          } =
          PublicKey -> Either Text PublicKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            PublicKeyRSA :: Integer -> Integer -> PublicKey
Cose.PublicKeyRSA
              { rsaN :: Integer
rsaN = ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
nb,
                rsaE :: Integer
rsaE = Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger Word32
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
..}
          } =
          PublicKey -> Either Text PublicKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            PublicKeyECDSA :: CoseCurveECDSA -> ByteString -> ByteString -> PublicKey
Cose.PublicKeyECDSA
              { ecdsaCurve :: CoseCurveECDSA
ecdsaCurve = CoseCurveECDSA
tpmsepCurveId,
                ecdsaX :: ByteString
ecdsaX = ByteString
tpmseX,
                ecdsaY :: ByteString
ecdsaY = 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
<> String -> Text
Text.pack (TPMTPublic -> String
forall a. Show a => a -> String
show TPMTPublic
key)

  asfEncode :: Format -> AttStmt Format -> Term
asfEncode Format
_ Statement {..} =
    [(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
alg),
        ( 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 {..}
    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 = CosePublicKey -> PublicKey
Cose.fromCose (CosePublicKey -> PublicKey) -> CosePublicKey -> PublicKey
forall a b. (a -> b) -> a -> b
$ AttestedCredentialData 'Registration 'True -> CosePublicKey
forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CosePublicKey
M.acdCredentialPublicKey AttestedCredentialData 'Registration 'True
adAttestedCredentialData
      Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PublicKey
pubKey PublicKey -> PublicKey -> Bool
forall a. Eq a => a -> a -> Bool
== PublicKey
pubAreaKey) (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
VerificationErrorCredentialKeyMismatch

      -- 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 :: Word32
magic = TPMSAttest -> Word32
tpmsaMagic TPMSAttest
certInfo
      Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
magic Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
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
$ Word32 -> VerificationError
VerificationErrorInvalidMagicNumber Word32
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
VerificationErrorInvalidType 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 CoseSignAlg
alg 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
VerificationErrorHashMismatch ByteString
attHash ByteString
extraData
          pure ()
        Maybe ByteString
Nothing -> VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure VerificationError
VerificationErrorUnknownHashFunction

      -- 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 :: Maybe ByteString
mPubAreaHash = case TPMTPublic -> TPMAlgId
tpmtpNameAlg TPMTPublic
pubArea of
            TPMAlgId
TPMAlgSHA1 -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe 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 -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe 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 -> Maybe ByteString
forall a. Maybe a
Nothing
            TPMAlgId
TPMAlgRSA -> Maybe ByteString
forall a. Maybe a
Nothing

      case Maybe ByteString
mPubAreaHash of
        Just 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
VerificationErrorInvalidName ByteString
pubName ByteString
name
          pure ()
        Maybe ByteString
Nothing -> VerificationError -> Validation (NonEmpty VerificationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure VerificationError
VerificationErrorInvalidNameAlgorithm

      -- 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.
      let unsignedAikCert :: Certificate
unsignedAikCert = SignedCertificate -> Certificate
X509.getCertificate SignedCertificate
aikCert
      case 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
unsignedAikCert of
        Right PublicKey
certPubKey -> case CoseSignAlg
-> PublicKey -> ByteString -> ByteString -> Either Text ()
Cose.verify CoseSignAlg
alg PublicKey
certPubKey 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
VerificationErrorVerificationFailure Text
err
        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
VerificationErrorInvalidPublicKey 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
unsignedAikCert
      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 -> Int -> VerificationError
VerificationErrorCertificateVersion Int
2 Int
version
      -- 4.9.2. Subject field MUST be set to empty.
      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)] -> Bool)
-> (DistinguishedName -> [(OID, ASN1CharacterString)])
-> DistinguishedName
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DistinguishedName -> [(OID, ASN1CharacterString)]
X509.getDistinguishedElements (DistinguishedName -> Bool) -> DistinguishedName -> Bool
forall a b. (a -> b) -> a -> b
$ Certificate -> DistinguishedName
X509.certSubjectDN Certificate
unsignedAikCert) (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
VerificationErrorNonEmptySubjectField
      -- 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]
      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 (SubjectAlternativeName -> Text
tpmManufacturer SubjectAlternativeName
subjectAlternativeName) Set Text
tpmManufacturers) (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
VerificationErrorUnknownVendor

      -- 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
VerificationErrorExtKeyOIDMissing

      -- 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
VerificationErrorBasicConstraintsTrue

      -- 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.
      case Maybe IdFidoGenCeAAGUID
aaguidExt of
        Just (IdFidoGenCeAAGUID AAGUID
aaguid) -> Bool
-> Validation (NonEmpty VerificationError) ()
-> Validation (NonEmpty VerificationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AttestedCredentialData 'Registration 'True -> AAGUID
forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> AAGUID
M.acdAaguid AttestedCredentialData 'Registration 'True
adAttestedCredentialData AAGUID -> AAGUID -> Bool
forall a. Eq a => a -> a -> Bool
== AAGUID
aaguid) (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
VerificationErrorCertificateAAGUIDMismatch
        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 :: 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 = (String, ByteString) -> (Text, SignedCertificate)
processEntry ((String, ByteString) -> (Text, SignedCertificate))
-> [(String, 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 :: (String, ByteString) -> (Text, SignedCertificate)
processEntry (String
path, ByteString
bytes) = case ByteString -> Either String 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
'/') (String -> Text
Text.pack String
path), SignedCertificate
cert)
      Left String
err -> String -> (Text, SignedCertificate)
forall a. HasCallStack => String -> a
error (String -> (Text, SignedCertificate))
-> String -> (Text, SignedCertificate)
forall a b. (a -> b) -> a -> b
$ String
"Error while decoding certificate " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
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