From 7766bca0d57e47c9c969db563b9a35b6ebb67008 Mon Sep 17 00:00:00 2001 From: Mark Skilbeck Date: Tue, 19 Feb 2019 15:53:41 -0800 Subject: [PATCH 1/5] Use messagepack extensions payloads that can be transmitted As far as I have been able to understand, cl-messagepack's current implementation of extensions doesn't allow you to encode arbitrary data, associate it with some type, and then communicate this across a network. cl-messagepack's implementation is more like you have some instance of an object, you assign an ID to it, you can then communicate this ID across the network and back, and then lookup this object in a hashtable using the ID. This restricts you to keeping the data in the same lisp image / memory. This is a first stab at what I think is a "true" implementation of messagepack's extensions. It is incomplete, but I'm making the PR for visibility. Use it to encode complex floats with the following: ``` (defun my-encode-complex (data stream) (encode-fixext-8 (append (rest (coerce (flexi-streams:with-output-to-sequence (s) (encode-float (realpart data) s)) 'list)) (rest (coerce (flexi-streams:with-output-to-sequence (s) (encode-float (imagpart data) s)) 'list))) stream 0)) (defun my-decode-complex (len stream) (complex (sb-kernel:make-single-float (ub32->sb32 (load-big-endian stream 4))) (sb-kernel:make-single-float (ub32->sb32 (load-big-endian stream 4)))) ;; (or #+sbcl (sb-kernel:make-single-float (ub32->sb32 (load-big-endian stream 4))) ;; #-(or sbcl) (error "No floating point support yet.")) ;; (or #+sbcl (sb-kernel:make-double-float (ub32->sb32 (load-big-endian stream 4)) ;; (load-big-endian stream 4)) ;; #+ccl (ccl::double-float-from-bits (load-big-endian stream 4) ;; (load-big-endian stream 4)) ;; #-(or sbcl ccl) (error "No floating point support yet.")) ) (register-extension-dispatcher 0 #'complexp #'my-encode-complex CL-USER> (mpk::decode (mpk::encode (list #C(1.2 1.3) #C(0.0 1.0) (list #C(1.2 1.3))))) ``` --- cl-messagepack.lisp | 262 ++++++++++++++------------------------------ 1 file changed, 83 insertions(+), 179 deletions(-) diff --git a/cl-messagepack.lisp b/cl-messagepack.lisp index 84a9961..2405f5a 100644 --- a/cl-messagepack.lisp +++ b/cl-messagepack.lisp @@ -110,6 +110,11 @@ (defvar *decoder-prefers-alists* nil) (defvar *decode-bin-as-string* nil) +(defvar *extension-dispatchers* (make-hash-table :size #xFF) + "Maps the extension type to a plist of functions whose keys are + :matcher - predicate used by the ENCODE routine to determine who should encode the data (e.g. COMPLEXP) + :encoder - function that encodes the data + :decoder - function that decodes the data") (defvar *extended-types* nil) (defvar *lookup-table* nil) @@ -160,10 +165,9 @@ (encode-hash data stream)) ((symbolp data) (encode-symbol data stream)) - ((and *extended-types* - (typep data 'extension-type) - (try-encode-ext-type data stream)) - t) + ((and *extension-dispatchers* + (dispatcher-for-extension-data data)) + (funcall (encoder-for-extension-data data) data stream)) (t (error (format nil "Cannot encode data ~a (maybe you should bind *extended-types*?)." data))))) @@ -312,6 +316,68 @@ (or (<= 0 data (1- (expt 2 64))) (<= (- (expt 2 63)) data (1- (expt 2 63))))) +(defun encode-fixext (data ext type stream) + (assert (<= #xd4 ext #xd8)) + (write-byte ext stream) + (write-byte type stream) + (loop :for byte :in data :do (write-byte byte stream))) + +(defmacro fixext-encoder (ext size) + `(progn + (defun ,(mksymb 'encode-fixext- size) (data stream type) + (let ((data (alexandria:ensure-list data))) + (assert (<= (length data) ,size)) + (encode-fixext data ,ext type stream))))) + +(fixext-encoder #xd4 1) +(fixext-encoder #xd5 2) +(fixext-encoder #xd6 4) +(fixext-encoder #xd7 8) +(fixext-encoder #xd8 16) + +(defmacro ext-encoder (ext size) + `(progn + (defun ,(mksymb 'encode-ext- size) (data stream type) + (let ((data (alexandria:ensure-list data)) + (length (length data))) + (assert (<= length (1- (expt 2 ,size)))) + (assert (<= #xc7 ,ext #xc9)) + (write-byte ,ext stream) + (store-big-endian (length data) stream ,size) + (write-byte type stream) + (loop :for byte in data :do (write-byte byte stream)))))) + +(ext-encoder #xc7 8) +(ext-encoder #xc8 16) +(ext-encoder #xc9 32) + +(defun register-extension-dispatcher (type matcher encoder decoder) + ;; TODO What if those keys don't exist + (setf (gethash type *extension-dispatchers*) + (list :matcher matcher + :encoder encoder + :decoder decoder))) + +(defun dispatcher-for-extension-data (data) + "Find the first dispatchers entry whose MATCHER predicate returns T for DATA" + (find data (loop for v being the hash-value of *extension-dispatchers* collect v) + :test (lambda (data hash-val) (funcall (getf hash-val :matcher) data)))) + +(defun encoder-for-extension-data (data) + (getf (dispatcher-for-extension-data data) :encoder)) + +(defun decoder-for-extension-data (data) + (getf (dispatcher-for-extension-data data) :decoder)) + +(defun extension-decode (type len stream) + ;; TODO What if decoder doesn't exist? + (funcall (getf (gethash type *extension-dispatchers*) :decoder) + len stream)) + +(defun extension-encode (type data stream) + (funcall (getf (gethash type *extension-dispatchers*) :encoder) + data stream)) + (defun parse-big-endian (byte-array) ;; TODO: do words at once? (loop with result = 0 @@ -357,22 +423,26 @@ (ub32->sb32 (load-big-endian stream 4))) ((= #xd3 byte) (ub64->sb64 (load-big-endian stream 8))) - ((<= #xd4 byte #xd8) ; fixext1: type, data + ((<= #xd4 byte #xd8) (let ((len (ash 1 (- byte #xd4)))) - (typed-data (read-byte stream) - (decode-byte-array len stream)))) + (extension-decode (read-byte stream) + len + stream))) ((= #xc7 byte) (let ((len (read-byte stream))) - (typed-data (read-byte stream) - (decode-byte-array len stream)))) + (extension-decode (read-byte stream) + len + stream))) ((= #xc8 byte) (let ((len (load-big-endian stream 2))) - (typed-data (read-byte stream) - (decode-byte-array len stream)))) + (extension-decode (read-byte stream) + len + stream))) ((= #xc9 byte) (let ((len (load-big-endian stream 4))) - (typed-data (read-byte stream) - (decode-byte-array len stream)))) + (extension-decode (read-byte stream) + len + stream))) ((= #xc0 byte) nil) ((= #xc3 byte) @@ -480,169 +550,3 @@ (let ((seq (make-array length :element-type '(mod 256)))) (read-sequence seq stream) (babel:octets-to-string seq))) - - - -;; How to get type-num for the types? -;; A class would have a :allocation :class ... -;; A pointer to the e-t-d would be longer than the int itself. -(defclass extension-type () - ((id :initform (error "need an ID") - :initarg :id - :reader extension-type-id - :writer (setf extension-type-id) - :type (or integer (array (unsigned-byte 8) *)))) - (:documentation - "Base type for Ext-Types.")) - -(defmethod print-object ((obj extension-type) stream) - (print-unreadable-object (obj stream :type T :identity T) - (format stream "~a" (extension-type-id obj)))) - - -(defclass extension-type-description () - #. (mapcar (lambda (d) - (destructuring-bind (name init &rest rest) d - `(,name :initform ,init - :initarg ,(intern (symbol-name name) :keyword) - :reader ,name - :writer (setf ,name) - ,@ rest))) - '((type-number nil :type (integer 0 127)) - (encode-with nil :type function) - (decode-with nil :type function) - (as-numeric nil :type (member t nil)) - (reg-class nil) - ))) - -(defmethod print-object ((obj extension-type-description) stream) - (print-unreadable-object (obj stream :type T :identity T) - (format stream "~a ~d" - (class-name (reg-class obj)) - (type-number obj)))) - - -(defun symbol-to-extension-type (num sym decode-as) - (assert (member decode-as '(:numeric :byte-array))) - (let ((num? (eq decode-as :numeric))) - (unless (find-class sym nil) - (closer-mop:ensure-class - sym - :direct-superclasses '(extension-type))) - (flet - ((maybe-cache (obj id) - (if *lookup-table* - (or - (lookup-table-find num id) - (lookup-table-insert num id obj)) - obj))) - (make-instance 'extension-type-description - :type-number num - :reg-class (find-class sym) - :encode-with (lambda (obj) - ;; TODO: better use EXTENSION-TYPE-ID? - (let ((id (slot-value obj 'id))) - ;; store outgoing objects... - (maybe-cache obj id) - id)) - :decode-with (lambda (id) - ;; TODO: (if num? ( ... ) x)? - (let ((obj (make-instance sym - 'id id))) - ;; store incoming objects... - ;; TODO: what if that object already exists? - (or - (maybe-cache obj id) - obj))) - :as-numeric num?)))) - - -(defun typed-data (type-num bytes) - (let ((ext-type (find type-num *extended-types* - :test #'eql - :key #'type-number))) - ;; TODO: better throw or error? - (assert ext-type) - (funcall (decode-with ext-type) - (if (as-numeric ext-type) - (parse-big-endian bytes) - bytes)))) - -(defun try-encode-ext-type (obj stream) - (let ((ext-type (find (class-of obj) *extended-types* - :test #'eq - :key #'reg-class))) - ;; doesn't run ENCODE-WITH function?! - (when ext-type - (let* ((id (funcall (encode-with ext-type) obj)) - (bytes (if (numberp id) - (flexi-streams:with-output-to-sequence (s) - (encode-integer id s)) - id)) - (len (length bytes))) - ;; TODO: in theory the ID might be longer than 256 bytes... - ;; (encode-sequence-length bytes stream #xc7 0 #xc8 #xc9) - ;; but we need the type inbetween. - (assert (<= 0 len #xff)) - (write-byte #xc7 stream) - (write-byte len stream) - (write-byte (type-number ext-type) stream) - (write-sequence bytes stream)) - T))) - - -(defun define-extension-types (args) - "This function defines types for the MessagePack extension type system - (#xD4 to #xD8, and #xC7 to #xC9), and returns a list of them - that can be bound to *EXTENSION-TYPES*. - 128 different types can be available simultaneously at any one time. - - This function takes integers, flags, and/or closures as arguments; - these get used as items for the next arguments. - * Integers define which type number to use next. - * Flags for decoding: - :BYTE-ARRAY - return the bytes as array. Default. - :NUMERIC - return value in DATA as a number. Only for fixextN. - * A symbol associates the current type number to this type; - this type should be derived from MESSAGEPACK-EXT-TYPE, as - to have a correct MESSAGEPACK:ID slot. - - Example: - (defvar *my-extension-types* - (define-extension-types :numeric - 5 'buffer 'block - 8 'cursor)) - Eg., the type 6 would then return (MAKE-BLOCK 'ID )." - (loop with type-num = 0 - with decode-as = :byte-array - ; with encode - for el in args - append (cond - ((numberp el) - (if (<= 0 el 127) - (setf type-num el) - (error "Integer ~a out of range." el)) - nil) - ((member el '(:byte-array :numeric)) - (setf decode-as el) - nil) - ((keywordp el) - (error "Keywords ~s not in use." el)) - ((symbolp el) - (prog1 - (list (symbol-to-extension-type type-num el decode-as)) - (incf type-num))) - (T - (error "~s not understood." el)) - ))) - - -(defun make-lookup-table () - "Returns something that can be used for *LOOKUP-TABLE*." - (make-hash-table :test #'equalp)) - -(defun lookup-table-insert (type id obj) - (setf (gethash (cons type id) *lookup-table*) obj)) - -(defun lookup-table-find (type id) - (gethash (cons type id) *lookup-table*)) From e5654d0a1fe1cacb10a9f3daa0591dcacd9f2752 Mon Sep 17 00:00:00 2001 From: Mark Skilbeck Date: Sun, 24 Feb 2019 16:21:46 -0800 Subject: [PATCH 2/5] Export register-extension-dispatcher --- package.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/package.lisp b/package.lisp index d631f43..a91efab 100644 --- a/package.lisp +++ b/package.lisp @@ -46,4 +46,5 @@ *encode-alist-as-map* *decoder-prefers-lists* *decoder-prefers-alists* - *decode-bin-as-string*)) + *decode-bin-as-string* + register-extension-dispatcher)) From 134a9a084be768d6d233cec6d5105b6cfa95b9bf Mon Sep 17 00:00:00 2001 From: Mark Skilbeck Date: Sun, 24 Feb 2019 18:04:35 -0800 Subject: [PATCH 3/5] Add conditions for missing encoders/decoders --- cl-messagepack.lisp | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/cl-messagepack.lisp b/cl-messagepack.lisp index 2405f5a..100a6bd 100644 --- a/cl-messagepack.lisp +++ b/cl-messagepack.lisp @@ -76,6 +76,12 @@ (when line (format t "~{#x~2,'0x ~}~%" (nreverse line))))) +(define-condition encode-no-suitable-encoder (simple-error) () + (:report (lambda (condition stream) + (declare (ignore condition)) + ;; TODO Better error msg + (format stream "No suitable encoder was found")))) + (defun encode (data) (flexi-streams:with-output-to-sequence (stream) (encode-stream data stream))) @@ -168,9 +174,7 @@ ((and *extension-dispatchers* (dispatcher-for-extension-data data)) (funcall (encoder-for-extension-data data) data stream)) - (t (error - (format nil - "Cannot encode data ~a (maybe you should bind *extended-types*?)." data))))) + (t (error 'encode-no-suitable-encoder)))) (defun encode-rational (data stream) (labels ((encode-bignum (data) @@ -370,7 +374,8 @@ (getf (dispatcher-for-extension-data data) :decoder)) (defun extension-decode (type len stream) - ;; TODO What if decoder doesn't exist? + (unless (gethash type *extension-dispatchers*) + (error 'decode-no-suitable-decoder)) (funcall (getf (gethash type *extension-dispatchers*) :decoder) len stream)) @@ -396,6 +401,11 @@ (read-byte ,g-stream)))) result))) +(define-condition decode-no-suitable-decoder (simple-error) () + (:report (lambda (condition stream) + (declare (ignore condition)) + ;; TODO Better error msg + (format stream "No suitable decoder was found")))) (defun decode (byte-array) (flexi-streams:with-input-from-sequence (stream byte-array) @@ -484,9 +494,7 @@ (funcall (if *decode-bin-as-string* #'decode-string #'decode-byte-array) (load-big-endian stream 2) stream)) ((= #xc6 byte) (funcall (if *decode-bin-as-string* #'decode-string #'decode-byte-array) (load-big-endian stream 4) stream)) - (t (error - (format nil - "Cannot decode ~a (maybe you should bind *extended-types*?)" byte)))))) + (t (error 'decode-no-suitable-decoder))))) (defun decode-rational (stream) (let ((numerator (decode-stream stream)) From d5404559d53e399ea8d81d3b5ca82f96d6deab17 Mon Sep 17 00:00:00 2001 From: Mark Skilbeck Date: Sun, 24 Feb 2019 18:07:39 -0800 Subject: [PATCH 4/5] Add tests for encoding/decoding extension types --- tests.lisp | 49 ++++++++++++++++++++++--------------------------- 1 file changed, 22 insertions(+), 27 deletions(-) diff --git a/tests.lisp b/tests.lisp index f2a517b..e5814a5 100644 --- a/tests.lisp +++ b/tests.lisp @@ -145,12 +145,28 @@ encode properly." 0 5))))) (test extension-types - "Test that extended types are encoded properly." - (let ((mpk:*extended-types* - (mpk:define-extension-types - '(7 type1)))) - (is (equalp #(#xC7 #x01 #x07 #x09) - (mpk:encode (make-instance 'type1 'messagepack-sym:id 9)))))) + "Test that extended types are encoded and decoded properly." + (labels ((complex-encoder (data stream) + (mpk::encode-fixext-8 (append (flexi-streams:with-output-to-sequence (s :as-list t) (mpk::encode-float (realpart data) s t)) + (flexi-streams:with-output-to-sequence (s :as-list t) (mpk::encode-float (imagpart data) s t))) + stream + 0)) + (complex-decoder (len stream) + (complex (sb-kernel:make-single-float (mpk::ub32->sb32 (mpk::load-big-endian stream 4))) + (sb-kernel:make-single-float (mpk::ub32->sb32 (mpk::load-big-endian stream 4)))))) + (let ((data (list #C(0.2 0.8) + #(#C(0.2 0.8) + #C(0.5 0.5))))) + (setf mpk::*extension-dispatchers* (make-hash-table)) + (loop for val in data do + (signals mpk::encode-no-suitable-encoder (mpk:encode val))) + + (signals mpk::decode-no-suitable-decoder (mpk:decode #(215 0 62 76 204 205 63 76 204 205))) + + (mpk:register-extension-dispatcher 0 #'complexp #'complex-encoder #'complex-decoder) + (loop for val in data do + (is (equalp val + (mpk:decode (mpk:encode val)))))))) (test decoding-integers "Test that (equalp (decode (encode data)) data) for integers (that @@ -258,27 +274,6 @@ tables that have #'equalp as test." (is (equalp medium-map (mpk:decode (mpk:encode medium-map)))) (is (equalp big-map (mpk:decode (mpk:encode big-map)))))) -(test extension-types-decoding - "Test that extended types are decoded properly." - (dolist (test '((:byte-array #(100 200 250 5) #(100 14 1 200)) - (:numeric 27 100))) - (destructuring-bind (encoding-type id1 id2) test - (let ((mpk:*extended-types* - (mpk:define-extension-types - `(,encoding-type 120 typea typeb))) - (mpk:*lookup-table* (mpk:make-lookup-table))) - (let* ((a1 (make-instance 'typea 'messagepack-sym:id id1)) - (a2 (make-instance 'typea 'messagepack-sym:id id2)) - (b1 (make-instance 'typeb 'messagepack-sym:id id1))) - (is (eq (mpk:decode (mpk:encode a1)) a1)) - (is (eq (mpk:decode (mpk:encode a2)) a2)) - (is (eq (mpk:decode (mpk:encode b1)) b1)) - (is (eq (mpk:decode (mpk:encode a1)) (mpk:decode (mpk:encode a1)))) - (is (eq (mpk:decode (mpk:encode a2)) (mpk:decode (mpk:encode a2)))) - (is (not (eq (mpk:decode (mpk:encode a1)) (mpk:decode (mpk:encode a2))))) - (is (not (eq (mpk:decode (mpk:encode b1)) (mpk:decode (mpk:encode a1))))) - (is (not (eq (mpk:decode (mpk:encode b1)) (mpk:decode (mpk:encode a2)))))))))) - (test decoding-maps-to-alists "Tests that decoding maps to alists works as expected." (let ((mpk:*decoder-prefers-alists* t)) From 55f41c0efe29c52343025d72126e0ffc0ce6fa3b Mon Sep 17 00:00:00 2001 From: Mark Skilbeck Date: Sun, 24 Feb 2019 18:07:54 -0800 Subject: [PATCH 5/5] Fix missing package name --- benchmark.lisp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/benchmark.lisp b/benchmark.lisp index 9789098..f6d5978 100644 --- a/benchmark.lisp +++ b/benchmark.lisp @@ -45,8 +45,8 @@ (json:encode-json test str))) (json:decode-json str)))) - (time (setf encoded-msgpack (encode test))) - (time (length (decode encoded-msgpack))) - (time (length (decode (encode test)))) + (time (setf encoded-msgpack (mpk:encode test))) + (time (length (mpk:decode encoded-msgpack))) + (time (length (mpk:decode (mpk:encode test)))) (values)))