webauthn 0.5.0.1 → 0.6.0.0

raw patch · 8 files changed

+53/−24 lines, 8 filesdep +thesedep ~validationnew-uploader

Dependencies added: these

Dependency ranges changed: validation

Files

• changelog.md +5/−0
• src/Crypto/WebAuthn/Metadata.hs +8/−7
• src/Crypto/WebAuthn/Metadata/Service/Decode.hs +11/−6
• src/Crypto/WebAuthn/Metadata/Service/Processing.hs +5/−5
• tests/Emulation.hs +2/−1
• tests/Main.hs +6/−1
• tests/MetadataSpec.hs +12/−2
• webauthn.cabal +4/−2

@@ -1,3 +1,8 @@+### 0.6.0.0++* [#162](https://github.com/tweag/webauthn/pull/162) Enable MDS blob parsing to handle invalid entries without completely failing to parse+* [#163](https://github.com/tweag/webauthn/pull/163) Fix build with mtl-2.3+ ### 0.5.0.1  * [#159](https://github.com/tweag/webauthn/pull/159) Allow mtl-2.3.1 and support GHC 9.4

@@ -11,10 +11,13 @@  import qualified Crypto.WebAuthn.Metadata.Service.Processing as Service import qualified Crypto.WebAuthn.Metadata.Service.Types as Service+import Data.Bifunctor (Bifunctor (second), first) import qualified Data.ByteString as BS import qualified Data.Hourglass as HG+import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text as Text+import Data.These (These)  -- | Verifies, decodes and extracts a 'Service.MetadataServiceRegistry' from a -- [FIDO Alliance Metadata Service](https://fidoalliance.org/metadata/) BLOB.@@ -24,11 +27,9 @@   BS.ByteString ->   -- | The time at which it was fetched   HG.DateTime ->-  -- | Either an error on a registry of metadata entries-  Either Text Service.MetadataServiceRegistry+  -- | Either a certifcate error or a list of errors, a registry of metadata entries or both where the MDS has bad entries+  Either Text (These (NE.NonEmpty Text) Service.MetadataServiceRegistry) metadataBlobToRegistry bytes now = do-  json <- case Service.jwtToJson bytes Service.fidoAllianceRootCertificate now of-    Left err -> Left $ Text.pack $ show err-    Right res -> pure res-  payload <- Service.jsonToPayload json-  pure $ Service.createMetadataRegistry $ Service.mpEntries payload+  json <- first (Text.pack . show) (Service.jwtToJson bytes Service.fidoAllianceRootCertificate now)+  let payload = Service.jsonToPayload json+  pure $ second (Service.createMetadataRegistry . Service.mpEntries) payload

@@ -15,26 +15,31 @@ import Crypto.WebAuthn.Metadata.Statement.Decode (decodeAAGUID, decodeCertificate, decodeMetadataStatement, decodeSubjectKeyIdentifier) import qualified Crypto.WebAuthn.Metadata.WebIDL as IDL import Data.Bifunctor (first)+import Data.Either (lefts, rights) import Data.Hourglass (Date, DateTime (dtDate), ISO8601_Date (ISO8601_Date), timeParse)-import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Maybe (mapMaybe) import Data.Text (Text) import qualified Data.Text as Text+import Data.These (These (That, These, This))  -- | Decodes a 'ServiceTypes.MetadataPayload' from a 'ServiceIDL.MetadataBLOBPayload', -- discarding any 'ServiceIDL.MetadataBLOBPayloadEntry' that are not relevant to webauthn. -- This includes entries of the protocol family 'StatementIDL.ProtocolFamilyUAF' -- and entries whose 'StatementIDL.attestationTypes' doesn't include either -- 'Registry.ATTESTATION_BASIC_FULL' or 'Registry.ATTESTATION_ATTCA'-decodeMetadataPayload :: ServiceIDL.MetadataBLOBPayload -> Either Text ServiceTypes.MetadataPayload+decodeMetadataPayload :: ServiceIDL.MetadataBLOBPayload -> These (NE.NonEmpty Text) ServiceTypes.MetadataPayload decodeMetadataPayload ServiceIDL.MetadataBLOBPayload {..} = do   let mpLegalHeader = legalHeader       mpNo = no-  mpNextUpdate <- decodeDate nextUpdate-  decodedEntries <- sequence $ mapMaybe decodeMetadataEntry entries+  mpNextUpdate <- either (This . NE.singleton) That $ decodeDate nextUpdate+  let errorOrEntries = mapMaybe decodeMetadataEntry entries+  let errors = lefts errorOrEntries+  let decodedEntries = rights errorOrEntries   let mpEntries = foldMap NE.toList decodedEntries-  pure ServiceTypes.MetadataPayload {..}+  case NE.nonEmpty errors of+    Nothing -> That (ServiceTypes.MetadataPayload {..})+    Just a -> These a (ServiceTypes.MetadataPayload {..})  liftEitherMaybe :: Either (Maybe a) b -> Maybe (Either a b) liftEitherMaybe (Left Nothing) = Nothing@@ -47,7 +52,7 @@ -- (i.e. UAF authenticators or FIDO2 authenticators that only support basic -- surrogate attestation), then this function returns 'Nothing'. If an error -- occured during decoding, 'Left' is returned.-decodeMetadataEntry :: ServiceIDL.MetadataBLOBPayloadEntry -> Maybe (Either Text (NonEmpty ServiceTypes.SomeMetadataEntry))+decodeMetadataEntry :: ServiceIDL.MetadataBLOBPayloadEntry -> Maybe (Either Text (NE.NonEmpty ServiceTypes.SomeMetadataEntry)) decodeMetadataEntry ServiceIDL.MetadataBLOBPayloadEntry {..} = liftEitherMaybe $   case (aaid, aaguid, attestationCertificateKeyIdentifiers) of     (Just _aaid, Nothing, Nothing) ->

@@ -60,9 +60,11 @@ import Data.HashMap.Strict (HashMap, (!?)) import qualified Data.HashMap.Strict as HashMap import Data.Hourglass (DateTime)+import Data.List.NonEmpty (NonEmpty, singleton) import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text as Text+import Data.These (These (This)) import qualified Data.X509 as X509 import qualified Data.X509.CertificateStore as X509 import qualified Data.X509.Validation as X509@@ -182,12 +184,10 @@ -- relying party the `Crypto.WebAuthn.Metadata.Service.Types.mpNextUpdate` -- and `Crypto.WebAuthn.Metadata.Service.Types.mpEntries` fields are most -- important.-jsonToPayload :: HashMap Text Value -> Either Text Service.MetadataPayload+jsonToPayload :: HashMap Text Value -> These (NonEmpty Text) Service.MetadataPayload jsonToPayload value = case Aeson.parseEither metadataPayloadParser value of-  Left err -> Left $ Text.pack err-  Right payload -> case decodeMetadataPayload payload of-    Left err -> Left err-    Right result -> pure result+  Left err -> This (singleton $ Text.pack err)+  Right payload -> decodeMetadataPayload payload  metadataPayloadParser :: HashMap Text Aeson.Value -> Aeson.Parser ServiceIDL.MetadataBLOBPayload metadataPayloadParser hm = case (hm !? "legalHeader", hm !? "no", hm !? "nextUpdate", hm !? "entries") of

@@ -7,7 +7,8 @@   ) where -import Control.Monad.Except (ExceptT (ExceptT), MonadError, MonadTrans (lift), runExceptT, throwError)+import Control.Monad.Except (ExceptT (ExceptT), MonadError, runExceptT, throwError)+import Control.Monad.Trans (MonadTrans (lift)) import Crypto.Hash (hash) import qualified Crypto.Random as Random import qualified Crypto.WebAuthn.Cose.SignAlg as Cose

@@ -24,9 +24,12 @@ import Data.Either (isRight) import Data.Foldable (for_) import qualified Data.Hourglass as HG+import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8)+import Data.These (These (That, These, This)) import Data.Validation (toEither) import qualified Emulation import qualified Encoding@@ -61,7 +64,9 @@   blobBytes <- BS.readFile "tests/golden-metadata/big/blob.jwt"   case Meta.metadataBlobToRegistry blobBytes predeterminedDateTime of     Left err -> error $ Text.unpack err-    Right res -> pure res+    Right (This err) -> error $ intercalate "," (Text.unpack <$> NE.toList err)+    Right (These err _res) -> error $ "Unexpected MDS parsing errors: " <> intercalate "," (Text.unpack <$> NE.toList err)+    Right (That res) -> pure res  -- | Given a JSON Message in a file, performs attestation. -- The Boolean argument denotes if the attestation message can be verified using the metadata service.

@@ -3,6 +3,7 @@  module MetadataSpec (spec) where +import Crypto.WebAuthn.Metadata (metadataBlobToRegistry) import Crypto.WebAuthn.Metadata.Service.Processing (RootCertificate (RootCertificate), fidoAllianceRootCertificate, jsonToPayload, jwtToJson) import Crypto.WebAuthn.Metadata.Service.WebIDL (MetadataBLOBPayload, entries, legalHeader, nextUpdate, no) import Data.Aeson (Result (Success), ToJSON (toJSON), decodeFileStrict, fromJSON)@@ -13,6 +14,7 @@ import qualified Data.PEM as PEM import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8)+import Data.These (These (That, These, This)) import qualified Data.X509 as X509 import qualified Data.X509.CertificateStore as X509 import Spec.Util (predeterminedDateTime)@@ -49,8 +51,9 @@   it "can decode and reencode the payload to the partially parsed JSON" $ do     Just value <- decodeFileStrict $ "tests/golden-metadata/" <> subdir <> "/payload.json"     case jsonToPayload value of-      Left err -> fail $ show err-      Right _result -> pure ()+      This err -> fail $ show err+      These err _result -> fail $ show err+      That _result -> pure ()  spec :: SpecWith () spec = do@@ -61,3 +64,10 @@     it "can validate the payload" $ do       blobBytes <- BS.readFile "tests/golden-metadata/big/blob.jwt"       jwtToJson blobBytes fidoAllianceRootCertificate predeterminedDateTime `shouldSatisfy` isRight+  describe "MDS with errors" $ do+    it "can process an MDS file with errors" $ do+      blobBytes <- BS.readFile "tests/golden-metadata/big/blob-with-errors.jwt"+      case metadataBlobToRegistry blobBytes predeterminedDateTime of+        Right (These _errs _res) -> pure ()+        Right _thisThat -> error "Expected parsing errors as well as registry"+        Left err -> error $ Text.unpack err

@@ -1,6 +1,6 @@ cabal-version: 2.4 name: webauthn-version: 0.5.0.1+version: 0.6.0.0 license: Apache-2.0 license-file: LICENSE copyright:@@ -96,10 +96,11 @@     serialise             >= 0.2.3 && < 0.3,     singletons            >= 2.6 && < 3.2,     text                  >= 1.2.4 && < 2.1,+    these                 >= 1.1 && < 1.2,     time                  >= 1.9.3 && < 1.12,     unordered-containers  >= 0.2.11 && < 0.3,     uuid                  >= 1.3.13 && < 1.4,-    validation            >= 1.1 && < 1.2,+    validation            >= 1.1 && < 1.3,     x509                  >= 1.7.5 && < 1.8,     x509-store            >= 1.6.7 && < 1.7,     x509-validation       >= 1.6.12 && < 1.7@@ -186,6 +187,7 @@     serialise,     singletons,     text,+    these,     unordered-containers,     uuid,     validation,