jsonschema 0.3.0.0 → 0.3.0.1
raw patch · 6 files changed
+123/−12 lines, 6 filesdep +bytestringPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−0
- jsonschema.cabal +7/−1
- src/Data/JSON/Schema.hs +3/−2
- src/JSONSchema/URIFragment.hs +71/−0
- src/JSONSchema/Validation.hs +7/−8
- test/JSONSchema/Spec.hs +29/−1
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Changelog +## 0.3.0.1+- Fix local `$ref` URI-fragment handling to follow RFC 6901: render definition+ names with JSON Pointer escaping followed by UTF-8 percent encoding, and+ percent-decode fragments as UTF-8 before resolving the JSON Pointer. Malformed+ escapes and invalid UTF-8 now fail resolution cleanly.+ ## 0.3.0.0 - Add value-directed schema construction: a structured `Schema` type (with `Field`, `AdditionalProperties`, and `SchemaDocument`) plus `schemaToValue` /
jsonschema.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: jsonschema-version: 0.3.0.0+version: 0.3.0.1 license: MPL-2.0 license-file: LICENSE author: DPella AB@@ -28,6 +28,10 @@ ghc ==9.6 ghc ==9.12 +source-repository head+ type: git+ location: https://github.com/DPella/jsonschema.git+ library default-language: Haskell2010@@ -53,11 +57,13 @@ other-modules: Data.JSON.Schema Data.JSON.ToJSONSchema+ JSONSchema.URIFragment JSONSchema.Validation build-depends: aeson >=2.2 && <2.3, base >=4.18 && <4.22,+ bytestring >=0.11 && <0.13, containers >=0.6.7 && <0.9, regex-tdfa >=1.3.2 && <1.4, scientific >=0.3.8 && <0.4,
src/Data/JSON/Schema.hs view
@@ -66,6 +66,7 @@ import Data.Aeson.KeyMap qualified as KM import Data.Text (Text) import Data.Text qualified as T+import JSONSchema.URIFragment (encodeURIFragment) {- | A value-level description of the data-shape subset of JSON Schema 2020-12 — the value-directed complement to the type-directed@@ -103,7 +104,7 @@ SAnyOf [Schema] | -- | @{"allOf": [..]}@ SAllOf [Schema]- | -- | @{"$ref": "#/$defs/<name>"}@ (the name is JSON-Pointer-escaped).+ | -- | @{"$ref": "#/$defs/<name>"}@ (the name is JSON-Pointer and URI-fragment escaped). SRef Text | -- | @{}@ (matches anything). SAny@@ -186,7 +187,7 @@ SNullable s -> object ["anyOf" .= [schemaToValue s, typed "null"]] SAnyOf ss -> object ["anyOf" .= map schemaToValue ss] SAllOf ss -> object ["allOf" .= map schemaToValue ss]- SRef name -> object ["$ref" .= ("#/$defs/" <> escapePointer name)]+ SRef name -> object ["$ref" .= ("#/$defs/" <> encodeURIFragment (escapePointer name))] SAny -> object [] SRaw v -> v where
+ src/JSONSchema/URIFragment.hs view
@@ -0,0 +1,71 @@+{- |+Module: JSONSchema.URIFragment+Copyright: (c) DPella AB 2025+License: LicenseRef-AllRightsReserved+Maintainer: <matti@dpella.io>, <lobo@dpella.io>++UTF-8 percent encoding and decoding for URI fragments.+-}+module JSONSchema.URIFragment (+ encodeURIFragment,+ decodeURIFragment,+) where++import Data.ByteString qualified as BS+import Data.Char (ord)+import Data.Text (Text)+import Data.Text.Encoding qualified as TE+import Data.Word (Word8)++-- | Percent-encode bytes that are not legal in an RFC 3986 URI fragment.+encodeURIFragment :: Text -> Text+encodeURIFragment = TE.decodeLatin1 . BS.concatMap encodeByte . TE.encodeUtf8+ where+ encodeByte byte+ | isFragmentByte byte = BS.singleton byte+ | otherwise = BS.pack [percent, hexDigit (byte `div` 16), hexDigit (byte `mod` 16)]++-- | Percent-decode a URI fragment and require the result to be valid UTF-8.+decodeURIFragment :: Text -> Maybe Text+decodeURIFragment fragment = do+ bytes <- decodeBytes (BS.unpack (TE.encodeUtf8 fragment))+ either (const Nothing) Just (TE.decodeUtf8' (BS.pack bytes))+ where+ decodeBytes [] = Just []+ decodeBytes (byte : rest)+ | byte /= percent = (byte :) <$> decodeBytes rest+ decodeBytes (_ : high : low : rest) = do+ highNibble <- hexValue high+ lowNibble <- hexValue low+ ((highNibble * 16 + lowNibble) :) <$> decodeBytes rest+ decodeBytes _ = Nothing++-- RFC 3986: fragment = *(pchar / "/" / "?").+isFragmentByte :: Word8 -> Bool+isFragmentByte byte =+ isAsciiAlphaNumeric byte+ || byte `elem` map (fromIntegral . ord) ("-._~!$&'()*+,;=:@/?" :: String)++isAsciiAlphaNumeric :: Word8 -> Bool+isAsciiAlphaNumeric byte =+ (byte >= ascii 'a' && byte <= ascii 'z')+ || (byte >= ascii 'A' && byte <= ascii 'Z')+ || (byte >= ascii '0' && byte <= ascii '9')++hexDigit :: Word8 -> Word8+hexDigit nibble+ | nibble < 10 = ascii '0' + nibble+ | otherwise = ascii 'A' + nibble - 10++hexValue :: Word8 -> Maybe Word8+hexValue byte+ | byte >= ascii '0' && byte <= ascii '9' = Just (byte - ascii '0')+ | byte >= ascii 'A' && byte <= ascii 'F' = Just (byte - ascii 'A' + 10)+ | byte >= ascii 'a' && byte <= ascii 'f' = Just (byte - ascii 'a' + 10)+ | otherwise = Nothing++ascii :: Char -> Word8+ascii = fromIntegral . ord++percent :: Word8+percent = ascii '%'
src/JSONSchema/Validation.hs view
@@ -51,6 +51,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Vector qualified as V+import JSONSchema.URIFragment (decodeURIFragment) import Text.Regex.TDFA ((=~)) import Text.Regex.TDFA.Text () @@ -687,14 +688,12 @@ resolveRef :: Value -> Text -> Maybe Value resolveRef root ref_path = case T.uncons ref_path of- Just ('#', rest) ->- -- empty fragment or pointer- if T.null rest- then Just root- else- if T.head rest == '/'- then jsonPointer root (T.tail rest)- else Nothing -- unsupported non-pointer fragment+ Just ('#', encodedFragment) -> do+ fragment <- decodeURIFragment encodedFragment+ case T.uncons fragment of+ Nothing -> Just root+ Just ('/', pointer) -> jsonPointer root pointer+ Just _ -> Nothing -- unsupported non-pointer fragment _ -> Nothing -- unsupported non-fragment refs -- | Evaluate a JSON Pointer (RFC 6901) against a JSON value.
test/JSONSchema/Spec.hs view
@@ -605,10 +605,14 @@ @?= object ["anyOf" .= [integerSchema, object ["type" .= ("boolean" :: Text)]]] , testCase "SAllOf" $ schemaToValue (SAllOf [SInteger]) @?= object ["allOf" .= [integerSchema]]- , testCase "SRef simple name" $+ , testCase "SRef ASCII name remains byte-identical" $ schemaToValue (SRef "Foo") @?= object ["$ref" .= ("#/$defs/Foo" :: Text)]+ , testCase "SRef percent-encodes Unicode as UTF-8" $+ schemaToValue (SRef "Å") @?= object ["$ref" .= ("#/$defs/%C3%85" :: Text)] , testCase "SRef escapes JSON Pointer characters" $ schemaToValue (SRef "a/b~c") @?= object ["$ref" .= ("#/$defs/a~1b~0c" :: Text)]+ , testCase "SRef pointer-escapes before UTF-8 percent encoding" $+ schemaToValue (SRef "Å/~") @?= object ["$ref" .= ("#/$defs/%C3%85~1~0" :: Text)] , testCase "SAny" $ schemaToValue SAny @?= object [] , testCase "SRaw renders the Value verbatim" $ schemaToValue (SRaw (object ["type" .= ("string" :: Text), "minLength" .= (3 :: Int)]))@@ -674,6 +678,30 @@ v = schemaDocumentToValue doc assertBool "integer valid" (validateJSONSchema v (Number 1)) assertBool "string invalid" (not (validateJSONSchema v (String "x")))+ , testCase "percent-encoded Unicode $ref resolves" $ do+ let s =+ object+ [ "$defs" .= object ["Å" .= object ["type" .= ("integer" :: Text)]]+ , "$ref" .= ("#%2F$defs%2F%C3%85" :: Text)+ ]+ assertBool "integer valid" (validateJSONSchema s (Number 1))+ assertBool "string invalid" (not (validateJSONSchema s (String "x")))+ , testCase "SchemaDocument with Unicode definition and SRef validates" $ do+ let doc = SchemaDocument [("Å", SInteger)] (SRef "Å")+ v = schemaDocumentToValue doc+ assertBool "integer valid" (validateJSONSchema v (Number 1))+ assertBool "string invalid" (not (validateJSONSchema v (String "x")))+ , testCase "malformed percent escapes fail resolution cleanly" $+ mapM_+ ( \ref -> do+ let s = object ["$defs" .= object ["x" .= object ["type" .= ("integer" :: Text)]], "$ref" .= (ref :: Text)]+ validate s (Number 1) @?= Left [ValidationError [] ("Unresolved $ref: " <> ref)]+ )+ ["#/$defs/%", "#/$defs/%GG"]+ , testCase "percent-decoded invalid UTF-8 fails resolution cleanly" $ do+ let ref = "#/$defs/%FF"+ s = object ["$defs" .= object ["x" .= object ["type" .= ("integer" :: Text)]], "$ref" .= (ref :: Text)]+ validate s (Number 1) @?= Left [ValidationError [] ("Unresolved $ref: " <> ref)] , testCase "SRaw embeds an out-of-subset keyword inside a Schema" $ do -- minLength is not in the Schema vocabulary; SRaw splices it into a field. let s =