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

-- | Stability: internal
-- Certain parts of the specification require that data is decoded from a
-- binary form. This module holds such functions.
module Crypto.WebAuthn.Model.WebIDL.Internal.Binary.Decoding
  ( -- * Decoding from bytes
    decodeAuthenticatorData,
    decodeAttestationObject,
    decodeCollectedClientData,
  )
where

import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Term as CBOR
import Codec.Serialise (decode)
import Control.Monad (forM, unless)
import Control.Monad.Except (MonadError (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))
import qualified Crypto.WebAuthn.Model.Kinds as K
import qualified Crypto.WebAuthn.Model.Types as M
import qualified Crypto.WebAuthn.WebIDL as IDL
import qualified Data.Aeson as Aeson
import Data.Bifunctor (first)
import qualified Data.Binary.Get as Binary
import qualified Data.Bits as Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Base64.URL as Base64Url
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 qualified Data.Text.Encoding as Text
import qualified Data.UUID as UUID
import GHC.Generics (Generic)

-- | 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 the decoders as a 'PartialBinaryDecoder DecodingError',
-- which is just a function that can partially consume a '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 :: ByteString -> PartialBinaryDecoder a -> Either Text a
runPartialBinaryDecoder ByteString
bytes PartialBinaryDecoder a
decoder = case PartialBinaryDecoder a -> ByteString -> Either Text (a, ByteString)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT PartialBinaryDecoder a
decoder (ByteString -> Either Text (a, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> Either Text (a, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict (ByteString -> Either Text (a, ByteString))
-> ByteString -> Either Text (a, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
bytes of
  Left Text
err -> Text -> Either Text a
forall a b. a -> Either a b
Left Text
err
  Right (a
result, ByteString
rest)
    | ByteString -> Bool
LBS.null ByteString
rest -> a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
    | Bool
otherwise -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"Not all binary input used, rest in base64 format is: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
Text.decodeUtf8 (ByteString -> ByteString
Base64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
rest)

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

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

-- | 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.
  SingI c =>
  BS.ByteString ->
  Either Text (M.AuthenticatorData c 'True)
decodeAuthenticatorData :: ByteString -> Either Text (AuthenticatorData c 'True)
decodeAuthenticatorData ByteString
strictBytes = ByteString
-> PartialBinaryDecoder (AuthenticatorData c 'True)
-> Either Text (AuthenticatorData c 'True)
forall a. ByteString -> PartialBinaryDecoder a -> Either Text a
runPartialBinaryDecoder ByteString
strictBytes (PartialBinaryDecoder (AuthenticatorData c 'True)
 -> Either Text (AuthenticatorData c 'True))
-> PartialBinaryDecoder (AuthenticatorData c 'True)
-> Either Text (AuthenticatorData c 'True)
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 (Digest SHA256 -> RpIdHash)
-> (ByteString -> Digest SHA256) -> ByteString -> RpIdHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Digest SHA256) -> Digest SHA256
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Digest SHA256) -> Digest SHA256)
-> (ByteString -> Maybe (Digest SHA256))
-> ByteString
-> Digest SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Digest SHA256)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
Hash.digestFromByteString
      (ByteString -> RpIdHash)
-> StateT ByteString (Either Text) ByteString
-> StateT ByteString (Either Text) RpIdHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString -> StateT ByteString (Either Text) ByteString
forall a. Get a -> PartialBinaryDecoder a
runBinary (Int -> Get ByteString
Binary.getByteString Int
32)

  -- https://www.w3.org/TR/webauthn-2/#flags
  Word8
bitFlags <- Get Word8 -> PartialBinaryDecoder Word8
forall a. Get a -> PartialBinaryDecoder a
runBinary Get Word8
Binary.getWord8
  let adFlags :: AuthenticatorDataFlags
adFlags =
        AuthenticatorDataFlags :: Bool -> Bool -> AuthenticatorDataFlags
M.AuthenticatorDataFlags
          { adfUserPresent :: Bool
M.adfUserPresent = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
Bits.testBit Word8
bitFlags Int
0,
            adfUserVerified :: Bool
M.adfUserVerified = Word8 -> Int -> Bool
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 (Word32 -> SignatureCounter)
-> StateT ByteString (Either Text) Word32
-> StateT ByteString (Either Text) SignatureCounter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32 -> StateT ByteString (Either Text) Word32
forall a. Get a -> PartialBinaryDecoder a
runBinary Get Word32
Binary.getWord32be

  -- https://www.w3.org/TR/webauthn-2/#attestedcredentialdata
  AttestedCredentialData c 'True
adAttestedCredentialData <- case (SingI c => Sing c
forall k (a :: k). SingI a => Sing a
sing @c, Word8 -> Int -> Bool
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) -> StateT ByteString (Either Text) (AttestedCredentialData c 'True)
PartialBinaryDecoder (AttestedCredentialData 'Registration 'True)
decodeAttestedCredentialData
    (SCeremonyKind c
K.SRegistration, Bool
False) -> Text
-> StateT ByteString (Either Text) (AttestedCredentialData c 'True)
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) -> AttestedCredentialData 'Authentication 'True
-> StateT
     ByteString
     (Either Text)
     (AttestedCredentialData 'Authentication 'True)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AttestedCredentialData 'Authentication 'True
forall (raw :: Bool). AttestedCredentialData 'Authentication raw
M.NoAttestedCredentialData
    (SCeremonyKind c
K.SAuthentication, Bool
True) -> Text
-> StateT ByteString (Either Text) (AttestedCredentialData c '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 Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
Bits.testBit Word8
bitFlags Int
7
      then AuthenticatorExtensionOutputs
-> Maybe AuthenticatorExtensionOutputs
forall a. a -> Maybe a
Just (AuthenticatorExtensionOutputs
 -> Maybe AuthenticatorExtensionOutputs)
-> StateT ByteString (Either Text) AuthenticatorExtensionOutputs
-> StateT
     ByteString (Either Text) (Maybe AuthenticatorExtensionOutputs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ByteString (Either Text) AuthenticatorExtensionOutputs
decodeExtensions
      else Maybe AuthenticatorExtensionOutputs
-> StateT
     ByteString (Either Text) (Maybe AuthenticatorExtensionOutputs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AuthenticatorExtensionOutputs
forall a. Maybe a
Nothing

  AuthenticatorData c 'True
-> PartialBinaryDecoder (AuthenticatorData c 'True)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthenticatorData :: forall (c :: CeremonyKind) (raw :: Bool).
RpIdHash
-> AuthenticatorDataFlags
-> SignatureCounter
-> AttestedCredentialData c raw
-> Maybe AuthenticatorExtensionOutputs
-> RawField raw
-> AuthenticatorData c raw
M.AuthenticatorData {Maybe AuthenticatorExtensionOutputs
AttestedCredentialData c 'True
AuthenticatorDataFlags
SignatureCounter
RpIdHash
RawField 'True
adRawData :: RawField 'True
adExtensions :: Maybe AuthenticatorExtensionOutputs
adAttestedCredentialData :: AttestedCredentialData c 'True
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
adExtensions :: Maybe AuthenticatorExtensionOutputs
adAttestedCredentialData :: AttestedCredentialData c 'True
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
adRawData :: RawField 'True
..}
  where
    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 (UUID -> AAGUID) -> (ByteString -> UUID) -> ByteString -> AAGUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe UUID -> UUID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe UUID -> UUID)
-> (ByteString -> Maybe UUID) -> ByteString -> UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe UUID
UUID.fromByteString
          (ByteString -> AAGUID)
-> StateT ByteString (Either Text) ByteString
-> StateT ByteString (Either Text) AAGUID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString -> StateT ByteString (Either Text) ByteString
forall a. Get a -> PartialBinaryDecoder a
runBinary (ByteOffset -> Get ByteString
Binary.getLazyByteString ByteOffset
16)

      -- https://www.w3.org/TR/webauthn-2/#credentialidlength
      Word16
credentialLength <-
        Get Word16 -> PartialBinaryDecoder Word16
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
          (ByteString -> CredentialId)
-> StateT ByteString (Either Text) ByteString
-> StateT ByteString (Either Text) CredentialId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString -> StateT ByteString (Either Text) ByteString
forall a. Get a -> PartialBinaryDecoder a
runBinary (Int -> Get ByteString
Binary.getByteString (Word16 -> Int
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 s. Decoder s CosePublicKey)
-> PartialBinaryDecoder (ByteString, CosePublicKey)
forall a.
(forall s. Decoder s a) -> PartialBinaryDecoder (ByteString, a)
runCBOR forall s. Decoder s CosePublicKey
forall a s. Serialise a => Decoder s a
decode
      let acdCredentialPublicKeyBytes :: RawField 'True
acdCredentialPublicKeyBytes = ByteString -> RawField 'True
M.WithRaw (ByteString -> RawField 'True) -> ByteString -> RawField 'True
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
usedBytes

      AttestedCredentialData 'Registration 'True
-> PartialBinaryDecoder
     (AttestedCredentialData 'Registration 'True)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AttestedCredentialData :: forall (raw :: Bool).
AAGUID
-> CredentialId
-> CosePublicKey
-> RawField raw
-> AttestedCredentialData 'Registration raw
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
..}

    decodeExtensions :: PartialBinaryDecoder M.AuthenticatorExtensionOutputs
    decodeExtensions :: StateT ByteString (Either Text) 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 s. Decoder s Term)
-> PartialBinaryDecoder (ByteString, Term)
forall a.
(forall s. Decoder s a) -> PartialBinaryDecoder (ByteString, a)
runCBOR forall s. Decoder s Term
CBOR.decodeTerm
      AuthenticatorExtensionOutputs
-> StateT ByteString (Either Text) AuthenticatorExtensionOutputs
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthenticatorExtensionOutputs :: AuthenticatorExtensionOutputs
M.AuthenticatorExtensionOutputs {}

-- | 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) <- ByteString
-> PartialBinaryDecoder (ByteString, Term)
-> Either Text (ByteString, Term)
forall a. ByteString -> PartialBinaryDecoder a -> Either Text a
runPartialBinaryDecoder ByteString
bytes ((forall s. Decoder s Term)
-> PartialBinaryDecoder (ByteString, Term)
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 -> [(Term, Term)] -> Either Text [(Term, Term)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Term, Term)]
pairs
    Term
_ -> Text -> Either Text [(Term, Term)]
forall a b. a -> Either a b
Left (Text -> Either Text [(Term, Term)])
-> Text -> Either Text [(Term, Term)]
forall a b. (a -> b) -> a -> b
$ Text
"The attestation object should be a CBOR map, but it's not: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Term -> String
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" Term -> [(Term, Term)] -> Maybe Term
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Term, Term)]
pairs, Text -> Term
CBOR.TString Text
"fmt" Term -> [(Term, Term)] -> Maybe Term
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Term, Term)]
pairs, Text -> Term
CBOR.TString Text
"attStmt" Term -> [(Term, Term)] -> Maybe Term
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 <- ByteString -> Either Text (AuthenticatorData 'Registration 'True)
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 -> Text -> Either Text (AttestationObject 'True)
forall a b. a -> Either a b
Left (Text -> Either Text (AttestationObject 'True))
-> Text -> Either Text (AttestationObject 'True)
forall a b. (a -> b) -> a -> b
$ Text
"Unknown attestation statement format: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fmt
        Just (M.SomeAttestationStatementFormat a
aoFmt) -> do
          HashMap Text Term
attStmtMap <-
            [(Text, Term)] -> HashMap Text Term
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
              ([(Text, Term)] -> HashMap Text Term)
-> Either Text [(Text, Term)] -> Either Text (HashMap Text Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Term, Term)]
-> ((Term, Term) -> Either Text (Text, Term))
-> Either Text [(Text, Term)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
                [(Term, Term)]
attStmtPairs
                ( \case
                    (CBOR.TString Text
text, Term
term) -> (Text, Term) -> Either Text (Text, Term)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
text, Term
term)
                    (Term
nonString, Term
_) -> Text -> Either Text (Text, Term)
forall a b. a -> Either a b
Left (Text -> Either Text (Text, Term))
-> Text -> Either Text (Text, Term)
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected non-string attestation statement key: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Term -> String
forall a. Show a => a -> String
show Term
nonString)
                )
          AttStmt a
aoAttStmt <- a -> HashMap Text Term -> Either Text (AttStmt a)
forall a.
AttestationStatementFormat a =>
a -> HashMap Text Term -> Either Text (AttStmt a)
M.asfDecode a
aoFmt HashMap Text Term
attStmtMap
          AttestationObject 'True -> Either Text (AttestationObject 'True)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AttestationObject :: forall (raw :: Bool) a.
AttestationStatementFormat a =>
AuthenticatorData 'Registration raw
-> a -> AttStmt a -> AttestationObject raw
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)
_ -> Text -> Either Text (AttestationObject 'True)
forall a b. a -> Either a b
Left (Text -> Either Text (AttestationObject 'True))
-> Text -> Either Text (AttestationObject 'True)
forall a b. (a -> b) -> a -> b
$ Text
"The attestation object doesn't have the expected structure of (authData: bytes, fmt: string, attStmt: map): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Term -> String
forall a. Show a => a -> String
show Term
result)

--- | [(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 :: IDL.DOMString,
    ClientDataJSON -> Text
challenge :: IDL.DOMString,
    ClientDataJSON -> Text
origin :: IDL.DOMString,
    ClientDataJSON -> Maybe Bool
crossOrigin :: Maybe IDL.Boolean
    -- TODO: We do not implement TokenBinding, see the documentation of
    -- `CollectedClientData` for more information.
    -- tokenBinding :: Maybe TokenBinding
  }
  deriving ((forall x. ClientDataJSON -> Rep ClientDataJSON x)
-> (forall x. Rep ClientDataJSON x -> ClientDataJSON)
-> Generic ClientDataJSON
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. See the Encoding module instead
instance Aeson.FromJSON ClientDataJSON where
  parseJSON :: Value -> Parser ClientDataJSON
parseJSON = Options -> Value -> Parser ClientDataJSON
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
Aeson.genericParseJSON Options
jsonEncodingOptions

-- | 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 :: 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
..} <-
    (String -> Text)
-> Either String ClientDataJSON -> Either Text ClientDataJSON
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"Collected client data JSON decoding error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) (Either String ClientDataJSON -> Either Text ClientDataJSON)
-> Either String ClientDataJSON -> Either Text ClientDataJSON
forall a b. (a -> b) -> a -> b
$
      ByteString -> Either String ClientDataJSON
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict ByteString
bytes
  -- [(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 <-
    (String -> Text)
-> Either String ByteString -> Either Text ByteString
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (((Text
"Failed to base64url-decode challenge " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
challenge Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) (Either String ByteString -> Either Text ByteString)
-> Either String ByteString -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$
      ByteString -> Either String ByteString
Base64Url.decode (Text -> ByteString
Text.encodeUtf8 Text
challenge)
  -- [(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 SingI c => Sing c
forall k (a :: k). SingI a => Sing a
sing @c of
        Sing c
K.SRegistration -> Text
"webauthn.create"
        Sing c
K.SAuthentication -> Text
"webauthn.get"
  Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
littype Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expectedType) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$
    Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$
      Text
"Expected collected client data to have webauthn type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
expectedType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but it is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
littype
  CollectedClientData c 'True
-> Either Text (CollectedClientData c 'True)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    CollectedClientData :: forall (c :: CeremonyKind) (raw :: Bool).
Challenge
-> Origin -> Bool -> RawField raw -> CollectedClientData c raw
M.CollectedClientData
      { ccdChallenge :: Challenge
ccdChallenge = ByteString -> Challenge
M.Challenge ByteString
challenge,
        ccdOrigin :: Origin
ccdOrigin = Text -> Origin
M.Origin Text
origin,
        ccdCrossOrigin :: Bool
ccdCrossOrigin = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
crossOrigin,
        ccdRawData :: RawField 'True
ccdRawData = ByteString -> RawField 'True
M.WithRaw ByteString
bytes
      }