Skip to content

Commit

Permalink
error
Browse files Browse the repository at this point in the history
  • Loading branch information
@frenchy64
frenchy64 committed Dec 19, 2024
1 parent 394eed5 commit 85cbfe2
Show file tree
Hide file tree
Showing 2 changed files with 116 additions and 104 deletions.
201 changes: 104 additions & 97 deletions src/flanders/json_schema.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -58,8 +58,104 @@
(defn unknown-schema! [v {::keys [path] :as opts}]
(throw (ex-info (format "Unknown JSON Schema at path %s: %s" (pr-str path) (pr-str v)) {:v v :opts (select-keys opts [::path ::base-id])})))

(defn unsupported-schema! [v {::keys [path] :as opts}]
(throw (ex-info (format "Unsupported JSON Schema at path %s: %s" (pr-str path) (pr-str v)) {:v v :opts (select-keys opts [::path ::base-id])})))
(defn unsupported-schema! [reason v {::keys [path] :as opts}]
(throw (ex-info (format "Unsupported JSON Schema at path %s: %s (%s)" (pr-str path) (pr-str v) reason)
{::unsupported true
:v v :opts (select-keys opts [::path ::base-id])})))

(defn- parse-map [v opts]
(let [{:strs [description title example
$ref $anchor $defs $dynamicAnchor $dynamicRef $id $vocabulary $schema
type] :as v}
(normalize-map v opts)
opts (update opts ::$schema #(or $schema %))
;_ (assert (= "http://json-schema.org/draft-07/schema#" (::$schema opts))
; (pr-str (::$schema opts)))
_ (assert (nil? $anchor)) ;; TODO
_ (assert (nil? $dynamicAnchor)) ;; TODO
_ (assert (nil? $dynamicRef)) ;; TODO
opts (update opts ::base-id (fn [parent-id]
;; TODO subschemas start new id https://json-schema.org/draft/2020-12/json-schema-core#section-8.2.1
;; need to reset ::path if we support this
(when (and parent-id $id)
(unsupported-schema! "Nested $id not yet supported" v opts))
(or $id parent-id
;; TODO Establishing a Base URI https://www.rfc-editor.org/rfc/rfc3986.html#section-5.1
#_(throw (ex-info "Must supply $id" {})))))
$defs (some-> $defs (normalize-map opts) not-empty)
local-defs (not-empty
(into {} (map (fn [[k v]]
(let [opts (conj-path opts "$defs" k)]
[(absolute-id opts) (->flanders v opts)])))
$defs))
base (or (when $ref
(let [this-id (resolve-id $ref opts)]
(assoc (f/ref this-id)
;;TODO rename or remove, for debugging purposes (e.g., defalias strings)
:v v)))
(when-some [disjuncts (get v "anyOf")]
(f/either :choices (into [] (map-indexed #(->flanders %2 (conj-path opts "anyOf" (str %1)))) disjuncts)))
(when-some [conjuncts (get v "allOf")]
(when-not (= 1 (count conjuncts))
(unsupported-schema! "Only a single allOf schema supported" v opts))
(->flanders (first conjuncts) (conj-path opts "allOf" "0")))
(when-some [[_ const] (find v "const")]
(f/enum [const]))
(case (some-> type (-normalize (conj-path opts "type")))
;; https://json-schema.org/understanding-json-schema/reference/numeric
;; TODO all json-schema numbers assume 1.0 and 1 are identical.
"integer" (if-some [enum (seq (get v "enum"))]
(f/enum (mapv long enum))
(f/int))
"number" (if-some [enum (seq (get v "enum"))]
(f/enum (mapv num enum))
(f/num))
"boolean" (if-some [enum (not-empty (set (get v "enum")))]
(cond
(= #{true false} enum) (f/bool)
(= #{true} enum) (f/bool :equals true)
(= #{false} enum) (f/bool :equals false)
:else (unsupported-schema! (str "Unsupported boolean enum: " (pr-str (get v "enum")))
v opts))
(f/bool))
"string" (let [{fmt "format" :strs [enum]} v]
(assert (nil? fmt) (pr-str fmt))
(if (seq enum)
(f/enum (into [] (map-indexed #(-normalize %2 (conj-path opts (str %)))) enum))
(f/str)))
"null" (unsupported-schema! "Flanders cannot check for nil" v opts)
"array" (let [{:strs [items uniqueItems]} v]
(assert (nil? uniqueItems))
(f/seq-of (->flanders items (conj-path opts "items"))))
"object" (let [properties (not-empty (into (sorted-map) (map (fn [[k v]] [(keyword k) v])) (get v "properties")))
required (not-empty (into #{} (map keyword) (get v "required")))
additionalProperties (get v "additionalProperties")]
(assert ((some-fn nil? boolean?) additionalProperties))
(when (and additionalProperties (or properties required)) ;;TODO
(unsupported-schema! "Cannot combine properties and additionalProperties" v opts))
(if properties
(f/map (mapv (fn [[k s]]
(f/entry k (->flanders s (conj-path opts (-normalize k opts))) :required? (contains? required k)))
properties))
(if additionalProperties
(f/map-of {})
(unsupported-schema! "TODO closed map" v opts))))
;; https://github.com/json-schema/json-schema/issues/172
nil f/any
(unknown-schema! v opts))
(when-some [enum (seq (get v "enum"))]
(f/enum (cond->> enum
(some (some-fn ident? string?) enum) (into [] (map #(-normalize %2 (conj-path opts (str %))))))))
(unknown-schema! v opts))]
(cond-> (assoc base ::base-id (::base-id opts))
;; TODO unit test
description (assoc :description description)
local-defs (assoc ::f/registry local-defs)
;;TODO recursive examples involving refs (currently :ref example is nil)
;example (assoc :example example)
;default (assoc :default default)
;title (assoc :title title)
)))

(defn ->flanders
"Converts parsed JSON Schema to Flanders."
Expand All @@ -68,99 +164,10 @@
(cond
(boolean? v) (if v
f/any
(unsupported-schema! v opts))
(nil? v) (unsupported-schema! v opts)
(map? v) (let [{:strs [description title example
$ref $anchor $defs $dynamicAnchor $dynamicRef $id $vocabulary $schema
type] :as v}
(normalize-map v opts)
opts (update opts ::$schema #(or $schema %))
;_ (assert (= "http://json-schema.org/draft-07/schema#" (::$schema opts))
; (pr-str (::$schema opts)))
_ (assert (nil? $anchor)) ;; TODO
_ (assert (nil? $dynamicAnchor)) ;; TODO
_ (assert (nil? $dynamicRef)) ;; TODO
opts (update opts ::base-id (fn [parent-id]
;; TODO subschemas start new id https://json-schema.org/draft/2020-12/json-schema-core#section-8.2.1
;; need to reset ::path if we support this
(when (and parent-id $id)
(throw (ex-info "Nested $id not yet supported" {})))
(or $id parent-id
;; TODO Establishing a Base URI https://www.rfc-editor.org/rfc/rfc3986.html#section-5.1
#_(throw (ex-info "Must supply $id" {})))))
$defs (some-> $defs (normalize-map opts) not-empty)
local-defs (not-empty
(into {} (map (fn [[k v]]
(let [opts (conj-path opts "$defs" k)]
[(absolute-id opts) (->flanders v opts)])))
$defs))
base (or (when $ref
(let [this-id (resolve-id $ref opts)]
(assoc (f/ref this-id)
;;TODO rename or remove, for debugging purposes (e.g., defalias strings)
:v v)))
(when-some [disjuncts (get v "anyOf")]
(f/either :choices (into [] (map-indexed #(->flanders %2 (conj-path opts "anyOf" (str %1)))) disjuncts)))
(when-some [conjuncts (get v "allOf")]
(when-not (= 1 (count conjuncts))
(throw (ex-info "Only a single allOf schema supported" {})))
(->flanders (first conjuncts) (conj-path opts "allOf" "0")))
(when-some [[_ const] (find v "const")]
(f/enum [const]))
(case (some-> type (-normalize (conj-path opts "type")))
;; https://json-schema.org/understanding-json-schema/reference/numeric
;; TODO all json-schema numbers assume 1.0 and 1 are identical.
"integer" (if-some [enum (seq (get v "enum"))]
(f/enum (mapv long enum))
(f/int))
"number" (if-some [enum (seq (get v "enum"))]
(f/enum (mapv num enum))
(f/num))
"boolean" (if-some [enum (not-empty (set (get v "enum")))]
(cond
(= #{true false} enum) (f/bool)
(= #{true} enum) (f/bool :equals true)
(= #{false} enum) (f/bool :equals false)
:else (throw (ex-info (str "Unsupported boolean enum: " (pr-str (get v "enum")))
{:schema v})))
(f/bool))
"string" (let [{fmt "format" :strs [enum]} v]
(assert (nil? fmt) (pr-str fmt))
(if (seq enum)
(f/enum (into [] (map-indexed #(-normalize %2 (conj-path opts (str %)))) enum))
(f/str)))
"null" (throw (ex-info "Flanders cannot check for nil" {}))
"array" (let [{:strs [items uniqueItems]} v]
(assert (nil? uniqueItems))
(f/seq-of (->flanders items (conj-path opts "items"))))
"object" (let [properties (not-empty (into (sorted-map) (map (fn [[k v]] [(keyword k) v])) (get v "properties")))
required (not-empty (into #{} (map keyword) (get v "required")))
additionalProperties (get v "additionalProperties")]
(assert ((some-fn nil? boolean?) additionalProperties))
(when (and additionalProperties (or properties required)) ;;TODO
(throw (ex-info "Cannot combine properties and additionalProperties" {})))
(if properties
(f/map (mapv (fn [[k s]]
(f/entry k (->flanders s (conj-path opts (-normalize k opts))) :required? (contains? required k)))
properties))

(if additionalProperties
(f/map-of {})
(assert nil (str "TODO closed map" (pr-str v))))))
;; https://github.com/json-schema/json-schema/issues/172
nil f/any
(unknown-schema! v opts))
(when-some [enum (seq (get v "enum"))]
(f/enum (cond->> enum
(some (some-fn ident? string?) enum) (into [] (map #(-normalize %2 (conj-path opts (str %))))))))
(unknown-schema! v opts))]
(cond-> (assoc base ::base-id (::base-id opts))
;; TODO unit test
description (assoc :description description)
local-defs (assoc ::f/registry local-defs)
;;TODO recursive examples involving refs (currently :ref example is nil)
;example (assoc :example example)
;default (assoc :default default)
;title (assoc :title title)
))
(unsupported-schema! "no opposite of f/any" v opts))
(nil? v) (unsupported-schema! "nil is not checkable in flanders" v opts)
(map? v) (let [v (normalize-map v opts)]
(if (sequential? (get v "type"))
(f/either :choices (mapv #(parse-map (assoc v "type" %) opts) (get v "type")))
(parse-map v opts)))
:else (unknown-schema! v opts))))
19 changes: 12 additions & 7 deletions test/flanders/json_schema_test.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -169,7 +169,8 @@
"float and integers are equal up to 64-bit representation limits" :skip
"const with -2.0 matches integer and float types" :skip
"const with 1 does not match true" {"float one is valid" :skip}
"const with 0 does not match other zero-like types" {"float zero is valid" :skip}}}]})
"const with 0 does not match other zero-like types" {"float zero is valid" :skip}}}
{:file "JSON-Schema-Test-Suite/tests/draft7/type.json"}]})

(defn ->printable [data]
(walk/postwalk
Expand All @@ -196,7 +197,7 @@
config (get config description)]
:when (not= :skip config)
backend [:malli #_:schema]]
(let [skip? (or (str/includes? description "float")
(let [skip? (or (str/includes? description "float with zero")
(str/includes? description ".0")
(and (map? schema)
(when-some [[_ const] (find schema "const")]
Expand All @@ -209,11 +210,15 @@
"\n"
"Input: "
(pr-str (->printable data)))
(case backend
:malli (let [m (is (->malli schema {::sut/$schema version}))]
(when (m/schema? m)
(is (= valid (m/validate m data))
(pr-str (m/form m)))))))))))))
(is (do (case backend
:malli (when-some [m (try (->malli schema {::sut/$schema version})
(catch Exception e
(when-not (::sut/unsupported (ex-data e))
(throw e))))]
(is (= valid (m/validate m data))
(pr-str (m/form m)))))
;; print testing string on error
true)))))))))

(comment
(clojure.test/test-vars [#'json-schema-test-suite-test])
Expand Down

0 comments on commit 85cbfe2

Please sign in to comment.