{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
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)
data AuthenticationError
=
AuthenticationCredentialDisallowed
{
AuthenticationError -> [CredentialDescriptor]
aeAllowedCredentials :: [M.CredentialDescriptor],
AuthenticationError -> Credential 'Authentication 'True
aeReceivedCredential :: M.Credential 'M.Authentication 'True
}
|
AuthenticationIdentifiedUserHandleMismatch
{
AuthenticationError -> UserHandle
aeIdentifiedUser :: M.UserHandle,
AuthenticationError -> UserHandle
aeRegisteredUser :: M.UserHandle
}
|
AuthenticationCredentialUserHandleMismatch
{
aeIdentifiedUser :: M.UserHandle,
AuthenticationError -> UserHandle
aeAuthenticatorUser :: M.UserHandle
}
|
AuthenticationCannotVerifyUserHandle
|
AuthenticationChallengeMismatch
{
AuthenticationError -> Challenge
aeCreatedChallenge :: M.Challenge,
AuthenticationError -> Challenge
aeReceivedChallenge :: M.Challenge
}
|
AuthenticationOriginMismatch
{
AuthenticationError -> Origin
aeExpectedOrigin :: M.Origin,
AuthenticationError -> Origin
aeReceivedOrigin :: M.Origin
}
|
AuthenticationRpIdHashMismatch
{
AuthenticationError -> RpIdHash
aeExpectedRpIdHash :: M.RpIdHash,
AuthenticationError -> RpIdHash
aeReceivedRpIdHash :: M.RpIdHash
}
|
AuthenticationUserNotPresent
|
AuthenticationUserNotVerified
|
AuthenticationSignatureDecodingError CBOR.DeserialiseFailure
|
AuthenticationSignatureInvalid Text
deriving (Int -> AuthenticationError -> ShowS
[AuthenticationError] -> ShowS
AuthenticationError -> String
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
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)
data SignatureCounterResult
=
SignatureCounterZero
|
SignatureCounterUpdated M.SignatureCounter
|
SignatureCounterPotentiallyCloned
deriving (SignatureCounterResult -> SignatureCounterResult -> Bool
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
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)
newtype AuthenticationResult = AuthenticationResult
{
AuthenticationResult -> SignatureCounterResult
arSignatureCounterResult :: SignatureCounterResult
}
deriving (AuthenticationResult -> AuthenticationResult -> Bool
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
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)
verifyAuthenticationResponse ::
M.Origin ->
M.RpIdHash ->
Maybe M.UserHandle ->
CredentialEntry ->
M.CredentialOptions 'M.Authentication ->
M.Credential 'M.Authentication 'True ->
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
let response :: AuthenticatorResponse 'Authentication 'True
response = forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> AuthenticatorResponse c raw
M.cResponse Credential 'Authentication 'True
credential
let allowCredentials :: [CredentialDescriptor]
allowCredentials = CredentialOptions 'Authentication -> [CredentialDescriptor]
M.coaAllowCredentials CredentialOptions 'Authentication
options
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
(forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CredentialDescriptor]
allowCredentials Bool -> Bool -> Bool
|| forall (c :: CeremonyKind) (raw :: Bool).
Credential c raw -> CredentialId
M.cIdentifier Credential 'Authentication 'True
credential forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map CredentialDescriptor -> CredentialId
M.cdId [CredentialDescriptor]
allowCredentials)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. e -> Validation (NonEmpty e) a
failure
forall a b. (a -> b) -> a -> b
$ [CredentialDescriptor]
-> Credential 'Authentication 'True -> AuthenticationError
AuthenticationCredentialDisallowed [CredentialDescriptor]
allowCredentials Credential 'Authentication 'True
credential
let owner :: UserHandle
owner = CredentialEntry -> UserHandle
ceUserHandle CredentialEntry
entry
let mUserHandler :: Maybe UserHandle
mUserHandler = case forall (raw :: Bool).
AuthenticatorResponse 'Authentication raw -> Maybe UserHandle
M.araUserHandle AuthenticatorResponse 'Authentication 'True
response of
Just (M.UserHandle ByteString
"") -> 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 forall a. Eq a => a -> a -> Bool
/= UserHandle
owner ->
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ UserHandle -> UserHandle -> AuthenticationError
AuthenticationIdentifiedUserHandleMismatch UserHandle
identifiedUser UserHandle
owner
| UserHandle
userHandle forall a. Eq a => a -> a -> Bool
/= UserHandle
owner ->
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ UserHandle -> UserHandle -> AuthenticationError
AuthenticationCredentialUserHandleMismatch UserHandle
userHandle UserHandle
owner
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just UserHandle
identifiedUser, Maybe UserHandle
Nothing)
| UserHandle
identifiedUser forall a. Eq a => a -> a -> Bool
/= UserHandle
owner ->
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ UserHandle -> UserHandle -> AuthenticationError
AuthenticationIdentifiedUserHandleMismatch UserHandle
identifiedUser UserHandle
owner
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Maybe UserHandle
Nothing, Just UserHandle
userHandle)
| UserHandle
userHandle forall a. Eq a => a -> a -> Bool
/= UserHandle
owner ->
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ UserHandle -> UserHandle -> AuthenticationError
AuthenticationCredentialUserHandleMismatch UserHandle
userHandle UserHandle
owner
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Maybe UserHandle
Nothing, Maybe UserHandle
Nothing) ->
forall e a. e -> Validation (NonEmpty e) a
failure AuthenticationError
AuthenticationCannotVerifyUserHandle
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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Challenge
M.ccdChallenge CollectedClientData 'Authentication 'True
c forall a. Eq a => a -> a -> Bool
== CredentialOptions 'Authentication -> Challenge
M.coaChallenge CredentialOptions 'Authentication
options) forall a b. (a -> b) -> a -> b
$
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$
Challenge -> Challenge -> AuthenticationError
AuthenticationChallengeMismatch (CredentialOptions 'Authentication -> Challenge
M.coaChallenge CredentialOptions 'Authentication
options) (forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Challenge
M.ccdChallenge CollectedClientData 'Authentication 'True
c)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Origin
M.ccdOrigin CollectedClientData 'Authentication 'True
c forall a. Eq a => a -> a -> Bool
== Origin
origin) forall a b. (a -> b) -> a -> b
$
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$
Origin -> Origin -> AuthenticationError
AuthenticationOriginMismatch Origin
origin (forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> Origin
M.ccdOrigin CollectedClientData 'Authentication 'True
c)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
M.adRpIdHash AuthenticatorData 'Authentication 'True
authData forall a. Eq a => a -> a -> Bool
== RpIdHash
rpIdHash) forall a b. (a -> b) -> a -> b
$
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$
RpIdHash -> RpIdHash -> AuthenticationError
AuthenticationRpIdHashMismatch RpIdHash
rpIdHash (forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RpIdHash
M.adRpIdHash AuthenticatorData 'Authentication 'True
authData)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AuthenticatorDataFlags -> Bool
M.adfUserPresent (forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
M.adFlags AuthenticatorData 'Authentication 'True
authData)) forall a b. (a -> b) -> a -> b
$
forall e a. e -> Validation (NonEmpty e) a
failure AuthenticationError
AuthenticationUserNotPresent
case ( CredentialOptions 'Authentication -> UserVerificationRequirement
M.coaUserVerification CredentialOptions 'Authentication
options,
AuthenticatorDataFlags -> Bool
M.adfUserVerified (forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AuthenticatorDataFlags
M.adFlags AuthenticatorData 'Authentication 'True
authData)
) of
(UserVerificationRequirement
M.UserVerificationRequirementRequired, Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(UserVerificationRequirement
M.UserVerificationRequirementRequired, Bool
False) -> forall e a. e -> Validation (NonEmpty e) a
failure AuthenticationError
AuthenticationUserNotVerified
(UserVerificationRequirement
M.UserVerificationRequirementPreferred, Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(UserVerificationRequirement
M.UserVerificationRequirementPreferred, Bool
False) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(UserVerificationRequirement
M.UserVerificationRequirementDiscouraged, Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(UserVerificationRequirement
M.UserVerificationRequirementDiscouraged, Bool
False) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let hash :: ClientDataHash
hash = Digest SHA256 -> ClientDataHash
M.ClientDataHash forall a b. (a -> b) -> a -> b
$ forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash forall a b. (a -> b) -> a -> b
$ RawField 'True -> ByteString
M.unRaw forall a b. (a -> b) -> a -> b
$ forall (c :: CeremonyKind) (raw :: Bool).
CollectedClientData c raw -> RawField raw
M.ccdRawData CollectedClientData 'Authentication 'True
c
let pubKeyBytes :: ByteString
pubKeyBytes = ByteString -> ByteString
LBS.fromStrict forall a b. (a -> b) -> a -> b
$ PublicKeyBytes -> ByteString
M.unPublicKeyBytes forall a b. (a -> b) -> a -> b
$ CredentialEntry -> PublicKeyBytes
cePublicKeyBytes CredentialEntry
entry
message :: ByteString
message = ByteString
rawData forall a. Semigroup a => a -> a -> a
<> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (ClientDataHash -> Digest SHA256
M.unClientDataHash ClientDataHash
hash)
case forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes forall a s. Serialise a => Decoder s a
decode ByteString
pubKeyBytes of
Left DeserialiseFailure
err -> forall e a. e -> Validation (NonEmpty e) a
failure 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 () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Left Text
err -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ Text -> AuthenticationError
AuthenticationSignatureInvalid Text
err
SignatureCounterResult
signCountResult <- case (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) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SignatureCounterResult
SignatureCounterZero
(SignatureCounter
returned, SignatureCounter
stored)
| SignatureCounter
returned forall a. Ord a => a -> a -> Bool
> SignatureCounter
stored -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SignatureCounter -> SignatureCounterResult
SignatureCounterUpdated SignatureCounter
returned
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SignatureCounterResult
SignatureCounterPotentiallyCloned
pure $
AuthenticationResult
{ arSignatureCounterResult :: SignatureCounterResult
arSignatureCounterResult = SignatureCounterResult
signCountResult
}