Fixes for simple-array fixnum

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/simple-array.lisp

@@ -416,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)))
@@ -452,15 +469,28 @@
 	       (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)))

test/cl-binary-store-tests.lisp

@@ -679,11 +679,23 @@
            (let ((a (make-array (file-length str))))
              (read-sequence a str)
              a))))
-      (loop repeat 10000
+      (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 ()))))
+