Fixes from fuzzing testing

This slows down simple-array fixnum reading on sbcl because we need to
protect against malicious data.  It's still very very fast.  If you need
faster we can SIMD a check or something.

Author: ajberkley

benchmarks.lisp

@@ -61,6 +61,7 @@
 	      (with-open-file (str "blarg.bin" :if-exists :supersede :if-does-not-exist :create
 					       :direction :output :element-type '(unsigned-byte 8))
 		(cl-binary-store:store str data))))))
+    ;;(assert (equalp (cl-binary-store:restore store) data))
     (when read
       (timed (" READ :" repeats output-size-MB)
         (dotimes (x repeats) (cl-binary-store:restore store)))

src/array.lisp

@@ -1,34 +1,35 @@
 (in-package :cl-binary-store)
 
 (defun restore-array (storage restore-object)
-  (declare (type function restore-object))
+  (declare (type function restore-object) (optimize (speed 3) (safety 1)))
   (let* ((has-fill-pointer (funcall restore-object))
 	 (fill-pointer (when has-fill-pointer (restore-tagged-unsigned-fixnum storage)))
 	 (adjustable (funcall restore-object))
 	 (array-rank (the (unsigned-byte 8) (restore-ub8 storage)))
 	 (dimensions (loop repeat array-rank
                            collect (restore-tagged-unsigned-fixnum storage)))
-	 (displaced (funcall restore-object)))
-    (check-if-too-much-data (read-storage-max-to-read storage) (reduce #'* dimensions))
+	 (displaced (funcall restore-object))
+         (array-total-size (reduce #'* dimensions)))
+    (unless (and (typep array-total-size 'fixnum) (>= array-total-size 0))
+      (unexpected-data "Array total size is too large"))
+    (check-if-too-much-data (read-storage-max-to-read storage) array-total-size)
     (labels ((check-fill-pointer (dimensions)
                (when has-fill-pointer
                  (unless (= array-rank 1)
                    (unexpected-data "found fill-pointer for a non-vector"))
-                 (unless (<= fill-pointer (length (first dimensions)))
-                   (unexpected-data (format nil "fill-pointer ~A > dimensions ~A"
-                                            fill-pointer dimensions))))))
+                 (unless (<= fill-pointer (first dimensions))
+                   (unexpected-data "fill-pointer > vector length")))
+               (values)))
       (if displaced
 	  (let ((element-type (funcall restore-object))
 	        (offset (restore-tagged-unsigned-fixnum storage))
 	        (displaced-to (funcall restore-object)))
             (unless (typep displaced-to 'array)
-              (unexpected-data "array" displaced-to))
+              (unexpected-data "displaced to a non array?!"))
             (unless (typep (array-element-type displaced-to) element-type)
-              (unexpected-data (format nil "array with element-type ~A" element-type)
-                               displaced-to))
+              (unexpected-data "array displaced to array of different element-type"))
             (unless (< offset (array-total-size displaced-to))
-              (unexpected-data (format nil "array of total size > ~A" offset)
-                               displaced-to))
+              (unexpected-data "array displaced to too small array"))
             (when has-fill-pointer (check-fill-pointer dimensions))
 	    (make-array dimensions :element-type element-type :adjustable adjustable
 				   :fill-pointer fill-pointer :displaced-to displaced-to
@@ -42,7 +43,7 @@
               ;; We need to make our array first in case any of the array elements refer to it!
               ;; If we are ever referred to, then there will already be a fixup in place for
               ;; our array handled by `restore-new-reference-indicator'.
-	      (loop for idx fixnum from 0 below (array-total-size array)
+	      (loop for idx fixnum from 0 below array-total-size
 		    do (restore-object-to (row-major-aref array idx) restore-object))
 	      array))))))
 

src/basic-codespace.lisp

@@ -17,7 +17,7 @@
   "This is the basic codespace of cl-binary-store.")
 
 ;; Enable debug to get source code saved to a file so the debugger does the right thing
-(define-codespace ("basic codespace" +basic-codespace+ :debug nil)
+(define-codespace ("basic codespace" +basic-codespace+ :debug t)
   (register-references num-eq-refs (make-hash-table :test #'eq :size *num-eq-refs-table-size*))
   (register-references
    double-float-refs (make-hash-table :test #+sbcl #'double-float-= #-sbcl #'eql

src/cl-binary-store.lisp

@@ -214,7 +214,14 @@
   ())
 
 (defun unexpected-data (expected &optional (data nil data-provided-p))
-  (error 'invalid-input-data :format-control "Expected ~A~A" :format-arguments (list expected (if data-provided-p (format nil ", found ~A" data) ""))))
+  (error 'invalid-input-data
+         :format-control "Expected ~A~A"
+         :format-arguments (list expected
+                                 (if data-provided-p
+                                     ;; be careful not to provide anything
+                                     ;; that cannot be printed trivially here!
+                                     (format nil ", found ~A" data)
+                                     ""))))
 
 (define-condition maybe-expected-error (invalid-input-data)
   ()

src/hash-table.lisp

@@ -31,6 +31,10 @@
              #-sbcl (declare (ignore synchronized weakness))
 	     ;; weakness works as far as I can discern
 	     ;; because of how we do reference restoration
+             (unless (typep rehash-size '(or (integer 1 *) (float (1.0) *)))
+               (unexpected-data "rehash-size is not correct"))
+             (unless (< size (ash most-positive-fixnum -4))
+               (unexpected-data "hash table too large"))
 	     (check-if-too-much-data (read-storage-max-to-read storage)
 				     (* 16 size)) ;; an estimate
 	     (make-hash-table :test test :size size

src/numbers.lisp

@@ -104,7 +104,7 @@
   (let* ((offset (read-storage-offset storage))
 	 (fixnum (signed-sap-ref-64 (read-storage-sap storage) offset)))
     (unless (typep fixnum 'fixnum)
-      (unexpected-data "fixnum" fixnum))
+      (unexpected-data "expected fixnum" fixnum))
     (setf (read-storage-offset storage) (truly-the fixnum (+ offset 8)))
     (truly-the fixnum fixnum)))
 
@@ -232,17 +232,17 @@
 
 (declaim (inline ensure-integer))
 (defun ensure-integer (x)
-  (unless (integerp x)
-    (unexpected-data "integer" x))
-  x)
+  (if (integerp x)
+      x
+      (progn (unexpected-data "expected an integer") 0)))
 
 (defun restore-ratio (restore-object)
   (declare (optimize (speed 3) (safety 1)) (type function restore-object))
   (let ((a (ensure-integer (funcall restore-object)))
         (b (ensure-integer (funcall restore-object))))
     (declare (type integer a b))
-    (unless (> b 0)
-      (unexpected-data "integer > 0" b))
+    (when (= b 0)
+      (unexpected-data "ratio denominator is 0"))
     (/ (the integer a) (the integer b))))
 
 (defun store-ratio (ratio storage num-eq-refs assign-new-reference-id)
@@ -261,9 +261,9 @@
 
 (declaim (inline ensure-real))
 (defun ensure-real (x)
-  (unless (typep x 'real)
-    (unexpected-data "real" x))
-  x)
+  (if (typep x 'real)
+      x
+      (progn (unexpected-data "real") 0)))
 
 (defun restore-complex (restore-object)
   (declare (type function restore-object))
@@ -328,8 +328,8 @@
 	       (#.+ub32-code+ (restore-ub32 storage))
 	       (#.+fixnum-code+
                 (let ((fixnum (restore-fixnum storage)))
-                  (unless (>= fixnum 0)
-                    (unexpected-data "unsigned fixnum" fixnum))
+                  (unless (<= 0 fixnum (- most-positive-fixnum +interior-coded-max-integer+ 1))
+                    (unexpected-data "unsigned fixnum/interior" fixnum))
                   (truly-the fixnum fixnum)))
                (otherwise (unexpected-data "tag for unsigned fixnum" tag)))
 	     +interior-coded-max-integer+ 1)))))

src/objects.lisp

@@ -291,12 +291,14 @@
     (if (< num-slots 0) ; it's a reference id, look it up in our implicit tracking table
 	(gethash num-slots implicit-eql-refs)
         (progn
-          (check-if-too-much-data (read-storage-max-to-read storage) (* 8 num-slots))
+          (if (> num-slots (ash most-positive-fixnum -3))
+              (unexpected-data "too many slots in object-info" num-slots)
+              (check-if-too-much-data (read-storage-max-to-read storage) (* 8 num-slots)))
           (let ((slot-name-vector (make-array num-slots))
 	        (type (funcall restore-object))
 	        (ref-id (- (the fixnum (incf (the fixnum (car implicit-ref-id)))))))
             (unless (symbolp type)
-              (unexpected-data "symbol" type))
+              (unexpected-data "expected a symbol"))
 	    ;; No circularity possible below as these are symbols
 	    (loop for idx fixnum from 0 below num-slots
 		  do (setf (svref slot-name-vector idx) (funcall restore-object)))
@@ -385,7 +387,7 @@
   (declare (type function restore-object) (ignorable storage) (optimize speed safety))
   (let ((object-info (funcall restore-object)))
     (unless (object-info-p object-info)
-      (unexpected-data "object-info" object-info))
+      (unexpected-data "expected an object-info"))
     (let* ((specialized-deserializer (object-info-specialized-deserializer object-info))
 	   (constructor (object-info-specialized-constructor object-info)))
       (cond

src/pathname.lisp

@@ -24,4 +24,4 @@
        :name (funcall restore-object)
        :type (funcall restore-object)
        :version (funcall restore-object))
-    (error (e) (unexpected-data "pathname" e))))
+    (error () (unexpected-data "pathname malformed"))))

src/reference-coding.lisp

@@ -44,7 +44,7 @@
            (+ (- +minimum-untagged-signed-integer+)
               (truly-the fixnum number)
               1 +reference-two-byte-max-ref-id+))
-      (unexpected-data "fixnum" number)))
+      (unexpected-data "reference tag not valid")))
 
 (declaim (inline encode-reference-direct))
 (defun encode-reference-direct (ref-index)

src/reference-count.lisp

@@ -19,6 +19,8 @@
 (defmethod action ((code (eql +set-reference-action-code+)) storage references restore-object)
   (let ((num-refs (restore-tagged-unsigned-fixnum storage)))
     #+info-cbs(format t "This file has ~A references~%" num-refs)
+    (unless (<= 0 num-refs (ash most-positive-fixnum -3))
+      (unexpected-data "num-refs stored in file invalid"))
     (check-if-too-much-data (read-storage-max-to-read storage) (* 8 num-refs))
     (values (setf (references-vector references) (make-array num-refs :initial-element nil))
 	    :ignore)))

src/simple-array.lisp

@@ -85,7 +85,7 @@
     (18 (values '(unsigned-byte 62) 64))
     (19 (values '(unsigned-byte 64) 64))
     (otherwise
-     (unexpected-data "encoded element type" encoded-element-type))))
+     (unexpected-data "encoded element type"))))
 
 (defconstant +first-direct-unsigned-integer+ 20)
 (defconstant +max-direct-encoded-unsigned-integer+ (- 255 +first-direct-unsigned-integer+))
@@ -95,10 +95,9 @@
   "Returns (values new-array array-bytes)"
   (declare (optimize (speed 3) (safety 1)) (type (unsigned-byte 8) encoded-element-type)
            (type fixnum num-elts))
-  (unless (<= num-elts (ash most-positive-fixnum -3))
-    (unexpected-data (format nil "num-elts smaller than ~A" (ash most-positive-fixnum -3)) num-elts))
+  (unless (<= num-elts (ash most-positive-fixnum -7))
+    (unexpected-data "num-elts too big"))
   (let ((num-elts num-elts))
-    (declare (type (unsigned-byte 59) num-elts))
     (multiple-value-bind (type actual-bits)
         (encoded-element-type-to-type/packing encoded-element-type)
       (let ((total-bytes (ceiling (the fixnum
@@ -199,8 +198,8 @@
 (defun restore-simple-base-string (storage)
   (declare (optimize (speed 3) (safety 1)))
   (let ((num-bytes (restore-tagged-unsigned-fixnum/interior storage)))
-    (unless (and (typep num-bytes 'fixnum) (>= num-bytes 0))
-      (unexpected-data "unsigned fixnum" num-bytes))
+    (unless (>= num-bytes 0)
+      (unexpected-data "unexpected negative length for simple-base-string"))
     (check-if-too-much-data (read-storage-max-to-read storage) num-bytes)
     (let ((string (make-string num-bytes :element-type 'base-char)))
       (chunked/read storage num-bytes
@@ -417,6 +416,23 @@
 	     ,@body
 	   (setf (read-storage-offset ,storage) (+ ,original-offset ,reserve-bytes)))))))
 
+(defmacro sap-ref-fixnum (sap offset)
+  "This is hideous.  On SBCL we have stored the data fixnum encoded, which means shifted up
+ by one so we shift it back to generate an 'unencoded' fixnum.  We would normally just have
+ blitted things back into the array without telling sbcl what we are doing, but in the
+ presence of potentially malicious data, we have to make sure that our numbers are fixnums,
+ so we shift them back down which makes it impossible for malicious actor to put bogus dat
+ in the array sap.  On non sbcl we just check to make sure things are fixnums because we
+ did not blit the data out"
+  #+sbcl
+  `(ash (signed-sap-ref-64 ,sap ,offset) -1)
+  #-sbcl
+  (let ((a (gensym)))
+    `(let ((,a (signed-sap-ref-64 ,sap ,offset)))
+       (if (typep ,a 'fixnum)
+           ,a
+           (unexpected-data "non fixnum in fixnum array")))))
+
 (defun restore-simple-specialized-vector (storage)
   (declare (optimize (speed 3) (safety 1)))
   (let ((num-elts (restore-tagged-unsigned-fixnum/interior storage)))
@@ -449,18 +465,32 @@
 		  (32 (reader 32 t))
 		  (64 (reader 64 t))))))
 	    (t
-	     (ecase type
+	     (case type
 	       (bit (reader 1 nil))
 	       (single-float (reader 32 nil sap-ref-single (simple-array single-float (*))))
 	       (double-float (reader 64 nil sap-ref-double (simple-array double-float (*))))
-	       (fixnum (reader 64 t signed-sap-ref-64 (simple-array fixnum (*))))))))
+	       (fixnum (reader 64 t sap-ref-fixnum (simple-array fixnum (*))))
+               (otherwise (unexpected-data "array of unexpected type"))))))
         #+sbcl
 	(with-pinned-objects (sv)
-	  (let ((target-sap (vector-sap sv)))
-	    (chunked/read
-	     storage num-bytes
-	     (lambda (source-sap source-sap-offset data-start/bytes data-end-bytes)
-	       (copy-sap target-sap data-start/bytes source-sap source-sap-offset (the fixnum (- data-end-bytes data-start/bytes)))))))
+          (multiple-value-bind (type bits-per-elt)
+              (encoded-element-type-to-type/packing encoded-element-info)
+            (declare (ignorable bits-per-elt))
+            (cond
+              ((eq type 'fixnum)
+               ;; We have to be careful here, as just blitting potentially malicious 64
+               ;; bit data into a simple-array fixnum (*) can cause issues.
+               ;; Now the problem is that we already "fixnum encoded" the data if it is
+               ;; correct, which means that it needs to be un-fixnum-ized
+               (reader 64 t sap-ref-fixnum (simple-array fixnum (*))))
+              (t
+	       (let ((target-sap (vector-sap sv)))
+                 ;; OK, so we have a problem here --- if the fixnums aren't actually fixnums
+                 ;; then we end up screwing things up.
+	         (chunked/read
+	          storage num-bytes
+	          (lambda (source-sap source-sap-offset data-start/bytes data-end-bytes)
+	            (copy-sap target-sap data-start/bytes source-sap source-sap-offset (the fixnum (- data-end-bytes data-start/bytes))))))))))
         sv))))
 
 ;; for ccl ccl::array-data-and-offset would be fine... it's been a stable interface
@@ -511,8 +541,19 @@
 	                  (type-of sa) num-bytes array-dimensions encoded-element-info)
       	(with-pinned-objects (sa)
 	  (let ((target-sap (array-sap sa)))
-	    (chunked/read
-	     storage num-bytes
-	     (lambda (source-sap source-sap-offset data-start/bytes data-end-bytes)
-	       (copy-sap target-sap data-start/bytes source-sap source-sap-offset (- data-end-bytes data-start/bytes))))))
+            (multiple-value-bind (type bits-per-elt)
+                (encoded-element-type-to-type/packing encoded-element-info)
+              (declare (ignorable bits-per-elt))
+              (cond
+                ((eq type 'fixnum)
+                 ;; We have to be careful here, as just blitting potentially malicious 64
+                 ;; bit data into a simple-array fixnum (*) can cause issues.
+                 (sb-kernel:with-array-data ((sv sa) (start) (end))
+                   (declare (ignore start end))
+                   (reader 64 t sap-ref-fixnum (simple-array fixnum (*)))))
+                (t
+	         (chunked/read
+	          storage num-bytes
+	          (lambda (source-sap source-sap-offset data-start/bytes data-end-bytes)
+	            (copy-sap target-sap data-start/bytes source-sap source-sap-offset (- data-end-bytes data-start/bytes)))))))))
       sa)))

src/simple-vector.lisp

@@ -12,6 +12,8 @@
 (defun restore-simple-vector (storage restore-object)
   (declare (optimize speed safety))
   (let* ((num-elts (restore-tagged-unsigned-fixnum/interior storage)))
+    (unless (< num-elts (ash most-positive-fixnum -3))
+      (unexpected-data "simple vector too long"))
     (check-if-too-much-data (read-storage-max-to-read storage) (* num-elts 8))
     (let ((sv (make-array num-elts)))
       ;; It's possible that we can refer to an

src/symbols.lisp

@@ -79,7 +79,7 @@
 (defun ensure-string (maybe-string)
   (if (stringp maybe-string)
       maybe-string
-      (progn (unexpected-data "string" maybe-string) "")))
+      (progn (unexpected-data "expected a string, it was not") "")))
 
 (declaim (inline restore-symbol))
 (defun restore-symbol (storage restore-object)

test/cl-binary-store-tests.lisp

@@ -592,7 +592,8 @@
 (define-test test-bignum
   (is '= (expt 2 64) (restore (store nil (expt 2 64))))
   (is '= 12345678901234567890 (restore (store nil 12345678901234567890)))
-  (is '= -12345678901234567890 (restore (store nil -12345678901234567890))))
+  (is '= -12345678901234567890 (restore (store nil -12345678901234567890)))
+  (is '= (expt 2 123456) (restore (store nil (expt 2 123456)))))
 
 (define-test test-write-into-extant-vector
   (loop for length in '(100 #-abcl 50000)
@@ -678,7 +679,23 @@
            (let ((a (make-array (file-length str))))
              (read-sequence a str)
              a))))
+      (loop repeat 100 ;;10000
+            with input = (make-array (random 100) :element-type '(unsigned-byte 8))
+            do (loop for i fixnum below (length input) do (setf (aref input i) (random 256)))
+            do (try input))
       (loop repeat 10
             with input = (make-array (random 1000000) :element-type '(unsigned-byte 8))
             do (loop for i fixnum below (length input) do (setf (aref input i) (random 256)))
             do (try input))))
+
+(define-test simple-array-fixnum-malicious
+  ;; The below is a non-fixnum claiming to be in a fixnum array
+  (finish
+   (handler-case
+       (cl-binary-store::restore #(21 5 3 127 127 127 127 127 127 127 127))
+     (invalid-input-data ())))
+  (finish
+   (handler-case
+       (cl-binary-store::restore #(21 5 3 127 127 127 127 127 127 127 127))
+     (invalid-input-data ()))))
+