wip

threatgrid · Dec 10, 2024 · 95d4df3 · 95d4df3
1 parent b3363df
commit 95d4df3
Showing 1 changed file with 32 additions and 24 deletions.
diff --git a/src/flanders/json_schema.cljc b/src/flanders/json_schema.cljc
@@ -1,5 +1,6 @@
 (ns flanders.json-schema
   (:require [clojure.string :as str]
+            [clojure.set :as set]
             [flanders.core :as f]))
 
 (defn- -normalize
@@ -62,35 +63,42 @@
   [v opts]
   (cond
     ;; TODO "default", "example", "description", "title"
-    (map? v) (let [{:strs [$defs $dynamicAnchor $dynamicRef $id $vocabulary $schema]} (normalize-map v)
+    (map? v) (let [{:strs [$ref $defs $dynamicAnchor $dynamicRef $id $vocabulary $schema]} (normalize-map v)
                    ;; TODO
                    _ (when $schema (assert (= "http://json-schema.org/draft-07/schema#" $schema) (pr-str $schema)))
                    _ (assert (nil? $dynamicAnchor)) ;; TODO
                    _ (assert (nil? $dynamicRef)) ;; TODO
-                   $defs (some-> $defs normalize-map)
-                   opts (-> opts
-                            (update ::base-id (fn [parent-id]
-                                                ;; TODO subschemas start new id https://json-schema.org/draft/2020-12/json-schema-core#section-8.2.1
-                                                (when (and parent-id $id)
-                                                  (throw (ex-info "$id only supported at top-level" {})))
-                                                (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" {})))))
-                            (as-> opts
-                              (update opts ::defs
-                                      (fn [defs]
-                                        (let [])
-                                        )
-                                      (fnil into {})
-                                      (map (fn [[k v]]
-                                             (let [{::keys [base-id path]} opts
-                                                   k (-normalize k)]
-                                               [(-normalize k)
-                                                (->flanders v (conj-path opts "$defs" k))])))
-                                      $defs)))]
+                   opts (as-> opts opts
+                          (update ::base-id (fn [parent-id]
+                                              ;; TODO subschemas start new id https://json-schema.org/draft/2020-12/json-schema-core#section-8.2.1
+                                              (when (and parent-id $id)
+                                                (throw (ex-info "$id only supported at top-level" {})))
+                                              (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" {})))))
+                          (cond-> opts
+                            (seq $defs)
+                            (update opts ::defs
+                                    (fn [defs]
+                                      (let [defs (or defs {})
+                                            $defs (normalize-map $defs)]
+                                        (when-some [clashes (seq (set/intersection (-> defs keys set)
+                                                                                   (-> $defs keys set)))]
+                                          (throw (ex-info "Clashing $def's" {:clashes clashes})))
+                                        (into defs
+                                              (map (fn [[k v]]
+                                                     (let [opts (conj-path opts "$defs" k)
+                                                           this-id (absolute-id opts)]
+                                                       [this-id
+                                                        (->flanders v (update opts ::seen (fnil conj #{}) this-id))])))
+                                              $defs)))
+                                    $defs)))]
                (or ;; https://datatracker.ietf.org/doc/html/draft-pbryan-zyp-json-ref-03#section-3
-                   (when (get v "$ref")
-                     (->JSONSchemaRef v opts))
+                   (when-some [this-id (some-> $ref (resolve-id opts))]
+                     (when (contains? (::seen opts) this-id)
+                       (throw (ex-info "Recursive schemas not allowed" {:id this-id})))
+                     (or (get-in opts [::defs this-id])
+                         (throw (ex-info "Could not resolve id" {:absolute-id this-id :relative-id $ref}))))
                    (when-some [disjuncts (get v "anyOf")]
                      (f/either :choices (into [] (map-indexed #(->flanders %2 (conj-path opts "anyOf" %1))) disjuncts)))
                    (when-some [conjuncts (get v "allOf")]