diff --git a/README.md b/README.md index 5445795..1d6eafb 100644 --- a/README.md +++ b/README.md @@ -65,18 +65,25 @@ Building The Thrift Common Lisp library is packaged as the ASDF[[1]] system `thrift`. It depends on the systems -* puri-ppcre[[2]] : for the thrift uri class +* puri[[2]] : for the thrift uri class * closer-mop[[3]] : for class metadata * trivial-utf-8[[4]] : for string codecs +* usocket[[5]] : for the socket transport +* ieee-floats[[6]] : for conversion between ints and floats +* trivial-gray-streams[[7]] : an abstraction layer for gray streams +* alexandria[[8]] : handy utilities -In order to build it, register those systems with ASDF and evaluate +The dependencies are bundled for local builds of tests and tutorial binaries - +it is possible to use those bundles to load the library, too. + +In order to build it, register those systems with ASDF and evaluate: (asdf:load-system :thrift) This will compile and load the Lisp compiler for Thrift definition files, the transport and protocol implementations, and the client and server interface functions. In order to use Thrift in an application, one must also author and/or -load the interface definitions for the remote service.[[5]] If one is implementing a service, +load the interface definitions for the remote service.[[9]] If one is implementing a service, one must also define the actual functions to which Thrift is to act as the proxy interface. The remainder of this document follows the Thrift tutorial to illustrate how to perform the steps @@ -95,29 +102,35 @@ Implement the Service --------------------- The tutorial comprises serveral functions: `add`, `ping`, `zip`, and `calculate`. -Each translatd IDL corresponds to three packages. In this case, the packages +Each translated IDL file generates three packages for every service. In the case of +the tutorial file, the relevant packages are: - * :tutorial - * :tutorial-implementation - * :tutorial-response + * tutorial.calculator + * tutorial.calculator-implementation + * tutorial.calculator-response + +This is to separate the request (generated), response (generated) and implementation +(meant to be implemented by the programmer) functions for defined Thrift methods. -The first package is for the service implementation. +It is suggested to work in the `tutorial-implementation` package while implementing +the services - it imports the `common-lisp` package, while the service-specific ones +don't (to avoid conflicts between Thrift method names and function names in `common-lisp`). ;; define the base operations (in-package :tutorial-implementation) - (defun add ( num1 num2) + (defun tutorial.calculator-implementation:add (num1 num2) (format t "~&Asked to add ~A and ~A." num1 num2) (+ num1 num2)) - (defun ping () + (defun tutorial.calculator-implementation:ping () (print :ping)) - (defun zip () + (defun tutorial.calculator-implementation:zip () (print :zip)) - (defun calculate (logid task) + (defun tutorial.calculator-implementation:calculate (logid task) (calculate-op (work-op task) (work-num1 task) (work-num2 task))) (defgeneric calculate-op (op arg1 arg2) @@ -141,32 +154,22 @@ The first package is for the service implementation. Translate the Thrift IDL ------------------------ -IDL files employ the file type `thrift`. In this case, there are two files to translate +IDL files employ the file extension `thrift`. In this case, there are two files to translate * `tutorial.thrift` * `shared.thrift` As the former includes the latter, one uses it to generate the interfaces: - $THRIFT/bin/thrift -O ./ --gen cl $THRIFT/tutorial/tutorial.thrift - -For the moment, the Lisp backend is present here as #P"THRIFT:compiler;cpp;src;generate;t_cl_generator.cc". -In order to use it, copy that file into the analogous location in the Thrift release tree prior to -making thrift. + $THRIFT/bin/thrift -r --gen cl $THRIFT/tutorial/tutorial.thrift + +`-r` stands for recursion, while `--gen` lets one choose the language to translate to. Load the Lisp translated service interfaces ------------------------------------------- -The translator generates two files for each IDL file. For example `tutorial-types.lisp` and -`tutorial-vars.lisp`. As the parameter definitions may istantiate objects defined in the `-types` -file, the ASDF dependencies must reflect this constraint. For the tutorial, the system could be -defined as - - (asdf:defsystem :thrift-tutorial - :depends-on (:thrift) - :serial t - :components ((:file "tutorial") - (:file "tutorial-types") - (:file "tutorial-vars"))) +The translator generates three files for each IDL file. For example `tutorial-types.lisp`, +`tutorial-vars.lisp` and an `.asd` file that can be used to load them both and pull in +other includes (like `shared` within the tutorial) as dependencies. Run a Server for the Service @@ -189,39 +192,28 @@ Use a Client to Access the Service Remotely [in some other process] run the client (in-package :cl-user) - (use-package :tutorial-request) (macrolet ((show (form) `(format *trace-output* "~%~s =>~{ ~s~}" ',form (multiple-value-list (ignore-errors ,form))))) (with-client (protocol #u"thrift://127.0.0.1:9091") - (show (ping protocol)) - (show (add protocol 1 2)) - (show (add protocol 1 4)) + (show (tutorial.calculator:ping protocol)) + (show (tutorial.calculator:add protocol 1 2)) + (show (tutorial.calculator:add protocol 1 4)) - (show (shared:get-struct protocol 1)) - - (let ((task (make-instance 'work + (let ((task (make-instance 'tutorial:work :op operation.subtract :num1 15 :num2 10))) - (show (calculate protocol task)) + (show (tutorial.calculator:calculate protocol 1 task)) + + (setf (tutorial:work-op task) operation.divide + (tutorial:work-num1 task) 1 + (tutorial:work-num2 task) 0) + (show (tutorial.calculator:calculate protocol 1 task))) - (setf (work-op task) operation.divide - (work-num1 task) 1 - (work-num2 task) 0) - (show (calculate protocol task))) + (show (shared.shared-service:get-struct protocol 1)) (show (zip protocol)))) - - -Status -====== - -The initial library version serves as an interface to Cassandra[[6]] in order to provide access to -Datagraph's Cassandra-based RDF store[[7]]. The code evolved from an initial version which had been -submitted to Thift in 2008[[8]]. - -A demonstration of access through the Cassandra API is among the READMES[[9]]. Issues ------ @@ -231,17 +223,6 @@ Issues initform for the slot and the encoding operator skips an unbound slot. This leave some ambiguity with bool fields. -### namespace - package equivalence - The IDL specifies a single namespace. The Lisp binding uses - three: the implementation, the request interface, and the response interface. - The current pattern is: - - * _namespace_ : request proxy function, structure types and accessors, exception types, - enum types, constants; use `:thrift` - * _namespace_`-implementation` : implementation function, use `:thrift`, use _namespace_, but - shadow all implementation function names. - * _namespace_`-response` : response functions - ### instantiation protocol : struct classes are standard classes and exception classes are whatever the implementation prescribes. decoders apply make-struct to an initargs list. @@ -249,7 +230,6 @@ Issues with direct side-effects on slot-values ### maps: - Maps are now represented as hash tables. As data through the call/reply interface is all statically typed, it is not necessary for the objects to themselves indicate the coding form. Association lists would be sufficient. As the key type is arbitrary, property lists offer no additional convenience: @@ -261,8 +241,13 @@ Issues [2]: http://github.com/lisp/com.b9.puri.ppcre [3]: www.common-lisp.net/closer-mop [4]: trivial-utf-8 - [5]: http://wiki.apache.org/thrift/ThriftGeneration - [6]: http://wiki.apache.org/cassandra/FrontPage - [7]: http://github.com/bendiken/rdf-cassandra - [8]: http://markmail.org/thread/4tfa3zbweyg2qwne: thrift jira lisp issue - [9]: ./READMES/readme-cassandra.lisp + [5]: https://github.com/usocket/usocket + [6]: https://github.com/marijnh/ieee-floats + [7]: https://github.com/trivial-gray-streams/trivial-gray-streams + [8]: https://gitlab.common-lisp.net/alexandria/alexandria + [9]: http://wiki.apache.org/thrift/ThriftGeneration + +* usocket[[5]] : for the socket transport +* ieee-floats[[6]] : for conversion between ints and floats +* trivial-gray-streams[[7]] : an abstraction layer for gray streams +* alexandria[[8]] : handy utilities diff --git a/READMES/readme-cassandra.lisp b/READMES/readme-cassandra.lisp index c122267..72744ea 100644 --- a/READMES/readme-cassandra.lisp +++ b/READMES/readme-cassandra.lisp @@ -1,8 +1,6 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*- - (in-package :cl-user) -#+(or ccl sbcl sbcl) /development/source/library/ +#+(or ccl sbcl) /development/source/library/ (load "build-init.lisp") ;;; ! first, select the api version in the cassandra system definition diff --git a/binary-protocol.lisp b/binary-protocol.lisp index 9ad1f08..b36c6af 100644 --- a/binary-protocol.lisp +++ b/binary-protocol.lisp @@ -1,27 +1,25 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- - -(in-package :org.apache.thrift.implementation) - -;;; This file defines the concrete `binary-protocol` layer for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. +(in-package #:org.apache.thrift.implementation) + +;;;; This file defines the concrete `binary-protocol` layer for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. ;;; ;;; classes @@ -30,11 +28,9 @@ ((field-id-mode :initform :identifier-number :allocation :class) (struct-id-mode :initform :none :allocation :class)) (:default-initargs - :version-id #x80 + :version-id #x80 :version-number #x01)) - - ;;; ;;; type code <-> name operators are specific to each protocol @@ -42,7 +38,6 @@ (or (car (rassoc type-code *binary-transport-types* :test #'eql)) (error "Invalid type code: ~s." type-code))) - (defmethod type-name-code ((protocol binary-protocol) (type-name symbol)) (or (cdr (assoc type-name *binary-transport-types*)) (error "Invalid type name: ~s." type-name))) @@ -59,7 +54,6 @@ (or (car (rassoc type-code *binary-message-types* :test 'eql)) (error "Invalid message type code: ~s." type-code))) - ;;; input (defmethod stream-read-type ((protocol binary-protocol)) @@ -72,7 +66,7 @@ (defmethod stream-read-bool ((protocol binary-protocol)) (= (stream-read-byte (protocol-input-transport protocol)) 1)) -(defmethod stream-read-i08 ((protocol binary-protocol)) +(defmethod stream-read-i8 ((protocol binary-protocol)) (stream-read-byte (protocol-input-transport protocol))) (macrolet ((read-and-decode-integer (protocol byte-count &aux (bit-count (* byte-count 8))) @@ -81,46 +75,39 @@ (declare (dynamic-extent buffer) (type (simple-array (unsigned-byte 8) (,byte-count)) buffer) (type (unsigned-byte ,(* byte-count 8)) value)) - (stream-read-sequence (protocol-input-transport ,protocol) buffer) + (stream-read-sequence (protocol-input-transport ,protocol) buffer 0 nil) ,@(loop for i from 0 below byte-count - collect `(setf value ,(if (= i 0) - `(aref buffer ,i) - `(+ (ash value 8) (aref buffer ,i))))) + collect `(setf value ,(if (= i 0) + `(aref buffer ,i) + `(+ (ash value 8) (aref buffer ,i))))) ;; (format *trace-output* "(in 0x~16,'0x)" value) (,(cons-symbol :org.apache.thrift.implementation :signed-byte- (prin1-to-string bit-count)) value)))) (defmethod stream-read-i16 ((protocol binary-protocol)) (read-and-decode-integer protocol 2)) - + (defmethod stream-read-i32 ((protocol binary-protocol)) (read-and-decode-integer protocol 4)) (defmethod stream-read-i64 ((protocol binary-protocol)) (read-and-decode-integer protocol 8))) - (defmethod stream-read-double ((protocol binary-protocol)) - #+allegro (let* ((buffer (make-array 8 :element-type *binary-transport-element-type*)) - (b (stream-read-sequence protocol buffer))) - (declare (dynamic-extent buffer)) - (apply #'excl:shorts-to-double-float - (mapcar #'bytes-int (list (subseq b 0 2) (subseq b 2 4) - (subseq b 4 6) (subseq b 6 8))))) - #-allegro (let ((value 0) - (buffer (make-array 8 :element-type '(unsigned-byte 8)))) - (declare (dynamic-extent buffer) - (type (simple-array (unsigned-byte 8) (8)) buffer) - (type (unsigned-byte 64) value)) - (stream-read-sequence (protocol-input-transport protocol) buffer) - ;; it it matters, could unwrap it with fewer intermediates saves - (macrolet ((unpack-buffer () - `(progn - ,@(loop for i from 0 below 8 - collect `(setf value ,(if (= i 0) - `(aref buffer ,i) - `(+ (ash value 8) (aref buffer ,i)))))))) - (unpack-buffer) - (ieee-754-64-integer-to-float value)))) + (let ((value 0) + (buffer (make-array 8 :element-type '(unsigned-byte 8)))) + (declare (dynamic-extent buffer) + (type (simple-array (unsigned-byte 8) (8)) buffer) + (type (unsigned-byte 64) value)) + (stream-read-sequence (protocol-input-transport protocol) buffer 0 nil) + ;; it it matters, could unwrap it with fewer intermediates saves + (macrolet ((unpack-buffer () + `(progn + ,@(loop for i from 0 below 8 + collect `(setf value ,(if (= i 0) + `(aref buffer ,i) + `(+ (ash value 8) (aref buffer ,i)))))))) + (unpack-buffer) + (ieee-floats:decode-float64 value)))) (defmethod stream-read-float ((protocol binary-protocol)) "As a special for for use with rdf - not part of the thrift. used just for specifically @@ -131,26 +118,24 @@ (declare (dynamic-extent buffer) (type (simple-array (unsigned-byte 8) (4)) buffer) (type (unsigned-byte 32) value)) - (stream-read-sequence (protocol-input-transport protocol) buffer) + (stream-read-sequence (protocol-input-transport protocol) buffer 0 nil) ;; it it matters, could unwrap it with fewer intermediates saves (macrolet ((unpack-buffer () `(progn ,@(loop for i from 0 below 4 - collect `(setf value ,(if (= i 0) - `(aref buffer ,i) - `(+ (ash value 8) (aref buffer ,i)))))))) + collect `(setf value ,(if (= i 0) + `(aref buffer ,i) + `(+ (ash value 8) (aref buffer ,i)))))))) (unpack-buffer) - (ieee-754-32-integer-to-float value)))) + (ieee-floats:decode-float32 value)))) - (defmethod stream-read-string ((protocol binary-protocol)) (let* ((l (stream-read-i32 protocol)) (a (make-array l :element-type *binary-transport-element-type*))) (declare (dynamic-extent a)) - (stream-read-sequence (protocol-input-transport protocol) a) + (stream-read-sequence (protocol-input-transport protocol) a 0 nil) (funcall (transport-string-decoder protocol) a))) - (defmethod stream-read-binary ((protocol binary-protocol)) "Read an 'unencoded' binary array. Although the spec describes a 'byte' array, and elsewhere specifies bytes to be signed, that makes no @@ -160,15 +145,11 @@ (let* ((l (stream-read-i32 protocol)) (result (make-array l :element-type *binary-transport-element-type*))) ;; would need to check the length before trying stack allocation - (stream-read-sequence (protocol-input-transport protocol) result) + (stream-read-sequence (protocol-input-transport protocol) result 0 nil) result)) - - - ;;; output - (defmethod stream-write-type ((protocol binary-protocol) type-name) (stream-write-byte (protocol-output-transport protocol) (type-name-code protocol type-name)) 1) @@ -176,18 +157,14 @@ (defmethod stream-write-message-type ((protocol binary-protocol) message-type-name) (stream-write-i16 protocol (message-type-code protocol message-type-name))) - - (defmethod stream-write-bool ((protocol binary-protocol) val) (stream-write-byte (protocol-output-transport protocol) (if val 1 0)) 1) - -(defmethod stream-write-i08 ((protocol binary-protocol) val) +(defmethod stream-write-i8 ((protocol binary-protocol) val) (stream-write-byte (protocol-output-transport protocol) val) 1) - (macrolet ((encode-and-write-integer (protocol value byte-count) `(let ((buffer (make-array ,byte-count :element-type '(unsigned-byte 8)))) (declare (dynamic-extent buffer) @@ -197,9 +174,9 @@ (locally (declare (type (signed-byte ,(* byte-count 8)) ,value)) ;; (format *trace-output* "~%(out 0x~16,'0x)" ,value) ,@(loop for i from (1- byte-count) downto 0 - append `((setf (aref buffer ,i) (logand #xff ,value)) - (setf ,value (ash ,value -8)))) - (stream-write-sequence (protocol-output-transport ,protocol) buffer) + append `((setf (aref buffer ,i) (logand #xff ,value)) + (setf ,value (ash ,value -8)))) + (stream-write-sequence (protocol-output-transport ,protocol) buffer 0 nil) ,byte-count)))) ;; no sign conversion as shift&mask encodes the sign bit (defmethod stream-write-i16 ((protocol binary-protocol) val) @@ -211,76 +188,68 @@ (defmethod stream-write-i64 ((protocol binary-protocol) val) (encode-and-write-integer protocol val 8))) - (defmethod stream-write-double ((protocol binary-protocol) val) - #+allegro (dolist (b (mapcar #'(lambda (x) (int-bytes x 2)) - (multiple-value-list (excl:double-float-to-shorts - (coerce val 'double-float))))) - (stream-write-byte protocol b)) ;; distinct from i64, as it's unsigned - #-allegro (let ((buffer (make-array 8 :element-type '(unsigned-byte 8))) - (int-value (ieee-754-64-float-to-integer val))) - (declare (dynamic-extent buffer) - (type (simple-array (unsigned-byte 8) (8)) buffer) - (type (unsigned-byte 64) int-value)) - ;; if the conversion is correct, this is redundant, sbcl eliminate it - (assert (typep int-value '(unsigned-byte 64)) () - 'type-error :datum int-value :expected-type '(unsigned-byte 64)) - ;; (format *trace-output* "~%(out 0x~16,'0x)" int-value) - (macrolet ((pack-buffer () - `(progn ,@(loop for i from 7 downto 0 - append `((setf (aref buffer ,i) (logand #xff int-value)) - (setf int-value (ash int-value -8))))))) - (pack-buffer)) - (stream-write-sequence (protocol-output-transport protocol) buffer) - 8)) + (let ((buffer (make-array 8 :element-type '(unsigned-byte 8))) + (int-value (ieee-floats:encode-float64 val))) + (declare (dynamic-extent buffer) + (type (simple-array (unsigned-byte 8) (8)) buffer) + (type (unsigned-byte 64) int-value)) + ;; if the conversion is correct, this is redundant, sbcl eliminate it + (assert (typep int-value '(unsigned-byte 64)) () + 'type-error :datum int-value :expected-type '(unsigned-byte 64)) + ;; (format *trace-output* "~%(out 0x~16,'0x)" int-value) + (macrolet ((pack-buffer () + `(progn ,@(loop for i from 7 downto 0 + append `((setf (aref buffer ,i) (logand #xff int-value)) + (setf int-value (ash int-value -8))))))) + (pack-buffer)) + (stream-write-sequence (protocol-output-transport protocol) buffer 0 nil) + 8)) (defmethod stream-write-float ((protocol binary-protocol) val) " Not part of the spec, but is useful elsewhere" ;; distinct from i34, as it's unsigned (let ((buffer (make-array 4 :element-type '(unsigned-byte 8))) - (int-value (ieee-754-32-float-to-integer val))) + (int-value (ieee-floats:encode-float32 val))) (declare (dynamic-extent buffer) (type (simple-array (unsigned-byte 8) (4)) buffer) (type (unsigned-byte 32) int-value)) ;; if the conversion is correct, this is redundant, sbcl eliminate it - (assert (typep int-value '(unsigned-byte 32)) () - 'type-error :datum int-value :expected-type '(unsigned-byte 64)) + (assert (typep int-value '(unsigned-byte 32)) ()) ;; (format *trace-output* "~%(out 0x~16,'0x)" int-value) (macrolet ((pack-buffer () `(progn ,@(loop for i from 3 downto 0 - append `((setf (aref buffer ,i) (logand #xff int-value)) - (setf int-value (ash int-value -8))))))) + append `((setf (aref buffer ,i) (logand #xff int-value)) + (setf int-value (ash int-value -8))))))) (pack-buffer)) - (stream-write-sequence (protocol-output-transport protocol) buffer) + (stream-write-sequence (protocol-output-transport protocol) buffer 0 nil) 4)) - (defmethod stream-write-string ((protocol binary-protocol) (string string) &optional (start 0) end) (assert (and (zerop start) (or (null end) (= end (length string)))) () "Substring writes are not supported.") (let ((bytes (funcall (transport-string-encoder protocol) string))) (stream-write-i32 protocol (length bytes)) - (stream-write-sequence (protocol-output-transport protocol) bytes) + (stream-write-sequence (protocol-output-transport protocol) bytes 0 nil) (+ 4 (length bytes)))) (defmethod stream-write-string ((protocol binary-protocol) (bytes vector) &optional (start 0) end) (assert (and (zerop start) (or (null end) (= end (length bytes)))) () "Substring writes are not supported.") (stream-write-i32 protocol (length bytes)) - (stream-write-sequence (protocol-output-transport protocol) bytes) + (stream-write-sequence (protocol-output-transport protocol) bytes 0 nil) (+ 4 (length bytes))) - (defmethod stream-write-binary ((protocol binary-protocol) (bytes vector)) (let ((unsigned-bytes (make-array (length bytes) :element-type '(unsigned-byte 8)))) (stream-write-i32 protocol (length bytes)) (map-into unsigned-bytes #'unsigned-byte-8 bytes) - (stream-write-sequence (protocol-output-transport protocol) unsigned-bytes) + (stream-write-sequence (protocol-output-transport protocol) unsigned-bytes 0 nil) (+ 4 (length bytes)))) (defmethod stream-write-binary ((protocol binary-protocol) (string string)) (let ((bytes (funcall (transport-string-encoder protocol) string))) (stream-write-i32 protocol (length bytes)) - (stream-write-sequence (protocol-output-transport protocol) bytes) + (stream-write-sequence (protocol-output-transport protocol) bytes 0 nil) (+ 4 (length bytes)))) diff --git a/classes.lisp b/classes.lisp index e4b334a..bc19c94 100644 --- a/classes.lisp +++ b/classes.lisp @@ -1,27 +1,25 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- - -(in-package :org.apache.thrift.implementation) - -;;; This file defines the abstract and metaclass definitions for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. +(in-package #:org.apache.thrift.implementation) + +;;;; This file defines the abstract and metaclass definitions for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. ;;; The thrift-class metaclass manages struct field definitions, which are used to generate @@ -32,7 +30,6 @@ ;;; The abstract metaclass is specialized as thrift-struct-class and thrift-exception-class ;;; to allow for different instantiation protocols for standard objects and conditions. - (defclass thrift-class (standard-class) ((identifier :reader class-identifier @@ -58,8 +55,6 @@ a standard exception class. The former sesrves to model the extended slot descrition, and the latter to make conditions.")) - - (defclass thrift-object () () (:documentation "The abstract root class of all struct instances.")) @@ -76,7 +71,6 @@ :reader field-definition-optional :documentation "To be used to suppress unbound slots when serializing. NYI, as the IDL translator does not provide the data."))) - (defclass direct-field-definition (field-definition c2mop:standard-direct-slot-definition) ((identifier-number :initform (error "identifier-number is required.")) @@ -87,38 +81,6 @@ ((reader :reader field-definition-reader))) - -;;; the specialized generic function classes -;;; now serve just to document the relation between the external identifier and the function -;;; all information is compiled statically into the request/response function definitions. - -(defclass thrift-generic-function (standard-generic-function) - ((identifier - :initarg :identifier - :reader generic-function-identifier)) - (:metaclass c2mop:funcallable-standard-class) - (:documentation "The abstract mixin for thrift interface operators which binds the external name.")) - - -(defclass thrift-request-function (thrift-generic-function) - () - (:metaclass c2mop:funcallable-standard-class) - (:documentation "The class of thrift request operators. Each acts as a proxy for an external - operator, encodes and manages the request/response exchange and returns the result value or signals - an exception - as per the response message.")) - - -(defclass thrift-response-function (thrift-generic-function) - ((implementation-function - :initarg :implementation-function - :reader generic-function-implementation-function)) - (:metaclass c2mop:funcallable-standard-class) - (:documentation "The class of thrift response operators. Each wraps the invocation of a base - implemntation operator with a mechanism to decode the arguments for application, to encode - the results as a 'reply' response message, and to catch exceptions and encode them as an - 'exception' response message.")) - - ;;; ;;; thrift-class operators @@ -131,12 +93,10 @@ (defmethod thrift:type-of ((value thrift-object)) 'struct) - (defmethod make-instance ((class thrift-exception-class) &rest initargs) (declare (dynamic-extent initargs)) (apply #'make-condition (class-condition-class class) initargs)) - (defgeneric find-thrift-class (name &optional errorp) (:documentation "Return a class registered by identifier name. If none is registered, if signal an error if errorp is true. Otherwise return nil.") @@ -153,14 +113,13 @@ (errorp (error "thrift-class not found: ~s" name))))) - (defgeneric (setf find-thrift-class) (class name) (:documentation "Register a classe according to identifier string. Given nil, delete the entry.") (:method ((object t) (identifier string)) (warn "FIX ME: transform the identifier into a global name: ~s." identifier) (setf (find-thrift-class (str-sym identifier)) object)) - + (:method ((class thrift-class) (name symbol)) (setf (gethash name *thrift-classes*) class)) @@ -168,11 +127,9 @@ (:method ((class null) (name symbol)) (remhash name *thrift-classes*))) - (defmethod initialize-instance :after ((class thrift-class) &key (identifier (class-name class))) (initialize-class-identifier class identifier)) - (defmethod reinitialize-instance :after ((class thrift-class) &key identifier ) (when identifier (initialize-class-identifier class identifier))) @@ -180,13 +137,10 @@ (defmethod initialize-instance :after ((class thrift-exception-class) &key condition-class) (initialize-class-condition-class class condition-class)) - (defmethod reinitialize-instance :after ((class thrift-exception-class) &key condition-class ) (when condition-class (initialize-class-condition-class class condition-class))) - - (defun initialize-class-identifier (class identifier) (loop (etypecase identifier ;; initialize instance asserts a value, reinitial does not @@ -207,7 +161,6 @@ (cons (setf condition-class (first condition-class)))))) - (defgeneric class-identifier (class) (:documentation "Return the external name for the given class. Given a designator (the class name of an instance), delegate to the class. Given an external name (a string) return it.") @@ -223,7 +176,7 @@ (class-identifier (find-class class-name))) (:method ((identifier string)) identifier)) - + ;;; 20110402 : lw does not allow for standard argument keys, thus the &allow-other-keys here (defmethod c2mop:direct-slot-definition-class ((class thrift-class) &key identifier (identifier-name identifier) @@ -257,7 +210,6 @@ (setf (slot-value sd 'optional) (some #'field-definition-optional direct-slots)))) sd)) - (defgeneric field-definition-identifier (field-definition) (:method ((fd cl:list)) ;; for use in macros @@ -267,7 +219,6 @@ "Provide a base method which returns nil to permit filtering all definitions." nil)) - (defgeneric field-definition-identifier-number (field-definition) (:method ((fd cl:list)) ;; for use in macros @@ -285,13 +236,11 @@ (:method ((sd c2mop:slot-definition)) "Provide a base method which returns nil to permit filtering all definitions." nil)) - (defgeneric field-definition-initarg (field-definition) (:method ((sd c2mop:slot-definition)) (first (c2mop:slot-definition-initargs sd)))) - (defgeneric field-definition-name (field-definition) (:method ((fd cl:list)) ;; for use in macros @@ -305,12 +254,10 @@ (:method ((sd c2mop:slot-definition)) (c2mop:slot-definition-name sd))) - (defgeneric field-definition-reader (field-definition) (:method ((sd c2mop:direct-slot-definition)) (first (c2mop:slot-definition-readers sd)))) - (defgeneric field-definition-type (field-definition) (:method ((fd cl:list)) ;; for use in macros @@ -330,18 +277,17 @@ 'bool literal-type)) (signed-byte (ecase (second literal-type) - (8 'i08) + (8 'i8) (16 'i16) (32 'i32) (64 'i64))) ((array vector) 'binary) (t literal-type))))))) - (defgeneric class-field-definitions (class) (:method ((class symbol)) (class-field-definitions (find-class class))) - + (:method ((class thrift-class)) (unless (c2mop:class-finalized-p class) (c2mop:finalize-inheritance class)) @@ -364,7 +310,6 @@ (class-field-definitions (cons-symbol (symbol-package (class-name class)) (class-name class) :-thrift-class)) nil))) - ;;; ;;; instantiation : provide specialized make- operators which use make-instance or make-condition ;;; as per metaclass type @@ -380,7 +325,7 @@ (:method ((class thrift-exception-class) &rest initargs) (declare (dynamic-extent initargs)) - (apply #'make-condition class initargs))) + (apply #'make-condition (class-condition-class class) initargs))) (defgeneric struct-name (class) (:method ((class class)) @@ -389,13 +334,3 @@ (class-name class)) (:method ((class thrift-exception-class)) (class-condition-class class))) - - -;;; -;;; exceptions - -(defmethod unknown-field ((class thrift-class) (name t) (id t) (type t) (value t)) - "The default method for thrift classes does nothing, which is intended to leave the final - disposition to the protocol." - - nil) diff --git a/client.lisp b/client.lisp index 9891b22..b0d9e3c 100644 --- a/client.lisp +++ b/client.lisp @@ -1,29 +1,25 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- - -(in-package :org.apache.thrift.implementation) - -;;; This file defines client operators for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. - +(in-package #:org.apache.thrift.implementation) +;;;; This file defines client operators for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. (defgeneric client (location &key protocol direction element-type &allow-other-keys) (:method ((location puri:uri) &rest initargs &key (direction :io) (element-type 'unsigned-byte et-s) &allow-other-keys) @@ -51,19 +47,25 @@ (setf initargs (copy-list initargs)) (remf initargs :protocol)) (apply #'make-instance protocol - :input-transport (thrift:protocol-input-transport protocol) - :output-transport (thrift:protocol-output-transport protocol) + :input-transport (thrift:protocol-input-transport instance) + :output-transport (thrift:protocol-output-transport instance) :direction direction initargs)) (:method ((instance binary-transport) &rest initargs - &key (protocol 'binary-protocol p-s) (direction (stream-direction instance)) &allow-other-keys) + &key (framed nil f-s) (protocol 'binary-protocol p-s) + (direction (stream-direction instance)) &allow-other-keys) (when p-s (setf initargs (copy-list initargs)) (remf initargs :protocol)) - (apply #'make-instance protocol :transport instance :direction direction - initargs))) - + (when f-s + (setf initargs (copy-list initargs)) + (remf initargs :framed)) + (let ((transport (if framed + (framed-transport instance) + instance))) + (apply #'make-instance protocol :transport transport :direction direction + initargs)))) (defmacro with-client ((protocol &rest args) &body body) (with-gensyms (op) @@ -71,10 +73,9 @@ (declare (dynamic-extent #',op)) (call-with-client #',op ,@args)))) - (defun call-with-client (op &rest args) (declare (dynamic-extent args)) (let ((protocol (apply #'client args))) (unwind-protect (funcall op protocol) (when (open-stream-p protocol) - (close protocol))))) \ No newline at end of file + (close protocol))))) diff --git a/conditions.lisp b/conditions.lisp index e2f0af4..00b4e04 100644 --- a/conditions.lisp +++ b/conditions.lisp @@ -1,52 +1,49 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- - -(in-package :org.apache.thrift.implementation) - -;;; This file defines exception classes and signaling operators for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. - - -;;; The exception hierarchy is rooted in thrift-error and mixes in other standard -;;; conditions as appropriate for the excpetion attributes -;;; -;;; thrift-error -;;; - application-error -;;; - protocol-error -;;; - protocol-version-error -;;; - protocol-type-error (type-error) -;;; - unknown-field-error (cell-error) -;;; - field-type-error (type-error) -;;; - transport-error -;;; +(in-package #:org.apache.thrift.implementation) + +;;;; This file defines exception classes and signaling operators for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. + +;;;; The exception hierarchy is rooted in thrift-error and mixes in other standard +;;;; conditions as appropriate for the excpetion attributes +;;;; +;;;; thrift-error +;;;; - application-error +;;;; - protocol-error +;;;; - protocol-version-error +;;;; - protocol-type-error (type-error) +;;;; - unknown-field-error (cell-error) +;;;; - field-type-error (type-error) +;;;; - transport-error ;;; abstract exceptions -(define-condition thrift-error (simple-error) - ((type - :initform *protocol-ex-unknown* - :reader thrift-error-type)) - (:report (lambda (error stream) - (apply #'format stream (thrift-error-format-control error) - (thrift-error-format-arguments error))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-condition thrift-error (simple-error) + ((type + :initform *protocol-ex-unknown* + :reader thrift-error-type)) + (:report (lambda (error stream) + (apply #'format stream (thrift-error-format-control error) + (thrift-error-format-arguments error)))))) (defgeneric thrift-error-format-control (error) (:method ((error thrift-error)) @@ -56,11 +53,10 @@ (:method ((error thrift-error)) (list (type-of error) (thrift-error-type error)))) - - -(define-condition protocol-error (thrift-error) - ((protocol :initarg :protocol :initform nil - :reader protocol-error-protocol))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-condition protocol-error (thrift-error) + ((protocol :initarg :protocol :initform nil + :reader protocol-error-protocol)))) (defmethod thrift-error-format-control ((error protocol-error)) (concatenate 'string (call-next-method) @@ -70,15 +66,12 @@ (append (call-next-method) (list (protocol-error-protocol error)))) - - (define-condition transport-error (thrift-error) ()) - - -(define-condition application-error (protocol-error) - ((type :initform *application-ex-unknown*) - (condition :initform nil :initarg :condition :reader application-error-condition))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (define-condition application-error (protocol-error) + ((type :initform *application-ex-unknown*) + (condition :initform nil :initarg :condition :reader application-error-condition)))) (defmethod thrift-error-format-control ((error application-error)) (concatenate 'string (call-next-method) @@ -88,11 +81,9 @@ (append (call-next-method) (list (application-error-condition error)))) - (defmethod thrift:type-of ((value thrift-error)) 'struct) - ;;; ;;; general exception response @@ -117,8 +108,6 @@ (append (call-next-method) (list (class-not-found-error-identifier error)))) - - (define-condition protocol-version-error (protocol-error type-error) ((type :initform *protocol-ex-bad-version*))) @@ -130,9 +119,6 @@ (append (call-next-method) (list (type-error-datum error) (type-error-expected-type error)))) - - - (define-condition element-type-error (protocol-error type-error) ((type :initform *protocol-ex-invalid-data*) (element-type :initarg :element-type :reader element-type-error-element-type) @@ -148,8 +134,6 @@ (element-type-error-element-type error) (type-error-expected-type error)))) - - (define-condition enum-type-error (protocol-error type-error) ((type :initform *protocol-ex-invalid-data*))) @@ -161,8 +145,6 @@ (append (call-next-method) (list (type-error-datum error) (type-error-expected-type error)))) - - (define-condition field-size-error (protocol-error type-error cell-error) ((type :initform *protocol-ex-size-limit*) (number :initarg :number :reader field-size-error-number)) @@ -175,12 +157,10 @@ (defmethod thrift-error-format-arguments ((error field-size-error)) (append (call-next-method) (list (field-size-error-number error) - (cell-error-name error) + (cell-error-name error) (type-error-datum error) (type-error-expected-type error)))) - - (define-condition field-type-error (protocol-error type-error cell-error) ((type :initform *protocol-ex-invalid-data*) (structure-type :initarg :structure-type :reader field-type-error-structure-type) @@ -194,17 +174,14 @@ (append (call-next-method) (list (field-type-error-structure-type error) (field-type-error-number error) - (type-error-expected-type error) - (cell-error-name error) + (type-error-expected-type error) + (cell-error-name error) (type-error-datum error)))) - - (define-condition sequence-number-error (application-error) ((type :initform *application-ex-bad-sequence-id*) (number :initarg :number :reader sequence-number-error-number) (expected-number :initarg :expected-number :reader sequence-number-error-expected-number))) - (defmethod thrift-error-format-control ((error sequence-number-error)) (concatenate 'string (call-next-method) @@ -214,9 +191,6 @@ (append (call-next-method) (list (sequence-number-error-number error) (sequence-number-error-expected-number error)))) - - - (define-condition unknown-field-error (protocol-error cell-error) ((type :initform *protocol-ex-invalid-data*) (structure-type :initarg :structure-type :reader unknown-field-error-structure-type) @@ -230,12 +204,10 @@ (defmethod thrift-error-format-arguments ((error unknown-field-error)) (append (call-next-method) (list (unknown-field-error-structure-type error) - (unknown-field-error-number error) - (cell-error-name error) + (unknown-field-error-number error) + (cell-error-name error) (unknown-field-error-datum error)))) - - (define-condition unknown-method-error (protocol-error ) ((type :initform *application-ex-unknown-method*) (identifier :initarg :identifier :reader unknown-method-error-identifier) @@ -250,8 +222,6 @@ (list (unknown-method-error-identifier error) (unknown-method-error-request error)))) - - (define-condition struct-type-error (protocol-error type-error) ((type :initform *protocol-ex-invalid-data*))) diff --git a/definition-operators.lisp b/definition-operators.lisp index 8728088..e5c64b0 100644 --- a/definition-operators.lisp +++ b/definition-operators.lisp @@ -1,79 +1,89 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- +(in-package #:org.apache.thrift.implementation) + +;;;; This file defines the thrift IDL operators for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. + + +;;;; The Common Lisp backend for the Thrift IDL translator[[1]] +;;;; generates Lisp source code in terms of the following definition +;;;; operators: +;;;; +;;;; def-constant +;;;; def-eum +;;;; def-struct +;;;; def-exception +;;;; def-request-method +;;;; def-response-method +;;;; def-service +;;;; +;;;; The syntax resembles that of the standard Lisp operators. The +;;;; primary distinction is that identifiers are the original strings +;;;; from the Thrift IDL source. The macro operators canonicalize and +;;;; intern these according to the current package and read table +;;;; case. The original values are retained to use as method and class +;;;; names for encoding/decoding. +;;;; +;;;; The interface definitions can incorporate structures in variable +;;;; definitions, and the service definitions entail method +;;;; definitions, which in turn require structure definitions in order +;;;; to compile codecs in-line. This suggests the following file load +;;;; order and organization: +;;;; +;;;; -types.lisp : (generated) enums, structs, exceptions, services +;;;; -vars.lisp : (generated) constants +;;;; : (authored) the base function definitions +;;;; +;;;; The extra file for constants is required, as the generator emits +;;;; them before the structs. Each operation comprises three phases: +;;;; +;;;; * The client invokes a proxy to communicate with the +;;;; service. This sends a request message and interprets results. +;;;; * The service accepts messages and processes them with individual +;;;; operators which decode arguments, invoke the implementation +;;;; operator, and encode the response to return to the client. +;;;; * The implementation operator itself. +;;;; +;;;; The three operators are defined as homologues in three related packages: +;;;; +;;;; * . : This is the package for names of the request +;;;; proxy functions. +;;;; * .-implementation : This is the home package for +;;;; implementation function names. It uses the application +;;;; interface package, but shadows all interface function names, +;;;; and it cross-exports all other interface symbols. +;;;; * .-response : This is the home package for response +;;;; function names. It needs no other symbols as the functions only +;;;; intended role is bound to service instances. +;;;; +;;;; Apart from those, there is of course the package. +;;;; This, the application interface package. It has the respective namespace +;;;; name. It is the home package for the structure and exception types and +;;;; accessors, enum types, and constants. +;;;; +;;;; The translated IDL files each begin with an in-package form for +;;;; the application interface package and other symbols are generated +;;;; relative to that. +;;;; +;;;; [1]: $THRIFT/compiler/src/generate/t_cl_generator.cc -(in-package :org.apache.thrift.implementation) - -;;; This file defines the thrift IDL operators for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. - - -;;; The Common Lisp backend for the Thrift IDL translator[[1]] generates Lisp source code in terms of the -;;; following definition operators: -;;; -;;; def-constant -;;; def-eum -;;; def-struct -;;; def-exception -;;; def-request-method -;;; def-response-method -;;; def-service -;;; -;;; The syntax resembles that of the standard Lisp operators. The primary distinction is that identifiers are -;;; the original strings from the Thrift IDL source. The macro operators canonicalize and intern these -;;; according to the current package and read table case. The original values are retained to use as method -;;; and class names for encoding/decoding. -;;; -;;; The interface definitions can incorporate structures in variable definitions, and the service definitions -;;; entail method definitions, which in turn require structure definitions in order to compile codecs -;;; in-line. This suggests the following file load order and organization: -;;; -;;; -types.lisp : (generated) enums, structs, exceptions, services -;;; -vars.lisp : (generated) constants -;;; : This, the application interface package, has the respective namespace name. -;;; It is the home package for the names for the request proxy function, structure and exception types -;;; and accessors, enum types, and constants -;;; * -implementation : This is the home package for implementation function names. It uses -;;; the application interface package, but shadows all interface function names, and it cross-exports -;;; all other interface symbols. -;;; * -response : This is the home package for response function names. It needs no other -;;; symbols as the functions only intended role is bound to service instances. -;;; -;;; The translated IDL files each begin with an in-package form for the application interface package and -;;; other symbols are generated relative to that. -;;; -;;; [1]: $THRIFT/compiler/src/generate/t_cl_generator.cc - - (defun parm-to-field-decl (parameter-spec) "Convert a specialize parameter declaration into the form for a structure field declaration (id-name type id) -> (id-name default &key type id documentation) @@ -83,34 +93,34 @@ (destructuring-bind (identifier type id &optional default) parameter-spec `(,identifier ,default :id ,id :type ,type))) - ;;; ;;; definition operators (defmacro def-package (name &key use) - (let ((implementation-name (cons-symbol :keyword name :-implementation)) + (let ((base-package-name (cons-symbol :keyword name)) + (implementation-name (cons-symbol :keyword name :-implementation)) (response-name (cons-symbol :keyword name :-response))) `(eval-when (:load-toplevel :compile-toplevel :execute) - (unless (find-package ,name) - (defpackage ,name + (unless (find-package ,base-package-name) + (defpackage ,base-package-name (:use :thrift ,@use) (:import-from :common-lisp nil t) (:documentation ,(format nil "This is the application interface package for ~a. - It uses the generic THRIFT package for access to the library interface." name)))) - + It uses the generic THRIFT package for access to the library interface." base-package-name)))) + (unless (find-package ,implementation-name) (defpackage ,implementation-name - (:use :thrift) + (:use :thrift :common-lisp) + (:shadowing-import-from :thrift + :float :list :set :map :byte :type-of) (:documentation ,(format nil "This is the implementation package for ~a. It uses the generic THRIFT package for access to the library interface." name)))) - + (unless (find-package ,response-name) (defpackage ,response-name (:use) (:documentation ,(format nil "This is the response package for ~a. It is isolated." name))))))) - - (defmacro def-enum (identifier entries) (assert (stringp identifier)) (let ((name (str-sym identifier)) @@ -129,15 +139,11 @@ (export '(,name ,@value-names) (symbol-package ',name))) ',name)))) - - (defmacro def-constant (identifier val) "Generate a defparameter form, as the 'constants' are often bound to constructed values." (assert (stringp identifier)) `(defparameter ,(str-sym identifier) ,val)) - - (defmacro def-struct (identifier fields &rest options) "DEF-STRUCT identifier [doc-string] ( field-specifier* ) option* [Macro] @@ -147,10 +153,12 @@ | (:metaclass metaclass) | (:identifier identifier) - Define a thrift struct with the declared fields. The class and field names are computed by cononicalizing the - respective identifier and interning it in the current *package*. Each identifier remains associated with its - metaobject for codec use. Options allow for an explicit identifier, a metacoal other than thrift-struct-class, - and a documentation string. + Define a thrift struct with the declared fields. The class and field + names are computed by cononicalizing the respective identifier and + interning it in the current *package*. Each identifier remains + associated with its metaobject for codec use. Options allow for an + explicit identifier, a metacoal other than thrift-struct-class, and a + documentation string. The class is bound to its name as both the thrift class and CLOS class." @@ -221,7 +229,6 @@ (symbol-package ',name)) (setf (find-thrift-class ',name) (find-class ',name))))))) - (defmacro def-exception (identifier fields &rest options) "DEF-EXCEPTION identifier [doc-string] ( field-specifier* ) option* [Macro] @@ -231,11 +238,12 @@ | (:metaclass metaclass) | (:identifier identifier) - Define a thrift exception with the declared fields. This involves two classes. A condition is defined - to use as a signal/error argument and a proxy struct class is defined for codec use. - The proxy class is bound as the class name's thrift class, while the struct class is bound as the - CLOS class." - + Define a thrift exception with the declared fields. This involves two + classes. A condition is defined to use as a signal/error argument and + a proxy struct class is defined for codec use. The proxy class is + bound as the class name's thrift class, while the struct class is + bound as the CLOS class." + (let* ((metaclass (or (second (assoc :metaclass options)) 'thrift-exception-class)) (identifier (or (second (assoc :identifier options)) identifier)) (name (str-sym identifier)) @@ -278,8 +286,6 @@ collect `(,(str-sym identifier "-" slot-identifier) error))))) (setf (find-thrift-class ',name) (find-class ',struct-name))))) - - (defun generate-struct-decoder (prot class-form field-definitions extra-field-plist) "Generate a form which decodes a the given struct fiels in-line. PROT : a variable bound to a protocol instance @@ -315,16 +321,15 @@ (t ;; handle unknown fields (let* ((value (stream-read-value-as ,prot read-field-type)) - (fd (unknown-field ,read-class name id read-field-type value))) + (fd (unknown-field ,read-class id name read-field-type value))) (if fd (setf (getf ,extra-field-plist (field-definition-initarg fd)) value) - (unknown-field ,prot name id read-field-type value))))) + (unknown-field ,prot id name read-field-type value))))) (stream-read-field-end ,prot)))))) (defmacro decode-struct (prot class field-definitions extra-plist) (generate-struct-decoder prot class field-definitions extra-plist)) - (defmacro def-request-method (name (parameter-list return-type) &rest options) "Generate a request function definition. Augment the base function signature with an initial @@ -332,7 +337,8 @@ the request/reply process, and the result decoding. Return the result value or signal an exception as per the response." - (let* ((identifier (or (second (assoc :identifier options)) (string name))) + (let* ((service-identifier (second (assoc :service-identifier options))) + (method-identifier (or (second (assoc :method-identifier options)) (string name))) (documentation (second (assoc :documentation options))) (exceptions (rest (assoc :exceptions options))) (exception-names (mapcar #'str-sym (mapcar #'car exceptions))) @@ -340,33 +346,37 @@ (parameter-names (mapcar #'(lambda (a) (str-sym (first a))) parameter-list)) (parameter-ids (mapcar #'third parameter-list)) (type-names (mapcar #'(lambda (a) (type-name-class (second a))) parameter-list)) - (call-struct (or (second (assoc :call-struct options)) (str identifier "_args"))) - (reply-struct (or (second (assoc :reply-struct-type options)) (str identifier "_result"))) + (call-struct (or (second (assoc :call-struct options)) + (str method-identifier "_args"))) + (reply-struct (or (second (assoc :reply-struct-type options)) + (str method-identifier "_result"))) (success (str-sym "success"))) - - (with-gensyms (gprot extra-initargs) + + (with-gensyms (gprot request-identifier extra-initargs) `(progn - (ensure-generic-function ',name - :lambda-list '(protocol ,@parameter-names) - :generic-function-class 'thrift-request-function - :identifier ,identifier) - #+ccl (ccl::record-arglist ',name '(protocol ,@parameter-names)) - (defmethod ,name ((,gprot protocol) ,@(mapcar #'list parameter-names type-names)) + (declaim (ftype (function (protocol ,@type-names)) ,name)) + (defun ,name (,gprot ,@parameter-names + &aux (,request-identifier (if (protocol-multiplexed-p ,gprot) + (concatenate 'string + ,service-identifier + ":" + ,method-identifier) + ,method-identifier))) ,@(when documentation `(,documentation)) - (stream-write-message-begin ,gprot ,identifier 'call + (stream-write-message-begin ,gprot ,request-identifier 'call (protocol-next-sequence-number ,gprot)) ;; use the respective args structure as a template to generate the message (stream-write-struct ,gprot (thrift:list ,@(mapcar #'(lambda (id name) `(cons ,id ,name)) parameter-ids parameter-names)) ',(str-sym call-struct)) (stream-write-message-end ,gprot) - ,(if oneway-p - nil + ,(unless oneway-p `(multiple-value-bind (request-message-identifier type sequence) - (stream-read-message-begin ,gprot) + (stream-read-message-begin ,gprot) (unless (eql sequence (protocol-sequence-number ,gprot)) (invalid-sequence-number ,gprot sequence (protocol-sequence-number ,gprot))) - (unless (equal ,identifier request-message-identifier) - (warn "response does not match request: ~s, ~s." ,identifier request-message-identifier)) + (unless (equal ,method-identifier request-message-identifier) + (warn "response does not match request: ~s, ~s." + ,request-identifier request-message-identifier)) (ecase type (reply (let (,@(unless (eq return-type 'void) `((,success nil))) @@ -382,7 +392,7 @@ `((cond ,@(mapcar #'(lambda (ex) `(,ex (response-exception ,gprot request-message-identifier sequence ,ex))) exception-names)))) - ,(if (eq return-type 'void) nil success ))) + ,(unless (eq return-type 'void) success ))) ((call oneway) ;; received a call/oneway when expecting a response (unexpected-request ,gprot request-message-identifier sequence @@ -393,82 +403,113 @@ (response-exception ,gprot request-message-identifier sequence (prog1 (stream-read-struct ,gprot *response-exception-type*) (stream-read-message-end ,gprot)))))))))))) - - (defmacro def-response-method (name (parameter-list return-type) &rest options) "Generate a response function definition. The method is defined with three arguments, a service, a sequence number and a protocol. The default method decodes the declared argument struct, invokes the base operator and, depending - on the return type, encodes a response message. The given sequence number is reused in the response. - The service argument is available for specialization, but otherwise ignored." - - (with-gensyms (service seq gprot extra-args) - (let* ((identifier (or (second (assoc :identifier options)) (string name))) + on the return type, encodes a response message. The given sequence number is reused in the response." + + (with-gensyms (service response-identifier seq gprot extra-args) + (let* ((method-identifier (or (second (assoc :method-identifier options)) (string name))) (documentation (second (assoc :documentation options))) (oneway-p (second (assoc :oneway options))) (implementation (or (second (assoc :implementation-function options)) (error "An implementation function is required."))) (parameter-names (mapcar #'(lambda (a) (str-sym (first a))) parameter-list)) + (parameter-count (length parameter-list)) (defaults (mapcar #'(lambda (a) (fourth a)) parameter-list)) - (call-struct (or (second (assoc :call-struct options)) (str identifier "_args"))) - (reply-struct (or (second (assoc :reply-struct options)) (str identifier "_result"))) + (call-struct (or (second (assoc :call-struct options)) + (str method-identifier "_args"))) + (reply-struct (or (second (assoc :reply-struct options)) + (str method-identifier "_result"))) (exceptions (rest (assoc :exceptions options))) (application-form `(if ,extra-args - (apply #',implementation ,@parameter-names ,extra-args) - (,implementation ,@parameter-names)))) - (if (fboundp implementation) - `(progn (ensure-generic-function ',name - :lambda-list '(service sequence-number protocol) - :generic-function-class 'thrift-response-function - :identifier ,identifier - :implementation-function - ,(etypecase implementation - ;; defer the evaluation - (symbol `(quote ,implementation)) - ((cons (eql lambda)) `(function ,implementation)))) - #+ccl (ccl::record-arglist ',name '(service sequence-number protocol)) - (defmethod ,name ((,service t) (,seq t) (,gprot protocol)) - ,@(when documentation `(,documentation)) - (let (,@(mapcar #'list parameter-names defaults) + (apply #',implementation ,@parameter-names ,extra-args) + (,implementation ,@parameter-names)))) + `(progn (declaim (ftype (function ,(make-list parameter-count :initial-element t)) ,implementation)) + (declaim (ftype (function (t t protocol)) ,name)) + (defun ,name (,service ,seq ,gprot) + ,@(when documentation `(,documentation)) + (let (,@(mapcar #'list parameter-names defaults) + (,response-identifier ,method-identifier) (,extra-args nil)) - ,(generate-struct-decoder gprot `(find-thrift-class ',(str-sym call-struct)) - (mapcar #'parm-to-field-decl parameter-list) extra-args) - ,(let ((expression - (cond (oneway-p - application-form) - ((eq return-type 'void) - `(prog1 + (declare (ignorable ,response-identifier)) + ,(generate-struct-decoder gprot `(find-thrift-class ',(str-sym call-struct)) + (mapcar #'parm-to-field-decl parameter-list) extra-args) + ,(let ((expression + (cond (oneway-p + application-form) + ((eq return-type 'void) + `(prog1 ,application-form - (stream-write-message-begin ,gprot ,identifier 'reply ,seq) - (stream-write-struct ,gprot (thrift:list) ',(str-sym reply-struct)) - (stream-write-message-end ,gprot))) - (t - `(let ((result ,application-form)) - (stream-write-message-begin ,gprot ,identifier 'reply ,seq) - (stream-write-struct ,gprot (thrift:list (cons 0 result)) ',(str-sym reply-struct)) - (stream-write-message-end ,gprot) - result))))) - (if exceptions + (stream-write-message-begin ,gprot ,response-identifier 'reply ,seq) + (stream-write-struct ,gprot (thrift:list) ',(str-sym reply-struct)) + (stream-write-message-end ,gprot))) + (t + `(let ((result ,application-form)) + (stream-write-message-begin ,gprot ,response-identifier 'reply ,seq) + (stream-write-struct ,gprot (thrift:list (cons 0 result)) ',(str-sym reply-struct)) + (stream-write-message-end ,gprot) + result))))) + (if exceptions `(handler-case ,expression ,@(loop for exception-spec in exceptions - collect (destructuring-bind (field-name default &key type id) - exception-spec - (declare (ignore field-name default)) - (let ((external-exception-type (second type))) - `(,(str-sym external-exception-type) (condition) - ;; sent as a reply in order to effect operation-specific exception - ;; processing. - (stream-write-message-begin ,gprot ,identifier 'reply ,seq) - (stream-write-struct ,gprot (thrift:list (cons ,id condition)) - ',(str-sym reply-struct)) - (stream-write-message-end ,gprot) - condition))))) - expression))))) - ;; if no implementation is present, warn and emit no interface - (progn (when *compile-verbose* (warn "No response implementation present: ~s." implementation)) - (values)))))) - + collect (destructuring-bind (field-name default &key type id) + exception-spec + (declare (ignore field-name default)) + (let ((external-exception-type (second type))) + `(,(str-sym external-exception-type) (condition) + ;; sent as a reply in order to effect operation-specific exception + ;; processing. + (stream-write-message-begin ,gprot ,response-identifier 'reply ,seq) + (stream-write-struct ,gprot (thrift:list (cons ,id condition)) + ',(str-sym reply-struct)) + (stream-write-message-end ,gprot) + condition))))) + expression)))))))) + +(defun %generate-method (service-identifier method-declaration) + (destructuring-bind (method-identifier + (parameter-list return-type) + &key (oneway nil) (exceptions nil) documentation) + (rest method-declaration) + (let* ((call-struct-identifier (str method-identifier "_args")) + (reply-struct-identifier (str method-identifier "_result")) + ;; all the following symbols are uninterned, hence not `eq'. + (request-function-symbol (cons-symbol nil method-identifier)) + (response-function-symbol (cons-symbol nil method-identifier)) + (implementation-function-symbol (cons-symbol nil method-identifier))) + `((eval-when (:compile-toplevel :load-toplevel :execute) + (def-struct ,call-struct-identifier + ,(mapcar #'parm-to-field-decl parameter-list)) + (def-struct ,reply-struct-identifier + (,@(unless (eq return-type 'void) `(("success" nil :id 0 :type ,return-type))) + ,@exceptions))) + ;; we put our untinterned symbols in their isolated packages + (mapc (lambda (s p) (import s p) (export s p)) + '(,request-function-symbol + ,response-function-symbol + ,implementation-function-symbol) + (list (find-package (%pkg-name ',(str-sym service-identifier) "")) + (find-package (%pkg-name ',(str-sym service-identifier) "-RESPONSE")) + (find-package (%pkg-name ',(str-sym service-identifier) "-IMPLEMENTATION")))) + (def-request-method ,request-function-symbol (,parameter-list ,return-type) + (:service-identifier ,service-identifier) + (:method-identifier ,method-identifier) + ,@(when documentation `((:documentation ,(string-trim *whitespace* documentation)))) + (:call-struct ,call-struct-identifier) + (:reply-struct ,reply-struct-identifier) + ,@(when exceptions `((:exceptions ,@exceptions))) + ,@(when oneway `((:oneway t)))) + (def-response-method ,response-function-symbol (,parameter-list ,return-type) + (:service-identifier ,service-identifier) + (:method-identifier ,method-identifier) + (:call-struct ,call-struct-identifier) + (:reply-struct ,reply-struct-identifier) + (:implementation-function ,implementation-function-symbol) + ,@(when exceptions `((:exceptions ,@exceptions))) + ,@(when oneway `((:oneway t)))))))) (defmacro def-service (identifier base-services &rest options) "Given the external name for the service, an optional inheritance list, slot definitions @@ -478,14 +519,13 @@ NB. THis must operate as a top-level form in order that the argument structure definitions be available to compile the request/response functions." - + (let* ((name (str-sym identifier)) (class-identifier (second (assoc :class options))) (class (if class-identifier (str-sym class-identifier) 'service)) (methods (remove :method options :test-not #'eq :key #'first)) (documentation (second (assoc :documentation options))) (identifiers (mapcar #'second methods)) - (response-names (mapcar #'response-str-sym identifiers)) (initargs (loop for (key . rest) in options unless (member key '(:service-class :method :documentation)) collect key @@ -494,54 +534,23 @@ collect `(,(str-sym identifier) ,(mapcar #'str-sym (mapcar #'first parameter-list)) ,return-type)))) - - `(progn ,@(mapcan #'(lambda (method-declaration) - (destructuring-bind (identifier (parameter-list return-type) &key (oneway nil) (exceptions nil) - (implementation-function-name (implementation-str-sym identifier)) - documentation) - (rest method-declaration) - (let* ((call-struct-identifier (str identifier "_args")) - (reply-struct-identifier (str identifier "_result")) - (request-function-name (str-sym identifier)) - (response-function-name (response-str-sym identifier))) - `((eval-when (:compile-toplevel :load-toplevel :execute) - (def-struct ,call-struct-identifier - ,(mapcar #'parm-to-field-decl parameter-list)) - (def-struct ,reply-struct-identifier - (,@(unless (eq return-type 'void) `(("success" nil :id 0 :type ,return-type))) - ,@exceptions))) - (shadow 'implementation-function-name (symbol-package ',implementation-function-name)) - (export ',request-function-name (symbol-package ',request-function-name)) - (export ',response-function-name (symbol-package ',response-function-name)) - (def-request-method ,request-function-name (,parameter-list ,return-type) - (:identifier ,identifier) - ,@(when documentation `((:documentation ,(string-trim *whitespace* documentation)))) - (:call-struct ,call-struct-identifier) - (:reply-struct ,reply-struct-identifier) - ,@(when exceptions `((:exceptions ,@exceptions))) - ,@(when oneway `((:oneway t)))) - (def-response-method ,response-function-name (,parameter-list ,return-type) - (:identifier ,identifier) - (:call-struct ,call-struct-identifier) - (:reply-struct ,reply-struct-identifier) - (:implementation-function ,implementation-function-name) - ,@(when exceptions `((:exceptions ,@exceptions))) - ,@(when oneway `((:oneway t)))))))) - methods) - + `(progn (defpackage ,(%pkg-name name "") (:use)) + (defpackage ,(%pkg-name name "-RESPONSE") (:use)) + (defpackage ,(%pkg-name name "-IMPLEMENTATION") (:use)) + ,@(mapcan (alexandria:curry #'%generate-method identifier) methods) ;; export the service name only (eval-when (:compile-toplevel :load-toplevel :execute) - (export ',name (symbol-package ',name))) + (export ',name)) ;; construct and bind the global service instance (defparameter ,name (make-instance ',class :identifier ,identifier - :base-services (list ,@(mapcar #'str-sym (if (listp base-services) base-services (list base-services)))) - :methods ',(mapcar #'(lambda (identifier name) `(,identifier . ,name)) - identifiers response-names) + :base-services (list ,@(mapcar #'str-sym (alexandria:ensure-list base-services))) + :methods (mapcar (lambda (identifier) + (cons identifier + (response-str-sym ,identifier identifier))) + ',identifiers) :documentation ,(format nil "~@[~a~%---~%~]~(~{~{~a~24t~a : ~a~}~^~%~}~)" documentation (sort method-interfaces #'string-lessp :key #'first)) ,@initargs))))) - - diff --git a/framed-transport.lisp b/framed-transport.lisp new file mode 100644 index 0000000..6c95723 --- /dev/null +++ b/framed-transport.lisp @@ -0,0 +1,134 @@ +(in-package #:org.apache.thrift.implementation) + +;;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;;; you may not use this file except in compliance with the License. +;;;; You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, software +;;;; distributed under the License is distributed on an "AS IS" BASIS, +;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;;; See the License for the specific language governing permissions and +;;;; limitations under the License. + +;;;; This implements framed transport according to the Apache Thrift +;;;; specification. The way it works is by creating a decorator (wrapper) +;;;; around a "real" binary transport (like a socket or file one). All +;;;; that's needed is to call (framed-transport real-transport) and use the +;;;; returned object in place of the "real" transport. + +(defconstant *frame-length-limit* 16384000) + +;;; Classes + +(defclass transport-decorator (binary-transport) + ((real-transport :accessor decorator-real-transport + :initarg :real-transport))) + +(defclass framed-transport (transport-decorator) + ((write-buffer :accessor framed-write-buffer + :initform nil) + (read-buffer :accessor framed-read-buffer + :initform nil) + (message-length :accessor framed-message-length + :initform 0))) + +;;; Initialization, closing + +(defmethod initialize-instance :after ((transport transport-decorator) &key real-transport) + (setf (slot-value transport 'real-transport) real-transport)) + +(defmethod initialize-instance :after ((transport framed-transport) &key) + (reset-write-buffer transport)) + +(defun framed-transport (real-transport) + (make-instance 'framed-transport + :real-transport real-transport + :direction (stream-direction real-transport))) + +(defmethod transport-close ((transport transport-decorator) &key abort) + (transport-close (decorator-real-transport transport) :abort abort)) + +(defmethod open-stream-p ((transport transport-decorator)) + (open-stream-p (decorator-real-transport transport))) + +;;; Helpers + +(defun bytes-to-uint (bytes) + (loop for shift from (1- (length bytes)) downto 0 + for byte across bytes summing + (ash byte (* 8 shift)))) + +(defun uint-to-bytes (integer byte-count) + (let ((bytes (make-array byte-count :element-type '(unsigned-byte 8))) + (remaining integer)) + (loop for i from 0 below byte-count doing + (multiple-value-bind (byte remainder) + (floor remaining (expt 256 (- byte-count i 1))) + (setf (aref bytes i) byte) + (setf remaining remainder))) + bytes)) + +;;; Buffer ops + +(defgeneric ensure-read-buffer (transport)) + +(defgeneric write-frame (transport)) + +(defgeneric reset-write-buffer (transport)) + +(defmethod ensure-read-buffer ((transport framed-transport)) + (when (zerop (length (framed-read-buffer transport))) + (let ((buffer (make-array 4 :element-type '(unsigned-byte 8)))) + (stream-read-sequence (decorator-real-transport transport) buffer 0 nil) + (let ((frame-length (bytes-to-uint buffer))) + (setf buffer (make-array frame-length :element-type '(unsigned-byte 8))) + (stream-read-sequence (decorator-real-transport transport) buffer 0 nil) + (setf (framed-read-buffer transport) buffer))))) + +(defmethod write-frame ((transport framed-transport)) + (let ((length (length (framed-write-buffer transport)))) + (unless (zerop length) + (when (> length *frame-length-limit*) (error "The frame is too big to write out.")) + (stream-write-sequence (decorator-real-transport transport) (uint-to-bytes length 4) 0 nil) + (stream-write-sequence (decorator-real-transport transport) (framed-write-buffer transport) 0 nil) + (reset-write-buffer transport)))) + +(defmethod reset-write-buffer ((transport framed-transport)) + (setf (framed-write-buffer transport) (make-array 50 + :adjustable t + :fill-pointer 0 + :element-type '(unsigned-byte 8)))) + +;;; Standard I/O methods (trivial-gray-streams) + +(defmethod stream-finish-output ((transport framed-transport)) + (write-frame transport) + (stream-finish-output (decorator-real-transport transport))) + +(defmethod stream-force-output ((transport framed-transport)) + (write-frame transport) + (stream-force-output (decorator-real-transport transport))) + +(defmethod stream-write-byte ((transport framed-transport) byte) + () + (vector-push-extend (unsigned-byte-8 byte) (framed-write-buffer transport))) + +(defmethod stream-write-sequence ((transport framed-transport) (sequence vector) start end &key) + (loop for byte across (subseq sequence start end) + do (vector-push-extend byte (framed-write-buffer transport)))) + +(defmethod stream-read-byte ((transport framed-transport)) + (ensure-read-buffer transport) + (let ((buffer (framed-read-buffer transport))) + (prog1 (signed-byte-8 (aref buffer 0)) + (setf (framed-read-buffer transport) (subseq buffer 1))))) + +(defmethod stream-read-sequence ((transport framed-transport) sequence start end &key) + (ensure-read-buffer transport) + (let ((length (length (subseq sequence start end)))) + (if (< (length (framed-read-buffer transport)) length) + (error "End of file reached while reading from a framed transport.")) + (setf (subseq sequence start end) (subseq (framed-read-buffer transport) 0 length)) + (setf (framed-read-buffer transport) (subseq (framed-read-buffer transport) length)))) diff --git a/package.lisp b/package.lisp index 5ab4737..630998c 100644 --- a/package.lisp +++ b/package.lisp @@ -1,194 +1,193 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- +(in-package #:common-lisp-user) -(in-package :common-lisp-user) +;;;; This file defines the packages for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. -;;; This file defines the packages for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. - -(defpackage :org.apache.thrift - (:nicknames :thrift) +(defpackage #:org.apache.thrift + (:nicknames #:thrift) (:use) - + (:documentation "This is the home package for the symbols in the library's interface. It uses no packages, but imports 'string' from :cl. It does export some symbols particular to Thrift types and/or operators which conflict with standard Common Lisp symbols. These must be selectively shadowed as per application requirements in a using package.") - (:import-from :common-lisp - :string) + (:import-from #:common-lisp + #:string) #+ccl - (:import-from :ccl - :stream-direction) + (:import-from #:ccl + #:stream-direction) ;; digitools stream-write-string signature requires four arguments. leave it to be shadowed #+sbcl - (:import-from :sb-gray - :stream-write-string) + (:import-from #:sb-gray + #:stream-write-string) #+lispworks - (:import-from :stream - :stream-write-string) - (:export - :*binary-transport-element-type* - :application-error - :binary-protocol - :binary-transport - :binary - :bool - :byte - :call - :class-condition-class - :class-field-definitions - :class-identifier - :class-not-found - :class-not-found-error - :client with-client - :def-constant - :def-enum - :def-exception - :def-package - :def-service - :def-struct - :direct-field-definition - :double - :effective-field-definition - :element-type-error - :enum - :enum-type-error - :exception - :field-definition-identifier - :field-definition-identifier-number - :field-definition-initarg - :field-definition-name - :field-definition-optional - :field-definition-reader - :field-definition-type - :field-size-error - :field-type-error - :float - :method-definition - :i08 - :i16 - :i32 - :i64 - :invalid-element-type - :invalid-enum - :invalid-field-size - :invalid-field-type - :invalid-protocol-version - :invalid-struct-type - :list - :map - :map-get - :protocol - :protocol-error - :protocol-field-id-mode - :protocol-input-transport - :protocol-output-transport - :protocol-version-error - :reply - :serve - :serve simple-server handler - :service - :service-base-services - :service-identifier - :service-package - :set - :shared-service - :stream-direction - :stream-read-binary - :stream-read-bool - :stream-read-double - :stream-read-field - :stream-read-field-begin - :stream-read-field-end - :stream-read-float - :stream-read-i08 - :stream-read-i16 - :stream-read-i32 - :stream-read-i64 - :stream-read-list - :stream-read-list-begin - :stream-read-list-end - :stream-read-map - :stream-read-map-begin - :stream-read-map-end - :stream-read-message - :stream-read-message-begin - :stream-read-message-end - :stream-read-message-type - :stream-read-set - :stream-read-set-begin - :stream-read-set-end - :stream-read-string - :stream-read-struct - :stream-read-struct-begin - :stream-read-struct-end - :stream-read-type - :stream-read-type-value - :stream-write-binary - :stream-write-bool - :stream-write-double - :stream-write-field - :stream-write-float - :stream-write-i08 - :stream-write-i16 - :stream-write-i32 - :stream-write-i64 - :stream-write-list - :stream-write-map - :stream-write-message - :stream-write-message-type - :stream-write-set - :stream-write-string - :stream-write-struct - :stream-write-type - :stream-write-type-value - :string - :struct - :struct-name - :struct-type-error - :thrift - :thrift-class - :thrift-error - :thrift-object - :thrift-struct-class - :thrift-exception-class - :transport - :transport-error - :type-of - :unknown-field - :unknown-field-error - :unknown-method - :unknown-method-error - :vector-input-stream - :vector-output-stream - :vector-stream-transport - :vector-stream-vector - :void + (:import-from #:stream + #:stream-write-string) + (:export + #:*binary-transport-element-type* + #:application-error + #:binary-protocol + #:binary-transport + #:binary + #:bool + #:byte + #:call + #:class-condition-class + #:class-field-definitions + #:class-identifier + #:class-not-found + #:class-not-found-error + #:client #:with-client + #:def-constant + #:def-enum + #:def-exception + #:def-package + #:def-service + #:def-struct + #:direct-field-definition + #:double + #:effective-field-definition + #:element-type-error + #:enum + #:enum-type-error + #:exception + #:field-definition-identifier + #:field-definition-identifier-number + #:field-definition-initarg + #:field-definition-name + #:field-definition-optional + #:field-definition-reader + #:field-definition-type + #:field-size-error + #:field-type-error + #:float + #:method-definition + #:i8 + #:i16 + #:i32 + #:i64 + #:invalid-element-type + #:invalid-enum + #:invalid-field-size + #:invalid-field-type + #:invalid-protocol-version + #:invalid-struct-type + #:list + #:map + #:map-get + #:protocol + #:protocol-error + #:protocol-field-id-mode + #:protocol-input-transport + #:protocol-output-transport + #:protocol-version-error + #:reply + #:response-exception + #:serve + #:serve #:simple-server #:handler + #:service + #:service-base-services + #:service-identifier + #:service-package + #:set + #:shared-service + #:stream-direction + #:stream-read-binary + #:stream-read-bool + #:stream-read-double + #:stream-read-field + #:stream-read-field-begin + #:stream-read-field-end + #:stream-read-float + #:stream-read-i8 + #:stream-read-i16 + #:stream-read-i32 + #:stream-read-i64 + #:stream-read-list + #:stream-read-list-begin + #:stream-read-list-end + #:stream-read-map + #:stream-read-map-begin + #:stream-read-map-end + #:stream-read-message + #:stream-read-message-begin + #:stream-read-message-end + #:stream-read-message-type + #:stream-read-set + #:stream-read-set-begin + #:stream-read-set-end + #:stream-read-string + #:stream-read-struct + #:stream-read-struct-begin + #:stream-read-struct-end + #:stream-read-type + #:stream-read-type-value + #:stream-write-binary + #:stream-write-bool + #:stream-write-double + #:stream-write-field + #:stream-write-float + #:stream-write-i8 + #:stream-write-i16 + #:stream-write-i32 + #:stream-write-i64 + #:stream-write-list + #:stream-write-map + #:stream-write-message + #:stream-write-message-type + #:stream-write-set + #:stream-write-string + #:stream-write-struct + #:stream-write-type + #:stream-write-type-value + #:string + #:struct + #:struct-name + #:struct-type-error + #:thrift + #:thrift-class + #:thrift-error + #:thrift-object + #:thrift-struct-class + #:thrift-exception-class + #:transport + #:transport-error + #:type-of + #:unknown-field + #:unknown-field-error + #:unknown-method + #:unknown-method-error + #:vector-input-stream + #:vector-output-stream + #:vector-stream + #:vector-stream-transport + #:vector-stream-vector + #:void )) +(defpackage #:org.apache.thrift.implementation + (:use #:common-lisp #:org.apache.thrift) + (:nicknames #:thrift.implementation) -(defpackage :org.apache.thrift.implementation - (:use :common-lisp :org.apache.thrift) - (:nicknames :thrift.implementation) - (:documentation "The is the package for the thrift implementation. It exports nothing, uses the :common-lisp and :thrift package for access to the respective interfaces. Those names which conflict, eg. cl:list v/s thrift:list, are imported the :common-lisp package and referenced with an explicit prefix @@ -196,37 +195,34 @@ It also imports names as required per run-time for access to standard floating point constants and gray stream operators.") - (:shadowing-import-from :common-lisp :byte :set :list :map :type-of :float) - - (:import-from :de.setf.utility - :stream-reader - :stream-writer - ) + (:shadowing-import-from #:common-lisp #:byte #:set #:list #:map #:type-of #:float) + + (:import-from #:trivial-gray-streams + #:stream-write-sequence #:stream-read-sequence + #:stream-write-byte #:stream-read-byte + #:stream-force-output #:stream-finish-output) + + ;; (:import-from #:de.setf.utility + ;; #:stream-reader + ;; #:stream-writer + ;; ) #+ccl - (:import-from :ccl - :stream-write-byte :stream-read-byte - :stream-direction - :stream-position - :stream-force-output :stream-finish-output) + (:import-from #:ccl + #:stream-direction + #:stream-position) #+mcl - (:import-from :ccl - :stream-close - :stream-read-sequence :stream-write-sequence - :stream-tyi :stream-tyo :stream-untyi) + (:import-from #:ccl + #:stream-close + #:stream-tyi #:stream-tyo #:stream-untyi) #+clozure - (:import-from :ccl - :double-float-positive-infinity - :double-float-negative-infinity - #+ccl-1.4 :double-float-nan) - #+sbcl - (:import-from :sb-ext - :double-float-positive-infinity - :double-float-negative-infinity - :single-float-positive-infinity - :single-float-negative-infinity) + (:import-from #:ccl + #:double-float-positive-infinity + #:double-float-negative-infinity + #+ccl-1.4 #:double-float-nan) #+sbcl - (:import-from :sb-gray - :stream-write-byte :stream-read-byte - :stream-read-sequence :stream-write-sequence - :stream-force-output :stream-finish-output) + (:import-from #:sb-ext + #:double-float-positive-infinity + #:double-float-negative-infinity + #:single-float-positive-infinity + #:single-float-negative-infinity) ) diff --git a/parameters.lisp b/parameters.lisp index ac4a9de..d90b77e 100644 --- a/parameters.lisp +++ b/parameters.lisp @@ -1,40 +1,37 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- - -(in-package :org.apache.thrift.implementation) - -;;; This file defines global variables for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. - +(in-package #:org.apache.thrift.implementation) + +;;;; This file defines global variables for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. (defparameter *binary-transport-types* '((stop . 0) (void . 1) (bool . 2) + (i8 . 3) (thrift:byte . 3) - (i08 . 3) (double . 4) (thrift:float . 5) ; this is not standard (i16 . 6) - (enum . 6) (i32 . 8) + (enum . 8) (u64 . 9) (i64 . 10) (string . 11) @@ -47,7 +44,6 @@ (utf8 . 16) (utf16 . 17))) - (defparameter *binary-message-types* '((call . 1) (reply . 2) @@ -60,7 +56,7 @@ (void . null) (bool . symbol) (thrift:byte . fixnum) - (i08 . fixnum) + (i8 . fixnum) (double . float) (i16 . fixnum) (enum . fixnum) @@ -103,8 +99,8 @@ (defparameter *response-exception-type* 'response-exception) -;;; the thrfit class registry binds class names (_not identifiers_) to either the -;;; +;;; the thrift class registry binds class names (_not identifiers_) to either the +;;; (defvar *thrift-classes* (make-hash-table :test 'eq) "Registers defined struct classes. This includes @@ -121,11 +117,9 @@ guide code operation and/or generation. Instantiation delegates to the actual condition class. (see make-struct.)") - ;;; ;;; floating point support - #+mcl (unless (boundp 'double-float-positive-infinity) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -135,7 +129,7 @@ (ccl::set-fpu-mode :division-by-zero nil) (funcall '/ 0d0)) (ccl::set-fpu-mode :division-by-zero t))) - + (defconstant double-float-negative-infinity (unwind-protect (progn @@ -161,7 +155,7 @@ (ccl::set-fpu-mode :division-by-zero nil) (funcall '/ 0s0)) (ccl::set-fpu-mode :division-by-zero t))) - + (defconstant single-float-negative-infinity (unwind-protect (progn @@ -194,5 +188,4 @@ (defconstant single-float-negative-infinity (coerce system::*minus-infinity-double* 'single-float)) (defconstant single-float-nan (+ single-float-positive-infinity single-float-negative-infinity)) - (defconstant double-float-nan (+ double-float-positive-infinity double-float-negative-infinity)) - ) + (defconstant double-float-nan (+ double-float-positive-infinity double-float-negative-infinity))) diff --git a/protocol.lisp b/protocol.lisp index c701daa..431bdbc 100644 --- a/protocol.lisp +++ b/protocol.lisp @@ -1,62 +1,60 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- - -(in-package :org.apache.thrift.implementation) - -;;; This file defines the abstract '`protocol` layer for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. - - -;;; The protocol class is the abstract root for comminucation protocol implementations. -;;; It is specialized for each message structure -;;; -;;; protocol -;;; - encoded-protocol -;;; - binary-protocol (see binary-protocol.lisp) -;;; -;;; The abstract class determines the abstract representation of message components in terms of -;;; and arrangement of Thrift data types. Each concrete protocol class implements the codec for -;;; base data types in terms of signed bytes and unsigned byte sequences. It then delegates to -;;; its input/output transports to decode and encode that data in terms of the transport's -;;; representation. -;;; nb. there is a bnf, protocols are observed to eliminate and/or reorder fields at will. whatever. - -;;; The stream interface operators are implemented in two forms. A generic interface is specialized -;;; by protocol and/or actual data argument type. In addition a compiler-macro complement performs -;;; compile-time in-line codec expansion when the data type is statically specified. As Thrift -;;; requires all types to be declared statically, this compiles IDL files to in-line codecs. -;;; -;;; Type comparisons - both at compile-time and as run-time validation, are according to nominal equality. -;;; As the Thrift type system permits no sub-typing, primtive types are a finite set and the struct/exception -;;; classes permit no super-types. -;;; The only variation would be to to permit integer subtypes for integer container elements, eg i08 sent -;;; where i32 was declared, but that would matter only if supporting a compact protocol. -;;; -;;; Names exists in two domains: -;;; - An 'identifier' is a string. They are used when the package is unknown, which is the situation at -;;; the start of a message. After that, a package is imputed from the association between a found message -;;; and its service context -;;; - A 'name' uis a symbol. These are interned into a services 'namespace' when the idl is compiled. -;;; These interned names are compiled onto request/response functions and the struct codecs. -;;; When messages are read, the respective service's namespace package applies to intern identifiers -;;; to match them against decoding type constraints. +(in-package #:org.apache.thrift.implementation) + +;;;; This file defines the abstract '`protocol` layer for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. + + +;;;; The protocol class is the abstract root for comminucation protocol implementations. +;;;; It is specialized for each message structure +;;;; +;;;; protocol +;;;; - encoded-protocol +;;;; - binary-protocol (see binary-protocol.lisp) +;;;; +;;;; The abstract class determines the abstract representation of message components in terms of +;;;; and arrangement of Thrift data types. Each concrete protocol class implements the codec for +;;;; base data types in terms of signed bytes and unsigned byte sequences. It then delegates to +;;;; its input/output transports to decode and encode that data in terms of the transport's +;;;; representation. +;;;; nb. there is a bnf, protocols are observed to eliminate and/or reorder fields at will. whatever. + +;;;; The stream interface operators are implemented in two forms. A generic interface is specialized +;;;; by protocol and/or actual data argument type. In addition a compiler-macro complement performs +;;;; compile-time in-line codec expansion when the data type is statically specified. As Thrift +;;;; requires all types to be declared statically, this compiles IDL files to in-line codecs. +;;;; +;;;; Type comparisons - both at compile-time and as run-time validation, are according to nominal equality. +;;;; As the Thrift type system permits no sub-typing, primtive types are a finite set and the struct/exception +;;;; classes permit no super-types. +;;;; The only variation would be to to permit integer subtypes for integer container elements, eg i8 sent +;;;; where i32 was declared, but that would matter only if supporting a compact protocol. +;;;; +;;;; Names exists in two domains: +;;;; - An 'identifier' is a string. They are used when the package is unknown, which is the situation at +;;;; the start of a message. After that, a package is imputed from the association between a found message +;;;; and its service context +;;;; - A 'name' uis a symbol. These are interned into a services 'namespace' when the idl is compiled. +;;;; These interned names are compiled onto request/response functions and the struct codecs. +;;;; When messages are read, the respective service's namespace package applies to intern identifiers +;;;; to match them against decoding type constraints. ;;; ;;; interface @@ -64,7 +62,7 @@ (defgeneric stream-read-type (protocol)) (defgeneric stream-read-message-type (protocol)) (defgeneric stream-read-bool (protocol)) -(defgeneric stream-read-i08 (protocol)) +(defgeneric stream-read-i8 (protocol)) (defgeneric stream-read-i16 (protocol)) (defgeneric stream-read-i32 (protocol)) (defgeneric stream-read-i64 (protocol)) @@ -94,7 +92,7 @@ (defgeneric stream-write-type (protocol type-name)) (defgeneric stream-write-message-type (protocol type-name)) (defgeneric stream-write-bool (protocol value)) -(defgeneric stream-write-i08 (protocol value)) +(defgeneric stream-write-i8 (protocol value)) (defgeneric stream-write-i16 (protocol value)) (defgeneric stream-write-i32 (protocol value)) (defgeneric stream-write-i64 (protocol value)) @@ -123,8 +121,6 @@ (defgeneric stream-write-set (protocol value &optional type)) (defgeneric stream-write-set-end (protocol)) - - ;;; ;;; macros ;;; nb. this does not interact at all nicely with redefined macros. @@ -182,11 +178,10 @@ #+digitool (setf (ccl:assq 'expand-iff-constant-types ccl:*fred-special-indent-alist*) 2) - ;;; ;;; classes -(defclass protocol (#+ccl stream #+sbcl sb-gray:fundamental-stream) +(defclass protocol (trivial-gray-streams:fundamental-stream) ((input-transport :initform (error "transport is required.") :initarg :input-transport :initarg :transport :reader protocol-input-transport) @@ -202,20 +197,19 @@ (field-id-mode :initarg :field-key :reader protocol-field-id-mode :type (member :identifier-number :identifier-name)) (struct-id-mode :initarg :struct-id-mode :reader protocol-struct-id-mode - :type (member :identifier-name :none)))) - + :type (member :identifier-name :none)) + (multiplexed + :initform nil :initarg :multiplexed :reader protocol-multiplexed-p + :documentation "Multiplexed protocol specifies service for each method."))) (defclass encoded-protocol (protocol) ((string-encoder :initarg :string-encoder :reader transport-string-encoder) (string-decoder :initarg :string-decoder :reader transport-string-decoder)) (:default-initargs :charset :utf8)) - - ;;; ;;; protocol operators - (defmethod initialize-instance ((protocol encoded-protocol) &rest initargs &key (charset nil)) (declare (dynamic-extent initargs)) (multiple-value-bind (decoder encoder) @@ -255,47 +249,34 @@ (when (next-method-p) (call-next-method)) (apply #'protocol-close stream args))) - (defgeneric protocol-version (protocol) (:method ((protocol protocol)) (cons (protocol-version-id protocol) (protocol-version-number protocol)))) - (defgeneric protocol-find-thrift-class (protocol name) (:method ((protocol protocol) (name string)) (or (find-thrift-class (str-sym name) nil) (class-not-found protocol name)))) - (defgeneric protocol-next-sequence-number (protocol) (:method ((protocol protocol)) (incf (protocol-sequence-number protocol)))) - (defmethod stream-position ((protocol protocol) &optional new-position) (if new-position (stream-position (protocol-input-transport protocol) new-position) (stream-position (protocol-input-transport protocol)))) - ;;; ;;; type code <-> name operators are specific to each protocol -(defgeneric type-code-name (protocol code) - ) - +(defgeneric type-code-name (protocol code)) -(defgeneric type-name-code (protocol name) - ) - - -(defgeneric message-type-code (protocol message-name) - ) - -(defgeneric message-type-name (protocol type-code) - ) +(defgeneric type-name-code (protocol name)) +(defgeneric message-type-code (protocol message-name)) +(defgeneric message-type-name (protocol type-code)) ;;; ;;; input implementation @@ -311,7 +292,7 @@ The protocol's field-id-mode determines which id form to expect. :identifier-number : decodes a type, and unless the type is STOP a subsequent id number :identifier-name : decodes an identifier name and a type." - + (let ((type nil) (id-number 0) (identifier nil)) @@ -329,7 +310,6 @@ type (stream-read-type protocol)))) (values identifier id-number type))) - (defmethod stream-read-field-end ((protocol protocol)) "The base method does nothing.") @@ -361,8 +341,6 @@ ;;; incorporates dispatches on field id to an inline-able call stream-read-value-as, while stream-read-field ;;; never itself knows the type at compile time. - - (defmethod stream-read-struct-begin ((protocol protocol)) (ecase (protocol-struct-id-mode protocol) (:identifier-name @@ -379,7 +357,7 @@ last step. Otherwise allocate an instacen and bind each value in succession. Should the field fail to correspond to a known slot, delegate unknown-field to the class for a field defintion. If it supplies none, then resort to the class." - + ;; Were it slot classes only, a better protocol would be (setf slot-value-using-class), but that does not ;; apply to exceptions. Given both cases, this is coded to stay symmetric. (let* ((class (stream-read-struct-begin protocol)) @@ -435,7 +413,7 @@ "Iff the type is a constant, compile the decoder inline. If class is not defined, signal an error. The intended use is to compile IDL files, for which the code generator and the definition macros arrange that structure definitions preceed references." - + (expand-iff-constant-types (type) form (with-gensyms (expected-class) (with-optional-gensyms (prot) env @@ -471,7 +449,7 @@ "Iff the type is a constant, compile the decoder inline. If class is not defined, signal an error. The intended use is to compile IDL files, for which the code generator and the definition macros arrange that structure definitions preceed references." - + (expand-iff-constant-types (type) form (with-gensyms (expected-class) (with-optional-gensyms (prot) env @@ -488,10 +466,6 @@ nconc (list (field-definition-initarg fd) (field-definition-name fd))) ,extra-initargs)))))))) - - - - (defmethod stream-read-message-begin ((protocol protocol)) "Read a message header strictly. PROTOCOL : protocol @@ -507,8 +481,8 @@ This version recognizes the layout established by the compact protocol, whereby the first byte is the protocol id and subsequent to that is specific to the protocol." - (let* ((id (logand (stream-read-i08 protocol) #xff)) ; actually unsigned - (ver (logand (stream-read-i08 protocol) #xff)) ; actually unsigned + (let* ((id (logand (stream-read-i8 protocol) #xff)) ; actually unsigned + (ver (logand (stream-read-i8 protocol) #xff)) ; actually unsigned (type-name (stream-read-message-type protocol))) (unless (and (= (protocol-version-id protocol) id) (= (protocol-version-number protocol) ver)) (invalid-protocol-version protocol id ver)) @@ -516,7 +490,6 @@ (sequence (stream-read-i32 protocol))) (values name type-name sequence)))) - (defmethod stream-read-message ((protocol protocol)) "Perform a generic 'read' of a complete message. PROTOCOL : protocol @@ -541,8 +514,6 @@ (defmethod stream-read-message-end ((protocol protocol))) - - (defmethod stream-read-map-begin ((protocol protocol)) ; t_key t_val size (values (stream-read-type protocol) @@ -588,8 +559,6 @@ (stream-read-map-end ,prot) (nreverse ,map))))))) - - (defmethod stream-read-list-begin ((protocol protocol)) ; t_elt size (values (stream-read-type protocol) @@ -622,8 +591,6 @@ collect (stream-read-value-as ,prot ',type)) (stream-read-list-end ,prot)))))) - - (defmethod stream-read-set-begin ((protocol protocol)) (values (stream-read-type protocol) (stream-read-i32 protocol))) @@ -655,8 +622,6 @@ collect (stream-read-value-as ,prot ',type)) (stream-read-set-end ,prot)))))) - - (defmethod stream-read-enum ((protocol protocol) type) "Read an i32 and verify type" (let ((value (stream-read-i32 protocol))) @@ -673,7 +638,6 @@ value) `(stream-read-i32 ,prot))) - (defgeneric stream-read-value-as (protocol type) (:documentation "Read a value if a specified type.") (:method ((protocol protocol) (type-code fixnum)) @@ -689,10 +653,10 @@ (:method ((protocol protocol) (type-code (eql 'bool))) (stream-read-bool protocol)) (:method ((protocol protocol) (type-code (eql 'thrift:byte))) - ;; call through the i08 methods as byte ops are transport, not protocol methods - (stream-read-i08 protocol)) - (:method ((protocol protocol) (type-code (eql 'i08))) - (stream-read-i08 protocol)) + ;; call through the i8 methods as byte ops are transport, not protocol methods + (stream-read-i8 protocol)) + (:method ((protocol protocol) (type-code (eql 'i8))) + (stream-read-i8 protocol)) (:method ((protocol protocol) (type-code (eql 'i16))) (stream-read-i16 protocol)) (:method ((protocol protocol) (type-code (eql 'enum))) @@ -720,7 +684,6 @@ (:method ((protocol protocol) (type-code (eql 'thrift:set))) (stream-read-set protocol))) - (define-compiler-macro stream-read-value-as (&whole form protocol type) "Given a constant type, generate the respective read operations. Recognizes all thrift types, container x element type combinations @@ -754,7 +717,6 @@ `(stream-read-struct ,protocol ',(str-sym (second type)))) (enum-type `(stream-read-enum ,protocol ',(str-sym (second type)))))) - (defgeneric stream-read-typed-value (protocol) (:documentation "Given a PROTOCOL instance, decode the value's type and then the value itself. @@ -764,9 +726,7 @@ (let ((type-name (stream-read-type protocol))) (stream-read-value-as protocol type-name)))) - - -;;; output implementation +;;; output implementation ;;; nb. defined in this sequence to ensure compile-macro presence is whether loading one or ;;; reloading while developing @@ -794,8 +754,6 @@ (stream-write-value-as ,prot ,value ',type) (stream-write-field-end ,prot))))) - - (defmethod stream-write-struct-begin ((protocol protocol) (name string)) (ecase (protocol-struct-id-mode protocol) (:identifier-name @@ -903,11 +861,9 @@ (assert (typep ,value ',type) () "Attempt to serialize ~s as ~s." ,value ',type))))))))) - - (defmethod stream-write-message-begin ((protocol protocol) name type sequence) - (stream-write-i08 protocol (protocol-version-id protocol)) - (stream-write-i08 protocol (protocol-version-number protocol)) + (stream-write-i8 protocol (protocol-version-id protocol)) + (stream-write-i8 protocol (protocol-version-number protocol)) (stream-write-message-type protocol type) (stream-write-string protocol name) (stream-write-i32 protocol sequence)) @@ -932,7 +888,6 @@ (stream-write-message-begin protocol (class-identifier type) message-type sequence-number) (stream-write-struct protocol object type) (stream-write-message-end protocol)) - (defmethod stream-write-message-end ((protocol protocol)) (stream-force-output (protocol-output-transport protocol))) @@ -942,14 +897,12 @@ (:method ((protocol protocol) (exception thrift-error)) (stream-write-message protocol exception 'exception :identifier (class-identifier exception))) - + (:method ((protocol protocol) (exception condition)) (stream-write-message protocol (make-instance 'application-error :condition exception) 'exception))) - - (defmethod stream-write-map-begin ((protocol protocol) key-type value-type size) (stream-write-type protocol key-type) (stream-write-type protocol value-type) @@ -979,8 +932,6 @@ (stream-write-value-as ,prot element-value ',value-type))) (stream-write-map-end ,prot))))) - - (defmethod stream-write-list-begin ((protocol protocol) (type t) length) (stream-write-type protocol type) (stream-write-i32 protocol length)) @@ -1009,8 +960,6 @@ (stream-write-value-as ,prot element ',element-type)) (stream-write-list-end ,prot))))) - - (defmethod stream-write-set-begin ((protocol protocol) (type t) length) (stream-write-type protocol type) (stream-write-i32 protocol length)) @@ -1040,8 +989,6 @@ (stream-write-value-as ,prot element ',element-type)) (stream-write-set-end ,prot))))) - - (defgeneric stream-write-value (protocol value) (:method ((protocol protocol) (value null)) (stream-write-bool protocol value)) @@ -1049,7 +996,7 @@ (stream-write-bool protocol value)) (:method ((protocol protocol) (value integer)) (etypecase value - (i08 (stream-write-i08 protocol value)) + (i8 (stream-write-i8 protocol value)) (i16 (stream-write-i16 protocol value)) (i32 (stream-write-i32 protocol value)) (i64 (stream-write-i64 protocol value)))) @@ -1063,7 +1010,7 @@ (stream-write-string protocol value)) (:method ((protocol protocol) (value vector)) (stream-write-binary protocol value)) - + (:method ((protocol protocol) (value thrift-object)) (stream-write-struct protocol value)) (:method ((protocol protocol) (value list)) @@ -1071,7 +1018,6 @@ (stream-write-map protocol value) (stream-write-list protocol value)))) - (defgeneric stream-write-value-as (protocol value type) (:method ((protocol protocol) (value t) (type-code fixnum)) (stream-write-value-as protocol value (type-code-name protocol type-code))) @@ -1079,17 +1025,17 @@ (:method ((protocol protocol) (value t) (type (eql 'bool))) (stream-write-bool protocol value)) (:method ((protocol protocol) (value integer) (type (eql 'thrift:byte))) - (stream-write-i08 protocol value)) - (:method ((protocol protocol) (value integer) (type (eql 'i08))) - (stream-write-i08 protocol value)) + (stream-write-i8 protocol value)) + (:method ((protocol protocol) (value integer) (type (eql 'i8))) + (stream-write-i8 protocol value)) (:method ((protocol protocol) (value integer) (type (eql 'i16))) (stream-write-i16 protocol value)) (:method ((protocol protocol) (value integer) (type (eql 'enum))) ;; as a fall-back - (stream-write-i16 protocol value)) + (stream-write-i32 protocol value)) (:method ((protocol protocol) (value integer) (type cons)) ;; as a fall-back - (stream-write-i16 protocol value)) + (stream-write-i32 protocol value)) (:method ((protocol protocol) (value integer) (type (eql 'i32))) (stream-write-i32 protocol value)) (:method ((protocol protocol) (value integer) (type (eql 'i64))) @@ -1131,7 +1077,6 @@ (thrift:set (stream-write-set protocol value (str-sym t1))) (thrift:map (stream-write-map protocol value (str-sym t1) (str-sym t2))))))) - (define-compiler-macro stream-write-value-as (&whole form protocol value type) "See stream-read-value-as." @@ -1160,8 +1105,7 @@ (struct-type `(stream-write-struct ,protocol ,value ',(str-sym (second type)))) (enum-type - `(stream-write-i16 ,protocol ,value)))) - + `(stream-write-i32 ,protocol ,value)))) (defgeneric stream-write-typed-value (protocol value) (:documentation "Given a PROTOCOL instance and a VALUE, encode the value's type and then the value itself. @@ -1180,7 +1124,6 @@ (error 'application-error :protocol protocol :condition condition))) - (defgeneric class-not-found (protocol identifier) (:method ((protocol protocol) identifier) (error 'class-not-found-error :protocol protocol :identifier identifier))) @@ -1190,17 +1133,18 @@ (:method ((protocol protocol) type datum) (error 'enum-type-error :protocol protocol :expected-type type :datum datum))) - (defgeneric unknown-field (protocol field-id-number field-name field-type value) (:documentation "Called when a decoded field is not present in the specified type. The base method for protocols ignores it. A prototypical protocol/class combination could extend the class by adding a field definition as per the name/id/type specified and bindng the value") - (:method ((protocol protocol) (id-number integer) (name t) (type t) (value t)) + nil) + ;; The default method for thrift classes does nothing, which is intended to leave the final + ;; disposition to the protocol. + (:method ((class thrift-class) (id t) (name t) (type t) (value t)) nil)) - (defgeneric invalid-field-size (protocol field-id field-name expected-type size) (:documentation "Called when a read structure field exceeds the dimension limit. The base method for binary protocols signals a field-size-error") @@ -1209,7 +1153,6 @@ (error 'field-size-error :protocol protocol :name name :number id :expected-type expected-type :datum size))) - (defgeneric invalid-field-type (protocol structure-type field-id field-name expected-type value) (:documentation "Called when a read structure field is not present in the specified type. The base method for binary protocols signals a field-type-error") @@ -1220,7 +1163,6 @@ :structure-type structure-type :name name :number id-number :expected-type expected-type :datum value) value)) - (defgeneric invalid-element-type (protocol container-type expected-type type) (:documentation "Called when the element type of a received compound value is not the specified type. The base method for binary protocols signals an element-type-error") @@ -1229,34 +1171,28 @@ (error 'element-type-error :protocol protocol :container-type container-type :expected-type expected-type :element-type type))) - (defgeneric unknown-method (protocol method-identifier sequence message) (:method ((protocol protocol) method-identifier (sequence t) (message t)) (error 'unknown-method-error :identifier method-identifier :request message))) - (defgeneric protocol-error (protocol type &optional message &rest arguments) (:method ((protocol protocol) type &optional message &rest arguments) (error 'protocol-error :type type :message message :message-arguments arguments))) - (defgeneric invalid-protocol-version (protocol id version) (:method ((protocol protocol) id version) (error 'protocol-version-error :protocol protocol :datum (cons id version) :expected-type (protocol-version protocol)))) - (defgeneric invalid-sequence-number (protocol number expected-number) (:method ((protocol protocol) number expected-number) (error 'sequence-number-error :protocol protocol :number number :expected-number expected-number))) - (defgeneric invalid-struct-type (protocol type datum) (:method ((protocol protocol) type datum) (error 'struct-type-error :protocol protocol :expected-type type :datum datum))) - ;;; ;;; response processing exception interface diff --git a/server.lisp b/server.lisp index f9b825a..d6c89af 100644 --- a/server.lisp +++ b/server.lisp @@ -1,33 +1,31 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- - -(in-package :org.apache.thrift.implementation) - -;;; This file implements service instance and a server interface for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. - - -;;; The principal Thrift entity for reomte interaction is the `service`. A service is a named -;;; collection of operations. A server associates a service with a listening port, accepts -;;; request for named operations, decodes and dsipatchs data to the service's operations, -;;; encodes the results and returns them them to thr requesting client. +(in-package #:org.apache.thrift.implementation) + +;;;; This file implements service instance and a server interface for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. + + +;;;; The principal Thrift entity for reomte interaction is the `service`. A service is a named +;;;; collection of operations. A server associates a service with a listening port, accepts +;;;; request for named operations, decodes and dsipatchs data to the service's operations, +;;;; encodes the results and returns them them to thr requesting client. (defclass service () @@ -61,7 +59,6 @@ each service is bound to a global parameter named as its Lisp equivalent. A service can also serve as the root for a set of subsidiary services, to which it defers method look-ups.")) - (defclass server () ((services :initform nil :initarg :services @@ -72,17 +69,18 @@ an exception is returned.")) (:documentation "A server associates a root service with a request transport.")) - (defclass socket-server (server) ((socket :accessor server-socket :initarg :socket)) (:documentation "The server class which combines services with a listening socket.")) +(defun thriftp (uri) + "Check whether the URI is a Thrift URI." + (eql :thrift (puri:uri-scheme uri))) -(defclass thrift (puri:uri) - () - (:documentation "A specialized URI class to distinguish Thrift locations when constructing a - server.")) - +;;; A special type to easily distinguish Thrift URIs. +(deftype thrift () '(and + puri:uri + (satisfies thriftp))) ;;; ;;; service operators @@ -101,22 +99,39 @@ (format stream "~@[~a~]" (service-identifier object)))) (defgeneric method-definition (service identifier) + (:method ((service (eql nil)) identifier)) + (:method ((services list) (identifier string)) + (alexandria:when-let* ((pos (position #\: identifier)) + (service-identifier (subseq identifier 0 pos)) + (method-identifier (subseq identifier (1+ pos)))) + (alexandria:if-let ((service (find service-identifier + services + :test #'string= + :key #'service-identifier))) + (return-from method-definition (method-definition service method-identifier)) + (dolist (service services) + (multiple-value-bind (fun service) + (method-definition (service-base-services service) identifier) + (when fun (return-from method-definition (values fun service))))))) + (dolist (base-service services) + (multiple-value-bind (fun service) + (method-definition base-service identifier) + (when fun (return-from method-definition (values fun service)))))) (:method ((service service) (identifier string)) (let ((fun (gethash identifier (service-methods service)))) (if fun - (values fun service) - (dolist (base-service (service-base-services service)) - (multiple-value-bind (fun service) - (method-definition identifier base-service) - (when fun (return-from method-definition (values fun service))))))))) + (values fun service) + (dolist (base-service (service-base-services service)) + (multiple-value-bind (fun service) + (method-definition base-service identifier) + (when fun (return-from method-definition (values fun service))))))))) (defgeneric (setf method-definition) (function service identifier) - (:method ((function thrift-generic-function) (service service) (identifier string)) + (:method ((function function) (service service) (identifier string)) (setf (gethash identifier (service-methods service)) function)) (:method ((function null) (service service) (identifier string)) (remhash identifier (service-methods service)))) - ;;; ;;; server operators @@ -127,7 +142,6 @@ (defgeneric server-output-transport (server connection) (:method ((server socket-server) (socket usocket:usocket)) (make-instance 'socket-transport :socket socket :direction :output))) - (defmethod accept-connection ((s socket-server)) (usocket:socket-accept (server-socket s) :element-type 'unsigned-byte)) @@ -140,64 +154,71 @@ (make-instance 'binary-protocol :input-transport input :output-transport output :direction :io))) - (defparameter *debug-server* t) -(defgeneric serve (connection-server service) +(defgeneric serve (connection-server service &key &allow-other-keys) (:documentation "Accept to a CONNECTION-SERVER, configure the CLIENT's transport and protocol in combination with the connection, and process messages until the connection closes.") - (:method ((location thrift) service) + (:method ((location puri:uri) service + &key framed (multiplexed (listp service)) &allow-other-keys) "Given a basic thrift uri, open a binary socket server and listen on the port." (let ((server (make-instance 'socket-server - :socket (usocket:socket-listen (puri:uri-host location) (puri:uri-port location) - :element-type 'unsigned-byte - :reuseaddress t)))) - (unwind-protect (serve server service) + :socket (usocket:socket-listen (puri:uri-host location) + (puri:uri-port location) + :element-type 'unsigned-byte + :reuseaddress t) + :services (alexandria:ensure-list service)))) + (unwind-protect (serve server + (server-services server) + :framed framed + :multiplexed multiplexed) (server-close server)))) - (:method ((s socket-server) (service service)) - (loop + (:method ((s socket-server) (services list) &key framed multiplexed &allow-other-keys) + (loop (let ((connection (accept-connection s))) (if (open-stream-p (usocket:socket-stream connection)) - (let* ((input-transport (server-input-transport s connection)) - (output-transport (server-output-transport s connection)) - (protocol (server-protocol s input-transport output-transport))) - (unwind-protect (block :process-loop - (handler-bind ((end-of-file (lambda (eof) - (declare (ignore eof)) - (return-from :process-loop))) - (error (lambda (error) - (if *debug-server* - (break "Server error: ~s: ~a" s error) - (warn "Server error: ~s: ~a" s error)) - (stream-write-exception protocol error) - (return-from :process-loop)))) - (loop (unless (open-stream-p input-transport) (return)) - (process service protocol)))) + (let ((input-transport (server-input-transport s connection)) + (output-transport (server-output-transport s connection))) + (when framed + (setf input-transport (framed-transport input-transport)) + (setf output-transport (framed-transport output-transport))) + (let ((protocol (server-protocol s input-transport output-transport))) + (setf (slot-value protocol 'multiplexed) multiplexed) + (unwind-protect (block :process-loop + (handler-bind ((end-of-file (lambda (eof) + (declare (ignore eof)) + (return-from :process-loop))) + (error (lambda (error) + (if *debug-server* + (break "Server error: ~s: ~a" s error) + (warn "Server error: ~s: ~a" s error)) + (stream-write-exception protocol error) + (return-from :process-loop)))) + (loop while (open-stream-p input-transport) + do (process services protocol)))) (close input-transport) - (close output-transport))) + (close output-transport)))) ;; listening socket closed (return)))))) - (defgeneric process (service protocol) (:documentation "Combine a service PEER with an input-protocol and an output-protocol to control processing the next message on the peer's input connection. The base method reads the message, decodes the function and the arguments, invokes the method, and replies with the results. The protocols are initially those of the peer itself, but they are passed her in order to permit wrapping for logging, etc.") - - (:method ((service service) (protocol t)) + (:method ((services list) (protocol protocol)) (flet ((consume-message () (prog1 (stream-read-struct protocol) (stream-read-message-end protocol)))) (multiple-value-bind (request-identifier type sequence-number) - (stream-read-message-begin protocol) + (stream-read-message-begin protocol) (ecase type ((call oneway) (multiple-value-bind (request-method service) - (method-definition service request-identifier) + (method-definition services request-identifier) (cond (request-method (let ((*package* (service-package service))) (funcall request-method service sequence-number protocol))) @@ -207,5 +228,3 @@ (unexpected-response protocol request-identifier sequence-number (consume-message))) (exception (request-exception protocol request-identifier sequence-number (consume-message)))))))) - - diff --git a/symbols.lisp b/symbols.lisp index 26b84dd..721d829 100644 --- a/symbols.lisp +++ b/symbols.lisp @@ -1,47 +1,40 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- +(in-package #:org.apache.thrift.implementation) -(in-package :org.apache.thrift.implementation) +;;;; This file defines symbols construction operators for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. -;;; This file defines symbols construction operators for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. - -;;; The IDL translator emits definition forms which retain the original identifer -;;; strings. These operators perform symbol name canonicalization, and symbol construction. -;;; They are used at compile-time by the IDL macros to construct symbols for classes, fields, -;;; and methods. Cross-references between namespaces are implemented as prefixed identifiers. -;;; The resective operators cache the original identifiers in metaobjects for use at run-time -;;; to decode/encode messages. +;;;; The IDL translator emits definition forms which retain the original identifer +;;;; strings. These operators perform symbol name canonicalization, and symbol construction. +;;;; They are used at compile-time by the IDL macros to construct symbols for classes, fields, +;;;; and methods. Cross-references between namespaces are implemented as prefixed identifiers. +;;;; The resective operators cache the original identifiers in metaobjects for use at run-time +;;;; to decode/encode messages. (eval-when (:compile-toplevel :load-toplevel :execute) ; for batch compilation + (defun %pkg-name (service suffix) + (alexandria:symbolicate (package-name *package*) #\. service suffix)) - (defun implementation-package () - (let ((package (concatenate 'string (package-name *package*) (string :-implementation)))) - (or (find-package package) - (make-package package :use nil)))) - - (defun response-package () - (let ((package (concatenate 'string (package-name *package*) (string :-response)))) - (or (find-package package) - (make-package package :use nil)))) + (defun response-package (service-name) + (find-package (%pkg-name service-name "-RESPONSE"))) (defun canonicalize-name (string) "Replace a camel-case pattern with lower case and '-' separation." @@ -65,12 +58,12 @@ (setf case :lower) (vector-push-extend c result)))))) (subseq result 0))) - + (defun cons-symbol (package &rest args) "Construct a symbol given string designators. If package is null, the symbol is a new, uninterned symbol." (declare (dynamic-extent args)) - + (flet ((element-length (element) (if element (length (string element)) 0))) (declare (dynamic-extent #'element-length)) @@ -102,7 +95,7 @@ (or (find-symbol name package) (intern (copy-seq name) package)) (make-symbol (copy-seq name)))))) - + (defun str-sym (&rest strs) "Given a sequence of symbol name consititents, construct a symbol observing current reader case settings. By default intern the symbol in the current *package*. @@ -119,23 +112,14 @@ (apply #'cons-symbol (cons-symbol :keyword (subseq first 0 colon)) (subseq first (1+ colon)) strs) (apply #'cons-symbol *package* first strs)))))) - + ;;; (assert (equal (list (str-sym "keyword:a") (str-sym "keyword:" "a") (str-sym "a" "sdf")) '(:a :a thrift-generated::asdf))) - - (defun implementation-str-sym (&rest identifiers) - (let* ((*package* (implementation-package)) - (sym (apply #'str-sym identifiers))) - (export sym *package*) - sym)) - (defun response-str-sym (&rest identifiers) - (let* ((*package* (response-package)) - (sym (apply #'str-sym identifiers))) + (defun response-str-sym (service-identifier method-identifier) + (let* ((*package* (response-package (str-sym service-identifier))) + (sym (str-sym method-identifier))) (export sym *package*) sym)) - - (defun strs-syms (strs &key (key #'identity)) - (mapcar #'str-sym (mapcar key strs))) (defmacro with-gensyms (syms &body b) `(let ,(mapcar #'(lambda (s) `(,s (gensym ,(string s)))) syms) @@ -162,5 +146,4 @@ (defun str (&rest args) (declare (dynamic-extent args)) - (apply #'concatenate 'string args)) - ) + (apply #'concatenate 'string args))) diff --git a/test/conditions.lisp b/test/conditions.lisp index 3c55d19..115311f 100644 --- a/test/conditions.lisp +++ b/test/conditions.lisp @@ -1,88 +1,135 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: thrift-test; -*- - -(in-package :thrift-test) - -;;; this file defines tests for exception classes. -;;; (run-tests "conditions/.*") - - -(test conditions/thrift-error - (stringp (princ-to-string (make-condition 'thrift-error)))) - - -(test conditions/application-error - (stringp (princ-to-string (make-condition 'application-error - :condition (nth-value 1 (ignore-errors (error "testing errors"))))))) - -(test conditions/protocol-error - (stringp (princ-to-string (make-condition 'protocol-error - :protocol (make-test-protocol))))) - -(test conditions/transport-error - (stringp (princ-to-string (make-condition 'transport-error)))) - -(test conditions/class-not-found-error - (and (stringp (princ-to-string (make-condition 'class-not-found-error - :protocol (make-test-protocol) - :identifier "UnknownClass"))) - (typep (nth-value 1 (ignore-errors (class-not-found (make-test-protocol) "UnknownClass"))) - 'class-not-found-error))) - -(test conditions/protocol-version-error - (and (stringp (princ-to-string (make-condition 'protocol-version-error - :protocol (make-test-protocol) - :datum '(0 . 0) :expected-type '(1 . 1)))) - (typep (nth-value 1 (ignore-errors (invalid-protocol-version (make-test-protocol) 0 0))) - 'protocol-version-error))) - -(test conditions/element-type-error - (and (stringp (princ-to-string (make-condition 'element-type-error - :protocol (make-test-protocol) - :container-type 'list :expected-type 'bool :element-type 'i16))) - (typep (nth-value 1 (ignore-errors (invalid-element-type (make-test-protocol) 'list 'bool 'i16))) - 'element-type-error))) - -(test conditions/enum-type-error - (and (stringp (princ-to-string (make-condition 'enum-type-error - :protocol (make-test-protocol) - :datum 3 :expected-type '(enum "x")))) - (typep (nth-value 1 (ignore-errors (invalid-enum (make-test-protocol) '(enum "x") 3))) - 'enum-type-error))) - -(test conditions/field-size-error - (and (stringp (princ-to-string (make-condition 'field-size-error - :protocol (make-test-protocol) - :name "fieldex" :number -1 - :datum most-negative-fixnum :expected-type `(integer 0 ,most-positive-fixnum)))) - (typep (nth-value 1 (ignore-errors (invalid-field-size (make-test-protocol) -1 "fieldex" `(integer 0 ,most-positive-fixnum) most-negative-fixnum))) - 'field-size-error))) - -(test conditions/field-type-error - (and (stringp (princ-to-string (make-condition 'field-type-error - :protocol (make-test-protocol) - :structure-type 'test-struct :name "fieldex" :number 17 - :expected-type 'bool :datum 12345))) - (typep (nth-value 1 (ignore-errors (invalid-field-type (make-test-protocol) 'test-struct 17 "fieldex" 'bool 12345))) - 'field-type-error))) - -(test conditions/unknown-field-error - (and (stringp (princ-to-string (make-condition 'unknown-field-error - :protocol (make-test-protocol) - :structure-type 'test-struct :name "fieldex" :number 17 :datum 12345))) - (typep (nth-value 1 (ignore-errors (unknown-field (make-test-protocol) 17 "fieldex" 'i16 12345))) - 'null))) - -(test conditions/unknown-method-error - (and (stringp (princ-to-string (make-condition 'unknown-method-error - :protocol (make-test-protocol) - :identifier "methodex" :request t))) - (typep (nth-value 1 (ignore-errors (unknown-method (make-test-protocol) "methodex" 12345 t))) - 'unknown-method-error))) - - -(test conditions/struct-type-error - (and (stringp (princ-to-string (make-condition 'struct-type-error - :protocol (make-test-protocol) - :expected-type 'test-struct :datum t))) - (typep (nth-value 1 (ignore-errors (invalid-struct-type (make-test-protocol) 'test-struct t))) - 'struct-type-error))) +;;;; Copyright 2010 James Anderson +;;;; +;;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;;; you may not use this file except in compliance with the License. +;;;; You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, software +;;;; distributed under the License is distributed on an "AS IS" BASIS, +;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;;; See the License for the specific language governing permissions and +;;;; limitations under the License. + +;;;; This file defines tests for exception classes. + +(fiasco:define-test-package (#:condition-tests :in thrift-test:thrift-self-tests) + (:use #:thrift-test-utils)) + +(in-package #:condition-tests) + +(deftest thrift-error () + (is (stringp (princ-to-string (make-condition 'thrift:thrift-error))))) + +(deftest application-error () + (is (stringp + (princ-to-string + (make-condition 'thrift:application-error + :condition (nth-value 1 (ignore-errors (error "testing errors")))))))) + +(deftest protocol-error () + (is (stringp (princ-to-string (make-condition 'thrift:protocol-error + :protocol (make-test-protocol)))))) + +(deftest transport-error () + (is (stringp (princ-to-string (make-condition 'thrift:transport-error))))) + +(deftest class-not-found-error () + (is (stringp (princ-to-string (make-condition 'thrift:class-not-found-error + :protocol (make-test-protocol) + :identifier "UnknownClass")))) + (is (typep (nth-value 1 (ignore-errors (thrift:class-not-found (make-test-protocol) "UnknownClass"))) + 'thrift:class-not-found-error))) + +(deftest protocol-version-error () + (is (stringp (princ-to-string (make-condition 'thrift:protocol-version-error + :protocol (make-test-protocol) + :datum '(0 . 0) + :expected-type '(1 . 1))))) + (is (typep (nth-value 1 (ignore-errors (thrift:invalid-protocol-version (make-test-protocol) 0 0))) + 'thrift:protocol-version-error))) + +(deftest element-type-error () + (is (stringp (princ-to-string (make-condition 'thrift:element-type-error + :protocol (make-test-protocol) + :container-type 'list + :expected-type 'bool + :element-type 'i16)))) + (is (typep (nth-value 1 (ignore-errors (thrift:invalid-element-type (make-test-protocol) + 'list + 'bool + 'i16))) + 'thrift:element-type-error))) + +(deftest enum-type-error () + (is (stringp (princ-to-string (make-condition 'thrift:enum-type-error + :protocol (make-test-protocol) + :datum 3 + :expected-type '(enum "x"))))) + (is (typep (nth-value 1 (ignore-errors (thrift:invalid-enum (make-test-protocol) '(enum "x") 3))) + 'thrift:enum-type-error))) + +(deftest field-size-error () + (is (stringp (princ-to-string (make-condition 'thrift:field-size-error + :protocol (make-test-protocol) + :name "fieldex" + :number -1 + :datum most-negative-fixnum + :expected-type `(integer 0 ,most-positive-fixnum))))) + (is (typep (nth-value 1 (ignore-errors (thrift:invalid-field-size (make-test-protocol) + -1 + "fieldex" + `(integer 0 ,most-positive-fixnum) + most-negative-fixnum))) + 'thrift:field-size-error))) + +(deftest field-type-error () + (is (stringp (princ-to-string (make-condition 'thrift:field-type-error + :protocol (make-test-protocol) + :structure-type 'test-struct + :name "fieldex" + :number 17 + :expected-type 'bool + :datum 12345)))) + (is (typep (nth-value 1 (ignore-errors (thrift:invalid-field-type (make-test-protocol) + 'test-struct 17 + "fieldex" + 'bool + 12345))) + 'thrift:field-type-error))) + +(deftest unknown-field-error () + (is (stringp (princ-to-string (make-condition 'thrift:unknown-field-error + :protocol (make-test-protocol) + :structure-type 'test-struct + :name "fieldex" + :number 17 + :datum 12345)))) + (is (typep (nth-value 1 (ignore-errors (thrift:unknown-field (make-test-protocol) + 17 + "fieldex" + 'i16 + 12345))) + 'null))) + +(deftest unknown-method-error () + (is (stringp (princ-to-string (make-condition 'thrift:unknown-method-error + :protocol (make-test-protocol) + :identifier "methodex" + :request t)))) + (is (typep (nth-value 1 (ignore-errors (thrift:unknown-method (make-test-protocol) + "methodex" + 12345 + t))) + 'thrift:unknown-method-error))) + +(deftest struct-type-error () + (is (stringp (princ-to-string (make-condition 'thrift:struct-type-error + :protocol (make-test-protocol) + :expected-type 'test-struct + :datum t)))) + (is (typep (nth-value 1 (ignore-errors (thrift:invalid-struct-type (make-test-protocol) + 'test-struct + t))) + 'thrift:struct-type-error))) diff --git a/test/definition-operators.lisp b/test/definition-operators.lisp index b5c4c0f..6e60420 100644 --- a/test/definition-operators.lisp +++ b/test/definition-operators.lisp @@ -1,92 +1,97 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: thrift-test; -*- +;;;; Copyright 2010 James Anderson +;;;; +;;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;;; you may not use this file except in compliance with the License. +;;;; You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, software +;;;; distributed under the License is distributed on an "AS IS" BASIS, +;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;;; See the License for the specific language governing permissions and +;;;; limitations under the License. -(in-package :thrift-test) +;;;; Tests for definition operators. -;;; tests for definition operators -;;; (run-tests "def-.*") +(fiasco:define-test-package (#:definition-operator-tests :in thrift-test:thrift-self-tests) + (:use #:thrift-test-utils)) -(test def-package.1 - (progn (def-package :test-package) - (prog1 (and (find-package :test-package) - (find-package :test-package-implementation) - (find-package :test-package-response)) - (delete-package :test-package) - (delete-package :test-package-implementation) - (delete-package :test-package-response)))) +(in-package #:definition-operator-tests) -(test def-package.2 - ;; redfinition should succeed - (progn (def-package :test-package) - (def-package :test-package) - (prog1 (and (find-package :test-package) - (find-package :test-package-implementation) - (find-package :test-package-response)) - (delete-package :test-package) - (delete-package :test-package-implementation) - (delete-package :test-package-response)))) -;;; (run-tests "def-package.*") +(deftest define-package () + (finishes (thrift:def-package :test-package)) + (is (find-package :test-package)) + (is (find-package :test-package-implementation)) + (is (find-package :test-package-response)) + (delete-package :test-package) + (delete-package :test-package-implementation) + (delete-package :test-package-response)) -(test def-enum - (progn (def-enum "TestEnum" ((first . 1) (second . 2))) - (prog1 (and (eql (symbol-value 'test-enum.first) 1) - (eql (symbol-value 'test-enum.second) 2))))) -;;; (run-tests "def-enum") +(deftest redefine-package () + (thrift:def-package :test-package) + (finishes (thrift:def-package :test-package)) + (is (find-package :test-package)) + (is (find-package :test-package-implementation)) + (is (find-package :test-package-response)) + (delete-package :test-package) + (delete-package :test-package-implementation) + (delete-package :test-package-response)) -(test def-constant - (progn (def-constant "aConstant" 1) - (prog1 (eql (symbol-value 'a-constant) 1) - (unintern 'a-constant)))) +(deftest define-enum () + (finishes (thrift:def-enum "TestEnum" ((first . 1) (second . 2)))) + (is (eql (symbol-value 'test-enum.first) 1)) + (is (eql (symbol-value 'test-enum.second) 2))) +(deftest define-constant () + (finishes (thrift:def-constant "aConstant" 1)) + (is (eql (symbol-value 'a-constant) 1)) + (unintern 'a-constant)) (defgeneric test-struct-too-field1 (struct)) (defgeneric test-struct-too-field2 (struct)) (defgeneric test-struct-too-field3 (struct)) (defgeneric (setf test-struct-too-field2) (value struct)) -(test def-struct - (progn - (def-struct "testStructToo" ()) - (def-struct "testStructToo" - (("field1" 0 :type i32 :id 1) - ("field2" nil :type i16 :id 2 :optional t) - ("field3" "string value" :type string :id 3))) - (let ((struct (make-instance 'test-struct-too :field1 -1))) - (prog1 (and (equal (test-struct-too-field3 struct) "string value") - (not (slot-boundp struct 'field2)) - (equal (test-struct-too-field1 struct) -1) - (typep (nth-value 1 (ignore-errors (setf (test-struct-too-field2 struct) 1.1))) - ;; some implementation may not constrain - ;; some signal a type error - #+ccl 'type-error - #+sbcl 'null)) ; how to enable slot type checks? - (mapc #'(lambda (method) (remove-method (c2mop:method-generic-function method) method)) - (c2mop:specializer-direct-methods (find-class 'test-struct-too))) - (setf (find-class 'test-struct-too) nil))))) -;;; (run-tests "def-struct") +(deftest define-struct () + (finishes (thrift:def-struct "testStructToo" ())) + (finishes (thrift:def-struct "testStructToo" + (("field1" 0 :type i32 :id 1) + ("field2" nil :type i16 :id 2 :optional t) + ("field3" "string value" :type string :id 3)))) + (let ((struct (make-instance 'test-struct-too :field1 -1))) + (is (equal (test-struct-too-field3 struct) "string value")) + (is (not (slot-boundp struct 'field2))) + (is (equal (test-struct-too-field1 struct) -1)) + (is (typep (nth-value 1 (ignore-errors (setf (test-struct-too-field1 struct) 1.1))) 'null)) + (mapc #'(lambda (method) (remove-method (c2mop:method-generic-function method) method)) + (c2mop:specializer-direct-methods (find-class 'test-struct-too))) + (setf (find-class 'test-struct-too) nil))) (defgeneric test-exception-reason (exception)) -(test def-exception - (progn - (eval '(def-exception "testException" (("reason" nil :type string :id 1)))) - (let ((ex (make-condition 'test-exception :reason "testing"))) - (prog1 (and (equal (test-exception-reason ex) "testing") - (eq (cl:type-of (nth-value 1 (ignore-errors (error ex)))) - 'test-exception) - (stringp (princ-to-string ex))) - (mapc #'(lambda (method) (remove-method (c2mop:method-generic-function method) method)) - (c2mop:specializer-direct-methods (find-class 'test-exception))) - (mapc #'(lambda (method) (remove-method (c2mop:method-generic-function method) method)) - (c2mop:specializer-direct-methods (find-class 'test-exception-exception-class))) - (setf (find-class 'test-exception) nil) - (setf (find-class 'test-exception-exception-class) nil))))) +(thrift:def-exception "testException" (("reason" nil :type string :id 1))) +(deftest define-exception () + (let ((ex (make-condition 'test-exception :reason "testing"))) + (is (equal (test-exception-reason ex) "testing")) + (is (eq (cl:type-of (nth-value 1 (ignore-errors (error ex)))) + 'test-exception)) + (is (stringp (princ-to-string ex))) + (mapc #'(lambda (method) (remove-method (c2mop:method-generic-function method) method)) + (c2mop:specializer-direct-methods (find-class 'test-exception))) + (mapc #'(lambda (method) (remove-method (c2mop:method-generic-function method) method)) + (c2mop:specializer-direct-methods (find-class 'test-exception-exception-class))) + (setf (find-class 'test-exception) nil) + (setf (find-class 'test-exception-exception-class) nil))) +#+(or) +(def-service "TestService" nil + (:method "someTestMethod" ((("arg1" i32 1) ("arg2" string 2)) string))) +#+(or) (test def-service - (progn (defun thrift-test-implementation::test-method (arg1 arg2) (format nil "~a ~a" arg1 arg2)) - (eval '(def-service "TestService" nil - (:method "testMethod" ((("arg1" i32 1) ("arg2" string 2)) string)))) + (progn (eval '(defun thrift-test.test-service-implementation:some-test-method (arg1 arg2) (format nil "~a ~a" arg1 arg2))) (let (request-protocol response-protocol (run-response-result nil)) @@ -96,22 +101,20 @@ (stream-read-message-begin response-protocol) (cond ((and (equal identifier "testMethod") (eq type 'call)) (setf run-response-result - (funcall 'thrift-test-response::test-method t seq response-protocol))) + (funcall 'thrift-test.test-service-response::test-method + t seq response-protocol))) (t (unknown-method response-protocol identifier seq (prog1 (stream-read-struct response-protocol) (stream-read-message-end response-protocol)))))))) - (multiple-value-setq (request-protocol response-protocol) (make-test-protocol-peers :request-hook #'run-response)) - - (prog1 (and (equal (funcall 'thrift-test::test-method request-protocol 1 "testing") + + (prog1 (and (equal (funcall 'thrift-test.test-service::test-method request-protocol 1 "testing") "1 testing") ;; if the first test succeed, this should also be true (equal run-response-result "1 testing")) - (fmakunbound 'thrift-test-implementation::test-method) - (fmakunbound 'thrift-test::test-method) - (fmakunbound 'thrift-test-response::test-method) + ;;(fmakunbound 'thrift-test.test-service-implementation::test-method) + ;;(fmakunbound 'thrift-test.test-service::test-method) + ;;(fmakunbound 'thrift-test.test-service-response::test-method) ))))) -;;; (run-tests "def-service") - diff --git a/test/package.lisp b/test/package.lisp index c70be02..8f13762 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -1,25 +1,56 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- +;;;; Copyright 2010 James Anderson +;;;; +;;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;;; you may not use this file except in compliance with the License. +;;;; You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, software +;;;; distributed under the License is distributed on an "AS IS" BASIS, +;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;;; See the License for the specific language governing permissions and +;;;; limitations under the License. -(in-package :common-lisp-user) +(in-package #:common-lisp-user) +(defpackage #:thrift-test + (:use #:common-lisp) + (:export #:thrift-self-tests)) -(defpackage :thrift-test - (:shadowing-import-from :thrift :byte :set :list :map :type-of :float) - (:use :common-lisp :thrift) - #+ccl - (:import-from :ccl :stream-tyo :stream-tyi :stream-reader :stream-writer - :stream-write-byte :stream-read-byte :stream-position - :stream-read-sequence :stream-write-sequence - :stream-force-output) - #+sbcl - (:import-from :sb-gray - :stream-write-byte :stream-read-byte - :stream-read-sequence :stream-write-sequence - :stream-force-output :stream-finish-output) - (:export :test - :with-test-services - :*test-location*)) +(defpackage #:thrift-test-utils + (:shadowing-import-from #:thrift #:byte #:set #:list #:map #:type-of #:float) + (:use #:thrift + #:cl) + (:import-from #:trivial-gray-streams + #:stream-write-byte + #:stream-read-byte + #:stream-read-sequence + #:stream-write-sequence + #:stream-force-output + #:stream-finish-output) + (:export #:field-three + #:make-test-large-struct + #:make-test-protocol + #:make-test-struct + #:make-test-transport + #:reset + #:rewind + #:stream-write-byte + #:stream-read-byte + #:stream-read-sequence + #:stream-write-sequence + #:stream-force-output + #:stream-finish-output + #:test-large-struct + #:test-large-struct-field-one + #:test-large-struct-field-two + #:test-large-struct-field-three + #:test-struct + #:test-struct-field-one + #:test-struct-field-two + #:with-test-services)) -(defpackage :thrift-test-request (:use )) +(defpackage #:thrift-test-request (:use)) -(defpackage :thrift-test-response (:use )) \ No newline at end of file +(defpackage #:thrift-test-response (:use)) diff --git a/test/protocol.lisp b/test/protocol.lisp index 0940144..872e3ea 100644 --- a/test/protocol.lisp +++ b/test/protocol.lisp @@ -1,166 +1,174 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: thrift-test; -*- - -(in-package :thrift-test) - -;;; tests for transport operations -;;; (run-tests "protocol.*") - +;;;; Copyright 2010 James Anderson +;;;; +;;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;;; you may not use this file except in compliance with the License. +;;;; You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, software +;;;; distributed under the License is distributed on an "AS IS" BASIS, +;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;;; See the License for the specific language governing permissions and +;;;; limitations under the License. + +;;;; Tests for transport operations. + +(fiasco:define-test-package (#:protocol-tests :in thrift-test:thrift-self-tests) + (:use #:thrift-test-utils)) + +(in-package #:protocol-tests) (defvar *string-w/euro* (cl:map 'string #'code-char '(48 46 57 57 57 8364))) -(test protocol.open-stream-p - (open-stream-p (make-test-transport))) +(deftest open-stream-p-test () + (is (open-stream-p (make-test-transport)))) (defun test-read-write-equivalence (protocol reader writer &rest values) - (let ((transport (protocol-output-transport protocol))) + (let ((transport (thrift:protocol-output-transport protocol))) (dolist (value values t) (reset protocol) (funcall writer protocol value) (rewind protocol) (let ((read (funcall reader protocol))) (unless (equalp read value) - (format *trace-output* "failed: ~a/~a ~s ~s ~s" - reader writer value read (subseq (get-vector-stream-vector transport) 0 (stream-position transport))) - (return nil)))))) - - -;;; - -(test protocol.stream-read/write-integer + (format *trace-output* + "failed: ~a/~a ~s ~s ~s" + reader + writer + value + read + (subseq (thrift.implementation::get-vector-stream-vector transport) + 0 + (thrift.implementation::stream-position transport))) + (return nil)))))) + +(deftest write-integer-test () (let ((stream (make-test-protocol))) - (every #'(lambda (entry) - (apply #'test-read-write-equivalence stream entry)) - `((stream-read-bool stream-write-bool t nil) - (stream-read-type stream-write-type thrift:byte thrift:map thrift:list thrift:set struct) - (stream-read-message-type stream-write-message-type call) - (stream-read-i08 stream-write-i08 ,(- (expt 2 7)) -1 0 1 ,(1- (expt 2 7))) - (stream-read-i16 stream-write-i16 ,(- (expt 2 15)) -1 0 1 ,(1- #x70f0) ,(1- (expt 2 15))) - (stream-read-i32 stream-write-i32 ,(- (expt 2 31)) -1 0 1 ,(1- #x7700ff00) ,(1- (expt 2 31))) - (stream-read-i64 stream-write-i64 ,(- (expt 2 63)) -1 0 1 ,(1- #x77770000ffff0000) ,(1- (expt 2 63))))))) - - -(test protocol.stream-read/write-double + (is (every #'(lambda (entry) + (apply #'test-read-write-equivalence stream entry)) + `((thrift:stream-read-bool thrift:stream-write-bool t nil) + ;; `thift:byte' is encoded the same in the protocol as i8, + ;; so it will be read back as i8. There is no good way + ;; around that, but these types are equivalent according + ;; to spec and `thrift:byte' is deprecated. + (thrift:stream-read-type thrift:stream-write-type ;thrift:byte + thrift:map thrift:list thrift:set thrift:struct) + (thrift:stream-read-message-type thrift:stream-write-message-type thrift:call) + (thrift:stream-read-i8 thrift:stream-write-i8 ,(- (expt 2 7)) -1 0 1 ,(1- (expt 2 7))) + (thrift:stream-read-i16 thrift:stream-write-i16 ,(- (expt 2 15)) -1 0 1 ,(1- #x70f0) ,(1- (expt 2 15))) + (thrift:stream-read-i32 thrift:stream-write-i32 ,(- (expt 2 31)) -1 0 1 ,(1- #x7700ff00) ,(1- (expt 2 31))) + (thrift:stream-read-i64 thrift:stream-write-i64 ,(- (expt 2 63)) -1 0 1 ,(1- #x77770000ffff0000) ,(1- (expt 2 63)))))))) + +(deftest write-double-test () (let ((stream (make-test-protocol))) - (every #'(lambda (entry) - (apply #'test-read-write-equivalence stream entry)) - `((stream-read-double stream-write-double - ,most-negative-double-float ,least-negative-double-float - ,most-positive-double-float ,least-positive-double-float - 0.0d0 1.0d0 -1.0d0))))) - - -(test protocol.stream-read/write-string + (is (every #'(lambda (entry) + (apply #'test-read-write-equivalence stream entry)) + `((thrift:stream-read-double thrift:stream-write-double + ,most-negative-double-float ,least-negative-double-float + ,most-positive-double-float ,least-positive-double-float + 0.0d0 1.0d0 -1.0d0)))))) + +(deftest write-string-test () (let ((stream (make-test-protocol))) - (every #'(lambda (entry) - (apply #'test-read-write-equivalence stream entry)) - `((stream-read-string stream-write-string "a" "0123456789" ,*string-w/euro*))))) - + (is (every #'(lambda (entry) + (apply #'test-read-write-equivalence stream entry)) + `((thrift:stream-read-string thrift:stream-write-string "a" "0123456789" ,*string-w/euro*)))))) -(test protocol.stream-read/write-binary +(deftest write-binary-test () (let ((stream (make-test-protocol))) - (every #'(lambda (entry) - (apply #'test-read-write-equivalence stream entry)) - ;; presuming (unsigned-bte 8) - `((stream-read-binary stream-write-binary #( 0 1 255)))))) + (is (every #'(lambda (entry) + (apply #'test-read-write-equivalence stream entry)) + ;; presuming (unsigned-byte 8) + `((thrift:stream-read-binary thrift:stream-write-binary #( 0 1 255))))))) - -(test protocol.stream-read/write-message - (let ((struct (make-instance 'test-struct :field1 "one" :field2 2)) +(deftest write-message-test () + (let ((struct (make-test-struct :field-one "one" :field-two 2)) (stream (make-test-protocol))) - (stream-write-message stream struct 'call) - (rewind stream) - (multiple-value-bind (name type sequence response) - (stream-read-message stream) - (and (equal name 'test-struct) - (eq type 'call) - (eql sequence 1) - (typep response 'test-struct) - (equal (test-struct-field1 response) "one") - (equal (test-struct-field2 response) 2))))) - - -(test protocol.stream-read/write-struct - (let ((struct (make-instance 'test-struct :field1 "one" :field2 2)) + (thrift:stream-write-message stream struct 'thrift:call) + (rewind stream) + (multiple-value-bind (name type sequence) + (thrift:stream-read-message-begin stream) + (let ((response (thrift:stream-read-struct stream 'test-struct))) + (is (string= name "TestStruct")) + (is (eq type 'thrift:call)) + (is (eql sequence 1)) + (is (typep response 'test-struct)) + (is (equal (test-struct-field-one response) "one")) + (is (equal (test-struct-field-two response) 2)))))) + +(deftest write-struct-test () + (let ((struct (make-test-struct :field-one "one" :field-two 2)) (stream (make-test-protocol))) - (stream-write-struct stream struct) + (thrift:stream-write-struct stream struct) (rewind stream) (let* ((type 'test-struct) - (result (stream-read-struct stream type))) - (and (typep result 'test-struct) - (equal (test-struct-field1 result) "one") - (equal (test-struct-field2 result) 2))))) -;;; (run-tests "protocol.stream-read/write-struct") - -(test protocol.stream-read/write-struct.inline - (let ((struct (make-instance 'test-struct :field1 "one" :field2 2)) + (result (thrift:stream-read-struct stream type))) + (is (typep result 'test-struct)) + (is (equal (test-struct-field-one result) "one")) + (is (equal (test-struct-field-two result) 2))))) + +(deftest write-struct.inline () + (let ((struct (make-test-struct :field-one "one" :field-two 2)) (stream (make-test-protocol))) - (stream-write-struct stream struct 'test-struct) + (thrift:stream-write-struct stream struct 'test-struct) (rewind stream) - (let ((result (stream-read-struct stream 'test-struct))) - (and (typep result 'test-struct) - (equal (test-struct-field1 result) "one") - (equal (test-struct-field2 result) 2))))) -;;; (run-tests "protocol.stream-read/write-struct.inline") - + (let ((result (thrift:stream-read-struct stream 'test-struct))) + (is (typep result 'test-struct)) + (is (equal (test-struct-field-one result) "one")) + (is (equal (test-struct-field-two result) 2))))) -(test protocol.stream-read/write-struct.optional - (let ((struct (make-instance 'test-large-struct :field1 1 :field2 2)) +(deftest write-struct.optional () + (let ((struct (make-instance 'test-large-struct :field-one 1 :field-two 2)) (stream (make-test-protocol))) - (assert (not (slot-boundp struct 'field3))) - (stream-write-struct stream struct 'test-large-struct) + (assert (not (slot-boundp struct 'field-three))) + (thrift:stream-write-struct stream struct 'test-large-struct) (rewind stream) - (let ((result (stream-read-struct stream 'test-large-struct))) - (and (typep result 'test-large-struct) - (not (slot-boundp result 'field3)) - (equal (test-struct-field1 result) 1) - (equal (test-struct-field2 result) 2))))) + (let ((result (thrift:stream-read-struct stream 'test-large-struct))) + (is (typep result 'test-large-struct)) + (is (not (slot-boundp result 'field-three))) + (is (equal (test-large-struct-field-one result) 1)) + (is (equal (test-large-struct-field-two result) 2))))) - -(test protocol.stream-read/write-field +(deftest write-field-test () (let ((stream (make-test-protocol))) - (every #'(lambda (entry) - (apply #'test-read-write-equivalence stream entry)) - `((,(lambda (p) (multiple-value-bind (value name id) - (stream-read-field p) - (when (ecase (protocol-field-id-mode stream) - (:identifier-name (and (equal name "test") (null id))) - (:identifier-number (and (null name) (equal id 10)))) - value))) - ,(lambda (p v) (stream-write-field p v :identifier-name "test" :identifier-number 10)) - "a" "0123456789" ,*string-w/euro*))))) - - -(test protocol.stream-read/write-map + (is (every #'(lambda (entry) + (apply #'test-read-write-equivalence stream entry)) + `((,(lambda (p) (multiple-value-bind (value name id) + (thrift:stream-read-field p) + (when (ecase (thrift:protocol-field-id-mode stream) + (:identifier-name (and (equal name "test") (null id))) + (:identifier-number (and (null name) (equal id 10)))) + value))) + ,(lambda (p v) (thrift:stream-write-field p v :identifier-name "test" :identifier-number 10)) + "a" "0123456789" ,*string-w/euro*)))))) + +(deftest write-map-test () (let ((stream (make-test-protocol))) - (every #'(lambda (entry) - (apply #'test-read-write-equivalence stream entry)) - `((stream-read-map stream-write-map ,(thrift:map 1 "a" 2 "b")))))) -;;; (run-tests "protocol.stream-read/write-map") - + (is (every #'(lambda (entry) + (apply #'test-read-write-equivalence stream entry)) + `((thrift:stream-read-map thrift:stream-write-map ,(thrift:map 1 "a" 2 "b"))))))) - -(test protocol.stream-read/write-list +(deftest write-list-test () (let ((stream (make-test-protocol))) - (every #'(lambda (entry) - (apply #'test-read-write-equivalence stream entry)) - `((stream-read-list stream-write-list - (t nil) (1 2 3) (32767 1 -1 -32768) - (,(expt 2 33) ,(- (expt 2 33))) - ("asdf" ,*string-w/euro*) - ;; no test for binary ! there is no type code - ;; and the java and cpp versions just send it as a string - ;; (#(1 2 3) #(4 5 6)) - (1.0d0 -1.0d0) - (,(thrift:map 1 "a" 2 "b"))))))) - - -(test protocol.stream-read/write-set + (is (every #'(lambda (entry) + (apply #'test-read-write-equivalence stream entry)) + `((thrift:stream-read-list thrift:stream-write-list + (t nil) (1 2 3) (32767 1 -1 -32768) + (,(expt 2 33) ,(- (expt 2 33))) + ("asdf" ,*string-w/euro*) + ;; no test for binary ! there is no type code + ;; and the java and cpp versions just send it as a string + ;; (#(1 2 3) #(4 5 6)) + (1.0d0 -1.0d0) + (,(thrift:map 1 "a" 2 "b")))))))) + +(deftest write-set-test () (let ((stream (make-test-protocol))) - (every #'(lambda (entry) - (apply #'test-read-write-equivalence stream entry)) - `((stream-read-set stream-write-set - (t nil) (1 2 3) (32767 1 -1 -32768)))))) - + (is (every #'(lambda (entry) + (apply #'test-read-write-equivalence stream entry)) + `((thrift:stream-read-set thrift:stream-write-set + (t nil) (1 2 3) (32767 1 -1 -32768))))))) #+(or ccl sbcl) (defun time-struct-io (&optional (count 1024)) @@ -190,31 +198,30 @@ (bytes (gcbytes))) (dotimes (i count) (rewind stream) - (stream-write-struct stream struct) + (thrift:stream-write-struct stream struct) (rewind stream) - (stream-read-struct stream)) + (thrift:stream-read-struct stream)) (setf dynamic-time (- (get-internal-run-time) time) dynamic-bytes (- (gcbytes) bytes))) (let ((time (get-internal-run-time)) (bytes (gcbytes))) (dotimes (i count) (rewind stream) - (stream-write-struct stream struct 'test-large-struct) + (thrift:stream-write-struct stream struct 'test-large-struct) (rewind stream) - (stream-read-struct stream 'test-large-struct)) + (thrift:stream-read-struct stream 'test-large-struct)) (setf static-time (- (get-internal-run-time) time) static-bytes (- (gcbytes) bytes))) (let ((time (get-internal-run-time)) (bytes (gcbytes))) (dotimes (i count) (rewind stream) - (stream-write-struct stream struct 'test-large-struct) + (thrift:stream-write-struct stream struct 'test-large-struct) (rewind stream) - (stream-read-struct stream 'test-large-struct result)) + (thrift:stream-read-struct stream 'test-large-struct result)) (setf static-with-time (- (get-internal-run-time) time) static-with-bytes (- (gcbytes) bytes))) (format *trace-output* "~%~d,~10T~d,~20T~d,~36T~d,~52T~d,~68T~d,~84T~d,~100T~d" slot-count bound-count dynamic-time static-time static-with-time dynamic-bytes static-bytes static-with-bytes)))))) -;;; (time-struct-io) \ No newline at end of file diff --git a/test/setup.lisp b/test/setup.lisp new file mode 100644 index 0000000..6c5cbf0 --- /dev/null +++ b/test/setup.lisp @@ -0,0 +1,37 @@ +;;;; Copyright 2010 James Anderson +;;;; +;;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;;; you may not use this file except in compliance with the License. +;;;; You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, software +;;;; distributed under the License is distributed on an "AS IS" BASIS, +;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;;; See the License for the specific language governing permissions and +;;;; limitations under the License. + +;;;; For testing test utils themselves. + +(fiasco:define-test-package (#:setup-tests :in thrift-test:thrift-self-tests) + (:use #:thrift-test-utils)) + +(in-package #:setup-tests) + +(deftest thrift-class () + (let ((class (find-class 'test-struct))) + (is (equal (thrift:class-identifier class) "TestStruct")) + (is (every #'(lambda (id name) + (equal (thrift:field-definition-identifier + (find id (thrift:class-field-definitions class) + :key #'thrift:field-definition-identifier-number)) + name)) + '(1 2) + '("fieldOne" "fieldTwo"))))) + +(deftest test-transport () + (is (typep (make-test-transport) 'thrift:binary-transport))) + +(deftest test-protocol () + (is (typep (make-test-protocol) 'thrift:binary-protocol))) diff --git a/test/test.lisp b/test/test.lisp index ad572b1..8dafa8a 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -1,225 +1,17 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: thrift-test; -*- - -(in-package :thrift-test) - -;;; (run-tests "setup/.*") -;;; (thrift-test::run-tests) -;;; (pprint-tabular t (sort (loop for key being each hash-key of *tests* collect (string key)) #'string-lessp)) - -(defparameter *test-root-pathname* - (make-pathname :name nil :type nil :defaults (or *compile-file-pathname* *load-pathname*))) - -(defvar *tests* (make-hash-table)) - -(defvar *test-location* #u"thrift://127.0.0.1:9091") - -(defvar *test-service* (make-instance 'service :identifier "Test Root")) - -(defvar *test-server-process* nil) - -(defvar *test-break-on-errors* t) - -(defun find-test (name) (gethash name *tests*)) - -(defun (setf find-test) (test-function name) - (if (null test-function) - (remhash name *tests*) - (setf (gethash name *tests*) test-function))) - -(defgeneric run-test (test) - (:method ((name symbol)) - (let ((test-function (find-test name))) - (if test-function - (run-test test-function) - (warn "test not found: ~s." name)))) - (:method ((test-function function)) - )) - -(defun run-tests (&rest test-names) - (let ((succeeded 0) - (failed ()) - (errored ())) - (flet ((run-test (test-function) - (multiple-value-bind (result condition name form) - (funcall test-function) - (cond (result - (incf succeeded)) - (condition - (format *trace-output* "~%test (~a) signaled:~%~:w~%~a" name form condition) - (push name errored)) - (t - (format *trace-output* "~&~%test (~a) failed:~%~:w" name form) - (push name failed)))))) - (if test-names - (dolist (pattern test-names) - (etypecase pattern - (symbol - (run-test (or (find-test pattern) (error "test not found: ~s." pattern)))) - (string - (let ((scanner (ppcre:create-scanner (string-upcase pattern)))) - (flet ((run-if-matched (name function) - (let* ((namestring (string name)) - (matched-string (cl-ppcre:scan-to-strings scanner namestring))) - (when (string-equal namestring matched-string) - (run-test function))))) - (maphash #'run-if-matched *tests*)))))) - (loop for test being each hash-value of *tests* do (run-test test)))) - `(,(or test-names ".*") - ,(if (or failed errored) :count :succeeded) ,(+ succeeded (length failed) (length errored)) - ,@(when failed `(:failed (,(length failed) ,@failed))) - ,@(when errored `(:errored (,(length errored) ,@errored)))))) - -(defmacro test (name form) - `(progn (setf (find-test ',name) - #'(lambda (&aux (name ',name) (form ',form)) - (multiple-value-bind (result error) - (block :do-test - (handler-bind ((error (lambda (c) - (when *test-break-on-errors* - (break "~%~a signaled ~a." ',name c)) - (return-from :do-test (values nil c))))) - ,form)) - (cond (error - (values nil error name form)) - (result - (values result nil name form)) - (t - (values nil nil name form)))))) - ',name)) - -#+digitool -(setf (ccl:assq 'test ccl:*fred-special-indent-alist*) 1) - - - -;;; -;;; - -(defclass test-struct (thrift-object) - ((field1 :type string :initarg :field1 :accessor test-struct-field1 - :identifier-number 1 :identifier "fieldOne") - (field2 :type i16 :initarg :field2 :accessor test-struct-field2 - :identifier-number 2 :identifier "fieldTwo")) - (:metaclass thrift-struct-class) - (:identifier "TestStruct") - (:documentation "a simple srtuct class for tests")) - -(defclass test-large-struct (thrift-object) - ((field1 :type i16 :initarg :field1 :accessor test-struct-field1 - :identifier-number 1 :identifier "fieldOne" :optional t) - (field2 :type i16 :initarg :field2 :accessor test-struct-field2 - :identifier-number 2 :identifier "fieldTwo" :optional t) - (field3 :type i16 :initarg :field3 :accessor test-struct-field3 - :identifier-number 3 :identifier "fieldThree" :optional t) - (field4 :type i16 :initarg :field4 :accessor test-struct-field4 - :identifier-number 4 :identifier "fieldfour" :optional t) - (field5 :type i16 :initarg :field5 :accessor test-struct-field5 - :identifier-number 5 :identifier "fieldFive" :optional t) - (field6 :type i16 :initarg :field6 :accessor test-struct-field6 - :identifier-number 6 :identifier "fieldSix" :optional t) - (field7 :type i16 :initarg :field7 :accessor test-struct-field7 - :identifier-number 7 :identifier "fieldSeven" :optional t) - (field8 :type i16 :initarg :field8 :accessor test-struct-field8 - :identifier-number 8 :identifier "fieldEight" :optional t) - (field9 :type i16 :initarg :field9 :accessor test-struct-field9 - :identifier-number 9 :identifier "fieldNine" :optional t) - (field10 :type i16 :initarg :field10 :accessor test-struct-field10 - :identifier-number 10 :identifier "fieldTen" :optional t)) - (:metaclass thrift-struct-class) - (:identifier "TestLargeStruct") - (:documentation "A struct class for use in timing tests and to test - optional field codecs - thus no initforms.")) - - - -(defun make-test-transport (&rest initargs) - (apply #'make-instance 'vector-stream-transport initargs)) - -(defun make-test-protocol (&rest initargs &key - (direction :io) - (input-transport (make-test-transport)) - (output-transport input-transport)) - (apply #'make-instance 'binary-protocol - :direction direction - :input-transport input-transport - :output-transport output-transport - initargs)) - -(defun make-test-protocol-peers (&key (request-hook 'rewind) (response-hook 'rewind)) - (let ((request-transport (make-test-transport :force-output-hook request-hook)) - (response-transport (make-test-transport :force-output-hook response-hook))) - (values (make-test-protocol :output-transport request-transport - :input-transport response-transport) - (make-test-protocol :output-transport response-transport - :input-transport request-transport)))) - -(defgeneric rewind (stream) - (:method ((protocol protocol)) - (rewind (protocol-input-transport protocol)) - (rewind (protocol-output-transport protocol)) - protocol) - - (:method ((stream vector-stream)) - (stream-position stream 0) - stream)) - -(defgeneric reset (stream) - (:method ((protocol protocol)) - (rewind protocol) - (reset (protocol-output-transport protocol)) - protocol) - - (:method ((stream vector-stream)) - (fill (get-vector-stream-vector stream) 0) - stream)) - - -(defun test-server (&optional (location *test-location*)) - (setq *test-location* location) - (or *test-server-process* - (setq *test-server-process* (bt:make-thread #'(lambda () (serve location *test-service*)))))) - -(defun stop-test-server () - (when (typep *test-server-process* 'bt:thread) - (bt:destroy-thread *test-server-process*) - (setq *test-server-process* nil))) -;;; (stop-test-server) - -(defun call-with-test-services (function &rest services) - (declare (dynamic-extent function)) - (unwind-protect (progn (setf (service-base-services *test-service*) - (union (service-base-services *test-service*) - services)) - (funcall function)) - (setf (service-base-services *test-service*) - (set-difference (service-base-services *test-service*) - services)))) - -(defmacro with-test-services ((protocol &rest services) &body body) - (let ((op (gensym))) - `(flet ((,op () (with-client (,protocol *test-location*) ,@body))) - ;; (test-server) doesn't work as the connect beats the accept and the client hangs - (call-with-test-services #',op ,@services)))) - - - -;;; - -(test setup/thrift-class - (let ((class (find-class 'test-struct))) - (and (equal (class-identifier class) "TestStruct") - (every #'(lambda (id name) - (equal (field-definition-identifier - (find id (class-field-definitions class) - :key #'field-definition-identifier-number)) - name)) - '(1 2) - '("fieldOne" "fieldTwo"))))) - -(test setup/test-transport - (typep (make-test-transport) 'binary-transport)) - -(test setup/test-protocol - (typep (make-test-protocol) 'binary-protocol)) - - +;;;; Copyright 2010 James Anderson +;;;; +;;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;;; you may not use this file except in compliance with the License. +;;;; You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, software +;;;; distributed under the License is distributed on an "AS IS" BASIS, +;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;;; See the License for the specific language governing permissions and +;;;; limitations under the License. + +(in-package #:thrift-test) + +(fiasco:defsuite (thrift-self-tests :bind-to-package #:thrift-test)) diff --git a/test/thrift-test.asd b/test/thrift-test.asd index 4fb90d3..05fa17d 100644 --- a/test/thrift-test.asd +++ b/test/thrift-test.asd @@ -1,15 +1,32 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- +;;;; Copyright 2010 James Anderson +;;;; +;;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;;; you may not use this file except in compliance with the License. +;;;; You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, software +;;;; distributed under the License is distributed on an "AS IS" BASIS, +;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;;; See the License for the specific language governing permissions and +;;;; limitations under the License. -(in-package :common-lisp-user) +(in-package #:common-lisp-user) -(asdf:defsystem :thrift-test - :depends-on (:thrift - :bordeaux-threads) +(asdf:defsystem #:thrift-test + :depends-on (#:thrift + #:bordeaux-threads + #:cl-ppcre + #:fiasco) + :perform (asdf:test-op (o s) (uiop:symbol-call :fiasco :run-tests :thrift-test)) :description "tests for com.apache.thrift" :serial t :components ((:file "package") - (:file "vector-protocol") (:file "test") + (:file "utils") + (:file "setup") + (:file "vector-protocol") (:file "conditions") (:file "definition-operators") (:file "protocol") @@ -38,4 +55,3 @@ (:file "ThriftTest-vars") empty (:file "ThriftTest") )))) - diff --git a/test/utils.lisp b/test/utils.lisp new file mode 100644 index 0000000..45f5769 --- /dev/null +++ b/test/utils.lisp @@ -0,0 +1,107 @@ +;;;; Copyright 2010 James Anderson +;;;; +;;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;;; you may not use this file except in compliance with the License. +;;;; You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, software +;;;; distributed under the License is distributed on an "AS IS" BASIS, +;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;;; See the License for the specific language governing permissions and +;;;; limitations under the License. + +;;;; A (meta)package for all sorts of test utils. Meant to be :used by test +;;;; packages. + +(in-package #:thrift-test-utils) + +(defvar *test-location* #u"thrift://127.0.0.1:9091") + +(defvar *test-service* (make-instance 'service :identifier "Test Root")) + +(defvar *test-server-process* nil) + +(def-struct "TestStruct" + (("fieldOne" nil :id 1 :type string) + ("fieldTwo" nil :id 2 :type i16))) + +(def-struct "TestLargeStruct" + (("fieldOne" nil :id 1 :type i16 :optional t) + ("fieldTwo" nil :id 2 :type i16 :optional t) + ("fieldThree" nil :id 3 :type i16 :optional t) + ("fieldFour" nil :id 4 :type i16 :optional t) + ("fieldFive" nil :id 5 :type i16 :optional t) + ("fieldSix" nil :id 6 :type i16 :optional t) + ("fieldSeven" nil :id 7 :type i16 :optional t) + ("fieldEight" nil :id 8 :type i16 :optional t) + ("fieldNine" nil :id 9 :type i16 :optional t) + ("fieldTen" nil :id 10 :type i16 :optional t))) + +(defun make-test-transport (&rest initargs) + (apply #'make-instance 'vector-stream-transport initargs)) + +(defun make-test-protocol (&rest initargs &key + (direction :io) + (input-transport (make-test-transport)) + (output-transport input-transport)) + (apply #'make-instance 'binary-protocol + :direction direction + :input-transport input-transport + :output-transport output-transport + initargs)) + +(defun make-test-protocol-peers (&key (request-hook 'rewind) (response-hook 'rewind)) + (let ((request-transport (make-test-transport :force-output-hook request-hook)) + (response-transport (make-test-transport :force-output-hook response-hook))) + (values (make-test-protocol :output-transport request-transport + :input-transport response-transport) + (make-test-protocol :output-transport response-transport + :input-transport request-transport)))) + +(defgeneric rewind (stream) + (:method ((protocol protocol)) + (rewind (protocol-input-transport protocol)) + (rewind (protocol-output-transport protocol)) + protocol) + + (:method ((stream vector-stream)) + (thrift.implementation::stream-position stream 0) + stream)) + +(defgeneric reset (stream) + (:method ((protocol protocol)) + (rewind protocol) + (reset (protocol-output-transport protocol)) + protocol) + + (:method ((stream vector-stream)) + (fill (thrift.implementation::get-vector-stream-vector stream) 0) + stream)) + +(defun test-server (&optional (location *test-location*)) + (setq *test-location* location) + (or *test-server-process* + (setq *test-server-process* (bt:make-thread #'(lambda () (serve location *test-service*)))))) + +(defun stop-test-server () + (when (typep *test-server-process* 'bt:thread) + (bt:destroy-thread *test-server-process*) + (setq *test-server-process* nil))) + +(defun call-with-test-services (function &rest services) + (declare (dynamic-extent function)) + (unwind-protect (progn (setf (service-base-services *test-service*) + (union (service-base-services *test-service*) + services)) + (funcall function)) + (setf (service-base-services *test-service*) + (set-difference (service-base-services *test-service*) + services)))) + +(defmacro with-test-services ((protocol &rest services) &body body) + (let ((op (gensym))) + `(flet ((,op () (with-client (,protocol *test-location*) ,@body))) + ;; (test-server) doesn't work as the connect beats the accept and the client hangs + (call-with-test-services #',op ,@services)))) diff --git a/test/vector-protocol.lisp b/test/vector-protocol.lisp index f68cf82..82b68f5 100644 --- a/test/vector-protocol.lisp +++ b/test/vector-protocol.lisp @@ -1,31 +1,44 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: thrift-test; -*- +;;;; Copyright 2010 James Anderson +;;;; +;;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;;; you may not use this file except in compliance with the License. +;;;; You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, software +;;;; distributed under the License is distributed on an "AS IS" BASIS, +;;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;;; See the License for the specific language governing permissions and +;;;; limitations under the License. -(in-package :thrift-test) +(fiasco:define-test-package (#:vector-protocol-tests :in thrift-test:thrift-self-tests) + (:use #:thrift-test-utils)) -(test vector-protocol.write-byte - (progn - (stream-write-byte (make-instance 'vector-stream-transport) 1) - (stream-write-byte (make-instance 'vector-stream-transport) -1))) +(in-package #:vector-protocol-tests) +(deftest write-byte-test () + (finishes (stream-write-byte (make-instance 'thrift:vector-stream-transport) 1)) + (finishes (stream-write-byte (make-instance 'thrift:vector-stream-transport) -1))) -(test vector-protocol.write-sequence +(deftest write-sequence-test () (let* ((data #(0 1 2 3 4 5 6 7 8 9 246 247 248 249 250 251 252 253 254 255)) (buffer (make-array 2 :element-type thrift::*binary-transport-element-type*)) - (outstream (make-instance 'vector-output-stream :vector buffer)) - (instream (make-instance 'vector-input-stream :vector nil))) - (write-sequence data outstream) + (outstream (make-instance 'thrift:vector-output-stream :vector buffer)) + (instream (make-instance 'thrift:vector-input-stream :vector nil))) + (stream-write-sequence outstream data 0 nil) (cl:map nil #'(lambda (c) (stream-write-byte outstream (char-code c))) "asdf") - (and (every #'eql - (concatenate 'vector data (cl:map 'vector #'char-code "asdf")) - (subseq (thrift.implementation::get-vector-stream-vector outstream) - 0 - (stream-position outstream))) - (let ((data2 (make-array (length data))) - (data3 (make-array 4))) - (thrift.implementation::setf-vector-stream-vector (thrift.implementation::get-vector-stream-vector outstream) - instream) - (and (eql (stream-read-sequence instream data2) (length data2)) - (equalp data2 data) - (stream-read-sequence instream data3) - (equal (cl:map 'string #'code-char data3) "asdf")))))) + (is (every #'eql + (concatenate 'vector data (cl:map 'vector #'char-code "asdf")) + (subseq (thrift.implementation::get-vector-stream-vector outstream) + 0 + (thrift.implementation::stream-position outstream)))) + (let ((data2 (make-array (length data))) + (data3 (make-array 4))) + (thrift.implementation::setf-vector-stream-vector (thrift.implementation::get-vector-stream-vector outstream) + instream) + (is (eql (stream-read-sequence instream data2 0 nil) (length data2))) + (is (equalp data2 data)) + (stream-read-sequence instream data3 0 nil) + (is (equal (cl:map 'string #'code-char data3) "asdf"))))) diff --git a/thrift.asd b/thrift.asd index b175b7f..e227a2c 100644 --- a/thrift.asd +++ b/thrift.asd @@ -1,35 +1,32 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- - -(in-package :common-lisp-user) - - -;;; This files defines the ASDF system for the `org.apache.thrift` library. -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. - - -(asdf:defsystem :thrift - :depends-on (;; use this puri version to support thrift uri class - #-:asdf.hierarchical-names :puri-ppcre - #+:asdf.hierarchical-names :com.b9.puri.puri-ppcre - :usocket - :closer-mop - :trivial-utf-8) +(in-package #:common-lisp-user) + +;;;; This files defines the ASDF system for the `org.apache.thrift` library. +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. + +(asdf:defsystem #:thrift + :depends-on (#:puri + #:usocket + #:closer-mop + #:trivial-utf-8 + #:ieee-floats + #:trivial-gray-streams + #:alexandria) :description "org.apache.thrift implements a Common Lisp binding for the Apache Thrift cross-language services protocol." :serial t @@ -38,9 +35,9 @@ (:file "types") (:file "parameters") (:file "classes") - (:file "float") (:file "definition-operators") (:file "transport") + (:file "framed-transport") (:file "conditions") (:file "protocol") (:file "binary-protocol") @@ -53,6 +50,4 @@ access to remote services. See README.md for more information. [1]: http://incubator.apache.org/thrift/static/thrift-20070401.pdf - [2]: http://wiki.apache.org/thrift/ - ") - + [2]: http://wiki.apache.org/thrift/") diff --git a/transport.lisp b/transport.lisp index 6d4a69d..651559d 100644 --- a/transport.lisp +++ b/transport.lisp @@ -1,42 +1,39 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- - -(in-package :org.apache.thrift.implementation) - -;;; This file defines the core of the 'transport' layer for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. - - -;;; The transport operators focus on the stream interface and supply the equivalents to the -;;; Thrift standard operators in terms of the gray stream interface: -;;; -;;; * open is superfluous. there is no use case for it, as they are not reused. -;;; the respective stream is opened as a side-effect of make-instance. -;;; * isOpen is implemented as methods for open-stream-p -;;; * close is implemented as transport-close to which stream-close/close delegates as per runtime -;;; * read-byte is implemented as methods for stream-read-byte -;;; * read-sequence is implemented as methods for stream-read-sequence -;;; * write-byte is implemented as methods for stream-write-byte -;;; * write-sequence is implemented as methods for stream-write-sequence -;;; * flush is implemented as a method on stream-finish-output - +(in-package #:org.apache.thrift.implementation) + +;;;; This file defines the core of the 'transport' layer for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. + + +;;;; The transport operators focus on the stream interface and supply the equivalents to the +;;;; Thrift standard operators in terms of the gray stream interface: +;;;; +;;;; * open is superfluous. there is no use case for it, as they are not reused. +;;;; the respective stream is opened as a side-effect of make-instance. +;;;; * isOpen is implemented as methods for open-stream-p +;;;; * close is implemented as transport-close to which stream-close/close delegates as per runtime +;;;; * read-byte is implemented as methods for stream-read-byte +;;;; * read-sequence is implemented as methods for stream-read-sequence +;;;; * write-byte is implemented as methods for stream-write-byte +;;;; * write-sequence is implemented as methods for stream-write-sequence +;;;; * flush is implemented as a method on stream-finish-output ;;; ;;; macros @@ -69,32 +66,26 @@ (define-compiler-macro unsigned-byte-8 (datum) `(logand ,datum #xff)) - ;;; ;;; classes -(defclass transport (#+sbcl sb-gray:fundamental-stream #+ccl stream) +(defclass transport (trivial-gray-streams:fundamental-stream) ((stream :reader transport-stream) (direction :initarg :direction :accessor stream-direction)) (:documentation "The abstract transport class is a specialized stream which wraps a base binary stream - a file or a socket, with methods which codec operators for primitive data types.")) - -(defclass binary-transport (transport) - ()) - +(defclass binary-transport (transport) ()) (defclass socket-transport (binary-transport) () (:documentation "A specialzed transport which wraps a socket and its stream.")) - (defclass file-transport (binary-transport) ((pathname :initarg :pathname :accessor transport-pathname :initform (error "pathname is required.")) ;; delegation, as make-instance does not return a usable stream in all implementations (stream :accessor transport-stream))) - ;;; ;;; initialization @@ -104,21 +95,18 @@ (call-next-method) (setf (slot-value transport 'stream) (usocket:socket-stream socket))) - (defun socket-transport (location &rest initargs &key (element-type *binary-transport-element-type*) (direction :io d-s)) (when d-s (setf initargs (copy-list initargs)) (remf initargs :direction)) - + (make-instance 'socket-transport :direction direction :socket (apply #'usocket:socket-connect (puri:uri-host location) (puri:uri-port location) :element-type element-type initargs))) - - (defmethod initialize-instance ((transport file-transport) &key pathname stream (direction :output) (element-type *binary-transport-element-type*) @@ -130,14 +118,12 @@ :direction direction :element-type element-type :if-exists if-exists :if-does-not-exist if-does-not-exist)))) - (defun file-transport (pathname &rest initargs &key (element-type *binary-transport-element-type*)) (apply #'make-instance 'file-transport :pathname pathname :element-type element-type initargs)) - ;;; open-stream-p is the only operator which guards against an unbound slot. ;;; stream-close checks that the stream is still open ;;; all other presume it is open. @@ -147,10 +133,15 @@ (when (slot-boundp transport 'stream) (open-stream-p (transport-stream transport)))) -(defun transport-close (transport &key abort) +(defun transport-close-wrapper (transport &key abort) "The transport close implementation is used by whichever interface the runtime presents for extensions. as per the gray interface, close is replaced with a generic function. in other cases, stream-close is a generic operator." + (transport-close transport :abort abort)) + +(defgeneric transport-close (transport &key abort)) + +(defmethod transport-close ((transport transport) &key abort) (when (open-stream-p transport) (close (transport-stream transport) :abort abort) (setf (slot-value transport 'direction) :closed) @@ -159,56 +150,41 @@ (when (fboundp 'stream-close) (defmethod stream-close ((transport transport)) (when (next-method-p) (call-next-method)) - (transport-close transport))) + (transport-close-wrapper transport))) (when (typep #'close 'generic-function) (defmethod close ((stream transport) &rest args) (when (next-method-p) (call-next-method)) - (apply #'transport-close stream args) + (apply #'transport-close-wrapper stream args) t)) - -#-sbcl -(defmethod stream-finish-output ((transport transport)) - (stream-finish-output (transport-stream transport))) -#+sbcl (defmethod stream-finish-output ((transport transport)) + #-(or sbcl ccl) + (stream-finish-output (transport-stream transport)) + #+(or sbcl ccl) (finish-output (transport-stream transport))) -#-sbcl -(defmethod stream-force-output ((transport transport)) - (stream-force-output (transport-stream transport))) -#+sbcl (defmethod stream-force-output ((transport transport)) + #-(or sbcl ccl) + (stream-force-output (transport-stream transport)) + #+ccl + (ccl:stream-force-output (transport-stream transport)) + #+sbcl (force-output (transport-stream transport))) - ;;; ;;; input -#-sbcl (defmethod stream-read-byte ((transport binary-transport)) - (let ((unsigned-byte (stream-read-byte (transport-stream transport)))) + (let ((unsigned-byte + #-(or sbcl ccl)(stream-read-byte (transport-stream transport)) + #+ccl(ccl:stream-read-byte (transport-stream transport)) + #+sbcl(read-byte (transport-stream transport)))) (if unsigned-byte - (signed-byte-8 unsigned-byte) - (error 'end-of-file :stream (transport-stream transport))))) -#+sbcl -(defmethod stream-read-byte ((transport binary-transport)) - (let ((unsigned-byte (read-byte (transport-stream transport)))) - (signed-byte-8 unsigned-byte))) + (signed-byte-8 unsigned-byte) + (error 'end-of-file :stream (transport-stream transport))))) - -#-(or mcl sbcl) -(defmethod stream-read-sequence ((transport binary-transport) (sequence vector) &optional (start 0) (end nil)) - (stream-read-sequence (transport-stream transport) sequence start end)) - -#+mcl -(defmethod stream-read-sequence ((transport binary-transport) (sequence vector) &rest args) - (declare (dynamic-extent args)) - (apply #'stream-read-sequence (transport-stream transport) sequence args)) - -#+sbcl -(defmethod stream-read-sequence ((transport binary-transport) (sequence vector) &optional (start 0) (end nil)) +(defmethod stream-read-sequence ((transport binary-transport) (sequence vector) start end &key) (unless (= (read-sequence sequence (transport-stream transport) :start start :end end) (or end (length sequence))) (error 'end-of-file :stream (transport-stream transport)))) @@ -216,23 +192,10 @@ ;;; ;;; output -#-sbcl -(defmethod stream-write-byte ((transport binary-transport) byte) - (stream-write-byte (transport-stream transport) (unsigned-byte-8 byte))) -#+sbcl (defmethod stream-write-byte ((transport binary-transport) byte) - (write-byte (unsigned-byte-8 byte) (transport-stream transport))) - - -#-(or mcl sbcl) -(defmethod stream-write-sequence ((transport binary-transport) (sequence vector) &optional (start 0) (end nil)) - (stream-write-sequence (transport-stream transport) sequence start end)) - -#+mcl -(defmethod stream-write-sequence ((transport binary-transport) (sequence vector) &rest args) - (declare (dynamic-extent args)) - (apply #'stream-write-sequence (transport-stream transport) sequence args)) + #-(or ccl sbcl)(stream-write-byte (transport-stream transport) (unsigned-byte-8 byte)) + #+ccl(ccl:stream-write-byte (transport-stream transport) (unsigned-byte-8 byte)) + #+sbcl(write-byte (unsigned-byte-8 byte) (transport-stream transport))) -#+sbcl -(defmethod stream-write-sequence ((transport binary-transport) (sequence vector) &optional (start 0) (end nil)) +(defmethod stream-write-sequence ((transport binary-transport) (sequence vector) start end &key) (write-sequence sequence (transport-stream transport) :start start :end end)) diff --git a/types.lisp b/types.lisp index bd1117f..cb5c36c 100644 --- a/types.lisp +++ b/types.lisp @@ -1,37 +1,34 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- - -(in-package :org.apache.thrift.implementation) - -;;; This file defines types for the `org.apache.thrift` library. -;;; -;;; copyright 2010 [james anderson](james.anderson@setf.de) -;;; -;;; Licensed to the Apache Software Foundation (ASF) under one -;;; or more contributor license agreements. See the NOTICE file -;;; distributed with this work for additional information -;;; regarding copyright ownership. The ASF licenses this file -;;; to you under the Apache License, Version 2.0 (the -;;; "License"); you may not use this file except in compliance -;;; with the License. You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, -;;; software distributed under the License is distributed on an -;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY -;;; KIND, either express or implied. See the License for the -;;; specific language governing permissions and limitations -;;; under the License. - -;;; Define type analogues between thrift and lisp types. -;;; The container types are defined to accept element type constraints. -;;; Distinguish those types which are lisp/thrift homologues. -;;; Define types for the type specifiers themselves for use at compile-time. - +(in-package #:org.apache.thrift.implementation) + +;;;; This file defines types for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. + +;;;; Define type analogues between thrift and lisp types. +;;;; The container types are defined to accept element type constraints. +;;;; Distinguish those types which are lisp/thrift homologues. +;;;; Define types for the type specifiers themselves for use at compile-time. (deftype bool () 'boolean) (deftype thrift:byte () '(signed-byte 8)) -(deftype i08 () '(signed-byte 8)) +(deftype i8 () '(signed-byte 8)) (deftype i16 () '(signed-byte 16)) (deftype i32 () '(signed-byte 32)) (deftype i64 () '(signed-byte 64)) @@ -40,10 +37,9 @@ 'single-float) ;; string is standard (deftype double () 'double-float) -;;; this is not what the spec says (it claims i08), but that makes no sense +;;; this is not what the spec says (it claims i8), but that makes no sense (deftype binary () '(array (unsigned-byte 8) (*))) - (deftype thrift:list (&optional element-type) "The thrift:list container type is implemented as a cl:list. The element type serves for declaration, but not discrimination. An empty list should conform." @@ -62,10 +58,9 @@ (declare (ignore key-type value-type)) 'list) - (deftype base-type () "Indicates the union of thrift base (atomic) types." - '(member bool thrift:byte i08 i16 i32 i64 double thrift:float string binary)) + '(member bool thrift:byte i8 i16 i32 i64 double thrift:float string binary)) (defun base-type-p (type) (typep type 'base-type)) @@ -108,7 +103,6 @@ (null '(or thrift-object thrift-error)) (symbol identifier))) - (defparameter *container-limit* nil "When non-null, the integer value limits the permissible container size.") @@ -128,14 +122,14 @@ (:documentation "Implements an equivalent to cl:type-of, but return the most specific thrift type instead of the cl type. This is used to determine the encoding for dynamically generated messages.") - + (:method ((value null)) 'bool) (:method ((value (eql t))) 'bool) (:method ((value integer)) (etypecase value - (i08 'thrift:byte) + (i8 'i8) (i16 'i16) (i32 'i32) (i64 'i64))) @@ -151,7 +145,6 @@ 'thrift:map 'thrift:list))) - (defgeneric type-name-class (type-name) (:documentation "Return the lisp type equivalent for the given thrift type. The value is universal. it is used to construct generic function lambda lists. @@ -169,13 +162,16 @@ ((thrift:list thrift:set) 'list) (thrift:map 'list)))) - (defgeneric type-category (type) (:documentation "Return the type name to match decoded values.") (:method ((type symbol)) type) - (:method ((type cons)) (first type))) + (:method ((type cons)) + (let ((first (first type))) + (if (eql first 'thrift:enum) + 'i32 + first)))) ;;; ;;; primitive constructors @@ -196,7 +192,6 @@ (defun thrift:set (&rest values) values) - ;;; ;;; primitive accessors ;;; --- in prepration to support association lists as maps @@ -229,13 +224,10 @@ ,store) `(map-get ,access-form ,ktemp))))) - (defun map-map (function map) (loop for (key . value) in map do (funcall function key value)) nil) - (defun map-size (map) (length map)) - diff --git a/vector-protocol.lisp b/vector-protocol.lisp index 77e9a62..456eeb1 100644 --- a/vector-protocol.lisp +++ b/vector-protocol.lisp @@ -1,12 +1,29 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- - -(in-package :org.apache.thrift.implementation) - -;;; define a binary stream to wrap a vector for use in tests. -;;; adapted from the cl-xml version to restrict i/o to unsigned byte operations. -;;; this version uses a signed byte stream, as that's the basis of the thrift binary transport -;;; - +(in-package #:org.apache.thrift.implementation) + +;;;; This file defines the abstract '`protocol` layer for the `org.apache.thrift` library. +;;;; +;;;; copyright 2010 [james anderson](james.anderson@setf.de) +;;;; +;;;; Licensed to the Apache Software Foundation (ASF) under one +;;;; or more contributor license agreements. See the NOTICE file +;;;; distributed with this work for additional information +;;;; regarding copyright ownership. The ASF licenses this file +;;;; to you under the Apache License, Version 2.0 (the +;;;; "License"); you may not use this file except in compliance +;;;; with the License. You may obtain a copy of the License at +;;;; +;;;; http://www.apache.org/licenses/LICENSE-2.0 +;;;; +;;;; Unless required by applicable law or agreed to in writing, +;;;; software distributed under the License is distributed on an +;;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY +;;;; KIND, either express or implied. See the License for the +;;;; specific language governing permissions and limitations +;;;; under the License. + +;;;; define a binary stream to wrap a vector for use in tests. +;;;; adapted from the cl-xml version to restrict i/o to unsigned byte operations. +;;;; this version uses a signed byte stream, as that's the basis of the thrift binary transport ;;; ;;; abstract @@ -23,39 +40,21 @@ :accessor stream-force-output-hook :documentation "A function of one argument, the stream, called as the base implementation of stream-force-output.") - #+(or CMU sbcl lispworks) (direction :initarg :direction) - ) + (direction :initarg :direction)) (:default-initargs #+CormanLisp :element-type #+CormanLisp 'character)) -(defClass vector-input-stream (vector-stream - #+ALLEGRO excl::fundamental-binary-input-stream - #+LispWorks stream:fundamental-stream - #+(and MCL digitool) ccl::input-binary-stream - #+(and MCL openmcl) fundamental-binary-input-stream - #+CMU extensions:fundamental-binary-input-stream - #+sbcl sb-gray:fundamental-binary-input-stream - #+CormanLisp stream - ) +(defclass vector-input-stream (vector-stream trivial-gray-streams:fundamental-binary-input-stream) () (:default-initargs :direction :input)) -(defClass vector-output-stream (vector-stream - #+ALLEGRO excl::fundamental-binary-output-stream - #+LispWorks stream:fundamental-stream - #+(and MCL digitool) ccl::output-binary-stream - #+(and MCL openmcl) fundamental-binary-output-stream - #+CMU extensions:fundamental-binary-output-stream - #+sbcl sb-gray:fundamental-binary-output-stream - #+CormanLisp stream - ) +(defclass vector-output-stream (vector-stream trivial-gray-streams:fundamental-binary-output-stream) () (:default-initargs :direction :output)) (defclass vector-stream-transport (vector-input-stream vector-output-stream binary-transport) ((stream :initform nil))) - (defun make-vector-stream-buffer (length &optional (type *binary-transport-element-type*)) (make-array length :element-type type :initial-element 0)) @@ -167,9 +166,8 @@ byte)))) stream)) - (defmethod stream-read-sequence ((stream vector-input-stream) (sequence vector) - #+mcl &key #-mcl &optional (start 0) (end nil)) + start end &key) (unless end (setf end (length sequence))) (assert (typep start '(integer 0))) (assert (>= end start)) @@ -182,11 +180,9 @@ (setf position new-position)) new-position))) - ;;; ;;; output - (defmethod stream-write-byte ((stream vector-output-stream) (datum integer) &aux next) (with-slots (position vector) stream (unless (< (setf next (1+ position)) (length vector)) @@ -197,7 +193,6 @@ (logand #xff datum)) (setf position next))) - #+mcl (defmethod ccl:stream-tyo ((stream vector-output-stream) byte) (stream-write-byte stream byte)) @@ -215,7 +210,7 @@ stream)) (defmethod stream-write-sequence ((stream vector-output-stream) (sequence vector) - #+mcl &key #-mcl &optional (start 0) (end nil)) + start end &key) (unless end (setf end (length sequence))) (assert (typep start '(integer 0))) (assert (>= end start))