{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}

-- | Stability: experimental
-- This module implements assertion of the received authenticator response.
-- See the WebAuthn
-- [specification](https://www.w3.org/TR/webauthn-2/#sctn-verifying-assertion)
-- for the algorithm implemented in this module.
-- Assertion is typically represented as a "login" or "authentication" action
-- in the front-end.
-- [Section 7 of the specification](https://www.w3.org/TR/webauthn-2/#sctn-rp-operations)
-- describes when the relying party must perform assertion. Another relevant
-- section is
-- [Section 1.3.3](https://www.w3.org/TR/webauthn-2/#sctn-sample-authentication)
-- which is a high level overview of the authentication procedure.
module Crypto.WebAuthn.Operation.Authentication
  ( verifyAuthenticationResponse,
    AuthenticationError (..),
    AuthenticationResult (..),
    SignatureCounterResult (..),
  )
where

import qualified Codec.CBOR.Read as CBOR
import Codec.Serialise (decode)
import Control.Exception (Exception)
import Control.Monad (unless)
import qualified Crypto.Hash as Hash
import qualified Crypto.WebAuthn.Cose.Internal.Verify as Cose
import Crypto.WebAuthn.Internal.Utils (failure)
import qualified Crypto.WebAuthn.Model as M
import Crypto.WebAuthn.Operation.CredentialEntry (CredentialEntry (cePublicKeyBytes, ceSignCounter, ceUserHandle))
import Data.ByteArray (convert)
import qualified Data.ByteString.Lazy as LBS
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Validation (Validation)

-- | Errors that may occur during [assertion](https://www.w3.org/TR/webauthn-2/#sctn-verifying-assertion)
data AuthenticationError
  = -- | The provided Credential was not one explicitly allowed by the server
    AuthenticationCredentialDisallowed
      { -- | The credentials allowed by the server
        AuthenticationError -> [CredentialDescriptor]
aeAllowedCredentials :: [M.CredentialDescriptor],
        -- | The credential returned by the client
        AuthenticationError -> Credential 'Authentication 'True
aeReceivedCredential :: M.Credential 'M.Authentication 'True
      }
  | -- | The received credential does not match the currently identified user
    AuthenticationIdentifiedUserHandleMismatch
      { -- | The `M.UserHandle` of the user who is attempting authentication
        AuthenticationError -> UserHandle
aeIdentifiedUser :: M.UserHandle,
        -- | The owner of the credential passed to the
        -- `verifyAuthenticationResponse` function (retrieved from the
        -- database)
        AuthenticationError -> UserHandle
aeRegisteredUser :: M.UserHandle
      }
  | -- | The stored credential does not match the user specified in the
    -- response
    AuthenticationCredentialUserHandleMismatch
      { -- | The `M.UserHandle` of the user who is attempting authentication
        aeIdentifiedUser :: M.UserHandle,
        -- | The `M.UserHandle` reported by the authenticator in the response
        AuthenticationError -> UserHandle
aeAuthenticatorUser :: M.UserHandle
      }
  | -- | No user was identified and the response did not specify a user
    AuthenticationCannotVerifyUserHandle
  | -- | The received challenge does not match the originally created
    -- challenge
    AuthenticationChallengeMismatch
      { -- | The challenge created by the relying party and part of the
        -- `M.CredentialOptions`
        AuthenticationError -> Challenge
aeCreatedChallenge :: M.Challenge,
        -- | The challenge received from the client, part of the response
        AuthenticationError -> Challenge
aeReceivedChallenge :: M.Challenge
      }
  | -- | The origin derived by the client does match the assumed origin
    AuthenticationOriginMismatch
      { -- | The origin explicitly passed to the `verifyAuthenticationResponse`
        -- response, set by the RP
        AuthenticationError -> Origin
aeExpectedOrigin :: M.Origin,
        -- | The origin received from the client as part of the client data
        AuthenticationError -> Origin
aeReceivedOrigin :: M.Origin
      }
  | -- | The rpIdHash in the authData is not a valid hash over the RpId
    -- expected by the Relying party
    AuthenticationRpIdHashMismatch
      { -- | The RP ID hash explicitly passed to the
        -- `verifyAuthenticationResponse` response, set by the RP
        AuthenticationError -> RpIdHash
aeExpectedRpIdHash :: M.RpIdHash,
        -- | The RP ID hash received from the client as part of the authenticator
        -- data
        AuthenticationError -> RpIdHash
aeReceivedRpIdHash :: M.RpIdHash
      }
  | -- | The UserPresent bit was not set in the authData
    AuthenticationUserNotPresent
  | -- | The UserVerified bit was not set in the authData while user
    -- verification was required
    AuthenticationUserNotVerified
  | -- | The public key provided in the 'CredentialEntry' could not be decoded
    AuthenticationSignatureDecodingError CBOR.DeserialiseFailure
  | -- | The public key doesn't verify the signature over the authData
    AuthenticationSignatureInvalid Text
  deriving (Int -> AuthenticationError -> ShowS
[AuthenticationError] -> ShowS
AuthenticationError -> String
(Int -> AuthenticationError -> ShowS)
-> (AuthenticationError -> String)
-> ([AuthenticationError] -> ShowS)
-> Show AuthenticationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthenticationError] -> ShowS
$cshowList :: [AuthenticationError] -> ShowS
show :: AuthenticationError -> String
$cshow :: AuthenticationError -> String
showsPrec :: Int -> AuthenticationError -> ShowS
$cshowsPrec :: Int -> AuthenticationError -> ShowS
Show, Show AuthenticationError
Typeable AuthenticationError
Typeable AuthenticationError
-> Show AuthenticationError
-> (AuthenticationError -> SomeException)
-> (SomeException -> Maybe AuthenticationError)
-> (AuthenticationError -> String)
-> Exception AuthenticationError
SomeException -> Maybe AuthenticationError
AuthenticationError -> String
AuthenticationError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: AuthenticationError -> String
$cdisplayException :: AuthenticationError -> String
fromException :: SomeException -> Maybe AuthenticationError
$cfromException :: SomeException -> Maybe AuthenticationError
toException :: AuthenticationError -> SomeException
$ctoException :: AuthenticationError -> SomeException
Exception)

-- | [Section 6.1.1 of the specification](https://www.w3.org/TR/webauthn-2/#sctn-sign-counter)
-- describes the use of the signature counter, and describes what the relying
-- part must do with them. In particular:
--
-- The [signature counter](https://www.w3.org/TR/webauthn-2/#signature-counter)
-- 's purpose is to aid
-- [Relying Parties](https://www.w3.org/TR/webauthn-2/#relying-party) in
-- detecting cloned authenticators. Clone detection is more important for
-- authenticators with limited protection measures.
--
-- A [Relying Party](https://www.w3.org/TR/webauthn-2/#relying-party) stores
-- the [signature counter](https://www.w3.org/TR/webauthn-2/#signature-counter)
-- of the most recent
-- [authenticatorGetAssertion](https://www.w3.org/TR/webauthn-2/#authenticatorgetassertion)
-- operation. (Or the counter from the
-- [authenticatorMakeCredential](https://www.w3.org/TR/webauthn-2/#authenticatormakecredential)
-- operation if no
-- [authenticatorGetAssertion](https://www.w3.org/TR/webauthn-2/#authenticatorgetassertion)
-- has ever been performed on a credential.) In subsequent
-- [authenticatorGetAssertion](https://www.w3.org/TR/webauthn-2/#authenticatorgetassertion)
-- operations, the
-- [Relying Party](https://www.w3.org/TR/webauthn-2/#relying-party) compares
-- the stored
-- [signature counter](https://www.w3.org/TR/webauthn-2/#signature-counter)
-- value with the new
-- `[signCount](https://www.w3.org/TR/webauthn-2/#signcount)` value returned in
-- the assertion’s
-- [authenticator data](https://www.w3.org/TR/webauthn-2/#authenticator-data).
-- If either is non-zero, and the new
-- `[signCount](https://www.w3.org/TR/webauthn-2/#signcount)` value is less
-- than or equal to the stored value, a cloned authenticator may exist, or the
-- authenticator may be malfunctioning.
data SignatureCounterResult
  = -- | There is no signature counter being used, the database entry doesn't
    -- need to be updated, but we also have no guarantees about the
    -- authenticator not being cloned
    SignatureCounterZero
  | -- | The signature counter needs to be updated in the database
    SignatureCounterUpdated M.SignatureCounter
  | -- | The signature counter decreased, the authenticator was potentially
    -- cloned and the relying party may want to e.g. lock this credential
    SignatureCounterPotentiallyCloned
  deriving (SignatureCounterResult -> SignatureCounterResult -> Bool
(SignatureCounterResult -> SignatureCounterResult -> Bool)
-> (SignatureCounterResult -> SignatureCounterResult -> Bool)
-> Eq SignatureCounterResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SignatureCounterResult -> SignatureCounterResult -> Bool
$c/= :: SignatureCounterResult -> SignatureCounterResult -> Bool
== :: SignatureCounterResult -> SignatureCounterResult -> Bool
$c== :: SignatureCounterResult -> SignatureCounterResult -> Bool
Eq, Int -> SignatureCounterResult -> ShowS
[SignatureCounterResult] -> ShowS
SignatureCounterResult -> String
(Int -> SignatureCounterResult -> ShowS)
-> (SignatureCounterResult -> String)
-> ([SignatureCounterResult] -> ShowS)
-> Show SignatureCounterResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SignatureCounterResult] -> ShowS
$cshowList :: [SignatureCounterResult] -> ShowS
show :: SignatureCounterResult -> String
$cshow :: SignatureCounterResult -> String
showsPrec :: Int -> SignatureCounterResult -> ShowS
$cshowsPrec :: Int -> SignatureCounterResult -> ShowS
Show)

-- | A successful result of 'verifyAuthenticationResponse', it should be inspected by the Relying Party to enforce its policy regarding logins.
newtype AuthenticationResult = AuthenticationResult
  { -- | How the signature counter of the credential changed compared to the
    -- existing database entry
    AuthenticationResult -> SignatureCounterResult
arSignatureCounterResult :: SignatureCounterResult
  }
  deriving (AuthenticationResult -> AuthenticationResult -> Bool
(AuthenticationResult -> AuthenticationResult -> Bool)
-> (AuthenticationResult -> AuthenticationResult -> Bool)
-> Eq AuthenticationResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthenticationResult -> AuthenticationResult -> Bool
$c/= :: AuthenticationResult -> AuthenticationResult -> Bool
== :: AuthenticationResult -> AuthenticationResult -> Bool
$c== :: AuthenticationResult -> AuthenticationResult -> Bool
Eq, Int -> AuthenticationResult -> ShowS
[AuthenticationResult] -> ShowS
AuthenticationResult -> String
(Int -> AuthenticationResult -> ShowS)
-> (AuthenticationResult -> String)
-> ([AuthenticationResult] -> ShowS)
-> Show AuthenticationResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthenticationResult] -> ShowS
$cshowList :: [AuthenticationResult] -> ShowS
show :: AuthenticationResult -> String
$cshow :: AuthenticationResult -> String
showsPrec :: Int -> AuthenticationResult -> ShowS
$cshowsPrec :: Int -> AuthenticationResult -> ShowS
Show)

-- | [(spec)](https://www.w3.org/TR/webauthn-2/#sctn-verifying-assertion)
-- Verifies a 'M.Credential' response for an [authentication ceremony](https://www.w3.org/TR/webauthn-2/#authentication).
-- The 'arSignatureCounterResult' field of the result should be inspected to
-- enforce Relying Party policy regarding potentially cloned authenticators.
verifyAuthenticationResponse ::
  -- | The origin of the server
  M.Origin ->
  -- | The hash of the relying party id
  M.RpIdHash ->
  -- | The user handle, in case the user is identified already
  -- TODO: Mention that this would be empty for username-less authentication
  Maybe M.UserHandle ->
  -- | The database entry for the credential, as created in the initial
  -- attestation and optionally updated in subsequent assertions
  CredentialEntry ->
  -- | The options that were passed to the get() method
  M.CredentialOptions 'M.Authentication ->
  -- | The credential returned from get()
  M.Credential 'M.Authentication 'True ->
  -- | Either a non-empty list of validation errors in case of the assertion
  -- being invalid
  -- Or in case of success a signature counter result, which should be dealt
  -- with
  Validation (NonEmpty AuthenticationError) AuthenticationResult
verifyAuthenticationResponse :: Origin
-> RpIdHash
-> Maybe UserHandle
-> CredentialEntry
-> CredentialOptions 'Authentication
-> Credential 'Authentication 'True
-> Validation (NonEmpty AuthenticationError) AuthenticationResult
verifyAuthenticationResponse Origin
origin RpIdHash
rpIdHash Maybe UserHandle
midentifiedUser CredentialEntry
entry CredentialOptions 'Authentication
options Credential 'Authentication 'True
credential = do
  -- 1. Let options be a new PublicKeyCredentialRequestOptions structure
  -- configured to the Relying Party's needs for the ceremony.
  -- NOTE: Implemented by caller
  -- If options.allowCredentials is present, the transports member of each
  -- item SHOULD be set to the value returned by
  -- credential.response.getTransports() when the corresponding credential was
  -- registered.
  -- TODO: The transports property is currently not propagated by webauthn-json.
  -- see: <https://github.com/github/webauthn-json/pull/44>

  -- 2. Call navigator.credentials.get() and pass options as the publicKey
  -- option. Let credential be the result of the successfully resolved promise.
  -- If the promise is rejected, abort the ceremony with a user-visible error,
  -- or otherwise guide the user experience as might be determinable from the
  -- context available in the rejected promise. For information on different
  -- error contexts and the circumstances leading to them, see § 6.3.3 The
  -- authenticatorGetAssertion Operation.
  -- NOTE: Implemented by caller

  -- 3. Let response be credential.response. If response is not an instance of
  -- AuthenticatorAssertionResponse, abort the ceremony with a user-visible
  -- error.
  -- NOTE: Already done as part of decoding
  let response :: AuthenticatorResponse 'Authentication 'True
response = Credential 'Authentication 'True
-> AuthenticatorResponse 'Authentication 'True
forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> AuthenticatorResponse c raw
M.cResponse Credential 'Authentication 'True
credential

  -- 4. Let clientExtensionResults be the result of calling credential.getClientExtensionResults().
  -- TODO: Extensions are not implemented by this library, see the TODO in the
  -- module documentation of `Crypto.WebAuthn.Model` for more information.

  -- 5. If options.allowCredentials is not empty, verify that credential.id
  -- identifies one of the public key credentials listed in
  -- options.allowCredentials.
  let allowCredentials :: [CredentialDescriptor]
allowCredentials = CredentialOptions 'Authentication -> [CredentialDescriptor]
M.coaAllowCredentials CredentialOptions 'Authentication
options
  Bool
-> Validation (NonEmpty AuthenticationError) ()
-> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    ([CredentialDescriptor] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CredentialDescriptor]
allowCredentials Bool -> Bool -> Bool
|| Credential 'Authentication 'True -> CredentialId
forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> CredentialId
M.cIdentifier Credential 'Authentication 'True
credential CredentialId -> [CredentialId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (CredentialDescriptor -> CredentialId)
-> [CredentialDescriptor] -> [CredentialId]
forall a b. (a -> b) -> [a] -> [b]
map CredentialDescriptor -> CredentialId
M.cdId [CredentialDescriptor]
allowCredentials)
    (Validation (NonEmpty AuthenticationError) ()
 -> Validation (NonEmpty AuthenticationError) ())
-> (AuthenticationError
    -> Validation (NonEmpty AuthenticationError) ())
-> AuthenticationError
-> Validation (NonEmpty AuthenticationError) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure
    (AuthenticationError
 -> Validation (NonEmpty AuthenticationError) ())
-> AuthenticationError
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$ [CredentialDescriptor]
-> Credential 'Authentication 'True -> AuthenticationError
AuthenticationCredentialDisallowed [CredentialDescriptor]
allowCredentials Credential 'Authentication 'True
credential

  -- 6. Identify the user being authenticated and verify that this user is the
  -- owner of the public key credential source credentialSource identified by
  -- credential.id:
  --
  -- -> If the user was identified before the authentication ceremony was
  -- initiated, e.g., via a username or cookie, verify that the identified
  -- user is the owner of credentialSource. If response.userHandle is present,
  -- let userHandle be its value. Verify that userHandle also maps to the same
  -- user.
  --
  -- -> If the user was not identified before the authentication ceremony was
  -- initiated, verify that response.userHandle is present, and that the user
  -- identified by this value is the owner of credentialSource.
  let owner :: UserHandle
owner = CredentialEntry -> UserHandle
ceUserHandle CredentialEntry
entry
  
  -- According to the [(spec)](https://www.w3.org/TR/webauthn-2/#dom-publickeycredentialuserentity-id)
  -- The user handle MUST NOT be empty, though it MAY be null.
  -- For clarification see https://github.com/w3c/webauthn/issues/1722
  -- However, Safari returns an empty string instead of null, see the bug report:
  -- https://bugs.webkit.org/show_bug.cgi?id=239737
  let mUserHandler :: Maybe UserHandle
mUserHandler = case AuthenticatorResponse 'Authentication 'True -> Maybe UserHandle
forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw -> Maybe UserHandle
M.araUserHandle AuthenticatorResponse 'Authentication 'True
response of
        Just (M.UserHandle ByteString
"") -> Maybe UserHandle
forall a. Maybe a
Nothing
        Maybe UserHandle
userHandle -> Maybe UserHandle
userHandle

  case (Maybe UserHandle
midentifiedUser, Maybe UserHandle
mUserHandler) of
    (Just UserHandle
identifiedUser, Just UserHandle
userHandle)
      | UserHandle
identifiedUser UserHandle -> UserHandle -> Bool
forall a. Eq a => a -> a -> Bool
/= UserHandle
owner ->
        AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (AuthenticationError
 -> Validation (NonEmpty AuthenticationError) ())
-> AuthenticationError
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$ UserHandle -> UserHandle -> AuthenticationError
AuthenticationIdentifiedUserHandleMismatch UserHandle
identifiedUser UserHandle
owner
      | UserHandle
userHandle UserHandle -> UserHandle -> Bool
forall a. Eq a => a -> a -> Bool
/= UserHandle
owner ->
        AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (AuthenticationError
 -> Validation (NonEmpty AuthenticationError) ())
-> AuthenticationError
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$ UserHandle -> UserHandle -> AuthenticationError
AuthenticationCredentialUserHandleMismatch UserHandle
userHandle UserHandle
owner
      | Bool
otherwise -> () -> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (Just UserHandle
identifiedUser, Maybe UserHandle
Nothing)
      | UserHandle
identifiedUser UserHandle -> UserHandle -> Bool
forall a. Eq a => a -> a -> Bool
/= UserHandle
owner ->
        AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (AuthenticationError
 -> Validation (NonEmpty AuthenticationError) ())
-> AuthenticationError
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$ UserHandle -> UserHandle -> AuthenticationError
AuthenticationIdentifiedUserHandleMismatch UserHandle
identifiedUser UserHandle
owner
      | Bool
otherwise -> () -> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (Maybe UserHandle
Nothing, Just UserHandle
userHandle)
      | UserHandle
userHandle UserHandle -> UserHandle -> Bool
forall a. Eq a => a -> a -> Bool
/= UserHandle
owner ->
        AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (AuthenticationError
 -> Validation (NonEmpty AuthenticationError) ())
-> AuthenticationError
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$ UserHandle -> UserHandle -> AuthenticationError
AuthenticationCredentialUserHandleMismatch UserHandle
userHandle UserHandle
owner
      | Bool
otherwise -> () -> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (Maybe UserHandle
Nothing, Maybe UserHandle
Nothing) ->
      AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure AuthenticationError
AuthenticationCannotVerifyUserHandle

  -- 7. Using credential.id (or credential.rawId, if base64url encoding is
  -- inappropriate for your use case), look up the corresponding credential
  -- public key and let credentialPublicKey be that credential public key.
  -- NOTE: Done by the caller, passed with entry

  -- 8. Let cData, authData and sig denote the value of response’s
  -- clientDataJSON, authenticatorData, and signature respectively.
  let M.AuthenticatorResponseAuthentication
        { araClientData :: forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw
-> CollectedClientData 'Authentication raw
M.araClientData = CollectedClientData 'Authentication 'True
c,
          araAuthenticatorData :: forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw
-> AuthenticatorData 'Authentication raw
M.araAuthenticatorData = authData :: AuthenticatorData 'Authentication 'True
authData@M.AuthenticatorData {adRawData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RawField raw
M.adRawData = M.WithRaw ByteString
rawData},
          araSignature :: forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw -> AssertionSignature
M.araSignature = AssertionSignature
sig
        } = AuthenticatorResponse 'Authentication 'True
response

  -- 9. Let JSONtext be the result of running UTF-8 decode on the value of
  -- cData.
  -- NOTE: Done as part of decoding

  -- 10. Let C, the client data claimed as used for the signature, be the
  -- result of running an implementation-specific JSON parser on JSONtext.
  -- NOTE: Done as part of decoding

  -- 11. Verify that the value of C.type is the string webauthn.get.
  -- NOTE: Done as part of decoding

  -- 12. Verify that the value of C.challenge equals the base64url encoding of options.challenge.
  Bool
-> Validation (NonEmpty AuthenticationError) ()
-> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CollectedClientData 'Authentication 'True -> Challenge
forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Challenge
M.ccdChallenge CollectedClientData 'Authentication 'True
c Challenge -> Challenge -> Bool
forall a. Eq a => a -> a -> Bool
== CredentialOptions 'Authentication -> Challenge
M.coaChallenge CredentialOptions 'Authentication
options) (Validation (NonEmpty AuthenticationError) ()
 -> Validation (NonEmpty AuthenticationError) ())
-> Validation (NonEmpty AuthenticationError) ()
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$
    AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (AuthenticationError
 -> Validation (NonEmpty AuthenticationError) ())
-> AuthenticationError
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$ Challenge -> Challenge -> AuthenticationError
AuthenticationChallengeMismatch (CredentialOptions 'Authentication -> Challenge
M.coaChallenge CredentialOptions 'Authentication
options) (CollectedClientData 'Authentication 'True -> Challenge
forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Challenge
M.ccdChallenge CollectedClientData 'Authentication 'True
c)

  -- 13. Verify that the value of C.origin matches the Relying Party's origin.
  Bool
-> Validation (NonEmpty AuthenticationError) ()
-> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CollectedClientData 'Authentication 'True -> Origin
forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Origin
M.ccdOrigin CollectedClientData 'Authentication 'True
c Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
origin) (Validation (NonEmpty AuthenticationError) ()
 -> Validation (NonEmpty AuthenticationError) ())
-> Validation (NonEmpty AuthenticationError) ()
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$
    AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (AuthenticationError
 -> Validation (NonEmpty AuthenticationError) ())
-> AuthenticationError
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$ Origin -> Origin -> AuthenticationError
AuthenticationOriginMismatch Origin
origin (CollectedClientData 'Authentication 'True -> Origin
forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Origin
M.ccdOrigin CollectedClientData 'Authentication 'True
c)

  -- 14. Verify that the value of C.tokenBinding.status matches the state of
  -- Token Binding for the TLS connection over which the attestation was
  -- obtained. If Token Binding was used on that TLS connection, also verify
  -- that C.tokenBinding.id matches the base64url encoding of the Token
  -- Binding ID for the connection.
  -- TODO: We do not implement TokenBinding, see the documentation of
  -- `CollectedClientData` for more information.

  -- 15. Verify that the rpIdHash in authData is the SHA-256 hash of the RP ID
  -- expected by the Relying Party.
  -- Note: If using the appid extension, this step needs some special logic.
  -- See § 10.1 FIDO AppID Extension (appid) for details.
  Bool
-> Validation (NonEmpty AuthenticationError) ()
-> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AuthenticatorData 'Authentication 'True -> RpIdHash
forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
M.adRpIdHash AuthenticatorData 'Authentication 'True
authData RpIdHash -> RpIdHash -> Bool
forall a. Eq a => a -> a -> Bool
== RpIdHash
rpIdHash) (Validation (NonEmpty AuthenticationError) ()
 -> Validation (NonEmpty AuthenticationError) ())
-> Validation (NonEmpty AuthenticationError) ()
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$
    AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (AuthenticationError
 -> Validation (NonEmpty AuthenticationError) ())
-> AuthenticationError
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$ RpIdHash -> RpIdHash -> AuthenticationError
AuthenticationRpIdHashMismatch RpIdHash
rpIdHash (AuthenticatorData 'Authentication 'True -> RpIdHash
forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
M.adRpIdHash AuthenticatorData 'Authentication 'True
authData)

  -- 16. Verify that the User Present bit of the flags in authData is set.
  Bool
-> Validation (NonEmpty AuthenticationError) ()
-> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AuthenticatorDataFlags -> Bool
M.adfUserPresent (AuthenticatorData 'Authentication 'True -> AuthenticatorDataFlags
forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
M.adFlags AuthenticatorData 'Authentication 'True
authData)) (Validation (NonEmpty AuthenticationError) ()
 -> Validation (NonEmpty AuthenticationError) ())
-> Validation (NonEmpty AuthenticationError) ()
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$
    AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure AuthenticationError
AuthenticationUserNotPresent

  -- 17. If user verification is required for this assertion, verify that the
  -- User Verified bit of the flags in authData is set.
  -- NOTE: The spec is interpreted to mean that the userVerification option
  -- being set to "required" is what is meant by whether user verification is
  -- required
  case ( CredentialOptions 'Authentication -> UserVerificationRequirement
M.coaUserVerification CredentialOptions 'Authentication
options,
         AuthenticatorDataFlags -> Bool
M.adfUserVerified (AuthenticatorData 'Authentication 'True -> AuthenticatorDataFlags
forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
M.adFlags AuthenticatorData 'Authentication 'True
authData)
       ) of
    (UserVerificationRequirement
M.UserVerificationRequirementRequired, Bool
True) -> () -> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (UserVerificationRequirement
M.UserVerificationRequirementRequired, Bool
False) -> AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure AuthenticationError
AuthenticationUserNotVerified
    (UserVerificationRequirement
M.UserVerificationRequirementPreferred, Bool
True) -> () -> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (UserVerificationRequirement
M.UserVerificationRequirementPreferred, Bool
False) -> () -> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (UserVerificationRequirement
M.UserVerificationRequirementDiscouraged, Bool
True) -> () -> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (UserVerificationRequirement
M.UserVerificationRequirementDiscouraged, Bool
False) -> () -> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- 18. Verify that the values of the client extension outputs in
  -- clientExtensionResults and the authenticator extension outputs in the
  -- extensions in authData are as expected, considering the client extension
  -- input values that were given in options.extensions and any specific policy
  -- of the Relying Party regarding unsolicited extensions, i.e., those that
  -- were not specified as part of options.extensions. In the general case,
  -- the meaning of "are as expected" is specific to the Relying Party and
  -- which extensions are in use.
  -- TODO: Extensions are not implemented by this library, see the TODO in the
  -- module documentation of `Crypto.WebAuthn.Model` for more information.

  -- 19. Let hash be the result of computing a hash over the cData using SHA-256.
  -- NOTE: Done on raw data from decoding so that we don't need to encode again
  -- here and so that we use the exact some serialization
  let hash :: ClientDataHash
hash = Digest SHA256 -> ClientDataHash
M.ClientDataHash (Digest SHA256 -> ClientDataHash)
-> Digest SHA256 -> ClientDataHash
forall a b. (a -> b) -> a -> b
$ ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash (ByteString -> Digest SHA256) -> ByteString -> Digest SHA256
forall a b. (a -> b) -> a -> b
$ RawField 'True -> ByteString
M.unRaw (RawField 'True -> ByteString) -> RawField 'True -> ByteString
forall a b. (a -> b) -> a -> b
$ CollectedClientData 'Authentication 'True -> RawField 'True
forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> RawField raw
M.ccdRawData CollectedClientData 'Authentication 'True
c

  -- 20. Using credentialPublicKey, verify that sig is a valid signature over
  -- the binary concatenation of authData and hash.
  let pubKeyBytes :: ByteString
pubKeyBytes = ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ PublicKeyBytes -> ByteString
M.unPublicKeyBytes (PublicKeyBytes -> ByteString) -> PublicKeyBytes -> ByteString
forall a b. (a -> b) -> a -> b
$ CredentialEntry -> PublicKeyBytes
cePublicKeyBytes CredentialEntry
entry
      message :: ByteString
message = ByteString
rawData ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (ClientDataHash -> Digest SHA256
M.unClientDataHash ClientDataHash
hash)
  case (forall s. Decoder s PublicKeyWithSignAlg)
-> ByteString
-> Either DeserialiseFailure (ByteString, PublicKeyWithSignAlg)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes forall s. Decoder s PublicKeyWithSignAlg
forall a s. Serialise a => Decoder s a
decode ByteString
pubKeyBytes of
    Left DeserialiseFailure
err -> AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (AuthenticationError
 -> Validation (NonEmpty AuthenticationError) ())
-> AuthenticationError
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$ DeserialiseFailure -> AuthenticationError
AuthenticationSignatureDecodingError DeserialiseFailure
err
    Right (ByteString
_, PublicKeyWithSignAlg
coseKey) ->
      case PublicKeyWithSignAlg -> ByteString -> ByteString -> Either Text ()
Cose.verify PublicKeyWithSignAlg
coseKey ByteString
message (AssertionSignature -> ByteString
M.unAssertionSignature AssertionSignature
sig) of
        Right () -> () -> Validation (NonEmpty AuthenticationError) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Left Text
err -> AuthenticationError -> Validation (NonEmpty AuthenticationError) ()
forall e a. e -> Validation (NonEmpty e) a
failure (AuthenticationError
 -> Validation (NonEmpty AuthenticationError) ())
-> AuthenticationError
-> Validation (NonEmpty AuthenticationError) ()
forall a b. (a -> b) -> a -> b
$ Text -> AuthenticationError
AuthenticationSignatureInvalid Text
err

  -- 21. Let storedSignCount be the stored signature counter value associated
  -- with credential.id. If authData.signCount is nonzero or storedSignCount
  -- is nonzero, then run the following sub-step:
  -- - If authData.signCount is
  --   -> greater than storedSignCount:
  --      Update storedSignCount to be the value of authData.signCount.
  --   -> less than or equal to storedSignCount:
  --      This is a signal that the authenticator may be cloned, i.e. at least
  --      two copies of the credential private key may exist and are being
  --      used in parallel. Relying Parties should incorporate this information
  --      into their risk scoring. Whether the Relying Party updates
  --      storedSignCount in this case, or not, or fails the authentication
  --      ceremony or not, is Relying Party-specific.
  SignatureCounterResult
signCountResult <- case (AuthenticatorData 'Authentication 'True -> SignatureCounter
forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> SignatureCounter
M.adSignCount AuthenticatorData 'Authentication 'True
authData, CredentialEntry -> SignatureCounter
ceSignCounter CredentialEntry
entry) of
    (SignatureCounter
0, SignatureCounter
0) -> SignatureCounterResult
-> Validation (NonEmpty AuthenticationError) SignatureCounterResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure SignatureCounterResult
SignatureCounterZero
    (SignatureCounter
returned, SignatureCounter
stored)
      | SignatureCounter
returned SignatureCounter -> SignatureCounter -> Bool
forall a. Ord a => a -> a -> Bool
> SignatureCounter
stored -> SignatureCounterResult
-> Validation (NonEmpty AuthenticationError) SignatureCounterResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignatureCounterResult
 -> Validation
      (NonEmpty AuthenticationError) SignatureCounterResult)
-> SignatureCounterResult
-> Validation (NonEmpty AuthenticationError) SignatureCounterResult
forall a b. (a -> b) -> a -> b
$ SignatureCounter -> SignatureCounterResult
SignatureCounterUpdated SignatureCounter
returned
      | Bool
otherwise -> SignatureCounterResult
-> Validation (NonEmpty AuthenticationError) SignatureCounterResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure SignatureCounterResult
SignatureCounterPotentiallyCloned

  -- 22. If all the above steps are successful, continue with the
  -- authentication ceremony as appropriate. Otherwise, fail the
  -- authentication ceremony.
  pure $
    AuthenticationResult :: SignatureCounterResult -> AuthenticationResult
AuthenticationResult
      { arSignatureCounterResult :: SignatureCounterResult
arSignatureCounterResult = SignatureCounterResult
signCountResult
      }