Cached contexts 2 (#20)

* Move schema-verson type to utils package

* reference: Make context encompass schema version and base schema

* utils: New typedef for schemas

* json-schema: Use new interface for validate

* json-schema.asd: Untabify

* t/reference: Fix call to internal function

* benchmark.lisp: Add a simple benchmark of caching

* json-schema, reference: Export more context slots and rework validate

Make sure calling validate uses the right values whether a schema or
context is passed.

* README: Add a section about contexts

Author: fisxoj

README.rst

@@ -20,7 +20,7 @@ json-schema is a validator for drafts 4, 6, 7, and 2019-09 of the `JSON Schema <
 
 **Drafts 4, 6, 7:**
 
-- ``$ref`` overrides any sibling keywords
+- ``$ref`` does not override any sibling keywords
 
 -------
 Example
@@ -86,6 +86,66 @@ If your data contains a top-level ``$schema`` key, you don't need to pass a sche
 Usage Notes
 -----------
 
+~~~~~~~~
+Contexts
+~~~~~~~~
+
+A context is a reusable set of state that contains all of the fetched network resources (if your schema references external resources) and resolved ids.  By storing that all, you can reuse the validation context multiple times without fetching/resolving everything again.
+
+::
+   (ql:quickload '(trivial-benchmark json-schema))
+
+   (defvar *schema* (json-schema.parse:parse #P"~/Downloads/schema"))
+
+   ;; schema is the json-schema meta schema document from:
+   ;; https://json-schema.org/specification-links.html#draft-2019-09-formerly-known-as-draft-8
+
+   (defvar *context*
+     (json-schema:make-context
+      *schema*
+      :draft2019-09))
+
+   ;;; Cached
+
+   (let ((data (json-schema.parse:parse "{\"type\": \"string\"}")))
+     (trivial-benchmark:with-timing (1000)
+       (json-schema:validate data
+                             :context *context*)))
+
+   ;; -                SAMPLES  TOTAL      MINIMUM  MAXIMUM   MEDIAN    AVERAGE    DEVIATION
+   ;; REAL-TIME        1000     0.826      0        0.022     0.001     0.000826   0.000797
+   ;; RUN-TIME         1000     0.826      0        0.022     0.001     0.000826   0.0008
+   ;; USER-RUN-TIME    1000     0.781011   0        0.020644  0.000745  0.000781   0.000665
+   ;; SYSTEM-RUN-TIME  1000     0.049933   0        0.000986  0         0.00005    0.000184
+   ;; PAGE-FAULTS      1000     0          0        0         0         0          0.0
+   ;; GC-RUN-TIME      1000     0.02       0        0.02      0         0.00002    0.000632
+   ;; BYTES-CONSED     1000     213753664  195344   228976    228032    213753.66  16221.591
+   ;; EVAL-CALLS       1000     0          0        0         0         0          0.0
+
+
+   ;;; Uncached
+
+   (let ((data (json-schema.parse:parse "{\"type\": \"string\"}")))
+     (trivial-benchmark:with-timing (1000)
+       (json-schema:validate data
+                             :schema *schema*
+                             :schema-version :draft2019-09)))
+
+   ;; -                SAMPLES  TOTAL      MINIMUM   MAXIMUM   MEDIAN    AVERAGE   DEVIATION
+   ;; REAL-TIME        1000     203.185    0.148     1.471     0.185     0.203185  0.112807
+   ;; RUN-TIME         1000     9.25       0.006     0.04      0.009     0.00925   0.002294
+   ;; USER-RUN-TIME    1000     8.145081   0.003368  0.039067  0.008105  0.008145  0.002317
+   ;; SYSTEM-RUN-TIME  1000     1.107377   0         0.004927  0.000994  0.001107  0.000967
+   ;; PAGE-FAULTS      1000     0          0         0         0         0         0.0
+   ;; GC-RUN-TIME      1000     0.08       0         0.03      0         0.00008   0.001464
+   ;; BYTES-CONSED     1000     719780512  707728    751424    718160    719780.5  11026.181
+   ;; EVAL-CALLS       1000     0          0         0         0         0         0.0
+
+
+So, for this trivial example, the cached version is around a 245x speedup!  Note, though, that json-schema evaluates these things lazily, so not every reference is necessarily resolved when the context is created.  They are mutable, though, and will build up state as they go.
+
+Thank you to `Raymond Wiker <https://github.com/rwiker>`_ for contributing the initial implementation.
+
 ~~~~~~~~~~~~~
 Decoding JSON
 ~~~~~~~~~~~~~
@@ -98,12 +158,3 @@ Network access
 ~~~~~~~~~~~~~~
 
 JSON Schema allows schemas to reference other documents over the network.  This library will fetch them automatically, by default.  If you don't want this to be allowed, you should set :variable:`json-schema.reference:*resolve-remote-references*` to ``nil``.  If a schema references a remote one, it will raise a :class:`json-schema.reference:fetching-not-allowed-error` instead of fetching it when fetching references is disallowed.
-
-
-~~~~~~~~~~~~~~~
-Reusing Schemas
-~~~~~~~~~~~~~~~
-
-Because of the nature of JSON Schema's references (location-independent references, particularly), schema documents need to be walked when loaded to discover named anchors and ids.  They also may load other schemas.
-
-If you're reusing a large schema document repeatedly, you might want to cache the resolution context.  Unfortunately, I'm still working on this feature!

benchmark.lisp

@@ -0,0 +1,47 @@
+(ql:quickload '(trivial-benchmark json-schema))
+
+(defvar *schema* (json-schema.parse:parse #P"~/Downloads/schema"))
+
+;; schema is the json-schema meta schema document from:
+;; https://json-schema.org/specification-links.html#draft-2019-09-formerly-known-as-draft-8
+
+(defvar *context*
+  (json-schema:make-context
+   *schema*
+   :draft2019-09))
+
+;;; Cached
+
+(let ((data (json-schema.parse:parse "{\"type\": \"string\"}")))
+  (trivial-benchmark:with-timing (1000)
+    (json-schema:validate data
+                          :context *context*)))
+
+;; -                SAMPLES  TOTAL      MINIMUM  MAXIMUM   MEDIAN    AVERAGE    DEVIATION
+;; REAL-TIME        1000     0.826      0        0.022     0.001     0.000826   0.000797
+;; RUN-TIME         1000     0.826      0        0.022     0.001     0.000826   0.0008
+;; USER-RUN-TIME    1000     0.781011   0        0.020644  0.000745  0.000781   0.000665
+;; SYSTEM-RUN-TIME  1000     0.049933   0        0.000986  0         0.00005    0.000184
+;; PAGE-FAULTS      1000     0          0        0         0         0          0.0
+;; GC-RUN-TIME      1000     0.02       0        0.02      0         0.00002    0.000632
+;; BYTES-CONSED     1000     213753664  195344   228976    228032    213753.66  16221.591
+;; EVAL-CALLS       1000     0          0        0         0         0          0.0
+
+
+;;; Uncached
+
+(let ((data (json-schema.parse:parse "{\"type\": \"string\"}")))
+  (trivial-benchmark:with-timing (1000)
+    (json-schema:validate data
+                          :schema *schema*
+                          :schema-version :draft2019-09)))
+
+;; -                SAMPLES  TOTAL      MINIMUM   MAXIMUM   MEDIAN    AVERAGE   DEVIATION
+;; REAL-TIME        1000     203.185    0.148     1.471     0.185     0.203185  0.112807
+;; RUN-TIME         1000     9.25       0.006     0.04      0.009     0.00925   0.002294
+;; USER-RUN-TIME    1000     8.145081   0.003368  0.039067  0.008105  0.008145  0.002317
+;; SYSTEM-RUN-TIME  1000     1.107377   0         0.004927  0.000994  0.001107  0.000967
+;; PAGE-FAULTS      1000     0          0         0         0         0         0.0
+;; GC-RUN-TIME      1000     0.08       0         0.03      0         0.00008   0.001464
+;; BYTES-CONSED     1000     719780512  707728    751424    718160    719780.5  11026.181
+;; EVAL-CALLS       1000     0          0         0         0         0         0.0

json-schema.asd

@@ -3,8 +3,8 @@
 (defsystem json-schema
   :description "JSON schema validation"
   :author "Matt Novenstern <[email protected]>"
-  :license "LGPL"
-  :version "1.0.2"
+  :license "LLGPL"
+  :version "2.0.0"
   :pathname "src"
   :components ((:file "utils")
                (:file "parse")
@@ -32,7 +32,7 @@
 
 (defsystem json-schema/json-schema-test-suite
   :depends-on ("json-schema"
-	       "rove")
+               "rove")
   :pathname "t"
   :components ((:file "json-schema-test-case-helper")
                (:file "draft2019-09")
@@ -41,17 +41,17 @@
                (:file "draft4"))
   :perform (test-op (op c)
                     (declare (ignore op))
-		    (uiop:symbol-call :rove :run c)))
+                    (uiop:symbol-call :rove :run c)))
 
 (defsystem json-schema/unit-tests
   :depends-on ("json-schema"
-	       "rove")
+               "rove")
   :pathname "t"
   :components ((:file "utils")
                (:file "reference"))
   :perform (test-op (op c)
                     (declare (ignore op))
-		    (uiop:symbol-call :rove :run c)))
+                    (uiop:symbol-call :rove :run c)))
 
 (defsystem json-schema/test
   :in-order-to ((test-op (test-op json-schema/json-schema-test-suite)

src/json-schema.lisp

@@ -2,9 +2,12 @@
   (:use :cl :alexandria)
   (:local-nicknames (:reference :json-schema.reference)
                     (:validators :json-schema.validators))
-  (:shadowing-import-from :json-schema.validators
+  (:shadowing-import-from :json-schema.utils
                           :schema-version)
+  (:import-from #:json-schema.reference
+                #:make-context)
   (:export #:validate
+           #:make-context
            #:*schema-version*
            #:schema-version))
 
@@ -14,12 +17,22 @@
 (defparameter *schema-version* :draft7)
 
 
-(defun validate (data &key (schema-version *schema-version*) (pretty-errors-p t) schema)
-  "The primary validation function for json-schema.  Takes data: which can be a simple value or an object as a hash table, and then optionally accepts a schema (if the data doesn't contain a top-level ``$schema`` key), schema version and pretty-errors-p deterimines whether the second return value is exception objects or strings of the rendered errors (strings by default)."
+(defun validate (data &key (schema-version *schema-version*) (pretty-errors-p t) schema context)
+  "The primary validation function for json-schema.  Takes data: which can be a simple value or an object as a hash table, and then optionally accepts a schema (if the data doesn't contain a top-level ``$schema`` key), schema version and pretty-errors-p deterimines whether the second return value is exception objects or strings of the rendered errors (strings by default).
 
-  (let ((schema (or schema (json-schema.parse:parse (dex:get (json-schema.utils:object-get "$schema" data) :force-string t)))))
-    (reference:with-context ((reference:get-id-fun-for-draft schema-version))
-      (reference:with-pushed-context (schema)
-        (if-let ((errors (validators:validate schema data schema-version)))
-          (values nil (mapcar (if pretty-errors-p #'princ-to-string #'identity) errors))
-          (values t nil))))))
+The third return value is a :class:`json-schema.reference::context`, which contains all of the state stored in processing a schema including caching network resources and all of the resolved ids."
+  (assert (not (and schema context)) nil "You should only pass one of ")
+
+  (let* ((schema (or schema
+                     (and context (reference:context-schema-version context))
+                     (reference:fetch-schema (json-schema.utils:object-get "$schema" data))))
+         (context (or context (reference:make-context
+                               (or schema (reference:fetch-schema (json-schema.utils:object-get "$schema" data)))
+                               schema schema-version))))
+    (reference:with-context (context)
+      (if-let ((errors (validators:validate
+                        (reference:context-root-schema context)
+                        data
+                        (reference:context-schema-version context))))
+        (values nil (mapcar (if pretty-errors-p #'princ-to-string #'identity) errors) context)
+        (values t nil context)))))