diff --git a/src/flanders/json_schema.cljc b/src/flanders/json_schema.cljc index 4cfbdbac..051d950d 100644 --- a/src/flanders/json_schema.cljc +++ b/src/flanders/json_schema.cljc @@ -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." @@ -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)))) diff --git a/test/flanders/json_schema_test.cljc b/test/flanders/json_schema_test.cljc index 3d89c5f7..30dce919 100644 --- a/test/flanders/json_schema_test.cljc +++ b/test/flanders/json_schema_test.cljc @@ -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 @@ -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")] @@ -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])