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)))