put the pieces together

src/WebAuthn.hs

@@ -33,6 +33,7 @@ module WebAuthn (
   -- * verfication
   , VerificationFailure(..)
   , registerCredential
+  , defaultCredentialCreationOptions
   , verify
   , encodeAttestation
   ) where
@@ -61,7 +62,7 @@ import qualified WebAuthn.TPM as TPM
 import qualified WebAuthn.FIDOU2F as U2F
 import qualified WebAuthn.Packed as Packed
 import qualified WebAuthn.AndroidSafetyNet as Android
-import Control.Monad (when)
+import Control.Monad (unless)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Except (runExceptT, ExceptT(..), throwE)
 import Data.Text (pack)
@@ -140,16 +141,12 @@ encodeAttestation attestationObject = CBOR.encodeMapLen 3
       AF_None -> CBOR.encodeString "none"
 
 -- | 7.1. Registering a New Credential
-registerCredential :: MonadIO m => PublicKeyCredentialCreationOptions
-  -> X509.CertificateStore
-  -> Challenge
-  -> RelyingParty
-  -> Maybe Text -- ^ Token Binding ID in base64
-  -> Bool -- ^ require user verification?
+registerCredential :: MonadIO m => X509.CertificateStore
+  -> CredentialCreationOptions
   -> ByteString -- ^ clientDataJSON
   -> ByteString -- ^ attestationObject
   -> m (Either VerificationFailure AttestedCredentialData)
-registerCredential opts cs challenge (RelyingParty rpOrigin rpId _ _) tbi verificationRequired clientDataJSON attestationObjectBS = runExceptT $ do
+registerCredential certStore opts clientDataJSON attestationObjectBS = runExceptT $ do
   _ <- hoistEither runAttestationCheck
   attestationObject <- hoistEither $ either (Left . CBORDecodeError "registerCredential") (pure . snd)
         $ CBOR.deserialiseFromBytes decodeAttestation
@@ -162,25 +159,26 @@ registerCredential opts cs challenge (RelyingParty rpOrigin rpId _ _) tbi verifi
     AF_FIDO_U2F s -> hoistEither $ U2F.verify s ad clientDataHash
     AF_Packed s -> hoistEither $ Packed.verify s mAdPubKey ad (authData attestationObject) clientDataHash
     AF_TPM s -> hoistEither $ TPM.verify s ad (authData attestationObject) clientDataHash
-    AF_AndroidSafetyNet s -> Android.verify cs s (authData attestationObject) clientDataHash
+    AF_AndroidSafetyNet s -> Android.verify certStore s (authData attestationObject) clientDataHash
     AF_None -> pure ()
     _ -> throwE (UnsupportedAttestationFormat (pack $ show (attStmt attestationObject)))
 
   case attestedCredentialData ad of
     Nothing -> throwE MalformedAuthenticatorData
     Just c -> pure c
   where
+    RelyingParty rpOrigin rpId _ _ = ccoRelyingParty opts
     clientDataHash = hash clientDataJSON :: Digest SHA256
     runAttestationCheck = do 
       CollectedClientData{..} <- either
         (Left . JSONDecodeError) Right $ J.eitherDecode $ BL.fromStrict clientDataJSON
       clientType == Create ?? InvalidType
-      challenge == clientChallenge ?? MismatchedChallenge
-      rpOrigin == clientOrigin ?? MismatchedOrigin
+      ccoChallenge opts == clientChallenge ?? MismatchedChallenge (ccoChallenge opts) clientChallenge
+      rpOrigin == clientOrigin ?? MismatchedOrigin rpOrigin clientOrigin
       case clientTokenBinding of
         TokenBindingUnsupported -> pure ()
         TokenBindingSupported -> pure ()
-        TokenBindingPresent t -> case tbi of
+        TokenBindingPresent t -> case ccoTokenBindingID opts of
           Nothing -> Left UnexpectedPresenceOfTokenBinding
           Just t'
             | t == t' -> pure ()
@@ -189,15 +187,14 @@ registerCredential opts cs challenge (RelyingParty rpOrigin rpId _ _) tbi verifi
       ad <- either (const $ Left MalformedAuthenticatorData) pure $ C.runGet parseAuthenticatorData (authData attestationObject)
       hash (encodeUtf8 rpId) == rpIdHash ad ?? MismatchedRPID
       userPresent ad ?? UserNotPresent
-      not verificationRequired || userVerified ad ?? UserUnverified
+      not (ccoRequireUserVerification opts) || userVerified ad ?? UserUnverified
       pure ad
     verifyPubKey ad = do
       let pubKey = credentialPublicKey <$> attestedCredentialData ad
       case pubKey of
         Just k -> do
           parsedPubKey <- either throwE return $ parsePublicKey k
-          let hasProperAlg pubKeyParam = hasMatchingAlg parsedPubKey $ pkcpAlg (pubKeyParam :: PubKeyCredParam)
-          when (not . any hasProperAlg $ pubKeyCredParams opts) $ throwE MalformedAuthenticatorData
+          unless (any (hasMatchingAlg parsedPubKey) $ ccoCredParams opts) $ throwE MalformedAuthenticatorData
           return $ Just parsedPubKey
         -- non present public key will fail anyway or the fmt == 'none'
         Nothing -> return Nothing
@@ -224,8 +221,8 @@ clientDataCheck :: WebAuthnType -> Challenge -> ByteString -> RelyingParty -> Ma
 clientDataCheck ctype challenge clientDataJSON rp tbi = do 
   ccd <-  first JSONDecodeError (J.eitherDecode $ BL.fromStrict clientDataJSON)
   clientType ccd == ctype ?? InvalidType
-  challenge == clientChallenge ccd ?? MismatchedChallenge
-  rpOrigin rp == clientOrigin ccd ?? MismatchedOrigin
+  challenge == clientChallenge ccd ?? MismatchedChallenge challenge (clientChallenge ccd)
+  rpOrigin rp == clientOrigin ccd ?? MismatchedOrigin (rpOrigin rp) (clientOrigin ccd)
   verifyClientTokenBinding tbi (clientTokenBinding ccd)
 
 verifyClientTokenBinding :: Maybe Text -> TokenBinding -> Either VerificationFailure ()
@@ -239,7 +236,7 @@ verifyClientTokenBinding _ _ = pure ()
 verifyAuthenticatorData :: RelyingParty -> ByteString -> Bool -> Either VerificationFailure AuthenticatorData
 verifyAuthenticatorData rp adRaw verificationRequired = do
   ad <- first (const MalformedAuthenticatorData) (C.runGet parseAuthenticatorData adRaw)
-  hash (encodeUtf8 $ rpId (rp :: RelyingParty)) == rpIdHash ad ?? MismatchedRPID
+  hash (case rp of RelyingParty{ rpId } -> encodeUtf8 rpId) == rpIdHash ad ?? MismatchedRPID
   userPresent ad ?? UserNotPresent
   not verificationRequired || userVerified ad ?? UserUnverified
   pure ad

src/WebAuthn/Types.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE RecordWildCards #-}
 module WebAuthn.Types (
   -- * Relying party
   RelyingParty(..)
@@ -33,8 +34,8 @@ module WebAuthn.Types (
   , PublicKeyCredentialDescriptor(..)
   , AuthenticatorTransport(..)
   , PublicKeyCredentialType(..)
-  , PublicKeyCredentialCreationOptions(..)
-  , PubKeyCredParam (..)
+  , CredentialCreationOptions(..)
+  , defaultCredentialCreationOptions
   , Attestation (..)
   , Extensions (..)
   , AuthenticatorSelection (..)
@@ -64,6 +65,7 @@ import qualified Data.ByteString.Base64.URL as Base64
 import Data.ByteString.Base16 as Base16 (decodeLenient, encode )
 import qualified Data.Hashable as H
 import qualified Data.Map as Map
+import qualified Data.ByteString.Char8 as B8
 import Data.List (stripPrefix)
 import Data.Text (Text)
 import Data.Text.Encoding ( decodeUtf8, encodeUtf8 )
@@ -75,16 +77,16 @@ import qualified Codec.CBOR.Term as CBOR
 import qualified Codec.CBOR.Read as CBOR
 import qualified Codec.Serialise as CBOR
 import Control.Monad.Fail ( MonadFail(fail) )
-import GHC.Generics (Generic)
 import qualified Data.X509 as X509
 import Data.Aeson.Types (Pair, typeMismatch)
 import Data.Char ( toLower, toUpper )
 import Data.ByteArray (ByteArrayAccess)
 import Data.Aeson (SumEncoding(UntaggedValue))
-import Data.List.NonEmpty
+import Data.List.NonEmpty as NE
 import Data.Aeson (genericToJSON)
 import qualified Data.Aeson as Aeson
 import Deriving.Aeson
+import Data.String
 
 newtype Base64ByteString = Base64ByteString { unBase64ByteString :: ByteString } deriving (Generic, Show, Eq, ByteArrayAccess)
 
@@ -101,7 +103,13 @@ instance FromJSON Base64ByteString where
 
 -- | 13.1. Cryptographic Challenges
 newtype Challenge = Challenge { rawChallenge :: ByteString }
-  deriving (Show, Eq, Ord, H.Hashable, CBOR.Serialise)
+  deriving (Eq, Ord, H.Hashable, CBOR.Serialise)
+
+instance IsString Challenge where
+  fromString = Challenge . Base64.decodeLenient . B8.pack
+
+instance Show Challenge where
+  show = show . Base64.encode . rawChallenge
 
 instance ToJSON Challenge where
   toJSON = toJSON . decodeUtf8 . Base64.encode . rawChallenge
@@ -278,8 +286,8 @@ maybeToCBORString lbl (Just txt) = [(lbl, CBOR.TString txt)]
 
 data VerificationFailure
   = InvalidType
-  | MismatchedChallenge
-  | MismatchedOrigin
+  | MismatchedChallenge Challenge Challenge
+  | MismatchedOrigin Origin Origin
   | UnexpectedPresenceOfTokenBinding
   | MismatchedTokenBinding
   | JSONDecodeError String
@@ -350,14 +358,14 @@ instance ToJSON UserVerification where
   toEncoding = genericToEncoding defaultOptions { sumEncoding = UntaggedValue, constructorTagModifier = fmap toLower }
   toJSON = genericToJSON defaultOptions { sumEncoding = UntaggedValue, constructorTagModifier = fmap toLower }
 
-data PublicKeyCredentialRequestOptions =  PublicKeyCredentialRequestOptions {
-  challenge :: Base64ByteString
+data PublicKeyCredentialRequestOptions =  PublicKeyCredentialRequestOptions
+  { challenge :: Challenge
   , timeout :: Maybe Integer
   , rpId :: Maybe Text
   , allowCredentials ::Maybe (NonEmpty PublicKeyCredentialDescriptor)
   , userVerification :: Maybe UserVerification
   -- extensions omitted as support is minimal https://developer.mozilla.org/en-US/docs/Web/API/PublicKeyCredentialRequestOptions/extensions
-} deriving (Eq, Show, Generic)
+  } deriving (Eq, Show, Generic)
 
 instance ToJSON PublicKeyCredentialRequestOptions where
   toEncoding = genericToEncoding defaultOptions { omitNothingFields = True}
@@ -379,12 +387,6 @@ pubKeyCredAlgFromInt = \case -7 -> Just ES256
                              -37 -> Just PS256
                              _ -> Nothing
 
-data PubKeyCredParam = PubKeyCredParam
-  { pkcpType :: PublicKeyCredentialType
-  , pkcpAlg :: PubKeyCredAlg
-  } deriving (Show, Eq, Generic)
-  deriving ToJSON via CustomJSON '[FieldLabelModifier (StripPrefix "pkcp", CamelToSnake)] PubKeyCredParam
-
 data Attestation = None | Direct | Indirect deriving (Eq, Show, Generic)
 
 instance ToJSON Attestation where
@@ -435,19 +437,33 @@ instance ToJSON AuthenticatorSelection where
   toEncoding = genericToEncoding defaultOptions { omitNothingFields = True }
   toJSON = genericToJSON defaultOptions { omitNothingFields = True }
 
-data PublicKeyCredentialCreationOptions = PublicKeyCredentialCreationOptions {
-  rp :: RelyingParty
-  , challenge :: Base64ByteString
-  , user :: User
-  , pubKeyCredParams :: NonEmpty PubKeyCredParam
-  , timeout :: Maybe Integer
-  , attestation :: Maybe Attestation
-  , extensions :: Maybe Extensions
-  , authenticatorSelection :: Maybe AuthenticatorSelection
-  , excludeCredentials :: Maybe (NonEmpty PublicKeyCredentialDescriptor)
-} deriving (Eq, Show, Generic)
-
-instance ToJSON PublicKeyCredentialCreationOptions where
-  toEncoding = genericToEncoding defaultOptions { omitNothingFields = True }
-  toJSON = genericToJSON defaultOptions { omitNothingFields = True }
+data CredentialCreationOptions = CredentialCreationOptions
+  { ccoRelyingParty :: RelyingParty
+  , ccoChallenge :: Challenge
+  , ccoUser :: User
+  , ccoCredParams :: NonEmpty PubKeyCredAlg
+  , ccoTimeout :: Maybe Integer
+  , ccoAttestation :: Maybe Attestation
+  , ccoExtensions :: Maybe Extensions
+  , ccoAuthenticatorSelection :: Maybe AuthenticatorSelection
+  , ccoExcludeCredentials :: Maybe (NonEmpty PublicKeyCredentialDescriptor)
+  , ccoTokenBindingID :: Maybe Text
+  , ccoRequireUserVerification :: Bool
+  } deriving (Eq, Show, Generic)
 
+defaultCredentialCreationOptions
+  :: RelyingParty
+  -> Challenge
+  -> User
+  -> CredentialCreationOptions
+defaultCredentialCreationOptions ccoRelyingParty ccoChallenge ccoUser = CredentialCreationOptions
+  { ccoTimeout = Nothing
+  , ccoCredParams = ES256 NE.:| []
+  , ccoAttestation = Nothing
+  , ccoExtensions = Nothing
+  , ccoAuthenticatorSelection = Nothing
+  , ccoExcludeCredentials = Nothing
+  , ccoRequireUserVerification = False
+  , ccoTokenBindingID = Nothing
+  , ..
+  }