--- a/.TODO.done Thu Aug 13 22:33:26 2020 -0400
+++ b/.TODO.done Fri Aug 14 00:17:21 2020 -0400
@@ -1,3 +1,4 @@
Optimize discarding | id:93105ef9d21d33bfb10c67fcac36bc60434d3fb4
+Add size and depth limits | id:ab9b49ec993f1e46c34b9d627549f41cad80609d
Add fuzz tests against other implementations | id:cd53968480f72453ee820d65a180efe6da0fef71
Add basic unit tests | id:ed372a368fce619ce8230043635de5258212f607
--- a/src/basic.lisp Thu Aug 13 22:33:26 2020 -0400
+++ b/src/basic.lisp Fri Aug 14 00:17:21 2020 -0400
@@ -1,15 +1,43 @@
(in-package :jarl)
;;;; Input --------------------------------------------------------------------
+(defparameter *read-size-limit* (expt 2 30)
+ "The maximum number of characters to read in a single `jarl:read` call.
+
+ If more than this number of characters would have to be read to finish parsing
+ a single object, a `json-size-limit-exceeded-error` will be signaled.
+
+ If both the size and depth limits are exceeded by exactly the same character,
+ it is unspecified which of the two errors will be signaled.")
+
+(defparameter *read-depth-limit* 100
+ "The maximum depth of nested objects and vectors to allow in a single `jarl:read` call.
+
+ If parsing a single object would require descending into more than this number
+ of JSON objects and/or arrays, a `json-depth-limit-exceeded-error` error will
+ be signaled.
+
+ If both the size and depth limits are exceeded by exactly the same character,
+ it is unspecified which of the two errors will be signaled.")
+
+
(defstruct input
(stream nil :type stream)
(line 1 :type (and fixnum (integer 0)))
- (column 0 :type (and fixnum (integer 0))))
+ (column 0 :type (and fixnum (integer 0)))
+ (depth 0 :type (and fixnum (integer 0)))
+ (depth-limit *read-depth-limit* :type (and fixnum (integer 0)))
+ (size 0 :type (and fixnum (integer 0)))
+ (size-limit *read-size-limit* :type (and fixnum (integer 0))))
(defun p (input &optional (eof :eof)) ; peek
+ (declare (type input input)
+ (optimize (speed 3) (safety 1) (debug 1)))
(peek-char nil (input-stream input) nil eof))
(defun r (input) ; read
+ (declare (type input input)
+ (optimize (speed 3) (safety 1) (debug 1)))
(let ((character (read-char (input-stream input) nil :eof)))
(case character
(#\newline (progn
@@ -17,21 +45,48 @@
(setf (input-column input) 0)))
(#\tab (incf (input-column input) 8))
(t (incf (input-column input))))
+ (when (> (incf (input-size input))
+ (input-size-limit input))
+ (error 'json-size-limit-exceeded-error
+ :line (input-line input)
+ :column (input-column input)
+ :limit (input-size-limit input)))
character))
;;;; Errors -------------------------------------------------------------------
-(define-condition json-parsing-error (error)
+(define-condition json-error (error)
((line :accessor line :initarg :line)
- (class-designator :accessor class-designator :initarg :class-designator)
- (column :accessor column :initarg :column)
+ (column :accessor column :initarg :column)))
+
+(define-condition json-parsing-error (json-error)
+ ((class-designator :accessor class-designator :initarg :class-designator)
(message :accessor message :initarg :message))
- (:report (lambda (c stream)
- (format stream "Error parsing JSON~@[ into ~S~] at line ~D column ~D: ~A"
- (class-designator c)
- (line c)
- (column c)
- (message c)))))
+ (:report
+ (lambda (c stream)
+ (format stream "Error parsing JSON~@[ into ~S~] at line ~D column ~D: ~A"
+ (class-designator c)
+ (line c)
+ (column c)
+ (message c)))))
+
+(define-condition json-limit-exceeded-error (json-parsing-error)
+ ((limit :accessor limit :initarg :limit)
+ (limit-name :allocation :class))
+ (:report
+ (lambda (c stream)
+ (format stream "~:(~A~) limit (~D) exceeded while parsing JSON at line ~D column ~D."
+ (slot-value c 'limit-name)
+ (limit c)
+ (line c)
+ (column c)))))
+
+(define-condition json-size-limit-exceeded-error (json-limit-exceeded-error)
+ ((limit-name :initform "size")))
+
+(define-condition json-depth-limit-exceeded-error (json-limit-exceeded-error)
+ ((limit-name :initform "depth")))
+
(defun e (class input format-string &rest args) ; error
(error 'json-parsing-error
@@ -40,6 +95,21 @@
:column (input-column input)
:message (apply #'format nil format-string args)))
+(defun incf-depth (input)
+ (declare (type input input)
+ (optimize (speed 3) (safety 1) (debug 1)))
+ (when (> (incf (input-depth input))
+ (input-depth-limit input))
+ (error 'json-depth-limit-exceeded-error
+ :line (input-line input)
+ :column (input-column input)
+ :limit (input-depth-limit input))))
+
+(defun decf-depth (input)
+ (declare (type input input)
+ (optimize (speed 3) (safety 1) (debug 1)))
+ (decf (input-depth input)))
+
;;;; Parsing Utilities --------------------------------------------------------
(defun skip-whitespace (input)
@@ -182,21 +252,26 @@
:do (e nil input "expected ~S when parsing ~S but got ~S" next string char)))
(array% ()
(r input) ; [
+ (incf-depth input)
(skip-whitespace input)
(if (eql (p input) #\])
- (r input)
+ (progn (decf-depth input)
+ (r input))
(loop (any%)
(skip-whitespace input)
(let ((ch (r input)))
(case ch
- (#\] (return))
+ (#\] (decf-depth input) (return))
(#\, (skip-whitespace input))
(t (e nil input "expected ~S or ~S but got ~S." #\] #\, ch)))))))
(object% ()
(r input) ; {
+ (incf-depth input)
(skip-whitespace input)
(if (eql (p input) #\})
- (r input)
+ (progn
+ (decf-depth input)
+ (r input))
(loop
(string%)
(parse-kv-separator nil input)
@@ -204,7 +279,7 @@
(skip-whitespace input)
(let ((ch (r input)))
(case ch
- (#\} (return))
+ (#\} (decf-depth input) (return))
(#\, (skip-whitespace input))
(t (e nil input "expected ~S or ~S but got ~S" #\} #\, ch)))))))
(number% ()
@@ -242,10 +317,13 @@
(let ((ch (r input)))
(unless (eql ch #\[)
(e 'vector input "expected ~S but got ~S" #\[ ch)))
+ (incf-depth input)
(skip-whitespace input)
;; todo allow specialized vectors?
(if (eql (p input) #\])
- (progn (r input) (vector))
+ (progn (r input)
+ (decf-depth input)
+ (vector))
(coerce
(loop
:with c = (car contained-class)
@@ -255,7 +333,7 @@
(skip-whitespace input)
(let ((ch (r input)))
(case ch
- (#\] (loop-finish))
+ (#\] (decf-depth input) (loop-finish))
(#\, (skip-whitespace input))
(t (e 'vector input "expected ~S or ~S but got ~S." #\] #\, ch))))))
'vector)))
@@ -277,10 +355,12 @@
(let ((ch (r input)))
(unless (eql ch #\{)
(e 'hash-table input "expected ~S but got ~S" #\{ ch)))
+ (incf-depth input)
(skip-whitespace input)
(let ((result (make-hash-table :test #'equal)))
(if (eql (p input) #\})
- (r input)
+ (progn (r input)
+ (decf-depth input))
(loop
:with c = (car contained-class)
:with cc = (cadr contained-class)
@@ -293,7 +373,7 @@
(skip-whitespace input)
(let ((ch (r input)))
(case ch
- (#\} (loop-finish))
+ (#\} (decf-depth input) (loop-finish))
(#\, (skip-whitespace input))
(t (e 'hash-table input "expected ~S or ~S but got ~S" #\} #\, ch)))))))
result))
--- a/src/mop.lisp Thu Aug 13 22:33:26 2020 -0400
+++ b/src/mop.lisp Fri Aug 14 00:17:21 2020 -0400
@@ -109,11 +109,12 @@
(let ((ch (r input)))
(unless (eql ch #\{)
(e class-name input "expected ~S but got ~S" #\{ ch)))
+ (incf-depth input)
(skip-whitespace input)
(if (eql (p input) #\})
- (progn
- (r input)
- (make-instance class))
+ (progn (r input)
+ (decf-depth input)
+ (make-instance class))
(loop
:with unknown = (unknown-slots class)
:with map = (name-initarg-map class)
@@ -132,7 +133,7 @@
(skip-whitespace input)
(let ((ch (r input)))
(case ch
- (#\} (loop-finish))
+ (#\} (decf-depth input) (loop-finish))
(#\, (skip-whitespace input))
(t (e class-name input "expected ~S or ~S but got ~S." #\} #\, ch)))))
:finally (return (apply #'make-instance class init)))))
@@ -166,50 +167,3 @@
(write-char #\} stream))
(error "Don't know how to print object ~S of class ~S as JSON." thing class))))
-
-;;;; API ----------------------------------------------------------------------
-(defun canonicalize-class-designator (class-designator)
- (flet ((fail () (error "Malformed class designator ~S" class-designator)))
- (etypecase class-designator
- (cons (destructuring-bind (head a &optional (b nil b?)) class-designator
- (ecase head
- ; (vector foo)
- ((hash-table vector)
- (progn (when b? (fail))
- (list head (canonicalize-class-designator a))))
- ; (or null foo)
- (or (progn
- (unless b? (fail)) ; must have a second option
- (when (eql 'null b) (rotatef a b)) ; sort a/b
- (unless (eql 'null a) (fail)) ; no arbitrary ors
- (list 'nullable (canonicalize-class-designator b)))))))
- (symbol (case class-designator
- (vector '(vector (t)))
- (hash-table '(hash-table (t)))
- (t (list class-designator)))))))
-
-(defun ensure-stream (stream-or-string)
- (etypecase stream-or-string
- (stream stream-or-string)
- (string (make-string-input-stream stream-or-string))))
-
-(defun read (class-designator stream-or-string &optional (eof-error-p t) eof)
- (let ((input (make-input :stream (ensure-stream stream-or-string))))
- (skip-whitespace input)
- (if (eql :eof (p input))
- (if eof-error-p
- (error 'end-of-file)
- eof)
- (destructuring-bind (class &optional contained)
- (canonicalize-class-designator class-designator)
- (read% class contained input)))))
-
-(defun print (object &optional (stream *standard-output*))
- (let ((*read-default-float-format* 'double-float)
- (*print-base* 10))
- (etypecase stream
- ((or stream (eql t)) (progn (print% object stream)
- (values)))
- (null (with-output-to-string (s)
- (print% object s))))))
-
--- a/test/tests.lisp Thu Aug 13 22:33:26 2020 -0400
+++ b/test/tests.lisp Fri Aug 14 00:17:21 2020 -0400
@@ -279,6 +279,25 @@
(1 1 "00")
(1 1 "00.0"))
+(define-test size-limit
+ ;; TODO Add some more of these.
+ (let ((jarl::*read-size-limit* 9))
+ (is (same #(1 2 3) (jarl:read t "[1, 2, 3]")))
+ (signals jarl::json-size-limit-exceeded-error (jarl:read t "[1, 2, 3 ]"))
+ (signals jarl::json-size-limit-exceeded-error (jarl:read t " null"))
+ (signals jarl::json-size-limit-exceeded-error (jarl:read t "\"foobarbaz"))
+ (signals jarl::json-size-limit-exceeded-error (jarl:read t "[[[[[[[[[[[[[[[[[[["))
+ (signals jarl::json-size-limit-exceeded-error (jarl:read nil "[1, 2, 3 ]"))))
+
+(define-test depth-limit
+ ;; TODO Add some more of these.
+ (let ((jarl::*read-depth-limit* 3))
+ (is (same #(#(#(1))) (jarl:read t "[[[1]]]")))
+ (signals jarl::json-depth-limit-exceeded-error (jarl:read t "[[[[1]]]]"))
+ (signals jarl::json-depth-limit-exceeded-error (jarl:read t (json "[{'foo': [[1]]}]")))
+ (signals jarl::json-depth-limit-exceeded-error (jarl:read nil "[[[[1]]]]"))
+ (signals jarl::json-depth-limit-exceeded-error (jarl:read nil (json "[{'foo': [[1]]}]")))))
+
;;;; Fuzz Utilities -----------------------------------------------------------
(defparameter *basic-chars*
@@ -419,9 +438,11 @@
(define-test fuzz-against-yason
- (dotimes (i 500)
+ (dotimes (i 1000)
(let* ((o (gen/any))
(js (jarl:print o nil))
(ys (yason/print (from-jarl 'yason o))))
- (is (same (jarl:read t js) (to-jarl 'yason (yason/read js))))
- (is (same (jarl:read t ys) (to-jarl 'yason (yason/read ys)))))))
+ (is (same (jarl:read t js)
+ (to-jarl 'yason (yason/read js))))
+ (is (same (jarl:read t ys)
+ (to-jarl 'yason (yason/read ys)))))))