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))) diff --git a/cl-messagepack.lisp b/cl-messagepack.lisp index 84a9961..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))) @@ -110,6 +116,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,13 +171,10 @@ (encode-hash data stream)) ((symbolp data) (encode-symbol data stream)) - ((and *extended-types* - (typep data 'extension-type) - (try-encode-ext-type data stream)) - t) - (t (error - (format nil - "Cannot encode data ~a (maybe you should bind *extended-types*?)." data))))) + ((and *extension-dispatchers* + (dispatcher-for-extension-data data)) + (funcall (encoder-for-extension-data data) data stream)) + (t (error 'encode-no-suitable-encoder)))) (defun encode-rational (data stream) (labels ((encode-bignum (data) @@ -312,6 +320,69 @@ (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) + (unless (gethash type *extension-dispatchers*) + (error 'decode-no-suitable-decoder)) + (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 @@ -330,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) @@ -357,22 +433,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) @@ -414,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)) @@ -480,169 +558,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*)) 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)) 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))