{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Crypto.WebAuthn.AttestationStatementFormat.FidoU2F
( format,
Format (..),
VerificationError (..),
)
where
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Term as CBOR
import Control.Exception (Exception)
import Control.Monad (unless)
import Crypto.PubKey.ECC.Types (CurveName (SEC_p256r1))
import qualified Crypto.WebAuthn.Cose.PublicKeyWithSignAlg as Cose
import Crypto.WebAuthn.Internal.Utils (failure)
import qualified Crypto.WebAuthn.Model.Types as M
import Data.Aeson (ToJSON, object, toJSON, (.=))
import Data.Bifunctor (first)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.HashMap.Strict ((!?))
import qualified Data.Text as Text
import qualified Data.X509 as X509
import qualified Data.X509.EC as X509
import qualified Data.X509.Validation as X509
data Format = Format
instance Show Format where
show :: Format -> String
show = Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AttestationStatementFormat a => a -> Text
M.asfIdentifier
data VerificationError
=
CertificatePublicKeyInvalid X509.PubKey
|
CredentialPublicKeyNotCoseEC2 Cose.CosePublicKey
|
CoordinateSizeInvalid
{
VerificationError -> Int
xLength :: Int,
VerificationError -> Int
yLength :: Int
}
|
SignatureInvalid X509.SignatureFailure
deriving (Int -> VerificationError -> ShowS
[VerificationError] -> ShowS
VerificationError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VerificationError] -> ShowS
$cshowList :: [VerificationError] -> ShowS
show :: VerificationError -> String
$cshow :: VerificationError -> String
showsPrec :: Int -> VerificationError -> ShowS
$cshowsPrec :: Int -> VerificationError -> ShowS
Show, Show VerificationError
Typeable VerificationError
SomeException -> Maybe VerificationError
VerificationError -> String
VerificationError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: VerificationError -> String
$cdisplayException :: VerificationError -> String
fromException :: SomeException -> Maybe VerificationError
$cfromException :: SomeException -> Maybe VerificationError
toException :: VerificationError -> SomeException
$ctoException :: VerificationError -> SomeException
Exception)
data Statement = Statement
{ Statement -> ByteString
sig :: BS.ByteString,
Statement -> SignedCertificate
attCert :: X509.SignedCertificate
}
deriving (Int -> Statement -> ShowS
[Statement] -> ShowS
Statement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Statement] -> ShowS
$cshowList :: [Statement] -> ShowS
show :: Statement -> String
$cshow :: Statement -> String
showsPrec :: Int -> Statement -> ShowS
$cshowsPrec :: Int -> Statement -> ShowS
Show, Statement -> Statement -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Statement -> Statement -> Bool
$c/= :: Statement -> Statement -> Bool
== :: Statement -> Statement -> Bool
$c== :: Statement -> Statement -> Bool
Eq)
instance ToJSON Statement where
toJSON :: Statement -> Value
toJSON Statement {ByteString
SignedCertificate
attCert :: SignedCertificate
sig :: ByteString
attCert :: Statement -> SignedCertificate
sig :: Statement -> ByteString
..} =
[Pair] -> Value
object
[ Key
"attestnCert" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= SignedCertificate
attCert,
Key
"sig" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString
sig
]
instance M.AttestationStatementFormat Format where
type AttStmt Format = Statement
asfIdentifier :: Format -> Text
asfIdentifier Format
_ = Text
"fido-u2f"
asfDecode :: Format -> HashMap Text Term -> Either Text (AttStmt Format)
asfDecode Format
_ HashMap Text Term
xs = case (HashMap Text Term
xs forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"sig", HashMap Text Term
xs forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
"x5c") of
(Just (CBOR.TBytes ByteString
sig), Just (CBOR.TList [CBOR.TBytes ByteString
certBytes])) -> do
SignedCertificate
attCert <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
"Failed to decode signed certificate: " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) (ByteString -> Either String SignedCertificate
X509.decodeSignedCertificate ByteString
certBytes)
pure $ ByteString -> SignedCertificate -> Statement
Statement ByteString
sig SignedCertificate
attCert
(Maybe Term, Maybe Term)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"CBOR map didn't have expected value types (sig: bytes, x5c: one-element list): " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show HashMap Text Term
xs)
asfEncode :: Format -> AttStmt Format -> Term
asfEncode Format
_ Statement {ByteString
SignedCertificate
attCert :: SignedCertificate
sig :: ByteString
attCert :: Statement -> SignedCertificate
sig :: Statement -> ByteString
..} =
[(Term, Term)] -> Term
CBOR.TMap
[ (Text -> Term
CBOR.TString Text
"sig", ByteString -> Term
CBOR.TBytes ByteString
sig),
(Text -> Term
CBOR.TString Text
"x5c", [Term] -> Term
CBOR.TList [ByteString -> Term
CBOR.TBytes forall a b. (a -> b) -> a -> b
$ forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> ByteString
X509.encodeSignedObject SignedCertificate
attCert])
]
type AttStmtVerificationError Format = VerificationError
asfVerify :: Format
-> DateTime
-> AttStmt Format
-> AuthenticatorData 'Registration 'True
-> ClientDataHash
-> Validation
(NonEmpty (AttStmtVerificationError Format)) SomeAttestationType
asfVerify
Format
_
DateTime
_
Statement {ByteString
SignedCertificate
attCert :: SignedCertificate
sig :: ByteString
attCert :: Statement -> SignedCertificate
sig :: Statement -> ByteString
..}
M.AuthenticatorData
{ adAttestedCredentialData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> AttestedCredentialData c raw
M.adAttestedCredentialData = M.AttestedCredentialData {CosePublicKey
AAGUID
CredentialId
RawField 'True
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 'True
acdCredentialPublicKey :: CosePublicKey
acdCredentialId :: CredentialId
acdAaguid :: AAGUID
..},
Maybe AuthenticatorExtensionOutputs
AuthenticatorDataFlags
SignatureCounter
RpIdHash
RawField 'True
adRawData :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> RawField raw
adExtensions :: forall (c :: CeremonyKind) (raw :: Bool).
AuthenticatorData c raw -> Maybe AuthenticatorExtensionOutputs
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 'True
adExtensions :: Maybe AuthenticatorExtensionOutputs
adSignCount :: SignatureCounter
adFlags :: AuthenticatorDataFlags
adRpIdHash :: RpIdHash
..
}
ClientDataHash
clientDataHash = do
let certPubKey :: PubKey
certPubKey = Certificate -> PubKey
X509.certPubKey forall a b. (a -> b) -> a -> b
$ SignedCertificate -> Certificate
X509.getCertificate SignedCertificate
attCert
case PubKey
certPubKey of
X509.PubKeyEC PubKeyEC
pk ->
case PubKeyEC -> Maybe CurveName
X509.ecPubKeyCurveName PubKeyEC
pk of
Just CurveName
SEC_p256r1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe CurveName
_ -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ PubKey -> VerificationError
CertificatePublicKeyInvalid PubKey
certPubKey
PubKey
_ -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ PubKey -> VerificationError
CertificatePublicKeyInvalid PubKey
certPubKey
case ByteString -> Maybe (ByteString, ByteString)
extractPublicKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawField 'True -> ByteString
M.unRaw forall a b. (a -> b) -> a -> b
$ RawField 'True
acdCredentialPublicKeyBytes of
Maybe (ByteString, ByteString)
Nothing -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ CosePublicKey -> VerificationError
CredentialPublicKeyNotCoseEC2 CosePublicKey
acdCredentialPublicKey
Just (ByteString
xb, ByteString
yb) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int
BS.length ByteString
xb forall a. Eq a => a -> a -> Bool
== Int
32 Bool -> Bool -> Bool
&& ByteString -> Int
BS.length ByteString
yb forall a. Eq a => a -> a -> Bool
== Int
32) forall a b. (a -> b) -> a -> b
$
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$
Int -> Int -> VerificationError
CoordinateSizeInvalid (ByteString -> Int
BS.length ByteString
xb) (ByteString -> Int
BS.length ByteString
yb)
let publicKeyU2F :: ByteString
publicKeyU2F = Word8 -> ByteString
BS.singleton Word8
0x04 forall a. Semigroup a => a -> a -> a
<> ByteString
xb forall a. Semigroup a => a -> a -> a
<> ByteString
yb
let credId :: ByteString
credId = CredentialId -> ByteString
M.unCredentialId CredentialId
acdCredentialId
verificationData :: ByteString
verificationData =
Word8 -> ByteString
BS.singleton Word8
0x00
forall a. Semigroup a => a -> a -> a
<> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (RpIdHash -> Digest SHA256
M.unRpIdHash RpIdHash
adRpIdHash)
forall a. Semigroup a => a -> a -> a
<> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (ClientDataHash -> Digest SHA256
M.unClientDataHash ClientDataHash
clientDataHash)
forall a. Semigroup a => a -> a -> a
<> ByteString
credId
forall a. Semigroup a => a -> a -> a
<> ByteString
publicKeyU2F
case SignatureALG
-> PubKey -> ByteString -> ByteString -> SignatureVerification
X509.verifySignature (HashALG -> PubKeyALG -> SignatureALG
X509.SignatureALG HashALG
X509.HashSHA256 PubKeyALG
X509.PubKeyALG_EC) PubKey
certPubKey ByteString
verificationData ByteString
sig of
SignatureVerification
X509.SignaturePass -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
X509.SignatureFailed SignatureFailure
e -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ SignatureFailure -> VerificationError
SignatureInvalid SignatureFailure
e
pure ()
pure $
forall (k :: AttestationKind).
AttestationType k -> SomeAttestationType
M.SomeAttestationType forall a b. (a -> b) -> a -> b
$
forall (p :: ProtocolKind).
VerifiableAttestationType
-> AttestationChain p -> AttestationType ('Verifiable p)
M.AttestationTypeVerifiable VerifiableAttestationType
M.VerifiableAttestationTypeUncertain (SignedCertificate -> AttestationChain 'FidoU2F
M.FidoU2FCert SignedCertificate
attCert)
asfTrustAnchors :: Format -> VerifiableAttestationType -> CertificateStore
asfTrustAnchors Format
_ VerifiableAttestationType
_ = forall a. Monoid a => a
mempty
format :: M.SomeAttestationStatementFormat
format :: SomeAttestationStatementFormat
format = forall a.
AttestationStatementFormat a =>
a -> SomeAttestationStatementFormat
M.SomeAttestationStatementFormat Format
Format
extractPublicKey :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)
ByteString
keyBS = do
(ByteString
rest, Term
result) <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes forall s. Decoder s Term
CBOR.decodeTerm forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
keyBS
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
LBS.null ByteString
rest) forall a. Maybe a
Nothing
[(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. Maybe a
Nothing
let xKey :: Int
xKey = -Int
2
let yKey :: Int
yKey = -Int
3
case (Int -> Term
CBOR.TInt Int
xKey forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Term, Term)]
pairs, Int -> Term
CBOR.TInt Int
yKey forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Term, Term)]
pairs) of
(Just (CBOR.TBytes ByteString
x), Just (CBOR.TBytes ByteString
y)) -> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
x, ByteString
y)
(Maybe Term, Maybe Term)
_ -> forall a. Maybe a
Nothing