{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Stability: experimental
-- Certain parts of the specification require that data is decoded\/encoded
-- from\/to a binary form. This module holds such functions.
module Crypto.WebAuthn.Encoding.Binary
  ( -- * 'M.CollectedClientData'
    encodeRawCollectedClientData,
    stripRawCollectedClientData,
    decodeCollectedClientData,

    -- * 'M.AttestedCredentialData'
    encodeRawAttestedCredentialData,
    stripRawAttestedCredentialData,

    -- * 'M.AuthenticatorData'
    encodeRawAuthenticatorData,
    stripRawAuthenticatorData,
    decodeAuthenticatorData,

    -- * 'M.AttestationObject'
    encodeRawAttestationObject,
    stripRawAttestationObject,
    encodeAttestationObject,
    decodeAttestationObject,

    -- * 'M.AuthenticatorResponse'
    encodeRawAuthenticatorResponse,
    stripRawAuthenticatorResponse,

    -- * 'M.Credential'
    encodeRawCredential,
    stripRawCredential,
  )
where

import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Term as CBOR
import qualified Codec.CBOR.Write as CBOR
import Codec.Serialise (Serialise (decode), encode)
import Control.Monad (unless)
import Control.Monad.Except (throwError)
import Control.Monad.State (MonadState (get, put), StateT (runStateT))
import qualified Crypto.Hash as Hash
import Crypto.WebAuthn.Internal.Utils (jsonEncodingOptions)
import Crypto.WebAuthn.Model.Identifier (AAGUID (AAGUID), unAAGUID)
import qualified Crypto.WebAuthn.Model.Kinds as K
import qualified Crypto.WebAuthn.Model.Types as M
import qualified Data.Aeson as Aeson
import qualified Data.Binary.Get as Binary
import qualified Data.Binary.Put as Binary
import Data.Bits ((.|.))
import qualified Data.Bits as Bits
import Data.ByteArray (convert)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Base64.URL as Base64Url
import Data.ByteString.Builder (Builder, stringUtf8, toLazyByteString)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (fromJust, fromMaybe)
import Data.Singletons (SingI (sing))
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Data.UUID as UUID
import Data.Word (Word16, Word8)
import GHC.Generics (Generic)

{-
The functions in this module are grouped and named according to the
following conventions:

  * If the type is parametrized by @raw@, there should be @stripRaw@ and
  @encodeRaw@ functions
  * If the type is serializable there should be a @decode@
  * In addition, if the type has a raw field for its own encoding (implying
    that it's parametrized by @raw@), no other function needs to be provided
  * Alternatively, there should be an @encode@ that encodes the type, using
    any nested raw fields if available

If the type is parametrized by @raw@, this module should guarantee these
invariants for any @value :: TheType (raw ~ False)@:

  * @stripRaw@ doesn't change any fields: @stripRaw value = value@
  * @encodeRaw@ doesn't change any fields: @stripRaw (encodeRaw value) = value@
  * If the type is also serializable:
  * If the type has a raw field, @decode@ inverses @encodeRaw@ and
    @getEncoded@: @stripRaw (decode (getEncoded (encodeRaw value))) = value@
  * Alternatively, @decode@ inverses @encodeRaw@ and @encode@:
    @stripRaw (decode (encode (encodeRaw value))) = value@

If the type is only serializable then this invariant should hold for any
@value :: TheType@

  * @decode@ inverses @encode@: @decode (encode value) = value@

If any such functions are expected to be used only internally, they may not be
exported
-}

-- | Webauthn contains a mixture of binary formats. For one it's CBOR and for
-- another it's a custom format. For CBOR we wish to use the
-- [cborg](https://hackage.haskell.org/package/cborg) library and for the
-- custom binary format the
-- [binary](https://hackage.haskell.org/package/binary) library. However these
-- two libraries don't interact nicely with each other. Because of this we are
-- specifying decoders that don't consume all input as a @PartialBinaryDecoder@,
-- which is just a state monad transformer over an 'LBS.ByteString'.
-- Using this we can somewhat easily flip between the two
-- libraries while decoding without too much nastiness.
type PartialBinaryDecoder a = StateT LBS.ByteString (Either Text) a

-- | Runs a @PartialBinaryDecoder@ using a strict bytestring. Afterwards it
-- makes sure that no bytes are left, otherwise returns an error.
runPartialBinaryDecoder ::
  BS.ByteString ->
  PartialBinaryDecoder a ->
  Either Text a
runPartialBinaryDecoder :: forall a. ByteString -> PartialBinaryDecoder a -> Either Text a
runPartialBinaryDecoder ByteString
bytes PartialBinaryDecoder a
decoder =
  case forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT PartialBinaryDecoder a
decoder forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict forall a b. (a -> b) -> a -> b
$ ByteString
bytes of
    Left Text
err -> forall a b. a -> Either a b
Left Text
err
    Right (a
result, ByteString
rest)
      | ByteString -> Bool
LBS.null ByteString
rest -> forall (m :: * -> *) a. Monad m => a -> m a
return a
result
      | Bool
otherwise ->
          forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
            Text
"Not all binary input used, rest in base64 format is: "
              forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8 (ByteString -> ByteString
Base64.encode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
rest)

-- | A @PartialBinaryDecoder@ for a binary encoding specified using
-- 'Binary.Get'.
runBinary ::
  Binary.Get a ->
  PartialBinaryDecoder a
runBinary :: forall a. Get a -> PartialBinaryDecoder a
runBinary Get a
decoder = do
  ByteString
bytes <- forall s (m :: * -> *). MonadState s m => m s
get
  case forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
Binary.runGetOrFail Get a
decoder ByteString
bytes of
    Left (ByteString
_rest, Int64
_offset, String
err) ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"Binary decoding error: " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
err
    Right (ByteString
rest, Int64
_offset, a
result) -> do
      forall s (m :: * -> *). MonadState s m => s -> m ()
put ByteString
rest
      forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

-- | A @PartialBinaryDecoder@ for a CBOR encoding specified using the given
-- 'CBOR.Decoder'.
runCBOR ::
  (forall s. CBOR.Decoder s a) ->
  PartialBinaryDecoder (LBS.ByteString, a)
runCBOR :: forall a.
(forall s. Decoder s a) -> PartialBinaryDecoder (ByteString, a)
runCBOR forall s. Decoder s a
decoder = do
  ByteString
bytes <- forall s (m :: * -> *). MonadState s m => m s
get
  case forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, Int64, a)
CBOR.deserialiseFromBytesWithSize forall s. Decoder s a
decoder ByteString
bytes of
    Left DeserialiseFailure
err ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"CBOR decoding error: " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show DeserialiseFailure
err)
    Right (ByteString
rest, Int64
consumed, a
a) -> do
      forall s (m :: * -> *). MonadState s m => s -> m ()
put ByteString
rest
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> ByteString -> ByteString
LBS.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
consumed) ByteString
bytes, a
a)

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#authdataextensions) Encodes
-- [authenticator extension
-- outputs](https://www.w3.org/TR/webauthn-2/#authenticator-extension-output)
-- as a CBOR map.
encodeExtensions ::
  M.AuthenticatorExtensionOutputs ->
  Builder
encodeExtensions :: AuthenticatorExtensionOutputs -> Builder
encodeExtensions M.AuthenticatorExtensionOutputs {} =
  -- TODO: Extensions are not implemented by this library, see the TODO in the
  -- module documentation of `Crypto.WebAuthn.Model` for more information.
  Encoding -> Builder
CBOR.toBuilder forall a b. (a -> b) -> a -> b
$ Term -> Encoding
CBOR.encodeTerm ([(Term, Term)] -> Term
CBOR.TMap [])

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#authdataextensions) Decodes a
-- CBOR map as [authenticator extension
-- outputs](https://www.w3.org/TR/webauthn-2/#authenticator-extension-output).
decodeExtensions ::
  PartialBinaryDecoder M.AuthenticatorExtensionOutputs
decodeExtensions :: PartialBinaryDecoder AuthenticatorExtensionOutputs
decodeExtensions = do
  -- TODO: Extensions are not implemented by this library, see the TODO in the
  -- module documentation of `Crypto.WebAuthn.Model` for more information.
  (ByteString
_, Term
_extensions :: CBOR.Term) <- forall a.
(forall s. Decoder s a) -> PartialBinaryDecoder (ByteString, a)
runCBOR forall s. Decoder s Term
CBOR.decodeTerm
  forall (f :: * -> *) a. Applicative f => a -> f a
pure M.AuthenticatorExtensionOutputs {}

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#dictionary-client-data)
-- Intermediate type used to extract the JSON structure stored in the
-- CBOR-encoded
-- [clientDataJSON](https://www.w3.org/TR/webauthn-2/#dom-authenticatorresponse-clientdatajson).
data ClientDataJSON = ClientDataJSON
  { ClientDataJSON -> Text
littype :: Text,
    ClientDataJSON -> Text
challenge :: Text,
    ClientDataJSON -> Text
origin :: Text,
    ClientDataJSON -> Maybe Bool
crossOrigin :: Maybe Bool
    -- TODO: We do not implement TokenBinding, see the documentation of
    -- `CollectedClientData` for more information.
    -- tokenBinding :: Maybe TokenBinding
  }
  deriving (forall x. Rep ClientDataJSON x -> ClientDataJSON
forall x. ClientDataJSON -> Rep ClientDataJSON x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ClientDataJSON x -> ClientDataJSON
$cfrom :: forall x. ClientDataJSON -> Rep ClientDataJSON x
Generic)

-- Note: Encoding should NOT be derived via aeson, use
-- 'encodeRawCollectedClientData' instead
instance Aeson.FromJSON ClientDataJSON where
  parseJSON :: Value -> Parser ClientDataJSON
parseJSON = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
Aeson.genericParseJSON Options
jsonEncodingOptions

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#dictionary-client-data) Encodes
-- all raw fields of a 'M.CollectedClientData' into 'M.ccdRawData' using the
-- [JSON-compatible serialization of client
-- data](https://www.w3.org/TR/webauthn-2/#collectedclientdata-json-compatible-serialization-of-client-data)
-- This function is useful for testing.
encodeRawCollectedClientData ::
  forall (c :: K.CeremonyKind) raw.
  SingI c =>
  M.CollectedClientData c raw ->
  M.CollectedClientData c 'True
encodeRawCollectedClientData :: forall (c :: CeremonyKind) (raw :: Bool).
SingI c =>
CollectedClientData c raw -> CollectedClientData c 'True
encodeRawCollectedClientData M.CollectedClientData {Maybe Bool
Origin
Challenge
RawField raw
ccdRawData :: forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> RawField raw
ccdCrossOrigin :: forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Maybe Bool
ccdOrigin :: forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Origin
ccdChallenge :: forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Challenge
ccdRawData :: RawField raw
ccdCrossOrigin :: Maybe Bool
ccdOrigin :: Origin
ccdChallenge :: Challenge
..} =
  M.CollectedClientData {ccdRawData :: RawField 'True
ccdRawData = ByteString -> RawField 'True
M.WithRaw ByteString
bytes, Maybe Bool
Origin
Challenge
ccdCrossOrigin :: Maybe Bool
ccdOrigin :: Origin
ccdChallenge :: Challenge
ccdCrossOrigin :: Maybe Bool
ccdOrigin :: Origin
ccdChallenge :: Challenge
..}
  where
    bytes :: ByteString
bytes = ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
builder

    -- https://www.w3.org/TR/webauthn-2/#clientdatajson-serialization
    builder :: Builder
    builder :: Builder
builder =
      String -> Builder
stringUtf8 String
"{\"type\":"
        forall a. Semigroup a => a -> a -> a
<> forall a. ToJSON a => a -> Builder
jsonBuilder Text
typeValue
        forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 String
",\"challenge\":"
        forall a. Semigroup a => a -> a -> a
<> forall a. ToJSON a => a -> Builder
jsonBuilder Text
challengeValue
        forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 String
",\"origin\":"
        forall a. Semigroup a => a -> a -> a
<> forall a. ToJSON a => a -> Builder
jsonBuilder Text
originValue
        forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 String
",\"crossOrigin\":"
        forall a. Semigroup a => a -> a -> a
<> forall a. ToJSON a => a -> Builder
jsonBuilder Bool
crossOriginValue
        forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 String
"}"

    typeValue :: Text
    typeValue :: Text
typeValue = case forall {k} (a :: k). SingI a => Sing a
sing @c of
      Sing c
SCeremonyKind c
K.SRegistration -> Text
"webauthn.create"
      Sing c
SCeremonyKind c
K.SAuthentication -> Text
"webauthn.get"

    challengeValue :: Text
    challengeValue :: Text
challengeValue = ByteString -> Text
decodeUtf8 (ByteString -> ByteString
Base64Url.encode (Challenge -> ByteString
M.unChallenge Challenge
ccdChallenge))

    originValue :: Text
    originValue :: Text
originValue = Origin -> Text
M.unOrigin Origin
ccdOrigin

    crossOriginValue :: Bool
    -- > If crossOrigin is not present, or is false:
    -- > Append 0x66616c7365 (false) to result.
    crossOriginValue :: Bool
crossOriginValue = forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
ccdCrossOrigin

    jsonBuilder :: Aeson.ToJSON a => a -> Builder
    jsonBuilder :: forall a. ToJSON a => a -> Builder
jsonBuilder = forall tag. Encoding' tag -> Builder
Aeson.fromEncoding forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Encoding
Aeson.toEncoding

-- | Removes all raw fields of a 'M.CollectedClientData'.
stripRawCollectedClientData ::
  M.CollectedClientData c raw ->
  M.CollectedClientData c 'False
stripRawCollectedClientData :: forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> CollectedClientData c 'False
stripRawCollectedClientData M.CollectedClientData {Maybe Bool
Origin
Challenge
RawField raw
ccdRawData :: RawField raw
ccdCrossOrigin :: Maybe Bool
ccdOrigin :: Origin
ccdChallenge :: Challenge
ccdRawData :: forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> RawField raw
ccdCrossOrigin :: forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Maybe Bool
ccdOrigin :: forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Origin
ccdChallenge :: forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Challenge
..} =
  M.CollectedClientData {ccdRawData :: RawField 'False
ccdRawData = RawField 'False
M.NoRaw, Maybe Bool
Origin
Challenge
ccdCrossOrigin :: Maybe Bool
ccdOrigin :: Origin
ccdChallenge :: Challenge
ccdCrossOrigin :: Maybe Bool
ccdOrigin :: Origin
ccdChallenge :: Challenge
..}

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#dictionary-client-data) Decodes
-- a 'M.CollectedClientData' from a 'BS.ByteString'. This is needed to parse
-- the
-- [clientDataJSON](https://www.w3.org/TR/webauthn-2/#dom-authenticatorresponse-clientdatajson)
-- field in the
-- [AuthenticatorResponse](https://www.w3.org/TR/webauthn-2/#iface-authenticatorresponse)
-- structure, which is used for both attestation and assertion.
decodeCollectedClientData ::
  forall (c :: K.CeremonyKind).
  SingI c =>
  BS.ByteString ->
  Either Text (M.CollectedClientData c 'True)
decodeCollectedClientData :: forall (c :: CeremonyKind).
SingI c =>
ByteString -> Either Text (CollectedClientData c 'True)
decodeCollectedClientData ByteString
bytes = do
  -- <https://www.w3.org/TR/webauthn-2/#collectedclientdata-json-compatible-serialization-of-client-data>
  ClientDataJSON {Maybe Bool
Text
crossOrigin :: Maybe Bool
origin :: Text
challenge :: Text
littype :: Text
crossOrigin :: ClientDataJSON -> Maybe Bool
origin :: ClientDataJSON -> Text
challenge :: ClientDataJSON -> Text
littype :: ClientDataJSON -> Text
..} <- case forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict ByteString
bytes of
    Left String
err ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        Text
"Collected client data JSON decoding error: "
          forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
err
    Right ClientDataJSON
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientDataJSON
res

  -- [(spec)](https://www.w3.org/TR/webauthn-2/#dom-collectedclientdata-challenge)
  -- This member contains the base64url encoding of the challenge provided by
  -- the [Relying Party](https://www.w3.org/TR/webauthn-2/#relying-party). See
  -- the [§ 13.4.3 Cryptographic
  -- Challenges](https://www.w3.org/TR/webauthn-2/#sctn-cryptographic-challenges)
  -- security consideration.
  ByteString
challenge <- case ByteString -> Either String ByteString
Base64Url.decode (Text -> ByteString
encodeUtf8 Text
challenge) of
    Left String
err ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        Text
"Failed to base64url-decode challenge "
          forall a. Semigroup a => a -> a -> a
<> Text
challenge
          forall a. Semigroup a => a -> a -> a
<> Text
": "
          forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
err
    Right ByteString
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
res

  -- [(spec)](https://www.w3.org/TR/webauthn-2/#dom-collectedclientdata-type)
  -- This member contains the string "webauthn.create" when creating new
  -- credentials, and "webauthn.get" when getting an assertion from an existing
  -- credential. The purpose of this member is to prevent certain types of
  -- signature confusion attacks (where an attacker substitutes one legitimate
  -- signature for another).
  let expectedType :: Text
expectedType = case forall {k} (a :: k). SingI a => Sing a
sing @c of
        Sing c
SCeremonyKind c
K.SRegistration -> Text
"webauthn.create"
        Sing c
SCeremonyKind c
K.SAuthentication -> Text
"webauthn.get"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
littype forall a. Eq a => a -> a -> Bool
== Text
expectedType) forall a b. (a -> b) -> a -> b
$
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
      Text
"Expected collected client data to have webauthn type "
        forall a. Semigroup a => a -> a -> a
<> Text
expectedType
        forall a. Semigroup a => a -> a -> a
<> Text
" but it is "
        forall a. Semigroup a => a -> a -> a
<> Text
littype
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    M.CollectedClientData
      { ccdChallenge :: Challenge
ccdChallenge = ByteString -> Challenge
M.Challenge ByteString
challenge,
        ccdOrigin :: Origin
ccdOrigin = Text -> Origin
M.Origin Text
origin,
        ccdCrossOrigin :: Maybe Bool
ccdCrossOrigin = Maybe Bool
crossOrigin,
        ccdRawData :: RawField 'True
ccdRawData = ByteString -> RawField 'True
M.WithRaw ByteString
bytes
      }

-- | Encodes all raw fields of a 'M.AttestedCredentialData', particularly
-- encodes 'M.acdCredentialPublicKey' using its 'Serialise' instance into
-- 'M.acdCredentialPublicKeyBytes', see
-- [@credentialPublicKey@](https://www.w3.org/TR/webauthn-2/#credentialpublickey).
encodeRawAttestedCredentialData ::
  M.AttestedCredentialData c raw ->
  M.AttestedCredentialData c 'True
encodeRawAttestedCredentialData :: forall (c :: CeremonyKind) (raw :: Bool).
AttestedCredentialData c raw -> AttestedCredentialData c 'True
encodeRawAttestedCredentialData M.AttestedCredentialData {CosePublicKey
AAGUID
CredentialId
RawField raw
acdCredentialPublicKeyBytes :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> RawField raw
acdCredentialPublicKey :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CosePublicKey
acdCredentialId :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CredentialId
acdAaguid :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> AAGUID
acdCredentialPublicKeyBytes :: RawField raw
acdCredentialPublicKey :: CosePublicKey
acdCredentialId :: CredentialId
acdAaguid :: AAGUID
..} =
  M.AttestedCredentialData
    { acdCredentialPublicKeyBytes :: RawField 'True
acdCredentialPublicKeyBytes = ByteString -> RawField 'True
M.WithRaw forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
bytes,
      CosePublicKey
AAGUID
CredentialId
acdCredentialPublicKey :: CosePublicKey
acdCredentialId :: CredentialId
acdAaguid :: AAGUID
acdCredentialPublicKey :: CosePublicKey
acdCredentialId :: CredentialId
acdAaguid :: AAGUID
..
    }
  where
    bytes :: ByteString
bytes = Encoding -> ByteString
CBOR.toLazyByteString forall a b. (a -> b) -> a -> b
$ forall a. Serialise a => a -> Encoding
encode CosePublicKey
acdCredentialPublicKey
encodeRawAttestedCredentialData AttestedCredentialData c raw
M.NoAttestedCredentialData =
  forall (raw :: Bool). AttestedCredentialData 'Authentication raw
M.NoAttestedCredentialData

-- | Removes all raw fields of a 'M.AttestedCredentialData'.
stripRawAttestedCredentialData ::
  M.AttestedCredentialData c raw ->
  M.AttestedCredentialData c 'False
stripRawAttestedCredentialData :: forall (c :: CeremonyKind) (raw :: Bool).
AttestedCredentialData c raw -> AttestedCredentialData c 'False
stripRawAttestedCredentialData M.AttestedCredentialData {CosePublicKey
AAGUID
CredentialId
RawField raw
acdCredentialPublicKeyBytes :: RawField raw
acdCredentialPublicKey :: CosePublicKey
acdCredentialId :: CredentialId
acdAaguid :: AAGUID
acdCredentialPublicKeyBytes :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> RawField raw
acdCredentialPublicKey :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CosePublicKey
acdCredentialId :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CredentialId
acdAaguid :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> AAGUID
..} =
  M.AttestedCredentialData {acdCredentialPublicKeyBytes :: RawField 'False
acdCredentialPublicKeyBytes = RawField 'False
M.NoRaw, CosePublicKey
AAGUID
CredentialId
acdCredentialPublicKey :: CosePublicKey
acdCredentialId :: CredentialId
acdAaguid :: AAGUID
acdCredentialPublicKey :: CosePublicKey
acdCredentialId :: CredentialId
acdAaguid :: AAGUID
..}
stripRawAttestedCredentialData AttestedCredentialData c raw
M.NoAttestedCredentialData =
  forall (raw :: Bool). AttestedCredentialData 'Authentication raw
M.NoAttestedCredentialData

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-attested-credential-data)
-- Encodes attested credential data into bytes, used by
-- 'encodeRawAuthenticatorData'.
encodeAttestedCredentialData ::
  M.AttestedCredentialData 'K.Registration 'True ->
  Builder
encodeAttestedCredentialData :: AttestedCredentialData 'Registration 'True -> Builder
encodeAttestedCredentialData M.AttestedCredentialData {CosePublicKey
AAGUID
CredentialId
RawField 'True
acdCredentialPublicKeyBytes :: RawField 'True
acdCredentialPublicKey :: CosePublicKey
acdCredentialId :: CredentialId
acdAaguid :: AAGUID
acdCredentialPublicKeyBytes :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> RawField raw
acdCredentialPublicKey :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CosePublicKey
acdCredentialId :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> CredentialId
acdAaguid :: forall (raw :: Bool).
AttestedCredentialData 'Registration raw -> AAGUID
..} =
  forall a. PutM a -> Builder
Binary.execPut (ByteString -> Put
Binary.putLazyByteString forall a b. (a -> b) -> a -> b
$ UUID -> ByteString
UUID.toByteString forall a b. (a -> b) -> a -> b
$ AAGUID -> UUID
unAAGUID AAGUID
acdAaguid)
    forall a. Semigroup a => a -> a -> a
<> forall a. PutM a -> Builder
Binary.execPut (Word16 -> Put
Binary.putWord16be Word16
credentialLength)
    forall a. Semigroup a => a -> a -> a
<> forall a. PutM a -> Builder
Binary.execPut (ByteString -> Put
Binary.putByteString forall a b. (a -> b) -> a -> b
$ CredentialId -> ByteString
M.unCredentialId CredentialId
acdCredentialId)
    forall a. Semigroup a => a -> a -> a
<> forall a. PutM a -> Builder
Binary.execPut (ByteString -> Put
Binary.putByteString forall a b. (a -> b) -> a -> b
$ RawField 'True -> ByteString
M.unRaw RawField 'True
acdCredentialPublicKeyBytes)
  where
    credentialLength :: Word16
    credentialLength :: Word16
credentialLength = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length forall a b. (a -> b) -> a -> b
$ CredentialId -> ByteString
M.unCredentialId CredentialId
acdCredentialId

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-attested-credential-data)
-- Decodes attested credential data from bytes, used by
-- 'decodeAuthenticatorData'.
decodeAttestedCredentialData ::
  PartialBinaryDecoder (M.AttestedCredentialData 'K.Registration 'True)
decodeAttestedCredentialData :: PartialBinaryDecoder (AttestedCredentialData 'Registration 'True)
decodeAttestedCredentialData = do
  -- https://www.w3.org/TR/webauthn-2/#aaguid
  AAGUID
acdAaguid <-
    -- Note: fromJust is safe because UUID.fromByteString only returns
    -- nothing if there's not exactly 16 bytes
    UUID -> AAGUID
AAGUID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe UUID
UUID.fromByteString
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Get a -> PartialBinaryDecoder a
runBinary (Int64 -> Get ByteString
Binary.getLazyByteString Int64
16)

  -- https://www.w3.org/TR/webauthn-2/#credentialidlength
  Word16
credentialLength <-
    forall a. Get a -> PartialBinaryDecoder a
runBinary Get Word16
Binary.getWord16be

  -- https://www.w3.org/TR/webauthn-2/#credentialid
  CredentialId
acdCredentialId <-
    ByteString -> CredentialId
M.CredentialId
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Get a -> PartialBinaryDecoder a
runBinary (Int -> Get ByteString
Binary.getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
credentialLength))

  -- https://www.w3.org/TR/webauthn-2/#credentialpublickey
  (ByteString
usedBytes, CosePublicKey
acdCredentialPublicKey) <- forall a.
(forall s. Decoder s a) -> PartialBinaryDecoder (ByteString, a)
runCBOR forall a s. Serialise a => Decoder s a
decode
  let acdCredentialPublicKeyBytes :: RawField 'True
acdCredentialPublicKeyBytes = ByteString -> RawField 'True
M.WithRaw forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
usedBytes

  forall (f :: * -> *) a. Applicative f => a -> f a
pure M.AttestedCredentialData {CosePublicKey
AAGUID
CredentialId
RawField 'True
acdCredentialPublicKeyBytes :: RawField 'True
acdCredentialPublicKey :: CosePublicKey
acdCredentialId :: CredentialId
acdAaguid :: AAGUID
acdCredentialPublicKeyBytes :: RawField 'True
acdCredentialPublicKey :: CosePublicKey
acdCredentialId :: CredentialId
acdAaguid :: AAGUID
..}

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#authenticator-data)
-- Encodes all raw-containing fields of a 'M.AuthenticatorData', particularly
-- 'M.adAttestedCredentialData', and the 'M.AuthenticatorData' itself into
-- 'M.adRawData'. This function is needed for an authenticator implementation.
encodeRawAuthenticatorData ::
  forall (c :: K.CeremonyKind) raw.
  SingI c =>
  M.AuthenticatorData c raw ->
  M.AuthenticatorData c 'True
encodeRawAuthenticatorData :: forall (c :: CeremonyKind) (raw :: Bool).
SingI c =>
AuthenticatorData c raw -> AuthenticatorData c 'True
encodeRawAuthenticatorData M.AuthenticatorData {Maybe AuthenticatorExtensionOutputs
AttestedCredentialData c raw
AuthenticatorDataFlags
SignatureCounter
RpIdHash
RawField raw
adRawData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RawField raw
adExtensions :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> Maybe AuthenticatorExtensionOutputs
adAttestedCredentialData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AttestedCredentialData c raw
adSignCount :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> SignatureCounter
adFlags :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
adRpIdHash :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
adRawData :: RawField raw
adExtensions :: Maybe AuthenticatorExtensionOutputs
adAttestedCredentialData :: AttestedCredentialData c raw
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
..} =
  M.AuthenticatorData
    { adRawData :: RawField 'True
adRawData = ByteString -> RawField 'True
M.WithRaw ByteString
bytes,
      adAttestedCredentialData :: AttestedCredentialData c 'True
adAttestedCredentialData = AttestedCredentialData c 'True
rawAttestedCredentialData,
      Maybe AuthenticatorExtensionOutputs
AuthenticatorDataFlags
SignatureCounter
RpIdHash
adExtensions :: Maybe AuthenticatorExtensionOutputs
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
adExtensions :: Maybe AuthenticatorExtensionOutputs
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
..
    }
  where
    rawAttestedCredentialData :: AttestedCredentialData c 'True
rawAttestedCredentialData =
      forall (c :: CeremonyKind) (raw :: Bool).
AttestedCredentialData c raw -> AttestedCredentialData c 'True
encodeRawAttestedCredentialData AttestedCredentialData c raw
adAttestedCredentialData

    bytes :: BS.ByteString
    bytes :: ByteString
bytes = ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
builder

    -- https://www.w3.org/TR/webauthn-2/#flags
    flags :: Word8
    flags :: Word8
flags =
      Word8
userPresentFlag
        forall a. Bits a => a -> a -> a
.|. Word8
userVerifiedFlag
        forall a. Bits a => a -> a -> a
.|. Word8
attestedCredentialDataPresentFlag
        forall a. Bits a => a -> a -> a
.|. Word8
extensionsPresentFlag
      where
        userPresentFlag :: Word8
userPresentFlag = if AuthenticatorDataFlags -> Bool
M.adfUserPresent AuthenticatorDataFlags
adFlags then forall a. Bits a => Int -> a
Bits.bit Int
0 else Word8
0
        userVerifiedFlag :: Word8
userVerifiedFlag = if AuthenticatorDataFlags -> Bool
M.adfUserVerified AuthenticatorDataFlags
adFlags then forall a. Bits a => Int -> a
Bits.bit Int
2 else Word8
0
        attestedCredentialDataPresentFlag :: Word8
attestedCredentialDataPresentFlag = case forall {k} (a :: k). SingI a => Sing a
sing @c of
          Sing c
SCeremonyKind c
K.SRegistration -> forall a. Bits a => Int -> a
Bits.bit Int
6
          Sing c
SCeremonyKind c
K.SAuthentication -> Word8
0
        extensionsPresentFlag :: Word8
extensionsPresentFlag = case Maybe AuthenticatorExtensionOutputs
adExtensions of
          Just AuthenticatorExtensionOutputs
_ -> forall a. Bits a => Int -> a
Bits.bit Int
7
          Maybe AuthenticatorExtensionOutputs
Nothing -> Word8
0

    -- https://www.w3.org/TR/webauthn-2/#sctn-authenticator-data
    builder :: Builder
    builder :: Builder
builder =
      forall a. PutM a -> Builder
Binary.execPut (ByteString -> Put
Binary.putByteString forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert forall a b. (a -> b) -> a -> b
$ RpIdHash -> Digest SHA256
M.unRpIdHash RpIdHash
adRpIdHash)
        forall a. Semigroup a => a -> a -> a
<> forall a. PutM a -> Builder
Binary.execPut (Word8 -> Put
Binary.putWord8 Word8
flags)
        forall a. Semigroup a => a -> a -> a
<> forall a. PutM a -> Builder
Binary.execPut (Word32 -> Put
Binary.putWord32be forall a b. (a -> b) -> a -> b
$ SignatureCounter -> Word32
M.unSignatureCounter SignatureCounter
adSignCount)
        forall a. Semigroup a => a -> a -> a
<> ( case forall {k} (a :: k). SingI a => Sing a
sing @c of
               Sing c
SCeremonyKind c
K.SRegistration ->
                 AttestedCredentialData 'Registration 'True -> Builder
encodeAttestedCredentialData AttestedCredentialData c 'True
rawAttestedCredentialData
               Sing c
SCeremonyKind c
K.SAuthentication ->
                 forall a. Monoid a => a
mempty
           )
        forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty AuthenticatorExtensionOutputs -> Builder
encodeExtensions Maybe AuthenticatorExtensionOutputs
adExtensions

-- | Removes all raw fields from a 'M.AuthenticatorData'.
stripRawAuthenticatorData ::
  M.AuthenticatorData c raw ->
  M.AuthenticatorData c 'False
stripRawAuthenticatorData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorData c 'False
stripRawAuthenticatorData M.AuthenticatorData {Maybe AuthenticatorExtensionOutputs
AttestedCredentialData c raw
AuthenticatorDataFlags
SignatureCounter
RpIdHash
RawField raw
adRawData :: RawField raw
adExtensions :: Maybe AuthenticatorExtensionOutputs
adAttestedCredentialData :: AttestedCredentialData c raw
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
adRawData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RawField raw
adExtensions :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> Maybe AuthenticatorExtensionOutputs
adAttestedCredentialData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AttestedCredentialData c raw
adSignCount :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> SignatureCounter
adFlags :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
adRpIdHash :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
..} =
  M.AuthenticatorData
    { adRawData :: RawField 'False
adRawData = RawField 'False
M.NoRaw,
      adAttestedCredentialData :: AttestedCredentialData c 'False
adAttestedCredentialData =
        forall (c :: CeremonyKind) (raw :: Bool).
AttestedCredentialData c raw -> AttestedCredentialData c 'False
stripRawAttestedCredentialData AttestedCredentialData c raw
adAttestedCredentialData,
      Maybe AuthenticatorExtensionOutputs
AuthenticatorDataFlags
SignatureCounter
RpIdHash
adExtensions :: Maybe AuthenticatorExtensionOutputs
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
adExtensions :: Maybe AuthenticatorExtensionOutputs
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
..
    }

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#authenticator-data) Decodes a
-- 'M.AuthenticatorData' from a 'BS.ByteString'. This is needed to parse a
-- webauthn clients
-- [authenticatorData](https://www.w3.org/TR/webauthn-2/#dom-authenticatorassertionresponse-authenticatordata)
-- field in the
-- [AuthenticatorAssertionResponse](https://www.w3.org/TR/webauthn-2/#iface-authenticatorassertionresponse)
-- structure.
decodeAuthenticatorData ::
  forall (c :: K.CeremonyKind).
  SingI c =>
  BS.ByteString ->
  Either Text (M.AuthenticatorData c 'True)
decodeAuthenticatorData :: forall (c :: CeremonyKind).
SingI c =>
ByteString -> Either Text (AuthenticatorData c 'True)
decodeAuthenticatorData ByteString
strictBytes = forall a. ByteString -> PartialBinaryDecoder a -> Either Text a
runPartialBinaryDecoder ByteString
strictBytes forall a b. (a -> b) -> a -> b
$ do
  -- https://www.w3.org/TR/webauthn-2/#authenticator-data
  let adRawData :: RawField 'True
adRawData = ByteString -> RawField 'True
M.WithRaw ByteString
strictBytes

  -- https://www.w3.org/TR/webauthn-2/#rpidhash
  RpIdHash
adRpIdHash <-
    Digest SHA256 -> RpIdHash
M.RpIdHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
Hash.digestFromByteString
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Get a -> PartialBinaryDecoder a
runBinary (Int -> Get ByteString
Binary.getByteString Int
32)

  -- https://www.w3.org/TR/webauthn-2/#flags
  Word8
bitFlags <- forall a. Get a -> PartialBinaryDecoder a
runBinary Get Word8
Binary.getWord8
  let adFlags :: AuthenticatorDataFlags
adFlags =
        M.AuthenticatorDataFlags
          { adfUserPresent :: Bool
M.adfUserPresent = forall a. Bits a => a -> Int -> Bool
Bits.testBit Word8
bitFlags Int
0,
            adfUserVerified :: Bool
M.adfUserVerified = forall a. Bits a => a -> Int -> Bool
Bits.testBit Word8
bitFlags Int
2
          }

  -- https://www.w3.org/TR/webauthn-2/#signcount
  SignatureCounter
adSignCount <- Word32 -> SignatureCounter
M.SignatureCounter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Get a -> PartialBinaryDecoder a
runBinary Get Word32
Binary.getWord32be

  -- https://www.w3.org/TR/webauthn-2/#attestedcredentialdata
  AttestedCredentialData c 'True
adAttestedCredentialData <- case (forall {k} (a :: k). SingI a => Sing a
sing @c, forall a. Bits a => a -> Int -> Bool
Bits.testBit Word8
bitFlags Int
6) of
    -- For [attestation
    -- signatures](https://www.w3.org/TR/webauthn-2/#attestation-signature),
    -- the authenticator MUST set the AT
    -- [flag](https://www.w3.org/TR/webauthn-2/#flags) and include the
    -- `[attestedCredentialData](https://www.w3.org/TR/webauthn-2/#attestedcredentialdata)`.
    (SCeremonyKind c
K.SRegistration, Bool
True) ->
      PartialBinaryDecoder (AttestedCredentialData 'Registration 'True)
decodeAttestedCredentialData
    (SCeremonyKind c
K.SRegistration, Bool
False) ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Expected attested credential data, but there is none"
    -- For [assertion
    -- signatures](https://www.w3.org/TR/webauthn-2/#assertion-signature), the
    -- AT [flag](https://www.w3.org/TR/webauthn-2/#flags) MUST NOT be set and
    -- the
    -- `[attestedCredentialData](https://www.w3.org/TR/webauthn-2/#attestedcredentialdata)`
    -- MUST NOT be included.
    (SCeremonyKind c
K.SAuthentication, Bool
False) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (raw :: Bool). AttestedCredentialData 'Authentication raw
M.NoAttestedCredentialData
    (SCeremonyKind c
K.SAuthentication, Bool
True) ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Expected no attested credential data, but there is"

  -- https://www.w3.org/TR/webauthn-2/#authdataextensions
  Maybe AuthenticatorExtensionOutputs
adExtensions <-
    if forall a. Bits a => a -> Int -> Bool
Bits.testBit Word8
bitFlags Int
7
      then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PartialBinaryDecoder AuthenticatorExtensionOutputs
decodeExtensions
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

  forall (f :: * -> *) a. Applicative f => a -> f a
pure M.AuthenticatorData {Maybe AuthenticatorExtensionOutputs
AttestedCredentialData c 'True
AuthenticatorDataFlags
SignatureCounter
RpIdHash
RawField 'True
adExtensions :: Maybe AuthenticatorExtensionOutputs
adAttestedCredentialData :: AttestedCredentialData c 'True
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
adRawData :: RawField 'True
adRawData :: RawField 'True
adExtensions :: Maybe AuthenticatorExtensionOutputs
adAttestedCredentialData :: AttestedCredentialData c 'True
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
..}

-- | Encodes all raw fields of an 'M.AttestationObject'.
encodeRawAttestationObject ::
  M.AttestationObject raw ->
  M.AttestationObject 'True
encodeRawAttestationObject :: forall (raw :: Bool).
AttestationObject raw -> AttestationObject 'True
encodeRawAttestationObject M.AttestationObject {a
AttStmt a
AuthenticatorData 'Registration raw
aoAttStmt :: ()
aoFmt :: ()
aoAuthData :: forall (raw :: Bool).
AttestationObject raw -> AuthenticatorData 'Registration raw
aoAttStmt :: AttStmt a
aoFmt :: a
aoAuthData :: AuthenticatorData 'Registration raw
..} =
  M.AttestationObject
    { aoAuthData :: AuthenticatorData 'Registration 'True
aoAuthData = forall (c :: CeremonyKind) (raw :: Bool).
SingI c =>
AuthenticatorData c raw -> AuthenticatorData c 'True
encodeRawAuthenticatorData AuthenticatorData 'Registration raw
aoAuthData,
      a
AttStmt a
aoAttStmt :: AttStmt a
aoFmt :: a
aoAttStmt :: AttStmt a
aoFmt :: a
..
    }

-- | Removes all raw fields of an 'M.AttestationObject'.
stripRawAttestationObject ::
  M.AttestationObject raw ->
  M.AttestationObject 'False
stripRawAttestationObject :: forall (raw :: Bool).
AttestationObject raw -> AttestationObject 'False
stripRawAttestationObject M.AttestationObject {a
AttStmt a
AuthenticatorData 'Registration raw
aoAttStmt :: AttStmt a
aoFmt :: a
aoAuthData :: AuthenticatorData 'Registration raw
aoAttStmt :: ()
aoFmt :: ()
aoAuthData :: forall (raw :: Bool).
AttestationObject raw -> AuthenticatorData 'Registration raw
..} =
  M.AttestationObject
    { aoAuthData :: AuthenticatorData 'Registration 'False
aoAuthData = forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorData c 'False
stripRawAuthenticatorData AuthenticatorData 'Registration raw
aoAuthData,
      a
AttStmt a
aoAttStmt :: AttStmt a
aoFmt :: a
aoAttStmt :: AttStmt a
aoFmt :: a
..
    }

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-generating-an-attestation-object)
-- Encodes an 'M.AttestationObject' as a 'BS.ByteString'. This is needed by
-- the client side to generate a valid JSON response.
encodeAttestationObject ::
  M.AttestationObject 'True ->
  BS.ByteString
encodeAttestationObject :: AttestationObject 'True -> ByteString
encodeAttestationObject M.AttestationObject {a
AttStmt a
AuthenticatorData 'Registration 'True
aoAttStmt :: AttStmt a
aoFmt :: a
aoAuthData :: AuthenticatorData 'Registration 'True
aoAttStmt :: ()
aoFmt :: ()
aoAuthData :: forall (raw :: Bool).
AttestationObject raw -> AuthenticatorData 'Registration raw
..} =
  Encoding -> ByteString
CBOR.toStrictByteString forall a b. (a -> b) -> a -> b
$ Term -> Encoding
CBOR.encodeTerm Term
term
  where
    -- https://www.w3.org/TR/webauthn-2/#sctn-generating-an-attestation-object
    term :: CBOR.Term
    term :: Term
term =
      [(Term, Term)] -> Term
CBOR.TMap
        [ (Text -> Term
CBOR.TString Text
"authData", ByteString -> Term
CBOR.TBytes forall a b. (a -> b) -> a -> b
$ RawField 'True -> ByteString
M.unRaw forall a b. (a -> b) -> a -> b
$ forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RawField raw
M.adRawData AuthenticatorData 'Registration 'True
aoAuthData),
          (Text -> Term
CBOR.TString Text
"fmt", Text -> Term
CBOR.TString forall a b. (a -> b) -> a -> b
$ forall a. AttestationStatementFormat a => a -> Text
M.asfIdentifier a
aoFmt),
          (Text -> Term
CBOR.TString Text
"attStmt", forall a. AttestationStatementFormat a => a -> AttStmt a -> Term
M.asfEncode a
aoFmt AttStmt a
aoAttStmt)
        ]

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-generating-an-attestation-object)
-- Decodes a 'M.AttestationObject' from a 'BS.ByteString'. This is needed to
-- parse a webauthn clients
-- [attestationObject](https://www.w3.org/TR/webauthn-2/#dom-authenticatorattestationresponse-attestationobject)
-- field in the
-- [AuthenticatorAttestationResponse](https://www.w3.org/TR/webauthn-2/#iface-authenticatorattestationresponse)
-- structure This function takes a 'M.SupportedAttestationStatementFormats'
-- argument to indicate which attestation statement formats are supported.
-- structure.
decodeAttestationObject ::
  M.SupportedAttestationStatementFormats ->
  BS.ByteString ->
  Either Text (M.AttestationObject 'True)
decodeAttestationObject :: SupportedAttestationStatementFormats
-> ByteString -> Either Text (AttestationObject 'True)
decodeAttestationObject SupportedAttestationStatementFormats
supportedFormats ByteString
bytes = do
  (ByteString
_consumed, Term
result) <-
    forall a. ByteString -> PartialBinaryDecoder a -> Either Text a
runPartialBinaryDecoder ByteString
bytes (forall a.
(forall s. Decoder s a) -> PartialBinaryDecoder (ByteString, a)
runCBOR forall s. Decoder s Term
CBOR.decodeTerm)
  [(Term, Term)]
pairs <- case Term
result of
    CBOR.TMap [(Term, Term)]
pairs -> forall (m :: * -> *) a. Monad m => a -> m a
return [(Term, Term)]
pairs
    Term
_ ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        Text
"The attestation object should be a CBOR map, but it's not: "
          forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show Term
result)

  -- https://www.w3.org/TR/webauthn-2/#sctn-generating-an-attestation-object
  case ( Text -> Term
CBOR.TString Text
"authData" forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Term, Term)]
pairs,
         Text -> Term
CBOR.TString Text
"fmt" forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Term, Term)]
pairs,
         Text -> Term
CBOR.TString Text
"attStmt" forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Term, Term)]
pairs
       ) of
    ( Just (CBOR.TBytes ByteString
authDataBytes),
      Just (CBOR.TString Text
fmt),
      Just (CBOR.TMap [(Term, Term)]
attStmtPairs)
      ) -> do
        AuthenticatorData 'Registration 'True
aoAuthData <- forall (c :: CeremonyKind).
SingI c =>
ByteString -> Either Text (AuthenticatorData c 'True)
decodeAuthenticatorData ByteString
authDataBytes

        case Text
-> SupportedAttestationStatementFormats
-> Maybe SomeAttestationStatementFormat
M.lookupAttestationStatementFormat Text
fmt SupportedAttestationStatementFormats
supportedFormats of
          Maybe SomeAttestationStatementFormat
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Unknown attestation statement format: " forall a. Semigroup a => a -> a -> a
<> Text
fmt
          Just (M.SomeAttestationStatementFormat a
aoFmt) -> do
            HashMap Text Term
attStmtMap <-
              forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {b}. (Term, b) -> Either Text (Text, b)
textKeyPairs [(Term, Term)]
attStmtPairs
            AttStmt a
aoAttStmt <- forall a.
AttestationStatementFormat a =>
a -> HashMap Text Term -> Either Text (AttStmt a)
M.asfDecode a
aoFmt HashMap Text Term
attStmtMap
            forall (f :: * -> *) a. Applicative f => a -> f a
pure M.AttestationObject {a
AttStmt a
AuthenticatorData 'Registration 'True
aoAttStmt :: AttStmt a
aoFmt :: a
aoAuthData :: AuthenticatorData 'Registration 'True
aoAttStmt :: AttStmt a
aoFmt :: a
aoAuthData :: AuthenticatorData 'Registration 'True
..}
    (Maybe Term, Maybe Term, Maybe Term)
_ ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        Text
"The attestation object doesn't have the expected structure of "
          forall a. Semigroup a => a -> a -> a
<> Text
"(authData: bytes, fmt: string, attStmt: map): "
          forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show Term
result)
  where
    textKeyPairs :: (Term, b) -> Either Text (Text, b)
textKeyPairs (CBOR.TString Text
text, b
term) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
text, b
term)
    textKeyPairs (Term
nonString, b
_) =
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        Text
"Unexpected non-string attestation statement key: "
          forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show Term
nonString)

-- | Encode all raw fields of an 'M.AuthenticatorResponse'.
encodeRawAuthenticatorResponse ::
  M.AuthenticatorResponse c raw ->
  M.AuthenticatorResponse c 'True
encodeRawAuthenticatorResponse :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorResponse c raw -> AuthenticatorResponse c 'True
encodeRawAuthenticatorResponse M.AuthenticatorResponseRegistration {[AuthenticatorTransport]
AttestationObject raw
CollectedClientData 'Registration raw
arrTransports :: forall (raw :: Bool).
AuthenticatorResponse 'Registration raw -> [AuthenticatorTransport]
arrAttestationObject :: forall (raw :: Bool).
AuthenticatorResponse 'Registration raw -> AttestationObject raw
arrClientData :: forall (raw :: Bool).
AuthenticatorResponse 'Registration raw
-> CollectedClientData 'Registration raw
arrTransports :: [AuthenticatorTransport]
arrAttestationObject :: AttestationObject raw
arrClientData :: CollectedClientData 'Registration raw
..} =
  M.AuthenticatorResponseRegistration
    { arrClientData :: CollectedClientData 'Registration 'True
arrClientData = forall (c :: CeremonyKind) (raw :: Bool).
SingI c =>
CollectedClientData c raw -> CollectedClientData c 'True
encodeRawCollectedClientData CollectedClientData 'Registration raw
arrClientData,
      arrAttestationObject :: AttestationObject 'True
arrAttestationObject = forall (raw :: Bool).
AttestationObject raw -> AttestationObject 'True
encodeRawAttestationObject AttestationObject raw
arrAttestationObject,
      [AuthenticatorTransport]
arrTransports :: [AuthenticatorTransport]
arrTransports :: [AuthenticatorTransport]
..
    }
encodeRawAuthenticatorResponse M.AuthenticatorResponseAuthentication {Maybe UserHandle
AuthenticatorData 'Authentication raw
CollectedClientData 'Authentication raw
AssertionSignature
araUserHandle :: forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw -> Maybe UserHandle
araSignature :: forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw -> AssertionSignature
araAuthenticatorData :: forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw
-> AuthenticatorData 'Authentication raw
araClientData :: forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw
-> CollectedClientData 'Authentication raw
araUserHandle :: Maybe UserHandle
araSignature :: AssertionSignature
araAuthenticatorData :: AuthenticatorData 'Authentication raw
araClientData :: CollectedClientData 'Authentication raw
..} =
  M.AuthenticatorResponseAuthentication
    { araClientData :: CollectedClientData 'Authentication 'True
araClientData = forall (c :: CeremonyKind) (raw :: Bool).
SingI c =>
CollectedClientData c raw -> CollectedClientData c 'True
encodeRawCollectedClientData CollectedClientData 'Authentication raw
araClientData,
      araAuthenticatorData :: AuthenticatorData 'Authentication 'True
araAuthenticatorData = forall (c :: CeremonyKind) (raw :: Bool).
SingI c =>
AuthenticatorData c raw -> AuthenticatorData c 'True
encodeRawAuthenticatorData AuthenticatorData 'Authentication raw
araAuthenticatorData,
      Maybe UserHandle
AssertionSignature
araUserHandle :: Maybe UserHandle
araSignature :: AssertionSignature
araUserHandle :: Maybe UserHandle
araSignature :: AssertionSignature
..
    }

-- | Removes all raw fields of an 'M.AuthenticatorResponse'.
stripRawAuthenticatorResponse ::
  M.AuthenticatorResponse c raw ->
  M.AuthenticatorResponse c 'False
stripRawAuthenticatorResponse :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorResponse c raw -> AuthenticatorResponse c 'False
stripRawAuthenticatorResponse M.AuthenticatorResponseRegistration {[AuthenticatorTransport]
AttestationObject raw
CollectedClientData 'Registration raw
arrTransports :: [AuthenticatorTransport]
arrAttestationObject :: AttestationObject raw
arrClientData :: CollectedClientData 'Registration raw
arrTransports :: forall (raw :: Bool).
AuthenticatorResponse 'Registration raw -> [AuthenticatorTransport]
arrAttestationObject :: forall (raw :: Bool).
AuthenticatorResponse 'Registration raw -> AttestationObject raw
arrClientData :: forall (raw :: Bool).
AuthenticatorResponse 'Registration raw
-> CollectedClientData 'Registration raw
..} =
  M.AuthenticatorResponseRegistration
    { arrClientData :: CollectedClientData 'Registration 'False
arrClientData = forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> CollectedClientData c 'False
stripRawCollectedClientData CollectedClientData 'Registration raw
arrClientData,
      arrAttestationObject :: AttestationObject 'False
arrAttestationObject = forall (raw :: Bool).
AttestationObject raw -> AttestationObject 'False
stripRawAttestationObject AttestationObject raw
arrAttestationObject,
      [AuthenticatorTransport]
arrTransports :: [AuthenticatorTransport]
arrTransports :: [AuthenticatorTransport]
..
    }
stripRawAuthenticatorResponse M.AuthenticatorResponseAuthentication {Maybe UserHandle
AuthenticatorData 'Authentication raw
CollectedClientData 'Authentication raw
AssertionSignature
araUserHandle :: Maybe UserHandle
araSignature :: AssertionSignature
araAuthenticatorData :: AuthenticatorData 'Authentication raw
araClientData :: CollectedClientData 'Authentication raw
araUserHandle :: forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw -> Maybe UserHandle
araSignature :: forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw -> AssertionSignature
araAuthenticatorData :: forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw
-> AuthenticatorData 'Authentication raw
araClientData :: forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw
-> CollectedClientData 'Authentication raw
..} =
  M.AuthenticatorResponseAuthentication
    { araClientData :: CollectedClientData 'Authentication 'False
araClientData = forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> CollectedClientData c 'False
stripRawCollectedClientData CollectedClientData 'Authentication raw
araClientData,
      araAuthenticatorData :: AuthenticatorData 'Authentication 'False
araAuthenticatorData = forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorData c 'False
stripRawAuthenticatorData AuthenticatorData 'Authentication raw
araAuthenticatorData,
      Maybe UserHandle
AssertionSignature
araUserHandle :: Maybe UserHandle
araSignature :: AssertionSignature
araUserHandle :: Maybe UserHandle
araSignature :: AssertionSignature
..
    }

-- | Encodes all raw fields of an 'M.Credential'.
encodeRawCredential ::
  M.Credential c raw ->
  M.Credential c 'True
encodeRawCredential :: forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> Credential c 'True
encodeRawCredential M.Credential {AuthenticatorResponse c raw
AuthenticationExtensionsClientOutputs
CredentialId
cClientExtensionResults :: forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> AuthenticationExtensionsClientOutputs
cResponse :: forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> AuthenticatorResponse c raw
cIdentifier :: forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> CredentialId
cClientExtensionResults :: AuthenticationExtensionsClientOutputs
cResponse :: AuthenticatorResponse c raw
cIdentifier :: CredentialId
..} =
  M.Credential
    { cResponse :: AuthenticatorResponse c 'True
cResponse = forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorResponse c raw -> AuthenticatorResponse c 'True
encodeRawAuthenticatorResponse AuthenticatorResponse c raw
cResponse,
      AuthenticationExtensionsClientOutputs
CredentialId
cClientExtensionResults :: AuthenticationExtensionsClientOutputs
cIdentifier :: CredentialId
cClientExtensionResults :: AuthenticationExtensionsClientOutputs
cIdentifier :: CredentialId
..
    }

-- | Removes all raw fields of an 'M.Credential'.
stripRawCredential ::
  M.Credential c raw ->
  M.Credential c 'False
stripRawCredential :: forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> Credential c 'False
stripRawCredential M.Credential {AuthenticatorResponse c raw
AuthenticationExtensionsClientOutputs
CredentialId
cClientExtensionResults :: AuthenticationExtensionsClientOutputs
cResponse :: AuthenticatorResponse c raw
cIdentifier :: CredentialId
cClientExtensionResults :: forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> AuthenticationExtensionsClientOutputs
cResponse :: forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> AuthenticatorResponse c raw
cIdentifier :: forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> CredentialId
..} =
  M.Credential
    { cResponse :: AuthenticatorResponse c 'False
cResponse = forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorResponse c raw -> AuthenticatorResponse c 'False
stripRawAuthenticatorResponse AuthenticatorResponse c raw
cResponse,
      AuthenticationExtensionsClientOutputs
CredentialId
cClientExtensionResults :: AuthenticationExtensionsClientOutputs
cIdentifier :: CredentialId
cClientExtensionResults :: AuthenticationExtensionsClientOutputs
cIdentifier :: CredentialId
..
    }