# HG changeset patch # User Steve Losh # Date 1597378641 14400 # Node ID e524dd8f7940a62e25750dbbb8c49ebe92cb5150 # Parent 69dd3d1b63f36572615503948ee217906f08d903 Add size and depth limit diff -r 69dd3d1b63f3 -r e524dd8f7940 .TODO.done --- 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 diff -r 69dd3d1b63f3 -r e524dd8f7940 src/basic.lisp --- 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)) diff -r 69dd3d1b63f3 -r e524dd8f7940 src/mop.lisp --- 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)))))) - diff -r 69dd3d1b63f3 -r e524dd8f7940 test/tests.lisp --- 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)))))))