# HG changeset patch # User Steve Losh # Date 1598761347 14400 # Node ID 700d5c6492454bd15426b9dd721ca4b3bb0d827d # Parent b148ffd264648c7bc7885f23ebea198afa4a3575 Expose input wrapping to users diff -r b148ffd26464 -r 700d5c649245 .TODO.done --- a/.TODO.done Sat Aug 29 23:57:54 2020 -0400 +++ b/.TODO.done Sun Aug 30 00:22:27 2020 -0400 @@ -1,5 +1,6 @@ Add read/print disabling mechanism | id:1268bf0b10c13aec23aafbd8f5e236db1e485fa5 Fix :allow-print and :allow-read to set t when removing them during class redef. | id:21cce1bed829a138de33b33e3ad3219f7888be04 +Input wrapping. | id:7bc7f71a7dd85e13efde40b5ea2a5b6bfe13cf58 Add basic wrapper definition | id:861f048b3b69079dedf8779be1cb73c05e6fc732 Optimize discarding | id:93105ef9d21d33bfb10c67fcac36bc60434d3fb4 Add after-read and before-print functions | id:9f982ca45b68d644159e0c64f0dc1b185f72a2f8 diff -r b148ffd26464 -r 700d5c649245 TODO --- a/TODO Sat Aug 29 23:57:54 2020 -0400 +++ b/TODO Sun Aug 30 00:22:27 2020 -0400 @@ -1,6 +1,5 @@ Indentation. | id:0184922ad2c249da5361f439f6449fadcb27d43c Clean up error hierarchy | id:3d3efa4af649474151661a9d294080ab24e22ff7 -Input wrapping. | id:7bc7f71a7dd85e13efde40b5ea2a5b6bfe13cf58 Fuzz against other JSON implementations | id:ccfe488e219c9454228a0510c61f8c59946e5875 Ensure slots are coalesced properly. | id:d800e6516a5bf5f8ce843f442956078e7a1b672e Add more MOP-based tests (including errors). | id:df727baeb41bad02c7d79b92f98c24c8a28ca772 diff -r b148ffd26464 -r 700d5c649245 docs/api.lisp --- a/docs/api.lisp Sat Aug 29 23:57:54 2020 -0400 +++ b/docs/api.lisp Sun Aug 30 00:22:27 2020 -0400 @@ -21,7 +21,7 @@ (d-api:draw-class-hierarchy "docs/static/errors.svg" '(jarl::json-error - jarl::json-parsing-error + jarl::json-reading-error jarl::json-limit-exceeded-error jarl::json-size-limit-exceeded-error jarl::json-depth-limit-exceeded-error) diff -r b148ffd26464 -r 700d5c649245 src/basic.lisp --- a/src/basic.lisp Sat Aug 29 23:57:54 2020 -0400 +++ b/src/basic.lisp Sun Aug 30 00:22:27 2020 -0400 @@ -4,7 +4,7 @@ (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 + If more than this number of characters would have to be read to finish reading 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, @@ -13,7 +13,7 @@ (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 + If reading 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. @@ -21,7 +21,7 @@ it is unspecified which of the two errors will be signaled.") -(defstruct input +(defstruct (input (:constructor make-input%)) (stream nil :type stream) (line 1 :type (and fixnum (integer 0))) (column 0 :type (and fixnum (integer 0))) @@ -31,6 +31,25 @@ (size-limit *read-size-limit* :type (and fixnum (integer 0))) (string-buffer nil :type (or null stream))) +(defun ensure-stream (stream-or-string) + (etypecase stream-or-string + (stream stream-or-string) + (string (make-string-input-stream stream-or-string)))) + +(defun make-input (stream-or-string) + (make-input% :stream (ensure-stream stream-or-string))) + +(defun reset-limits (input) + (setf (input-depth input) 0 + (input-size input) 0 + (input-depth-limit input) *read-depth-limit* + (input-size-limit input) *read-size-limit*)) + +(defun reset-position (input) + (setf (input-line input) 0 + (input-column input) 0)) + + (defun p (input &optional (eof :eof)) ; peek (declare (type input input) (optimize (speed 3) (safety 1) (debug 1))) @@ -60,23 +79,23 @@ ((line :accessor line :initarg :line) (column :accessor column :initarg :column))) -(define-condition json-parsing-error (json-error) +(define-condition json-reading-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" + (format stream "Error reading 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) +(define-condition json-limit-exceeded-error (json-reading-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." + (format stream "~:(~A~) limit (~D) exceeded while reading JSON at line ~D column ~D." (slot-value c 'limit-name) (limit c) (line c) @@ -90,7 +109,7 @@ (defun e (class input format-string &rest args) ; error - (error 'json-parsing-error + (error 'json-reading-error :class-designator class :line (input-line input) :column (input-column input) @@ -128,7 +147,7 @@ (loop :for next :across remaining-characters :for char = (r input) :unless (eql next char) - :do (e 'keyword input "expected ~S when parsing ~S but got ~S" next literal char)) + :do (e 'keyword input "expected ~S when reading ~S but got ~S" next literal char)) literal) (defun parse-hex-digit (input) @@ -227,6 +246,7 @@ (defmethod read% ((class (eql 'keyword)) contained-class input) + (declare (ignore contained-class)) (let ((ch (r input))) (case ch (#\t (parse-literal input :true "rue")) @@ -234,6 +254,7 @@ (t (e 'keyword input "expected ~S or ~S but got ~S" #\t #\f ch))))) (defmethod read% ((class (eql 'null)) contained-class input) + (declare (ignore contained-class)) (let ((ch (r input))) (if (eql ch #\n) (parse-literal input nil "ull") @@ -265,6 +286,7 @@ 'vector))) (defmethod read% ((class (eql 'string)) contained-class input) + (declare (ignore contained-class)) (let ((ch (r input))) (unless (eql ch #\") (e 'string input "expected opening ~S but got ~S" #\" ch))) @@ -294,8 +316,8 @@ :with c = (car contained-class) :with cc = (cadr contained-class) :for name = (read% 'string nil input) - :for sep = (parse-kv-separator 'hash-table input) - :for value = (progn (skip-whitespace input) + :for value = (progn (parse-kv-separator 'hash-table input) + (skip-whitespace input) (read% c cc input)) :do (progn (setf (gethash name result) value) @@ -308,6 +330,7 @@ result)) (defmethod read% ((class (eql 'number)) contained-class input) + (declare (ignore contained-class)) (let ((ch (p input))) (unless (member ch '(#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (r input) ; chomp to ensure accurate column count @@ -321,6 +344,7 @@ (t (read% (first contained-class) (second contained-class) input)))) (defmethod read% ((class (eql t)) contained-class input) + (declare (ignore contained-class)) (skip-whitespace input) (case (p input) (:eof (r input) (e 't input "got ~S" :eof)) @@ -416,21 +440,19 @@ (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 read (class-designator input &optional (eof-error-p t) eof) + (etypecase input + (input (reset-limits input)) + ((or stream string) (setf input (make-input input)))) + (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) diff -r b148ffd26464 -r 700d5c649245 src/package.lisp --- a/src/package.lisp Sat Aug 29 23:57:54 2020 -0400 +++ b/src/package.lisp Sun Aug 30 00:22:27 2020 -0400 @@ -4,7 +4,7 @@ (:export :read :print - :json-parsing-error :line :column + :json-reading-error :line :column :json-class :lisp-case-to-snake-case diff -r b148ffd26464 -r 700d5c649245 test/tests.lisp --- a/test/tests.lisp Sat Aug 29 23:57:54 2020 -0400 +++ b/test/tests.lisp Sun Aug 30 00:22:27 2020 -0400 @@ -83,9 +83,9 @@ (handler-case (progn (jarl:read class string) - (error "Should have signaled a json-parsing-error when parsing ~S but didn't." + (error "Should have signaled a json-reading-error when reading ~S but didn't." class)) - (jarl::json-parsing-error (e) + (jarl::json-reading-error (e) (is (equal (list class line col) (list class (jarl:line e) (jarl:column e)))))))) @@ -323,7 +323,11 @@ (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 ]")))) + (signals jarl::json-size-limit-exceeded-error (jarl:read nil "[1, 2, 3 ]")) + (let ((input (jarl::make-input "123456789[][1,2,3,4,5,6,7,8,9]"))) + (is (same 123456789 (jarl:read t input))) + (is (same (v) (jarl:read t input))) + (signals jarl::json-size-limit-exceeded-error (jarl:read t input))))) (define-test depth-limit ;; TODO Add some more of these. @@ -332,7 +336,10 @@ (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]]}]"))))) + (signals jarl::json-depth-limit-exceeded-error (jarl:read nil (json "[{'foo': [[1]]}]"))) + (let ((input (jarl::make-input "[[[]]][[[[]]]]"))) + (is (same (v (v (v))) (jarl:read t input))) + (signals jarl::json-depth-limit-exceeded-error (jarl:read t input))) )) ;;;; MOP ---------------------------------------------------------------------- @@ -579,6 +586,19 @@ (signals error (jarl:read 'us-err "{'id':1, 'foo': 'bar', 'meow': 'wow'}"))) +;;;; Passing Input ------------------------------------------------------------ +(define-test passing-input + (let ((input (jarl::make-input (json "[1,2] 99 [} {}")))) + (is (same (v 1 2) (jarl:read '(vector number) input))) + (is (same 99 (jarl:read 'number input))) + (handler-case + (progn (jarl:read 'vector input) + (error "Should have signaled an error, but did not.")) + (jarl::json-reading-error (e) + (is (= 1 (jarl::line e))) + (is (= 13 (jarl::column e))))))) + + ;;;; Fuzz Utilities ----------------------------------------------------------- (defparameter *basic-chars* " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_,'[]{}+=")