{-# 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.ToJSONOrphans (PrettyHexByteString (PrettyHexByteString))
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 -> [Char]
(Int -> TPMAlgId -> ShowS)
-> (TPMAlgId -> [Char]) -> ([TPMAlgId] -> ShowS) -> Show TPMAlgId
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TPMAlgId -> ShowS
showsPrec :: Int -> TPMAlgId -> ShowS
$cshow :: TPMAlgId -> [Char]
show :: TPMAlgId -> [Char]
$cshowList :: [TPMAlgId] -> ShowS
showList :: [TPMAlgId] -> ShowS
Show, TPMAlgId -> TPMAlgId -> Bool
(TPMAlgId -> TPMAlgId -> Bool)
-> (TPMAlgId -> TPMAlgId -> Bool) -> Eq TPMAlgId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TPMAlgId -> TPMAlgId -> Bool
== :: TPMAlgId -> TPMAlgId -> Bool
$c/= :: TPMAlgId -> TPMAlgId -> Bool
/= :: 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
$cfrom :: forall x. TPMAlgId -> Rep TPMAlgId x
from :: forall x. TPMAlgId -> Rep TPMAlgId x
$cto :: forall x. Rep TPMAlgId x -> TPMAlgId
to :: forall x. Rep TPMAlgId x -> TPMAlgId
Generic, [TPMAlgId] -> Value
[TPMAlgId] -> Encoding
TPMAlgId -> Value
TPMAlgId -> Encoding
(TPMAlgId -> Value)
-> (TPMAlgId -> Encoding)
-> ([TPMAlgId] -> Value)
-> ([TPMAlgId] -> Encoding)
-> ToJSON TPMAlgId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: TPMAlgId -> Value
toJSON :: TPMAlgId -> Value
$ctoEncoding :: TPMAlgId -> Encoding
toEncoding :: TPMAlgId -> Encoding
$ctoJSONList :: [TPMAlgId] -> Value
toJSONList :: [TPMAlgId] -> Value
$ctoEncodingList :: [TPMAlgId] -> Encoding
toEncodingList :: [TPMAlgId] -> Encoding
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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgRSA
toTPMAlgId Word16
0x0004 = TPMAlgId -> m TPMAlgId
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgSHA1
toTPMAlgId Word16
0x000B = TPMAlgId -> m TPMAlgId
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgSHA256
toTPMAlgId Word16
0x0023 = TPMAlgId -> m TPMAlgId
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMAlgId
TPMAlgECC
toTPMAlgId Word16
_ = [Char] -> m TPMAlgId
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unsupported or invalid TPM_ALD_IG"

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

-- | [(spec)](https://trustedcomputinggroup.org/wp-content/uploads/TCG_TPM2_r1p59_Part2_Structures_pub.pdf)
tpmGeneratedValue :: Word32
tpmGeneratedValue :: 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
$c== :: TPMSClockInfo -> TPMSClockInfo -> Bool
== :: TPMSClockInfo -> TPMSClockInfo -> Bool
$c/= :: TPMSClockInfo -> TPMSClockInfo -> Bool
/= :: TPMSClockInfo -> TPMSClockInfo -> Bool
Eq, Int -> TPMSClockInfo -> ShowS
[TPMSClockInfo] -> ShowS
TPMSClockInfo -> [Char]
(Int -> TPMSClockInfo -> ShowS)
-> (TPMSClockInfo -> [Char])
-> ([TPMSClockInfo] -> ShowS)
-> Show TPMSClockInfo
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TPMSClockInfo -> ShowS
showsPrec :: Int -> TPMSClockInfo -> ShowS
$cshow :: TPMSClockInfo -> [Char]
show :: TPMSClockInfo -> [Char]
$cshowList :: [TPMSClockInfo] -> ShowS
showList :: [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
$cfrom :: forall x. TPMSClockInfo -> Rep TPMSClockInfo x
from :: forall x. TPMSClockInfo -> Rep TPMSClockInfo x
$cto :: forall x. Rep TPMSClockInfo x -> TPMSClockInfo
to :: forall x. Rep TPMSClockInfo x -> TPMSClockInfo
Generic, [TPMSClockInfo] -> Value
[TPMSClockInfo] -> Encoding
TPMSClockInfo -> Value
TPMSClockInfo -> Encoding
(TPMSClockInfo -> Value)
-> (TPMSClockInfo -> Encoding)
-> ([TPMSClockInfo] -> Value)
-> ([TPMSClockInfo] -> Encoding)
-> ToJSON TPMSClockInfo
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: TPMSClockInfo -> Value
toJSON :: TPMSClockInfo -> Value
$ctoEncoding :: TPMSClockInfo -> Encoding
toEncoding :: TPMSClockInfo -> Encoding
$ctoJSONList :: [TPMSClockInfo] -> Value
toJSONList :: [TPMSClockInfo] -> Value
$ctoEncodingList :: [TPMSClockInfo] -> Encoding
toEncodingList :: [TPMSClockInfo] -> Encoding
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 -> PrettyHexByteString
tpmsciName :: PrettyHexByteString,
    TPMSCertifyInfo -> PrettyHexByteString
tpmsciQualifiedName :: PrettyHexByteString
  }
  deriving (TPMSCertifyInfo -> TPMSCertifyInfo -> Bool
(TPMSCertifyInfo -> TPMSCertifyInfo -> Bool)
-> (TPMSCertifyInfo -> TPMSCertifyInfo -> Bool)
-> Eq TPMSCertifyInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TPMSCertifyInfo -> TPMSCertifyInfo -> Bool
== :: TPMSCertifyInfo -> TPMSCertifyInfo -> Bool
$c/= :: TPMSCertifyInfo -> TPMSCertifyInfo -> Bool
/= :: TPMSCertifyInfo -> TPMSCertifyInfo -> Bool
Eq, Int -> TPMSCertifyInfo -> ShowS
[TPMSCertifyInfo] -> ShowS
TPMSCertifyInfo -> [Char]
(Int -> TPMSCertifyInfo -> ShowS)
-> (TPMSCertifyInfo -> [Char])
-> ([TPMSCertifyInfo] -> ShowS)
-> Show TPMSCertifyInfo
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TPMSCertifyInfo -> ShowS
showsPrec :: Int -> TPMSCertifyInfo -> ShowS
$cshow :: TPMSCertifyInfo -> [Char]
show :: TPMSCertifyInfo -> [Char]
$cshowList :: [TPMSCertifyInfo] -> ShowS
showList :: [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
$cfrom :: forall x. TPMSCertifyInfo -> Rep TPMSCertifyInfo x
from :: forall x. TPMSCertifyInfo -> Rep TPMSCertifyInfo x
$cto :: forall x. Rep TPMSCertifyInfo x -> TPMSCertifyInfo
to :: forall x. Rep TPMSCertifyInfo x -> TPMSCertifyInfo
Generic, [TPMSCertifyInfo] -> Value
[TPMSCertifyInfo] -> Encoding
TPMSCertifyInfo -> Value
TPMSCertifyInfo -> Encoding
(TPMSCertifyInfo -> Value)
-> (TPMSCertifyInfo -> Encoding)
-> ([TPMSCertifyInfo] -> Value)
-> ([TPMSCertifyInfo] -> Encoding)
-> ToJSON TPMSCertifyInfo
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: TPMSCertifyInfo -> Value
toJSON :: TPMSCertifyInfo -> Value
$ctoEncoding :: TPMSCertifyInfo -> Encoding
toEncoding :: TPMSCertifyInfo -> Encoding
$ctoJSONList :: [TPMSCertifyInfo] -> Value
toJSONList :: [TPMSCertifyInfo] -> Value
$ctoEncodingList :: [TPMSCertifyInfo] -> Encoding
toEncodingList :: [TPMSCertifyInfo] -> Encoding
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 -> PrettyHexByteString
tpmsaQualifiedSigner :: PrettyHexByteString,
    TPMSAttest -> PrettyHexByteString
tpmsaExtraData :: PrettyHexByteString,
    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
$c== :: TPMSAttest -> TPMSAttest -> Bool
== :: TPMSAttest -> TPMSAttest -> Bool
$c/= :: TPMSAttest -> TPMSAttest -> Bool
/= :: TPMSAttest -> TPMSAttest -> Bool
Eq, Int -> TPMSAttest -> ShowS
[TPMSAttest] -> ShowS
TPMSAttest -> [Char]
(Int -> TPMSAttest -> ShowS)
-> (TPMSAttest -> [Char])
-> ([TPMSAttest] -> ShowS)
-> Show TPMSAttest
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TPMSAttest -> ShowS
showsPrec :: Int -> TPMSAttest -> ShowS
$cshow :: TPMSAttest -> [Char]
show :: TPMSAttest -> [Char]
$cshowList :: [TPMSAttest] -> ShowS
showList :: [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
$cfrom :: forall x. TPMSAttest -> Rep TPMSAttest x
from :: forall x. TPMSAttest -> Rep TPMSAttest x
$cto :: forall x. Rep TPMSAttest x -> TPMSAttest
to :: forall x. Rep TPMSAttest x -> TPMSAttest
Generic, [TPMSAttest] -> Value
[TPMSAttest] -> Encoding
TPMSAttest -> Value
TPMSAttest -> Encoding
(TPMSAttest -> Value)
-> (TPMSAttest -> Encoding)
-> ([TPMSAttest] -> Value)
-> ([TPMSAttest] -> Encoding)
-> ToJSON TPMSAttest
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: TPMSAttest -> Value
toJSON :: TPMSAttest -> Value
$ctoEncoding :: TPMSAttest -> Encoding
toEncoding :: TPMSAttest -> Encoding
$ctoJSONList :: [TPMSAttest] -> Value
toJSONList :: [TPMSAttest] -> Value
$ctoEncodingList :: [TPMSAttest] -> Encoding
toEncodingList :: [TPMSAttest] -> Encoding
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
$c== :: TPMUPublicParms -> TPMUPublicParms -> Bool
== :: TPMUPublicParms -> TPMUPublicParms -> Bool
$c/= :: TPMUPublicParms -> TPMUPublicParms -> Bool
/= :: TPMUPublicParms -> TPMUPublicParms -> Bool
Eq, Int -> TPMUPublicParms -> ShowS
[TPMUPublicParms] -> ShowS
TPMUPublicParms -> [Char]
(Int -> TPMUPublicParms -> ShowS)
-> (TPMUPublicParms -> [Char])
-> ([TPMUPublicParms] -> ShowS)
-> Show TPMUPublicParms
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TPMUPublicParms -> ShowS
showsPrec :: Int -> TPMUPublicParms -> ShowS
$cshow :: TPMUPublicParms -> [Char]
show :: TPMUPublicParms -> [Char]
$cshowList :: [TPMUPublicParms] -> ShowS
showList :: [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
$cfrom :: forall x. TPMUPublicParms -> Rep TPMUPublicParms x
from :: forall x. TPMUPublicParms -> Rep TPMUPublicParms x
$cto :: forall x. Rep TPMUPublicParms x -> TPMUPublicParms
to :: forall x. Rep TPMUPublicParms x -> TPMUPublicParms
Generic, [TPMUPublicParms] -> Value
[TPMUPublicParms] -> Encoding
TPMUPublicParms -> Value
TPMUPublicParms -> Encoding
(TPMUPublicParms -> Value)
-> (TPMUPublicParms -> Encoding)
-> ([TPMUPublicParms] -> Value)
-> ([TPMUPublicParms] -> Encoding)
-> ToJSON TPMUPublicParms
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: TPMUPublicParms -> Value
toJSON :: TPMUPublicParms -> Value
$ctoEncoding :: TPMUPublicParms -> Encoding
toEncoding :: TPMUPublicParms -> Encoding
$ctoJSONList :: [TPMUPublicParms] -> Value
toJSONList :: [TPMUPublicParms] -> Value
$ctoEncodingList :: [TPMUPublicParms] -> Encoding
toEncodingList :: [TPMUPublicParms] -> Encoding
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 PrettyHexByteString
  | TPMSECCPoint
      { TPMUPublicId -> PrettyHexByteString
tpmseX :: PrettyHexByteString,
        TPMUPublicId -> PrettyHexByteString
tpmseY :: PrettyHexByteString
      }
  deriving (TPMUPublicId -> TPMUPublicId -> Bool
(TPMUPublicId -> TPMUPublicId -> Bool)
-> (TPMUPublicId -> TPMUPublicId -> Bool) -> Eq TPMUPublicId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TPMUPublicId -> TPMUPublicId -> Bool
== :: TPMUPublicId -> TPMUPublicId -> Bool
$c/= :: TPMUPublicId -> TPMUPublicId -> Bool
/= :: TPMUPublicId -> TPMUPublicId -> Bool
Eq, Int -> TPMUPublicId -> ShowS
[TPMUPublicId] -> ShowS
TPMUPublicId -> [Char]
(Int -> TPMUPublicId -> ShowS)
-> (TPMUPublicId -> [Char])
-> ([TPMUPublicId] -> ShowS)
-> Show TPMUPublicId
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TPMUPublicId -> ShowS
showsPrec :: Int -> TPMUPublicId -> ShowS
$cshow :: TPMUPublicId -> [Char]
show :: TPMUPublicId -> [Char]
$cshowList :: [TPMUPublicId] -> ShowS
showList :: [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
$cfrom :: forall x. TPMUPublicId -> Rep TPMUPublicId x
from :: forall x. TPMUPublicId -> Rep TPMUPublicId x
$cto :: forall x. Rep TPMUPublicId x -> TPMUPublicId
to :: forall x. Rep TPMUPublicId x -> TPMUPublicId
Generic, [TPMUPublicId] -> Value
[TPMUPublicId] -> Encoding
TPMUPublicId -> Value
TPMUPublicId -> Encoding
(TPMUPublicId -> Value)
-> (TPMUPublicId -> Encoding)
-> ([TPMUPublicId] -> Value)
-> ([TPMUPublicId] -> Encoding)
-> ToJSON TPMUPublicId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: TPMUPublicId -> Value
toJSON :: TPMUPublicId -> Value
$ctoEncoding :: TPMUPublicId -> Encoding
toEncoding :: TPMUPublicId -> Encoding
$ctoJSONList :: [TPMUPublicId] -> Value
toJSONList :: [TPMUPublicId] -> Value
$ctoEncodingList :: [TPMUPublicId] -> Encoding
toEncodingList :: [TPMUPublicId] -> Encoding
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 -> PrettyHexByteString
tpmtpAuthPolicy :: PrettyHexByteString,
    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
$c== :: TPMTPublic -> TPMTPublic -> Bool
== :: TPMTPublic -> TPMTPublic -> Bool
$c/= :: TPMTPublic -> TPMTPublic -> Bool
/= :: TPMTPublic -> TPMTPublic -> Bool
Eq, Int -> TPMTPublic -> ShowS
[TPMTPublic] -> ShowS
TPMTPublic -> [Char]
(Int -> TPMTPublic -> ShowS)
-> (TPMTPublic -> [Char])
-> ([TPMTPublic] -> ShowS)
-> Show TPMTPublic
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TPMTPublic -> ShowS
showsPrec :: Int -> TPMTPublic -> ShowS
$cshow :: TPMTPublic -> [Char]
show :: TPMTPublic -> [Char]
$cshowList :: [TPMTPublic] -> ShowS
showList :: [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
$cfrom :: forall x. TPMTPublic -> Rep TPMTPublic x
from :: forall x. TPMTPublic -> Rep TPMTPublic x
$cto :: forall x. Rep TPMTPublic x -> TPMTPublic
to :: forall x. Rep TPMTPublic x -> TPMTPublic
Generic, [TPMTPublic] -> Value
[TPMTPublic] -> Encoding
TPMTPublic -> Value
TPMTPublic -> Encoding
(TPMTPublic -> Value)
-> (TPMTPublic -> Encoding)
-> ([TPMTPublic] -> Value)
-> ([TPMTPublic] -> Encoding)
-> ToJSON TPMTPublic
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: TPMTPublic -> Value
toJSON :: TPMTPublic -> Value
$ctoEncoding :: TPMTPublic -> Encoding
toEncoding :: TPMTPublic -> Encoding
$ctoJSONList :: [TPMTPublic] -> Value
toJSONList :: [TPMTPublic] -> Value
$ctoEncodingList :: [TPMTPublic] -> Encoding
toEncodingList :: [TPMTPublic] -> Encoding
ToJSON)

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

instance Show Format where
  show :: Format -> [Char]
show = Text -> [Char]
Text.unpack (Text -> [Char]) -> (Format -> Text) -> Format -> [Char]
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
$c== :: SubjectAlternativeName -> SubjectAlternativeName -> Bool
== :: SubjectAlternativeName -> SubjectAlternativeName -> Bool
$c/= :: SubjectAlternativeName -> SubjectAlternativeName -> Bool
/= :: SubjectAlternativeName -> SubjectAlternativeName -> Bool
Eq, Int -> SubjectAlternativeName -> ShowS
[SubjectAlternativeName] -> ShowS
SubjectAlternativeName -> [Char]
(Int -> SubjectAlternativeName -> ShowS)
-> (SubjectAlternativeName -> [Char])
-> ([SubjectAlternativeName] -> ShowS)
-> Show SubjectAlternativeName
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubjectAlternativeName -> ShowS
showsPrec :: Int -> SubjectAlternativeName -> ShowS
$cshow :: SubjectAlternativeName -> [Char]
show :: SubjectAlternativeName -> [Char]
$cshowList :: [SubjectAlternativeName] -> ShowS
showList :: [SubjectAlternativeName] -> ShowS
Show)

newtype CertInfoBytes = CertInfoBytes {CertInfoBytes -> ByteString
unCertInfoBytes :: BS.ByteString}
  deriving newtype (CertInfoBytes -> CertInfoBytes -> Bool
(CertInfoBytes -> CertInfoBytes -> Bool)
-> (CertInfoBytes -> CertInfoBytes -> Bool) -> Eq CertInfoBytes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CertInfoBytes -> CertInfoBytes -> Bool
== :: CertInfoBytes -> CertInfoBytes -> Bool
$c/= :: CertInfoBytes -> CertInfoBytes -> Bool
/= :: CertInfoBytes -> CertInfoBytes -> Bool
Eq, Int -> CertInfoBytes -> ShowS
[CertInfoBytes] -> ShowS
CertInfoBytes -> [Char]
(Int -> CertInfoBytes -> ShowS)
-> (CertInfoBytes -> [Char])
-> ([CertInfoBytes] -> ShowS)
-> Show CertInfoBytes
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CertInfoBytes -> ShowS
showsPrec :: Int -> CertInfoBytes -> ShowS
$cshow :: CertInfoBytes -> [Char]
show :: CertInfoBytes -> [Char]
$cshowList :: [CertInfoBytes] -> ShowS
showList :: [CertInfoBytes] -> ShowS
Show)

newtype PubAreaBytes = PubAreaBytes {PubAreaBytes -> ByteString
unPubAreaBytes :: BS.ByteString}
  deriving newtype (PubAreaBytes -> PubAreaBytes -> Bool
(PubAreaBytes -> PubAreaBytes -> Bool)
-> (PubAreaBytes -> PubAreaBytes -> Bool) -> Eq PubAreaBytes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PubAreaBytes -> PubAreaBytes -> Bool
== :: PubAreaBytes -> PubAreaBytes -> Bool
$c/= :: PubAreaBytes -> PubAreaBytes -> Bool
/= :: PubAreaBytes -> PubAreaBytes -> Bool
Eq, Int -> PubAreaBytes -> ShowS
[PubAreaBytes] -> ShowS
PubAreaBytes -> [Char]
(Int -> PubAreaBytes -> ShowS)
-> (PubAreaBytes -> [Char])
-> ([PubAreaBytes] -> ShowS)
-> Show PubAreaBytes
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PubAreaBytes -> ShowS
showsPrec :: Int -> PubAreaBytes -> ShowS
$cshow :: PubAreaBytes -> [Char]
show :: PubAreaBytes -> [Char]
$cshowList :: [PubAreaBytes] -> ShowS
showList :: [PubAreaBytes] -> 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 -> Signature
sig :: Cose.Signature,
    Statement -> TPMSAttest
certInfo :: TPMSAttest,
    Statement -> CertInfoBytes
certInfoRaw :: CertInfoBytes,
    Statement -> TPMTPublic
pubArea :: TPMTPublic,
    Statement -> PubAreaBytes
pubAreaRaw :: PubAreaBytes,
    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
$c== :: Statement -> Statement -> Bool
== :: Statement -> Statement -> Bool
$c/= :: Statement -> Statement -> Bool
/= :: Statement -> Statement -> Bool
Eq, Int -> Statement -> ShowS
[Statement] -> ShowS
Statement -> [Char]
(Int -> Statement -> ShowS)
-> (Statement -> [Char])
-> ([Statement] -> ShowS)
-> Show Statement
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Statement -> ShowS
showsPrec :: Int -> Statement -> ShowS
$cshow :: Statement -> [Char]
show :: Statement -> [Char]
$cshowList :: [Statement] -> ShowS
showList :: [Statement] -> ShowS
Show)

instance ToJSON Statement where
  toJSON :: Statement -> Value
toJSON Statement {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
NonEmpty SignedCertificate
Certificate
PublicKey
Signature
PublicKeyWithSignAlg
PubAreaBytes
CertInfoBytes
SubjectAlternativeName
TPMTPublic
TPMSAttest
x5c :: Statement -> NonEmpty SignedCertificate
aikCert :: Statement -> Certificate
aikPubKeyAndAlg :: Statement -> PublicKeyWithSignAlg
subjectAlternativeName :: Statement -> SubjectAlternativeName
aaguidExt :: Statement -> Maybe IdFidoGenCeAAGUID
extendedKeyUsage :: Statement -> [ExtKeyUsagePurpose]
basicConstraintsCA :: Statement -> Bool
sig :: Statement -> Signature
certInfo :: Statement -> TPMSAttest
certInfoRaw :: Statement -> CertInfoBytes
pubArea :: Statement -> TPMTPublic
pubAreaRaw :: Statement -> PubAreaBytes
pubAreaKey :: Statement -> PublicKey
x5c :: NonEmpty SignedCertificate
aikCert :: Certificate
aikPubKeyAndAlg :: PublicKeyWithSignAlg
subjectAlternativeName :: SubjectAlternativeName
aaguidExt :: Maybe IdFidoGenCeAAGUID
extendedKeyUsage :: [ExtKeyUsagePurpose]
basicConstraintsCA :: Bool
sig :: Signature
certInfo :: TPMSAttest
certInfoRaw :: CertInfoBytes
pubArea :: TPMTPublic
pubAreaRaw :: PubAreaBytes
pubAreaKey :: PublicKey
..} =
    [Pair] -> Value
object
      [ Key
"ver" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"2.0",
        Key
"alg" Key -> CoseSignAlg -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= PublicKeyWithSignAlg -> CoseSignAlg
Cose.signAlg PublicKeyWithSignAlg
aikPubKeyAndAlg,
        Key
"x5c" Key -> NonEmpty SignedCertificate -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= NonEmpty SignedCertificate
x5c,
        Key
"sig" Key -> Signature -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Signature
sig,
        Key
"certInfo" Key -> TPMSAttest -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= TPMSAttest
certInfo,
        Key
"pubArea" Key -> TPMTPublic -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= TPMTPublic
pubArea
      ]

-- | Verification errors specific to TPM attestation
data VerificationError
  = -- | The public key in the certificate is different from the on in the
    -- attested credential data
    PublicKeyMismatch
      { -- | The public key extracted from the certificate
        VerificationError -> PublicKey
certificatePublicKey :: Cose.PublicKey,
        -- | The public key part of the credential data
        VerificationError -> PublicKey
credentialDataPublicKey :: Cose.PublicKey
      }
  | -- | The magic number in certInfo was not set to TPM_GENERATED_VALUE (0xff544347)
    MagicNumberInvalid Word32
  | -- | The type in certInfo was not set to TPM_ST_ATTEST_CERTIFY (0x8017)
    TypeInvalid Word16
  | -- | The algorithm specified in the nameAlg field is unsupported or is not
    -- a valid name algorithm
    NameAlgorithmInvalid TPMAlgId
  | -- | The calulated name does not match the provided name.
    NameMismatch
      { -- | The name calculated from the TPMT_PUBLIC structure with the name
        -- algorithm.
        VerificationError -> ByteString
pubAreaName :: BS.ByteString,
        -- | The expected name from TPMS_CERTIFY_INFO of the TPMS_ATTEST
        -- structure
        VerificationError -> ByteString
certifyInfoName :: BS.ByteString
      }
  | -- | The public key in the certificate was invalid, either because the it
    -- had an unexpected algorithm, or because it was otherwise malformed
    PublicKeyInvalid Text
  | -- | The certificate didn't have the expected version-value (2)
    CertificateVersionInvalid Int
  | -- | The Public key cannot verify the signature over the authenticatorData
    -- and the clientDataHash.
    VerificationFailure Text
  | -- | The subject field was not empty
    SubjectFieldNotEmpty [(OID, X509.ASN1CharacterString)]
  | -- | The vendor was unknown
    VendorUnknown Text
  | -- | The Extended Key Usage did not contain the 2.23.133.8.3 OID
    ExtKeyOIDMissing
  | -- | The CA component of the basic constraints extension was set to True
    BasicConstraintsTrue
  | -- | The AAGUID in the attested credential data does not match the AAGUID
    -- in the fido certificate extension
    CertificateAAGUIDMismatch
      { -- | AAGUID from the id-fido-gen-ce-aaguid certificate extension
        VerificationError -> AAGUID
certificateExtensionAAGUID :: AAGUID,
        -- | AAGUID from the attested credential data
        VerificationError -> AAGUID
attestedCredentialDataAAGUID :: AAGUID
      }
  | -- | The (supposedly) ASN1 encoded certificate extension could not be
    -- decoded
    ASN1Error ASN1Error
  | -- | The certificate extension does not contain a AAGUID
    CredentialAAGUIDMissing
  | -- | The desired algorithm does not have a known associated hash function
    HashFunctionUnknown
  | -- | The calculated hash over the attToBeSigned does not match the received
    -- hash
    HashMismatch
      { -- | The hash of the concatenation of the @authenticatorData@ and
        -- @clientDataHash@ (@attToBeSigned@) calculated by the @alg@ specified in
        -- the @Statement@.
        VerificationError -> ByteString
calculatedHash :: BS.ByteString,
        -- | The extra data from the TPMS_ATTEST structure.
        VerificationError -> ByteString
extraData :: BS.ByteString
      }
  deriving (Int -> VerificationError -> ShowS
[VerificationError] -> ShowS
VerificationError -> [Char]
(Int -> VerificationError -> ShowS)
-> (VerificationError -> [Char])
-> ([VerificationError] -> ShowS)
-> Show VerificationError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VerificationError -> ShowS
showsPrec :: Int -> VerificationError -> ShowS
$cshow :: VerificationError -> [Char]
show :: VerificationError -> [Char]
$cshowList :: [VerificationError] -> ShowS
showList :: [VerificationError] -> ShowS
Show, Show VerificationError
Typeable VerificationError
Typeable VerificationError
-> Show VerificationError
-> (VerificationError -> SomeException)
-> (SomeException -> Maybe VerificationError)
-> (VerificationError -> [Char])
-> Exception VerificationError
SomeException -> Maybe VerificationError
VerificationError -> [Char]
VerificationError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> [Char])
-> Exception e
$ctoException :: VerificationError -> SomeException
toException :: VerificationError -> SomeException
$cfromException :: SomeException -> Maybe VerificationError
fromException :: SomeException -> Maybe VerificationError
$cdisplayException :: VerificationError -> [Char]
displayException :: VerificationError -> [Char]
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 = [Char] -> SubjectAlternativeName -> [ASN1]
forall a. HasCallStack => [Char] -> a
error [Char]
"Unimplemented: This library does not implement encoding the SubjectAlternativeName extension"
  extDecode :: [ASN1] -> Either [Char] SubjectAlternativeName
extDecode [ASN1]
asn1 =
    ShowS
-> Either [Char] SubjectAlternativeName
-> Either [Char] SubjectAlternativeName
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Char]
"Could not decode ASN1 subject-alternative-name extension: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) (Either [Char] SubjectAlternativeName
 -> Either [Char] SubjectAlternativeName)
-> Either [Char] SubjectAlternativeName
-> Either [Char] SubjectAlternativeName
forall a b. (a -> b) -> a -> b
$
      ParseASN1 SubjectAlternativeName
-> [ASN1] -> Either [Char] SubjectAlternativeName
forall a. ParseASN1 a -> [ASN1] -> Either [Char] a
runParseASN1 ParseASN1 SubjectAlternativeName
decodeSubjectAlternativeName [ASN1]
asn1
    where
      decodeSubjectAlternativeName :: ParseASN1 SubjectAlternativeName
      decodeSubjectAlternativeName :: ParseASN1 SubjectAlternativeName
decodeSubjectAlternativeName =
        do
          Map OID Text
map <- [(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 ([Char] -> ParseASN1 Text
forall a. [Char] -> ParseASN1 a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"manufacturer field not found in subject alternative name") Text -> ParseASN1 Text
forall a. a -> ParseASN1 a
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 ([Char] -> ParseASN1 Text
forall a. [Char] -> ParseASN1 a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"model field not found in subject alternative name") Text -> ParseASN1 Text
forall a. a -> ParseASN1 a
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 ([Char] -> ParseASN1 Text
forall a. [Char] -> ParseASN1 a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"version field not found in subject alternative name") Text -> ParseASN1 Text
forall a. a -> ParseASN1 a
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
tpmManufacturer :: Text
tpmModel :: Text
tpmVersion :: Text
tpmManufacturer :: Text
tpmModel :: Text
tpmVersion :: 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 a. a -> ParseASN1 a
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 -> Signature
Cose.Signature -> Signature
sig)),
        Just (CBOR.TBytes (ByteString -> CertInfoBytes
CertInfoBytes -> CertInfoBytes
certInfoRaw)),
        Just (CBOR.TBytes (ByteString -> PubAreaBytes
PubAreaBytes -> PubAreaBytes
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 ->
                ([Char] -> Text)
-> Either [Char] SignedCertificate -> Either Text SignedCertificate
forall a b c. (a -> b) -> Either a c -> Either b c
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) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack) (ByteString -> Either [Char] 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
<> [Char] -> Text
Text.pack (Term -> [Char]
forall a. Show a => a -> [Char]
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 <- CertInfoBytes -> Either Text TPMSAttest
decodeCertInfoBytes CertInfoBytes
certInfoRaw
            TPMTPublic
pubArea <- PubAreaBytes -> Either Text TPMTPublic
decodePubAreaBytes PubAreaBytes
pubAreaRaw
            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 [Char] SubjectAlternativeName)
forall a. Extension a => Extensions -> Maybe (Either [Char] a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
              Just (Right SubjectAlternativeName
ext) -> SubjectAlternativeName -> Either Text SubjectAlternativeName
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectAlternativeName
ext
              Just (Left [Char]
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
<> [Char] -> Text
Text.pack [Char]
err
              Maybe (Either [Char] 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 [Char] IdFidoGenCeAAGUID)
forall a. Extension a => Extensions -> Maybe (Either [Char] a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
              Just (Right IdFidoGenCeAAGUID
ext) -> Maybe IdFidoGenCeAAGUID -> Either Text (Maybe IdFidoGenCeAAGUID)
forall a. a -> Either Text a
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 [Char]
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
<> [Char] -> Text
Text.pack [Char]
err
              Maybe (Either [Char] IdFidoGenCeAAGUID)
Nothing -> Maybe IdFidoGenCeAAGUID -> Either Text (Maybe IdFidoGenCeAAGUID)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IdFidoGenCeAAGUID
forall a. Maybe a
Nothing
            X509.ExtExtendedKeyUsage [ExtKeyUsagePurpose]
extendedKeyUsage <- case Extensions -> Maybe (Either [Char] ExtExtendedKeyUsage)
forall a. Extension a => Extensions -> Maybe (Either [Char] a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
              Just (Right ExtExtendedKeyUsage
ext) -> ExtExtendedKeyUsage -> Either Text ExtExtendedKeyUsage
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtExtendedKeyUsage
ext
              Just (Left [Char]
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
<> [Char] -> Text
Text.pack [Char]
err
              Maybe (Either [Char] 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 [Char] ExtBasicConstraints)
forall a. Extension a => Extensions -> Maybe (Either [Char] a)
X509.extensionGetE (Certificate -> Extensions
X509.certExtensions Certificate
aikCert) of
              Just (Right ExtBasicConstraints
ext) -> ExtBasicConstraints -> Either Text ExtBasicConstraints
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtBasicConstraints
ext
              Just (Left [Char]
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
<> [Char] -> Text
Text.pack [Char]
err
              Maybe (Either [Char] 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 {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
NonEmpty SignedCertificate
Certificate
PublicKey
Signature
PublicKeyWithSignAlg
PubAreaBytes
CertInfoBytes
SubjectAlternativeName
TPMTPublic
TPMSAttest
x5c :: NonEmpty SignedCertificate
aikCert :: Certificate
aikPubKeyAndAlg :: PublicKeyWithSignAlg
subjectAlternativeName :: SubjectAlternativeName
aaguidExt :: Maybe IdFidoGenCeAAGUID
extendedKeyUsage :: [ExtKeyUsagePurpose]
basicConstraintsCA :: Bool
sig :: Signature
certInfo :: TPMSAttest
certInfoRaw :: CertInfoBytes
pubArea :: TPMTPublic
pubAreaRaw :: PubAreaBytes
pubAreaKey :: PublicKey
sig :: Signature
certInfoRaw :: CertInfoBytes
pubAreaRaw :: PubAreaBytes
x5c :: NonEmpty SignedCertificate
certInfo :: TPMSAttest
pubArea :: TPMTPublic
pubAreaKey :: PublicKey
aikCert :: Certificate
aikPubKeyAndAlg :: PublicKeyWithSignAlg
subjectAlternativeName :: SubjectAlternativeName
aaguidExt :: Maybe IdFidoGenCeAAGUID
extendedKeyUsage :: [ExtKeyUsagePurpose]
basicConstraintsCA :: Bool
..}
      (Maybe Term, Maybe Term, Maybe Term, Maybe Term, Maybe Term,
 Maybe Term)
_ -> Text -> Either Text (AttStmt Format)
forall a b. a -> Either a b
Left (Text -> Either Text (AttStmt Format))
-> Text -> Either Text (AttStmt Format)
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
<> [Char] -> Text
Text.pack (HashMap Text Term -> [Char]
forall a. Show a => a -> [Char]
show HashMap Text Term
xs)
    where
      decodeCertInfoBytes :: CertInfoBytes -> Either Text TPMSAttest
      decodeCertInfoBytes :: CertInfoBytes -> Either Text TPMSAttest
decodeCertInfoBytes (CertInfoBytes ByteString
bytes) =
        case Get TPMSAttest
-> ByteString
-> Either
     (ByteString, ByteOffset, [Char])
     (ByteString, ByteOffset, TPMSAttest)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, [Char]) (ByteString, ByteOffset, a)
Get.runGetOrFail Get TPMSAttest
getTPMAttest (ByteString -> ByteString
LBS.fromStrict ByteString
bytes) of
          Left (ByteString
_, ByteOffset
_, [Char]
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
<> [Char] -> Text
Text.pack (ShowS
forall a. Show a => a -> [Char]
show [Char]
err)
          Right (ByteString
_, ByteOffset
_, TPMSAttest
res) -> TPMSAttest -> Either Text TPMSAttest
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMSAttest
res

      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
$ [Char] -> Get ()
forall a. [Char] -> Get a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid magic number"
        Word16
tpmsaType <- Get Word16
Get.getWord16be
        PrettyHexByteString
tpmsaQualifiedSigner <- Get PrettyHexByteString
getTPMByteString
        PrettyHexByteString
tpmsaExtraData <- Get PrettyHexByteString
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 a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMSAttest {Word16
Word32
Word64
PrettyHexByteString
TPMSCertifyInfo
TPMSClockInfo
tpmsaMagic :: Word32
tpmsaType :: Word16
tpmsaQualifiedSigner :: PrettyHexByteString
tpmsaExtraData :: PrettyHexByteString
tpmsaClockInfo :: TPMSClockInfo
tpmsaFirmwareVersion :: Word64
tpmsaAttested :: TPMSCertifyInfo
tpmsaMagic :: Word32
tpmsaType :: Word16
tpmsaQualifiedSigner :: PrettyHexByteString
tpmsaExtraData :: PrettyHexByteString
tpmsaClockInfo :: TPMSClockInfo
tpmsaFirmwareVersion :: Word64
tpmsaAttested :: TPMSCertifyInfo
..}

      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 {Bool
Word32
Word64
tpmsciClock :: Word64
tpmsciResetCount :: Word32
tpmsciRestartCount :: Word32
tpmsciSafe :: Bool
tpmsciClock :: Word64
tpmsciResetCount :: Word32
tpmsciRestartCount :: Word32
tpmsciSafe :: Bool
..}

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

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

      decodePubAreaBytes :: PubAreaBytes -> Either Text TPMTPublic
      decodePubAreaBytes :: PubAreaBytes -> Either Text TPMTPublic
decodePubAreaBytes (PubAreaBytes ByteString
bytes) =
        case Get TPMTPublic
-> ByteString
-> Either
     (ByteString, ByteOffset, [Char])
     (ByteString, ByteOffset, TPMTPublic)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, [Char]) (ByteString, ByteOffset, a)
Get.runGetOrFail Get TPMTPublic
getTPMTPublic (ByteString -> ByteString
LBS.fromStrict ByteString
bytes) of
          Left (ByteString
_, ByteOffset
_, [Char]
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 certInfo: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (ShowS
forall a. Show a => a -> [Char]
show [Char]
err)
          Right (ByteString
_, ByteOffset
_, TPMTPublic
res) -> TPMTPublic -> Either Text TPMTPublic
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMTPublic
res

      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
        PrettyHexByteString
tpmtpAuthPolicy <- Get PrettyHexByteString
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 a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TPMTPublic {Word16
Word32
PrettyHexByteString
TPMUPublicId
TPMUPublicParms
TPMAlgId
tpmtpType :: TPMAlgId
tpmtpNameAlg :: TPMAlgId
tpmtpNameAlgRaw :: Word16
tpmtpObjectAttributes :: Word32
tpmtpAuthPolicy :: PrettyHexByteString
tpmtpParameters :: TPMUPublicParms
tpmtpUnique :: TPMUPublicId
tpmtpType :: TPMAlgId
tpmtpNameAlgRaw :: Word16
tpmtpNameAlg :: TPMAlgId
tpmtpObjectAttributes :: Word32
tpmtpAuthPolicy :: PrettyHexByteString
tpmtpParameters :: TPMUPublicParms
tpmtpUnique :: TPMUPublicId
..}

      -- 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
Word32
tpmsrpSymmetric :: Word16
tpmsrpScheme :: Word16
tpmsrpKeyBits :: Word16
tpmsrpExponent :: Word32
tpmsrpSymmetric :: Word16
tpmsrpScheme :: Word16
tpmsrpKeyBits :: Word16
tpmsrpExponent :: Word32
..}
      getTPMUPublicParms TPMAlgId
TPMAlgSHA1 = [Char] -> Get TPMUPublicParms
forall a. [Char] -> Get a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"SHA1 does not have public key parameters"
      getTPMUPublicParms TPMAlgId
TPMAlgSHA256 = [Char] -> Get TPMUPublicParms
forall a. [Char] -> Get a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"SHA256 does not have public key parameters"
      getTPMUPublicParms TPMAlgId
TPMAlgECC = do
        Word16
tpmsepSymmetric <- Get Word16
Get.getWord16be
        Word16
tpmsepScheme <- Get Word16
Get.getWord16be
        CoseCurveECDSA
tpmsepCurveId <- 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
CoseCurveECDSA
tpmsepSymmetric :: Word16
tpmsepScheme :: Word16
tpmsepCurveId :: CoseCurveECDSA
tpmsepkdf :: Word16
tpmsepSymmetric :: Word16
tpmsepScheme :: Word16
tpmsepCurveId :: CoseCurveECDSA
tpmsepkdf :: Word16
..}

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

      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
tpmsrpSymmetric :: TPMUPublicParms -> Word16
tpmsrpScheme :: TPMUPublicParms -> Word16
tpmsrpKeyBits :: TPMUPublicParms -> Word16
tpmsrpExponent :: TPMUPublicParms -> Word32
tpmsrpSymmetric :: Word16
tpmsrpScheme :: Word16
tpmsrpKeyBits :: Word16
tpmsrpExponent :: Word32
..},
            tpmtpUnique :: TPMTPublic -> TPMUPublicId
tpmtpUnique = TPM2BPublicKeyRSA (PrettyHexByteString ByteString
nb)
          } =
          UncheckedPublicKey -> Either Text PublicKey
Cose.checkPublicKey
            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
tpmsepSymmetric :: TPMUPublicParms -> Word16
tpmsepScheme :: TPMUPublicParms -> Word16
tpmsepCurveId :: TPMUPublicParms -> CoseCurveECDSA
tpmsepkdf :: TPMUPublicParms -> Word16
tpmsepSymmetric :: Word16
tpmsepScheme :: Word16
tpmsepCurveId :: CoseCurveECDSA
tpmsepkdf :: Word16
..},
            tpmtpUnique :: TPMTPublic -> TPMUPublicId
tpmtpUnique = TPMSECCPoint {tpmseX :: TPMUPublicId -> PrettyHexByteString
tpmseX = PrettyHexByteString ByteString
tpmseX, tpmseY :: TPMUPublicId -> PrettyHexByteString
tpmseY = PrettyHexByteString ByteString
tpmseY}
          } =
          UncheckedPublicKey -> Either Text PublicKey
Cose.checkPublicKey
            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
<> [Char] -> Text
Text.pack (TPMTPublic -> [Char]
forall a. Show a => a -> [Char]
show TPMTPublic
key)

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

  type AttStmtVerificationError Format = VerificationError

  asfVerify :: Format
-> DateTime
-> AttStmt Format
-> AuthenticatorData 'Registration 'True
-> ClientDataHash
-> Validation
     (NonEmpty (AttStmtVerificationError Format)) SomeAttestationType
asfVerify
    Format
_
    DateTime
_
    Statement {Bool
[ExtKeyUsagePurpose]
Maybe IdFidoGenCeAAGUID
NonEmpty SignedCertificate
Certificate
PublicKey
Signature
PublicKeyWithSignAlg
PubAreaBytes
CertInfoBytes
SubjectAlternativeName
TPMTPublic
TPMSAttest
x5c :: Statement -> NonEmpty SignedCertificate
aikCert :: Statement -> Certificate
aikPubKeyAndAlg :: Statement -> PublicKeyWithSignAlg
subjectAlternativeName :: Statement -> SubjectAlternativeName
aaguidExt :: Statement -> Maybe IdFidoGenCeAAGUID
extendedKeyUsage :: Statement -> [ExtKeyUsagePurpose]
basicConstraintsCA :: Statement -> Bool
sig :: Statement -> Signature
certInfo :: Statement -> TPMSAttest
certInfoRaw :: Statement -> CertInfoBytes
pubArea :: Statement -> TPMTPublic
pubAreaRaw :: Statement -> PubAreaBytes
pubAreaKey :: Statement -> PublicKey
x5c :: NonEmpty SignedCertificate
aikCert :: Certificate
aikPubKeyAndAlg :: PublicKeyWithSignAlg
subjectAlternativeName :: SubjectAlternativeName
aaguidExt :: Maybe IdFidoGenCeAAGUID
extendedKeyUsage :: [ExtKeyUsagePurpose]
basicConstraintsCA :: Bool
sig :: Signature
certInfo :: TPMSAttest
certInfoRaw :: CertInfoBytes
pubArea :: TPMTPublic
pubAreaRaw :: PubAreaBytes
pubAreaKey :: PublicKey
..}
    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
adRpIdHash :: RpIdHash
adFlags :: AuthenticatorDataFlags
adSignCount :: SignatureCounter
adAttestedCredentialData :: AttestedCredentialData 'Registration 'True
adExtensions :: Maybe AuthenticatorExtensionOutputs
adRpIdHash :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
adFlags :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
adSignCount :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> SignatureCounter
adAttestedCredentialData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AttestedCredentialData c raw
adExtensions :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> Maybe AuthenticatorExtensionOutputs
..}
    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 :: 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
MagicNumberInvalid 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
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 PrettyHexByteString ByteString
extraData = TPMSAttest -> PrettyHexByteString
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 -> Digest SHA1) -> ByteString -> Digest SHA1
forall a b. (a -> b) -> a -> b
$ PubAreaBytes -> ByteString
unPubAreaBytes PubAreaBytes
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 -> Digest SHA256) -> ByteString -> Digest SHA256
forall a b. (a -> b) -> a -> b
$ PubAreaBytes -> ByteString
unPubAreaBytes PubAreaBytes
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 PrettyHexByteString ByteString
name = TPMSCertifyInfo -> PrettyHexByteString
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 -> Message -> Signature -> Either Text ()
Cose.verify PublicKeyWithSignAlg
aikPubKeyAndAlg (ByteString -> Message
Cose.Message (ByteString -> Message) -> ByteString -> Message
forall a b. (a -> b) -> a -> b
$ CertInfoBytes -> ByteString
unCertInfoBytes CertInfoBytes
certInfoRaw) Signature
sig of
        Right () -> () -> Validation (NonEmpty VerificationError) ()
forall a. a -> Validation (NonEmpty VerificationError) a
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 a. [a] -> 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 a. Eq a => a -> [a] -> 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 a. a -> Validation (NonEmpty VerificationError) a
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 a. a -> Maybe a
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 a. a -> Maybe a
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 a. a -> Maybe a
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 a. a -> Maybe a
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 a. a -> Maybe a
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 a. a -> Maybe a
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 a. a -> Maybe a
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 = ([Char], ByteString) -> (Text, SignedCertificate)
processEntry (([Char], ByteString) -> (Text, SignedCertificate))
-> [([Char], 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 :: ([Char], ByteString) -> (Text, SignedCertificate)
processEntry ([Char]
path, ByteString
bytes) = case ByteString -> Either [Char] SignedCertificate
X509.decodeSignedCertificate ByteString
bytes of
      Right SignedCertificate
cert -> ((Char -> Bool) -> Text -> Text
Text.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') ([Char] -> Text
Text.pack [Char]
path), SignedCertificate
cert)
      Left [Char]
err -> [Char] -> (Text, SignedCertificate)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Text, SignedCertificate))
-> [Char] -> (Text, SignedCertificate)
forall a b. (a -> b) -> a -> b
$ [Char]
"Error while decoding certificate " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
path [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
err

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