PublicKeyCredentialCreationOptions for device registration

src/Web/WebAuthn.hs

@@ -55,6 +55,7 @@ import Control.Monad.Trans.Except (runExceptT, ExceptT(..), throwE)
 import Data.Text (pack)
 import qualified Data.X509.CertificateStore as X509
 import Data.Bifunctor (first)
+import Data.Text.Encoding (encodeUtf8)
 
 generateChallenge :: Int -> IO Challenge
 generateChallenge len = Challenge <$> getRandomBytes len
@@ -130,7 +131,7 @@ registerCredential :: MonadIO m => X509.CertificateStore
   -> ByteString -- ^ clientDataJSON
   -> ByteString -- ^ attestationObject
   -> m (Either VerificationFailure CredentialData)
-registerCredential cs challenge RelyingParty{..} tbi verificationRequired clientDataJSON attestationObjectBS = runExceptT $ do
+registerCredential cs challenge (RelyingParty rpOrigin rpId _ _) tbi verificationRequired clientDataJSON attestationObjectBS = runExceptT $ do
   _ <- hoistEither runAttestationCheck
   attestationObject <- hoistEither $ either (Left . CBORDecodeError "registerCredential") (pure . snd)
         $ CBOR.deserialiseFromBytes decodeAttestation
@@ -167,7 +168,7 @@ registerCredential cs challenge RelyingParty{..} tbi verificationRequired client
             | otherwise -> Left MismatchedTokenBinding
     extractAuthData attestationObject = do
       ad <- either (const $ Left MalformedAuthenticatorData) pure $ C.runGet parseAuthenticatorData (authData attestationObject)
-      hash rpId == rpIdHash ad ?? MismatchedRPID
+      hash (encodeUtf8 rpId) == rpIdHash ad ?? MismatchedRPID
       userPresent ad ?? UserNotPresent
       not verificationRequired || userVerified ad ?? UserUnverified
       pure ad
@@ -208,7 +209,7 @@ verifyClientTokenBinding _ _ = pure ()
 verifyAuthenticatorData :: RelyingParty -> ByteString -> Bool -> Either VerificationFailure AuthenticatorData
 verifyAuthenticatorData rp adRaw verificationRequired = do
   ad <- first (const MalformedAuthenticatorData) (C.runGet parseAuthenticatorData adRaw)
-  hash (rpId (rp :: RelyingParty)) == rpIdHash ad ?? MismatchedRPID
+  hash (encodeUtf8 $ rpId (rp :: RelyingParty)) == rpIdHash ad ?? MismatchedRPID
   userPresent ad ?? UserNotPresent
   not verificationRequired || userVerified ad ?? UserUnverified
   pure ad

src/Web/WebAuthn/AndroidSafetyNet.hs

@@ -35,18 +35,18 @@ decode :: CBOR.Term -> CBOR.Decoder s StmtSafetyNet
 decode (CBOR.TMap xs) = do
   let m = Map.fromList xs
   let CBOR.TBytes response = fromMaybe (CBOR.TString "response") (Map.lookup (CBOR.TString "response") m)
-  case (B.split (fromIntegral . ord $ '.') response) of 
+  case B.split (fromIntegral . ord $ '.') response of 
     (h : p : s : _) -> StmtSafetyNet (Base64ByteString h) (Base64ByteString p) (Base64URL.decodeLenient s) <$> getCertificateChain h
-    _ -> fail ("decodeSafetyNet: response was not a JWT")
+    _ -> fail "decodeSafetyNet: response was not a JWT"
 decode _ = fail "decodeSafetyNet: expected a Map"
 
 getCertificateChain :: MonadFail m => ByteString -> m X509.CertificateChain
 getCertificateChain h = do
   let bs = BL.fromStrict $ Base64URL.decodeLenient h
-  case (J.eitherDecode bs) of
-    Left e -> fail ("android-safetynet: Response header decode failed: " <> (show e))
+  case J.eitherDecode bs of
+    Left e -> fail ("android-safetynet: Response header decode failed: " <> show e)
     Right jth -> do
-      if (alg jth) /= "RS256" then fail ("android-safetynet: Unknown signature alg " <> (show $ alg jth)) else do
+      if alg (jth ::JWTHeader) /= "RS256" then fail ("android-safetynet: Unknown signature alg " <> show (alg (jth :: JWTHeader))) else do
         let x5cbs = Base64.decodeLenient . encodeUtf8 <$> x5c jth
         case X509.decodeCertificateChain (X509.CertificateChainRaw x5cbs) of
           Left e -> fail ("Certificate chain decode failed: " <> show e)
@@ -62,12 +62,12 @@ verify cs sf authDataRaw clientDataHash = do
   let dat = authDataRaw <> BA.convert clientDataHash
   as <- extractAndroidSafetyNet
   let nonceCheck = Base64.encode (BA.convert (hash dat :: Digest SHA256))
-  if nonceCheck /= (BL.toStrict $ BL.pack (nonce as)) then throwE NonceCheckFailure else pure ()
+  if nonceCheck /= BL.toStrict (BL.pack (nonce as)) then throwE NonceCheckFailure else pure ()
   where
     extractAndroidSafetyNet = ExceptT $ pure $ first JSONDecodeError 
       $ J.eitherDecode (BL.fromStrict . Base64URL.decodeLenient . unBase64ByteString $ payload sf)
     verifyJWS = do
-      let dat = (unBase64ByteString $ header sf) <> "." <> (unBase64ByteString $ payload sf)
+      let dat = unBase64ByteString (header sf) <> "." <> unBase64ByteString (payload sf)
       res <- liftIO $ X509.validateDefault cs (X509.exceptionValidationCache []) ("attest.android.com", "") (certificates sf)
       case res of
         [] -> pure ()

src/Web/WebAuthn/Types.hs

@@ -30,6 +30,12 @@ module Web.WebAuthn.Types (
   , PublicKeyCredentialDescriptor(..)
   , AuthenticatorTransport(..)
   , PublicKeyCredentialType(..)
+  , PublicKeyCredentialCreationOptions(..)
+  , PubKeyCredParam (..)
+  , Attestation (..)
+  , Extensions (..)
+  , AuthenticatorSelection (..)
+  , PubKeyCredAlg (..)
   ) where
 
 import Prelude hiding (fail)
@@ -42,9 +48,13 @@ import Data.Aeson as J
       constructorTagModifier,
       FromJSON(..),
       ToJSON(..),
-      Options(..) )
+      Options(..)
+      , genericToEncoding
+      , defaultOptions
+      , object
+      , (.=)
+    )
 import Data.ByteString (ByteString)
-import qualified Data.ByteString as B
 import qualified Data.ByteString.Base64.URL as Base64
 import Data.ByteString.Base16 as Base16 (decodeLenient, encode )
 import qualified Data.Hashable as H
@@ -61,18 +71,20 @@ 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 (typeMismatch)
-import Data.Aeson (genericToEncoding, defaultOptions)
-import Data.Char ( toLower )
+import Data.Aeson.Types (Pair, typeMismatch)
+import Data.Char ( toLower, toUpper )
+import Data.ByteArray (ByteArrayAccess)
+import Data.Aeson (SumEncoding(UntaggedValue))
+import Data.List.NonEmpty
 
-newtype Base64ByteString = Base64ByteString { unBase64ByteString :: ByteString } deriving (Generic, Show, Eq)
+newtype Base64ByteString = Base64ByteString { unBase64ByteString :: ByteString } deriving (Generic, Show, Eq, ByteArrayAccess)
 
 instance ToJSON Base64ByteString where
   toJSON (Base64ByteString bs) = String $ decodeUtf8 $ Base64.encode bs
 
 instance FromJSON Base64ByteString where
   parseJSON s@(String v) = do
-    eth <- pure $ Base64.decode (encodeUtf8 v)
+    let eth = Base64.decode (encodeUtf8 v)
     case eth of
       Left err -> typeMismatch ("Base64: " <> err) s
       Right str -> pure (Base64ByteString str)
@@ -129,19 +141,29 @@ data Origin = Origin
 instance ToJSON Origin where
   toJSON origin = String (originScheme origin <> "://" <> originHost origin <> (port $ originPort origin))
     where
-      port (Just int) = ":" <> (T.pack $ show int)
+      port (Just int) = ":" <> T.pack (show int)
       port Nothing = ""
 
 data RelyingParty = RelyingParty
   { rpOrigin :: Origin
-  , rpId :: ByteString
-  , rpAllowSelfAttestation :: Bool
-  , rpAllowNoAttestation :: Bool
+  , rpId :: Text
+  , icon :: Maybe Base64ByteString
+  , name :: Maybe Base64ByteString
   }
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Generic)
+
+instance ToJSON RelyingParty where
+  toJSON rpo = object (["id" .= toJSON (rpId (rpo :: RelyingParty))] 
+    <> maybeToPair "icon" (icon rpo)
+    <> maybeToPair "name" (name (rpo :: RelyingParty)))
+
+maybeToPair :: Text -> Maybe Base64ByteString -> [Pair]
+maybeToPair _ Nothing = []
+maybeToPair lbl (Just bs) = [lbl .= toJSON bs]
+
 
 defaultRelyingParty :: Origin -> RelyingParty
-defaultRelyingParty orig = RelyingParty orig (encodeUtf8 $ originHost orig) False False
+defaultRelyingParty orig = RelyingParty orig (originHost orig) Nothing Nothing
 
 instance FromJSON Origin where
   parseJSON = withText "Origin" $ \str -> case T.break (==':') str of
@@ -198,20 +220,31 @@ instance J.FromJSON CredentialData
 instance J.ToJSON CredentialData
 
 data User = User
-  { userId :: B.ByteString
-  , userName :: T.Text
-  , userDisplayName :: T.Text
+  { id :: Base64ByteString
+  , name :: Maybe T.Text
+  , displayName :: Maybe T.Text
   } deriving (Generic, Show, Eq)
 
+instance ToJSON User where
+  toEncoding = genericToEncoding defaultOptions { omitNothingFields = True}
+
 instance CBOR.Serialise User where
   encode (User i n d) = CBOR.encode $ Map.fromList
-    [("id" :: Text, CBOR.TBytes i), ("name", CBOR.TString n), ("displayName", CBOR.TString d)]
+    ([("id" :: Text, CBOR.TBytes (unBase64ByteString i))] <> maybeToCBORString "name" n <> maybeToCBORString "displayName" d)
   decode = do
     m <- CBOR.decode
     CBOR.TBytes i <- maybe (fail "id") pure $ Map.lookup ("id" :: Text) m
-    CBOR.TString n <- maybe (fail "name") pure $ Map.lookup "name" m
-    CBOR.TString d <- maybe (fail "displayName") pure $ Map.lookup "displayName" m
-    return $ User i n d
+    let mayn = Map.lookup "name" m
+    let mayd = Map.lookup "displayName" m
+    return $ User (Base64ByteString i) (maybeCBORTStringToText mayn) (maybeCBORTStringToText mayd)
+
+maybeCBORTStringToText :: Maybe CBOR.Term -> Maybe Text
+maybeCBORTStringToText (Just (CBOR.TString txt)) = Just txt
+maybeCBORTStringToText _ = Nothing
+
+maybeToCBORString :: Text -> Maybe Text -> [(Text, CBOR.Term)]
+maybeToCBORString _ Nothing = []
+maybeToCBORString lbl (Just txt) = [(lbl, CBOR.TString txt)]
 
 data VerificationFailure
   = InvalidType
@@ -259,7 +292,6 @@ data JWTHeader = JWTHeader {
 
 instance FromJSON JWTHeader
 
-
 data PublicKeyCredentialType = PublicKey deriving (Eq, Show)
 
 instance ToJSON PublicKeyCredentialType where
@@ -272,12 +304,12 @@ data AuthenticatorTransport = USB -- usb
   deriving (Eq, Show, Generic)
 
 instance ToJSON AuthenticatorTransport where
-  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = fmap toLower }
+  toEncoding = genericToEncoding defaultOptions { sumEncoding = UntaggedValue, constructorTagModifier = fmap toLower }
 
 data PublicKeyCredentialDescriptor = PublicKeyCredentialDescriptor {
   tipe :: PublicKeyCredentialType
   , id :: Base64ByteString
-  , transports :: [AuthenticatorTransport]
+  , transports :: Maybe (NonEmpty AuthenticatorTransport)
 } deriving (Eq, Show, Generic)
 
 instance ToJSON PublicKeyCredentialDescriptor where
@@ -286,12 +318,98 @@ instance ToJSON PublicKeyCredentialDescriptor where
 mapTipe :: String -> String
 mapTipe str = if str == "tipe" then "type" else str 
 
+data UserVerification = Required | Preferred | Discouraged deriving (Show, Eq, Generic)
+
+instance ToJSON UserVerification where
+  toEncoding = genericToEncoding defaultOptions { sumEncoding = UntaggedValue, constructorTagModifier = fmap toLower }
+
 data PublicKeyCredentialRequestOptions =  PublicKeyCredentialRequestOptions {
   challenge :: Base64ByteString
   , timeout :: Maybe Integer
   , rpId :: Maybe Text
-  , allowCredentials :: Maybe PublicKeyCredentialDescriptor
+  , 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)
 
 instance ToJSON PublicKeyCredentialRequestOptions where
-  toEncoding = genericToEncoding defaultOptions { omitNothingFields = True}
+  toEncoding = genericToEncoding defaultOptions { omitNothingFields = True}
+
+data PubKeyCredAlg = ES256 -- -7 
+  | RS256 -- (-257) 
+  | PS256 -- (-37)
+  deriving (Show, Eq)
+
+instance ToJSON PubKeyCredAlg where
+  toJSON ES256 = Number (-7)
+  toJSON RS256 = Number (-257)
+  toJSON PS256 = Number (-37)
+
+data PubKeyCredParam = PubKeyCredParam {
+  tipe :: PublicKeyCredentialType
+  , alg :: PubKeyCredAlg
+} deriving (Show, Eq, Generic)
+
+instance ToJSON PubKeyCredParam where
+  toEncoding = genericToEncoding defaultOptions { omitNothingFields = True, fieldLabelModifier = mapTipe}
+
+data Attestation = None | Direct | Indirect deriving (Eq, Show, Generic)
+
+instance ToJSON Attestation where
+  toEncoding = genericToEncoding defaultOptions { sumEncoding = UntaggedValue, constructorTagModifier = fmap  toLower }
+
+newtype AuthnSel = AuthnSel [Base64ByteString] deriving (Show, Eq, Generic)
+
+instance ToJSON AuthnSel where
+  toEncoding = genericToEncoding defaultOptions { unwrapUnaryRecords = True }
+
+data BiometricPerfBounds = BiometricPerfBounds {
+  far :: Double
+  , frr :: Double
+} deriving (Show, Eq, Generic)
+
+instance ToJSON BiometricPerfBounds where
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = fmap toUpper }
+
+data Extensions = Extensions {
+  uvi :: Bool
+  , loc :: Bool
+  , uvm :: Bool
+  , exts :: Bool
+  , authnSel :: Maybe AuthnSel
+  , biometricPerfBounds :: Maybe BiometricPerfBounds
+} deriving (Show, Eq, Generic)
+
+instance ToJSON Extensions where
+  toEncoding = genericToEncoding defaultOptions { omitNothingFields = True }
+
+data AuthenticatorAttachment = Platform | CrossPlatform deriving (Eq, Show)
+
+instance ToJSON AuthenticatorAttachment where
+  toJSON Platform = String "platform"
+  toJSON CrossPlatform = String "cross-platform" 
+
+data AuthenticatorSelection = AuthenticatorSelection {
+  authenticatorAttachment :: Maybe AuthenticatorAttachment
+  , requireResidentKey :: Maybe Bool
+  , userVerification :: Maybe UserVerification
+} deriving (Show, Eq, Generic)
+
+instance ToJSON AuthenticatorSelection where
+  toEncoding = genericToEncoding 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 }
+