├── .gitignore ├── test ├── gen-cl │ ├── StressTest-vars.lisp │ ├── StressTest.lisp │ ├── ThriftTest-vars.lisp │ ├── AnnotationTest-vars.lisp │ ├── JavaBeansTest-vars.lisp │ ├── ManyTypedefs-vars.lisp │ ├── DenseLinkingTest-vars.lisp │ ├── OptionalRequiredTest-vars.lisp │ ├── ManyTypedefs.lisp │ ├── AnnotationTest.lisp │ ├── DocTest-vars.lisp │ ├── SmallTest-vars.lisp │ ├── AnnotationTest-types.lisp │ ├── StressTest-types.lisp │ ├── ManyTypedefs-types.lisp │ ├── ConstantsDemo.lisp │ ├── ConstantsDemo-types.lisp │ ├── JavaBeansTest.lisp │ ├── JavaBeansTest-types.lisp │ ├── SmallTest.lisp │ ├── SmallTest-types.lisp │ ├── ThriftTest.lisp │ ├── ConstantsDemo-vars.lisp │ ├── OptionalRequiredTest.lisp │ ├── OptionalRequiredTest-types.lisp │ ├── DenseLinkingTest.lisp │ ├── DenseLinkingTest-types.lisp │ ├── DocTest.lisp │ ├── DocTest-types.lisp │ ├── ThriftTest-types.lisp │ ├── DebugProtoTest-vars.lisp │ ├── DebugProtoTest.lisp │ └── DebugProtoTest-types.lisp ├── package.lisp ├── vector-protocol.lisp ├── thrift-test.asd ├── conditions.lisp ├── definition-operators.lisp ├── test.lisp └── protocol.lisp ├── .gitattributes ├── thrift.asd ├── READMES └── readme-cassandra.lisp ├── client.lisp ├── package.lisp ├── parameters.lisp ├── symbols.lisp ├── types.lisp ├── vector-protocol.lisp ├── transport.lisp ├── server.lisp ├── conditions.lisp ├── README.md ├── float.lisp └── binary-protocol.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | tmp/ 2 | *.dribble 3 | *.fasl 4 | *.dfsl 5 | *.cfsl 6 | *.fas 7 | *.lib 8 | *.o 9 | *.*fsl 10 | *.bak 11 | *~ 12 | bin/ 13 | 14 | #Mac stuff 15 | Icon? 16 | .DS_Store -------------------------------------------------------------------------------- /test/gen-cl/StressTest-vars.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (in-package :thrift-generated) 7 | 8 | -------------------------------------------------------------------------------- /test/gen-cl/StressTest.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift.test.debug -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift.test.debug) 7 | 8 | -------------------------------------------------------------------------------- /test/gen-cl/ThriftTest-vars.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (in-package :thrift-generated) 7 | 8 | -------------------------------------------------------------------------------- /test/gen-cl/AnnotationTest-vars.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (in-package :thrift-generated) 7 | 8 | -------------------------------------------------------------------------------- /test/gen-cl/JavaBeansTest-vars.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (in-package :thrift-generated) 7 | 8 | -------------------------------------------------------------------------------- /test/gen-cl/ManyTypedefs-vars.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (in-package :thrift-generated) 7 | 8 | -------------------------------------------------------------------------------- /test/gen-cl/DenseLinkingTest-vars.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (in-package :thrift-generated) 7 | 8 | -------------------------------------------------------------------------------- /test/gen-cl/OptionalRequiredTest-vars.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (in-package :thrift-generated) 7 | 8 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.html -crlf 2 | *.htm -crlf 3 | *.dot -crlf 4 | *.svg -crlf 5 | *.ent -crlf 6 | *.css -crlf 7 | *.dtd -crlf 8 | *.xs -crlf 9 | *.xsl -crlf 10 | *.xml -crlf 11 | *.xmlq -crlf 12 | -------------------------------------------------------------------------------- /test/gen-cl/ManyTypedefs.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; base operators definitions 4 | 5 | (def-package :thrift-generated) 6 | 7 | (defun method2 () 8 | (list (map '(1 "string")))) 9 | 10 | (defun method2 (int) 11 | (make-instance 'struct1 :myint int :mylist (list (map '(1 "string"))))) 12 | 13 | -------------------------------------------------------------------------------- /test/gen-cl/AnnotationTest.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-struct "foo" 9 | (("bar" nil :type i32 :id 1) 10 | ("baz" nil :type i32 :id 2) 11 | ("qux" nil :type i32 :id 3) 12 | ("bop" nil :type i32 :id 4))) 13 | 14 | -------------------------------------------------------------------------------- /test/gen-cl/DocTest-vars.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (in-package :thrift-generated) 7 | 8 | (thrift:def-constant "INT32CONSTANT" 9853) 9 | 10 | (thrift:def-constant "INT16CONSTANT" 1616) 11 | 12 | (thrift:def-constant "MAPCONSTANT" (thrift:map 13 | (cl:cons "hello" "world") 14 | (cl:cons "goodnight" "moon"))) 15 | 16 | -------------------------------------------------------------------------------- /test/gen-cl/SmallTest-vars.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (in-package :thrift-generated) 7 | 8 | (thrift:def-constant "CMAP" (thrift:map 9 | (cl:cons 235 (thrift:map 10 | (cl:cons 235 235) )) 11 | (cl:cons 53 (thrift:map 12 | (cl:cons 53 53) )))) 13 | 14 | (thrift:def-constant "CINT" 325) 15 | 16 | (thrift:def-constant "WHOA" (make-instance 'hello 17 | :simple 532 18 | )) 19 | 20 | -------------------------------------------------------------------------------- /test/gen-cl/AnnotationTest-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | 3 | (in-package :thrift-generated) 4 | 5 | ;;; Embed the thrift AnnotationTest in the cl test suite 6 | 7 | (thrift-test:test gen-cl/annotation-test 8 | (let ((struct (make-instance 'thrift-generated::foo 9 | :bar -1 :baz -2 :qux -3))) 10 | (and (eql (thrift-generated::foo-bar struct) -1) 11 | (eql (thrift-generated::foo-baz struct) -2) 12 | (eql (thrift-generated::foo-qux struct) -3) 13 | (not (slot-boundp struct 'thrift-generated::bop))))) -------------------------------------------------------------------------------- /test/gen-cl/StressTest-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-service "Service" nil 9 | (:method "echoVoid" (() void)) 10 | (:method "echoByte" ((("arg" byte 1)) byte)) 11 | (:method "echoI32" ((("arg" i32 1)) i32)) 12 | (:method "echoI64" ((("arg" i64 1)) i64)) 13 | (:method "echoString" ((("arg" string 1)) string)) 14 | (:method "echoList" ((("arg" (list byte) 1)) (list byte))) 15 | (:method "echoSet" ((("arg" (set byte) 1)) (set byte))) 16 | (:method "echoMap" ((("arg" (map byte byte) 1)) (map byte byte)))) 17 | -------------------------------------------------------------------------------- /test/gen-cl/ManyTypedefs-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-struct "struct1" 9 | (("myint" nil :type i32 :id 1) 10 | ("mylist" nil :type (list (map i32 string)) :id 2))) 11 | 12 | (thrift:def-exception "exception1" 13 | (("alist" nil :type (list (map i32 string)) :id 1) 14 | ("mystruct" nil :type (struct "struct1") :id 2))) 15 | 16 | (thrift:def-service "AService" nil 17 | (:method "method1" ((("myint" i32 1)) (struct "struct1")) 18 | :exceptions (("exn" nil :type (struct "exception1") :id 1))) 19 | (:method "method2" (() (list (map i32 string))))) 20 | -------------------------------------------------------------------------------- /test/gen-cl/ConstantsDemo.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-enum "enumconstants" 9 | (("ONE" . 1) 10 | ("TWO" . 2))) 11 | 12 | (thrift:def-struct "thing" 13 | (("hello" nil :type i32 :id 1) 14 | ("goodbye" nil :type i32 :id 2))) 15 | 16 | (thrift:def-struct "thing2" 17 | (("val" 2 :type (enum "enumconstants") :id 1))) 18 | 19 | (thrift:def-exception "blah" 20 | (("bing" nil :type i32 :id 1))) 21 | 22 | (thrift:def-exception "gak" 23 | ()) 24 | 25 | (thrift:def-service "yowza" nil 26 | (:method "blingity" (() void)) 27 | (:method "blangity" (() i32) 28 | :exceptions (("hoot" nil :type (struct "blah") :id 1)))) 29 | -------------------------------------------------------------------------------- /test/gen-cl/ConstantsDemo-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-enum "enumconstants" 9 | (("ONE" . 1) 10 | ("TWO" . 2))) 11 | 12 | (thrift:def-struct "thing" 13 | (("hello" nil :type i32 :id 1) 14 | ("goodbye" nil :type i32 :id 2))) 15 | 16 | (thrift:def-struct "thing2" 17 | (("val" 2 :type (enum "enumconstants") :id 1))) 18 | 19 | (thrift:def-exception "blah" 20 | (("bing" nil :type i32 :id 1))) 21 | 22 | (thrift:def-exception "gak" 23 | ()) 24 | 25 | (thrift:def-service "yowza" nil 26 | (:method "blingity" (() void)) 27 | (:method "blangity" (() i32) 28 | :exceptions (("hoot" nil :type (struct "blah") :id 1)))) 29 | -------------------------------------------------------------------------------- /test/gen-cl/JavaBeansTest.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-struct "oneofeachbeans" 9 | (("boolean_field" nil :type bool :id 1) 10 | ("a_bite" nil :type byte :id 2) 11 | ("integer16" nil :type i16 :id 3) 12 | ("integer32" nil :type i32 :id 4) 13 | ("integer64" nil :type i64 :id 5) 14 | ("double_precision" nil :type double :id 6) 15 | ("some_characters" nil :type string :id 7) 16 | ("base64" nil :type string :id 8) 17 | ("byte_list" nil :type (list byte) :id 9) 18 | ("i16_list" nil :type (list i16) :id 10) 19 | ("i64_list" nil :type (list i64) :id 11))) 20 | 21 | (thrift:def-service "Service" nil 22 | (:method "mymethod" ((("blah" i64 -1)) i64))) 23 | -------------------------------------------------------------------------------- /test/gen-cl/JavaBeansTest-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-struct "oneofeachbeans" 9 | (("boolean_field" nil :type bool :id 1) 10 | ("a_bite" nil :type byte :id 2) 11 | ("integer16" nil :type i16 :id 3) 12 | ("integer32" nil :type i32 :id 4) 13 | ("integer64" nil :type i64 :id 5) 14 | ("double_precision" nil :type double :id 6) 15 | ("some_characters" nil :type string :id 7) 16 | ("base64" nil :type string :id 8) 17 | ("byte_list" nil :type (list byte) :id 9) 18 | ("i16_list" nil :type (list i16) :id 10) 19 | ("i64_list" nil :type (list i64) :id 11))) 20 | 21 | (thrift:def-service "Service" nil 22 | (:method "mymethod" ((("blah" i64 -1)) i64))) 23 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | 6 | (defpackage :thrift-test 7 | (:shadowing-import-from :thrift :byte :set :list :map :type-of :float) 8 | (:use :common-lisp :thrift) 9 | #+ccl 10 | (:import-from :ccl :stream-tyo :stream-tyi :stream-reader :stream-writer 11 | :stream-write-byte :stream-read-byte :stream-position 12 | :stream-read-sequence :stream-write-sequence 13 | :stream-force-output) 14 | #+sbcl 15 | (:import-from :sb-gray 16 | :stream-write-byte :stream-read-byte 17 | :stream-read-sequence :stream-write-sequence 18 | :stream-force-output :stream-finish-output) 19 | (:export :test 20 | :with-test-services 21 | :*test-location*)) 22 | 23 | (defpackage :thrift-test-request (:use )) 24 | 25 | (defpackage :thrift-test-response (:use )) -------------------------------------------------------------------------------- /test/gen-cl/SmallTest.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: testnamespace -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :testnamespace) 7 | 8 | 9 | (defun test-i32 (boo) (incf boo)) 10 | 11 | (defun test-void () 12 | (error 'goodbye 13 | :simple -1 14 | :complex (map '(1 . 1)) 15 | :complexer (map (cons 0 (map (cons 1 2)))))) 16 | 17 | (defun test-me (hello wonk) 18 | (incf (hello-simple wonk) hello) 19 | wonk) 20 | 21 | (defun test-thinger (bootz) 22 | (concatenate 'string bootz "." bootz)) 23 | 24 | ;;; (test-server) 25 | 26 | (thrift-test:test gen-cl/small-test 27 | (thrift-test:with-test-services (protocol small-service) 28 | (and (equal (thrift-generated-request:test-thinger protocol "12345") 29 | "12345.12345") 30 | (let ((s (thrift-generated-request:test-me 31 | protocol 1 (make-instance 'hello :simple 0 32 | :complexer (map (cons 0 (map (cons 1 2)))))))) 33 | (and (typep s 'hello) 34 | (eql (hello-simple s) 1))) 35 | (typep (nth-value 1 (ignore-errors (thrift-generated-request:test-void protocol))) 36 | 'goodbye) 37 | (eql (thrift-generated-request:test-i32 protocol 1) 2))) -------------------------------------------------------------------------------- /test/gen-cl/SmallTest-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-struct "goodbyez" 9 | (("val" 325 :type i32 :id 1))) 10 | 11 | (thrift:def-struct "boolpasser" 12 | (("value" t :type bool :id 1))) 13 | 14 | (thrift:def-struct "hello" 15 | (("simple" 53 :type i32 :id 1) 16 | ("complex" (thrift:map 17 | (cl:cons 23 532) 18 | (cl:cons 6243 632) 19 | (cl:cons 2355 532) ) :type (map i32 i32) :id 2) 20 | ("complexer" nil :type (map i32 (map i32 i32)) :id 3) 21 | ("words" "words" :type string :id 4) 22 | ("thinz" (make-instance 'goodbyez 23 | :val 36632 24 | ) :type (struct "goodbyez") :id 5))) 25 | 26 | (thrift:def-exception "goodbye" 27 | (("simple" nil :type i32 :id 1) 28 | ("complex" nil :type (map i32 i32) :id 2) 29 | ("complexer" nil :type (map i32 (map i32 i32)) :id 3))) 30 | 31 | (thrift:def-service "SmallService" nil 32 | (:method "testThinger" ((("bootz" string 1)) string)) 33 | (:method "testMe" ((("hello" i32 1) ("wonk" (struct "hello") 2)) (struct "hello")) 34 | :exceptions (("g" nil :type (struct "goodbye") :id 1))) 35 | (:method "testVoid" (() void) 36 | :exceptions (("g" nil :type (struct "goodbye") :id 1))) 37 | (:method "testI32" ((("boo" i32 1)) i32))) 38 | -------------------------------------------------------------------------------- /test/gen-cl/ThriftTest.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift.test -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift.test) 7 | 8 | 9 | (defun test-void ()) 10 | 11 | (defun test-string (string-thing) string-thing) 12 | 13 | (defun test-byte (byte-thing) byte-thing) 14 | 15 | (defun test-i32 (i32-thing) i32-thing) 16 | (defun test-i64 (i64-thing) i64-thing) 17 | 18 | (defun test-double (double-thing) double-thing) 19 | (defun test-struct (struct-thing) struct-thing) 20 | (defun test-nest (struct-thing) struct-thing) 21 | (defun test-map (map-thing) map-thing) 22 | (defun test-set (set-132-thing) set-132-thing) 23 | (defun test-list (list-132-thing) list-132-thing) 24 | (defun test-enum (enum-numberz-thing) enum-numberz-thing) 25 | (defun test-typedef (typedef-i64-thing) typedef-i64-thing) 26 | (defun test-map-map (i32-thing) (map i32-thing (map (cons i32-thing i32-thing)))) 27 | 28 | 29 | (defun test-insanity (struct-insanity-thing) (map 1 (map (cons 1 struct-insanity-thing)))) 30 | 31 | (defun test-multi (arg0-byte arg1-i32 arg2-i64 arg3-map arg4-enum-numberz arg5-i64) 32 | (make-instance 'xtruct)) 33 | 34 | (defun test-exception (string-thing) 35 | (error 'xception)) 36 | 37 | (defun test-multi-exception (arg-string arg1-string struct-xtruct) 38 | (error 'xception)) 39 | 40 | (defun test-oneway (secondstosleep) nil) 41 | 42 | 43 | (defun blah-blah () nil) 44 | 45 | -------------------------------------------------------------------------------- /test/gen-cl/ConstantsDemo-vars.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (in-package :thrift-generated) 7 | 8 | (thrift:def-constant "myInt" 3) 9 | 10 | (thrift:def-constant "GEN_ENUM_NAMES" (thrift:map 11 | (cl:cons 1 "HOWDY") 12 | (cl:cons 2 "PARTNER"))) 13 | 14 | (thrift:def-constant "hex_const" 31) 15 | 16 | (thrift:def-constant "GEN_ME" -3523553) 17 | 18 | (thrift:def-constant "GEn_DUB" 325.532) 19 | 20 | (thrift:def-constant "GEn_DU" 85.2355) 21 | 22 | (thrift:def-constant "GEN_STRING" "asldkjasfd") 23 | 24 | (thrift:def-constant "GEN_MAP" (thrift:map 25 | (cl:cons 35532 233) 26 | (cl:cons 43523 853))) 27 | 28 | (thrift:def-constant "GEN_LIST" (thrift:list 29 | 235235 30 | 23598352 31 | 3253523 32 | )) 33 | 34 | (thrift:def-constant "GEN_MAPMAP" (thrift:map 35 | (cl:cons 235 (thrift:map 36 | (cl:cons 532 53255) 37 | (cl:cons 235 235) )))) 38 | 39 | (thrift:def-constant "GEN_MAP2" (thrift:map 40 | (cl:cons "hello" 233) 41 | (cl:cons "lkj98d" 853) 42 | (cl:cons "lkjsdf" 98325))) 43 | 44 | (thrift:def-constant "GEN_THING" (make-instance 'thing 45 | :hello 325 46 | :goodbye 325352 47 | )) 48 | 49 | (thrift:def-constant "GEN_WHAT" (thrift:map 50 | (cl:cons 35 (make-instance 'thing 51 | :hello 325 52 | :goodbye 325352 53 | )))) 54 | 55 | (thrift:def-constant "GEN_SET" (thrift:set 56 | 235 57 | 235 58 | 53235 59 | )) 60 | 61 | -------------------------------------------------------------------------------- /test/vector-protocol.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: thrift-test; -*- 2 | 3 | (in-package :thrift-test) 4 | 5 | (test vector-protocol.write-byte 6 | (progn 7 | (stream-write-byte (make-instance 'vector-stream-transport) 1) 8 | (stream-write-byte (make-instance 'vector-stream-transport) -1))) 9 | 10 | 11 | (test vector-protocol.write-sequence 12 | (let* ((data #(0 1 2 3 4 5 6 7 8 9 246 247 248 249 250 251 252 253 254 255)) 13 | (buffer (make-array 2 :element-type thrift::*binary-transport-element-type*)) 14 | (outstream (make-instance 'vector-output-stream :vector buffer)) 15 | (instream (make-instance 'vector-input-stream :vector nil))) 16 | (write-sequence data outstream) 17 | (cl:map nil #'(lambda (c) (stream-write-byte outstream (char-code c))) "asdf") 18 | (and (every #'eql 19 | (concatenate 'vector data (cl:map 'vector #'char-code "asdf")) 20 | (subseq (thrift.implementation::get-vector-stream-vector outstream) 21 | 0 22 | (stream-position outstream))) 23 | (let ((data2 (make-array (length data))) 24 | (data3 (make-array 4))) 25 | (thrift.implementation::setf-vector-stream-vector (thrift.implementation::get-vector-stream-vector outstream) 26 | instream) 27 | (and (eql (stream-read-sequence instream data2) (length data2)) 28 | (equalp data2 data) 29 | (stream-read-sequence instream data3) 30 | (equal (cl:map 'string #'code-char data3) "asdf")))))) 31 | 32 | -------------------------------------------------------------------------------- /test/gen-cl/OptionalRequiredTest.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-struct "oldschool" 9 | (("im_int" nil :type i16 :id 1) 10 | ("im_str" nil :type string :id 2) 11 | ("im_big" nil :type (list (map i32 string)) :id 3))) 12 | 13 | (thrift:def-struct "simple" 14 | (("im_default" nil :type i16 :id 1) 15 | ("im_required" nil :type i16 :id 2) 16 | ("im_optional" nil :type i16 :id 3))) 17 | 18 | (thrift:def-struct "tricky1" 19 | (("im_default" nil :type i16 :id 1))) 20 | 21 | (thrift:def-struct "tricky2" 22 | (("im_optional" nil :type i16 :id 1))) 23 | 24 | (thrift:def-struct "tricky3" 25 | (("im_required" nil :type i16 :id 1))) 26 | 27 | (thrift:def-struct "complex" 28 | (("cp_default" nil :type i16 :id 1) 29 | ("cp_required" nil :type i16 :id 2) 30 | ("cp_optional" nil :type i16 :id 3) 31 | ("the_map" nil :type (map i16 (struct "simple")) :id 4) 32 | ("req_simp" nil :type (struct "simple") :id 5) 33 | ("opt_simp" nil :type (struct "simple") :id 6))) 34 | 35 | (thrift:def-struct "manyopt" 36 | (("opt1" nil :type i32 :id 1) 37 | ("opt2" nil :type i32 :id 2) 38 | ("opt3" nil :type i32 :id 3) 39 | ("def4" nil :type i32 :id 4) 40 | ("opt5" nil :type i32 :id 5) 41 | ("opt6" nil :type i32 :id 6))) 42 | 43 | (thrift:def-struct "javatesthelper" 44 | (("req_int" nil :type i32 :id 1) 45 | ("opt_int" nil :type i32 :id 2) 46 | ("req_obj" nil :type string :id 3) 47 | ("opt_obj" nil :type string :id 4) 48 | ("req_bin" nil :type string :id 5) 49 | ("opt_bin" nil :type string :id 6))) 50 | 51 | -------------------------------------------------------------------------------- /test/gen-cl/OptionalRequiredTest-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-struct "oldschool" 9 | (("im_int" nil :type i16 :id 1) 10 | ("im_str" nil :type string :id 2) 11 | ("im_big" nil :type (list (map i32 string)) :id 3))) 12 | 13 | (thrift:def-struct "simple" 14 | (("im_default" nil :type i16 :id 1) 15 | ("im_required" nil :type i16 :id 2) 16 | ("im_optional" nil :type i16 :id 3))) 17 | 18 | (thrift:def-struct "tricky1" 19 | (("im_default" nil :type i16 :id 1))) 20 | 21 | (thrift:def-struct "tricky2" 22 | (("im_optional" nil :type i16 :id 1))) 23 | 24 | (thrift:def-struct "tricky3" 25 | (("im_required" nil :type i16 :id 1))) 26 | 27 | (thrift:def-struct "complex" 28 | (("cp_default" nil :type i16 :id 1) 29 | ("cp_required" nil :type i16 :id 2) 30 | ("cp_optional" nil :type i16 :id 3) 31 | ("the_map" nil :type (map i16 (struct "simple")) :id 4) 32 | ("req_simp" nil :type (struct "simple") :id 5) 33 | ("opt_simp" nil :type (struct "simple") :id 6))) 34 | 35 | (thrift:def-struct "manyopt" 36 | (("opt1" nil :type i32 :id 1) 37 | ("opt2" nil :type i32 :id 2) 38 | ("opt3" nil :type i32 :id 3) 39 | ("def4" nil :type i32 :id 4) 40 | ("opt5" nil :type i32 :id 5) 41 | ("opt6" nil :type i32 :id 6))) 42 | 43 | (thrift:def-struct "javatesthelper" 44 | (("req_int" nil :type i32 :id 1) 45 | ("opt_int" nil :type i32 :id 2) 46 | ("req_obj" nil :type string :id 3) 47 | ("opt_obj" nil :type string :id 4) 48 | ("req_bin" nil :type string :id 5) 49 | ("opt_bin" nil :type string :id 6))) 50 | 51 | -------------------------------------------------------------------------------- /test/gen-cl/DenseLinkingTest.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-struct "oneofeachzz" 9 | (("im_true" nil :type bool :id 1) 10 | ("im_false" nil :type bool :id 2) 11 | ("a_bite" nil :type byte :id 3) 12 | ("integer16" nil :type i16 :id 4) 13 | ("integer32" nil :type i32 :id 5) 14 | ("integer64" nil :type i64 :id 6) 15 | ("double_precision" nil :type double :id 7) 16 | ("some_characters" nil :type string :id 8) 17 | ("zomg_unicode" nil :type string :id 9) 18 | ("what_who" nil :type bool :id 10))) 19 | 20 | (thrift:def-struct "bonkzz" 21 | (("type" nil :type i32 :id 1) 22 | ("message" nil :type string :id 2))) 23 | 24 | (thrift:def-struct "nestingzz" 25 | (("my_bonk" nil :type (struct "bonkzz") :id 1) 26 | ("my_ooe" nil :type (struct "oneofeachzz") :id 2))) 27 | 28 | (thrift:def-struct "holymoleyzz" 29 | (("big" nil :type (list (struct "oneofeachzz")) :id 1) 30 | ("contain" nil :type (set (list string)) :id 2) 31 | ("bonks" nil :type (map string (list (struct "bonkzz"))) :id 3))) 32 | 33 | (thrift:def-struct "backwardszz" 34 | (("first_tag2" nil :type i32 :id 2) 35 | ("second_tag1" nil :type i32 :id 1))) 36 | 37 | (thrift:def-struct "emptyzz" 38 | ()) 39 | 40 | (thrift:def-struct "wrapperzz" 41 | (("foo" nil :type (struct "emptyzz") :id 1))) 42 | 43 | (thrift:def-struct "randomstuffzz" 44 | (("a" nil :type i32 :id 1) 45 | ("b" nil :type i32 :id 2) 46 | ("c" nil :type i32 :id 3) 47 | ("d" nil :type i32 :id 4) 48 | ("myintlist" nil :type (list i32) :id 5) 49 | ("maps" nil :type (map i32 (struct "wrapperzz")) :id 6) 50 | ("bigint" nil :type i64 :id 7) 51 | ("triple" nil :type double :id 8))) 52 | 53 | (thrift:def-service "Srv" nil 54 | (:method "Janky" ((("arg" i32 1)) i32))) 55 | -------------------------------------------------------------------------------- /test/gen-cl/DenseLinkingTest-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-struct "oneofeachzz" 9 | (("im_true" nil :type bool :id 1) 10 | ("im_false" nil :type bool :id 2) 11 | ("a_bite" nil :type byte :id 3) 12 | ("integer16" nil :type i16 :id 4) 13 | ("integer32" nil :type i32 :id 5) 14 | ("integer64" nil :type i64 :id 6) 15 | ("double_precision" nil :type double :id 7) 16 | ("some_characters" nil :type string :id 8) 17 | ("zomg_unicode" nil :type string :id 9) 18 | ("what_who" nil :type bool :id 10))) 19 | 20 | (thrift:def-struct "bonkzz" 21 | (("type" nil :type i32 :id 1) 22 | ("message" nil :type string :id 2))) 23 | 24 | (thrift:def-struct "nestingzz" 25 | (("my_bonk" nil :type (struct "bonkzz") :id 1) 26 | ("my_ooe" nil :type (struct "oneofeachzz") :id 2))) 27 | 28 | (thrift:def-struct "holymoleyzz" 29 | (("big" nil :type (list (struct "oneofeachzz")) :id 1) 30 | ("contain" nil :type (set (list string)) :id 2) 31 | ("bonks" nil :type (map string (list (struct "bonkzz"))) :id 3))) 32 | 33 | (thrift:def-struct "backwardszz" 34 | (("first_tag2" nil :type i32 :id 2) 35 | ("second_tag1" nil :type i32 :id 1))) 36 | 37 | (thrift:def-struct "emptyzz" 38 | ()) 39 | 40 | (thrift:def-struct "wrapperzz" 41 | (("foo" nil :type (struct "emptyzz") :id 1))) 42 | 43 | (thrift:def-struct "randomstuffzz" 44 | (("a" nil :type i32 :id 1) 45 | ("b" nil :type i32 :id 2) 46 | ("c" nil :type i32 :id 3) 47 | ("d" nil :type i32 :id 4) 48 | ("myintlist" nil :type (list i32) :id 5) 49 | ("maps" nil :type (map i32 (struct "wrapperzz")) :id 6) 50 | ("bigint" nil :type i64 :id 7) 51 | ("triple" nil :type double :id 8))) 52 | 53 | (thrift:def-service "Srv" nil 54 | (:method "Janky" ((("arg" i32 1)) i32))) 55 | -------------------------------------------------------------------------------- /test/thrift-test.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | (asdf:defsystem :thrift-test 6 | :depends-on (:thrift 7 | :bordeaux-threads) 8 | :description "tests for com.apache.thrift" 9 | :serial t 10 | :components ((:file "package") 11 | (:file "vector-protocol") 12 | (:file "test") 13 | (:file "conditions") 14 | (:file "definition-operators") 15 | (:file "protocol") 16 | #+(or) 17 | (:module :gen-cl 18 | :serial t 19 | :components ((:file "AnnotationTest-types") 20 | (:file "AnnotationTest-vars") 21 | (:file "AnnotationTest") 22 | ; (:file "ConstantsDemo") 23 | ; (:file "DebugProtoTest") 24 | ; (:file "DenseLinkingTest") 25 | ; (:file "DocTest") 26 | ;(:file "JavaBeansTest") 27 | (:file "ManyTypedefs-types") 28 | (:file "ManyTypedefs-vars") 29 | (:file "ManyTypedefs") 30 | ;(:file "OptionalRequiredTest") 31 | (:file "SmallTest-types") 32 | (:file "SmallTest-vars") 33 | (:file "SmallTest") 34 | (:file "StressTest-types.lisp") 35 | (:file "StressTest-vars.lisp") 36 | (:file "StressTest.lisp") 37 | (:file "ThriftTest-types") 38 | (:file "ThriftTest-vars") empty 39 | (:file "ThriftTest") 40 | )))) 41 | 42 | -------------------------------------------------------------------------------- /test/gen-cl/DocTest.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-enum "Numberz" 9 | (("ONE" . 1) 10 | ("TWO" . 2) 11 | ("THREE" . 3) 12 | ("FIVE" . 5) 13 | ("SIX" . 6) 14 | ("EIGHT" . 8))) 15 | 16 | (thrift:def-struct "xtruct" 17 | (("string_thing" nil :type string :id 1) 18 | ("byte_thing" nil :type byte :id 4) 19 | ("i32_thing" nil :type i32 :id 9) 20 | ("i64_thing" nil :type i64 :id 11))) 21 | 22 | (thrift:def-struct "xtruct2" 23 | (("byte_thing" nil :type byte :id 1) 24 | ("struct_thing" nil :type (struct "xtruct") :id 2) 25 | ("i32_thing" nil :type i32 :id 3))) 26 | 27 | (thrift:def-struct "insanity" 28 | (("userMap" nil :type (map (enum "Numberz") i64) :id 1) 29 | ("xtructs" nil :type (list (struct "xtruct")) :id 2))) 30 | 31 | (thrift:def-exception "xception" 32 | (("errorCode" nil :type i32 :id 1) 33 | ("message" nil :type string :id 2))) 34 | 35 | (thrift:def-exception "xception2" 36 | (("errorCode" nil :type i32 :id 1) 37 | ("struct_thing" nil :type (struct "xtruct") :id 2))) 38 | 39 | (thrift:def-struct "emptystruct" 40 | ()) 41 | 42 | (thrift:def-struct "onefield" 43 | (("field" nil :type (struct "emptystruct") :id 1))) 44 | 45 | (thrift:def-service "ThriftTest" nil 46 | (:method "testVoid" (() void)) 47 | (:method "testString" ((("thing" string 1)) string)) 48 | (:method "testByte" ((("thing" byte 1)) byte)) 49 | (:method "testI32" ((("thing" i32 1)) i32)) 50 | (:method "testI64" ((("thing" i64 1)) i64)) 51 | (:method "testDouble" ((("thing" double 1)) double)) 52 | (:method "testStruct" ((("thing" (struct "xtruct") 1)) (struct "xtruct"))) 53 | (:method "testNest" ((("thing" (struct "xtruct2") 1)) (struct "xtruct2"))) 54 | (:method "testMap" ((("thing" (map i32 i32) 1)) (map i32 i32))) 55 | (:method "testSet" ((("thing" (set i32) 1)) (set i32))) 56 | (:method "testList" ((("thing" (list i32) 1)) (list i32))) 57 | (:method "testEnum" ((("thing" (enum "Numberz") 1)) (enum "Numberz"))) 58 | (:method "testTypedef" ((("thing" i64 1)) i64)) 59 | (:method "testMapMap" ((("hello" i32 1)) (map i32 (map i32 i32)))) 60 | (:method "testInsanity" ((("argument" (struct "insanity") 1)) (map i64 (map (enum "Numberz") (struct "insanity")))))) 61 | -------------------------------------------------------------------------------- /thrift.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | 6 | ;;; This files defines the ASDF system for the `org.apache.thrift` library. 7 | ;;; 8 | ;;; Licensed to the Apache Software Foundation (ASF) under one 9 | ;;; or more contributor license agreements. See the NOTICE file 10 | ;;; distributed with this work for additional information 11 | ;;; regarding copyright ownership. The ASF licenses this file 12 | ;;; to you under the Apache License, Version 2.0 (the 13 | ;;; "License"); you may not use this file except in compliance 14 | ;;; with the License. You may obtain a copy of the License at 15 | ;;; 16 | ;;; http://www.apache.org/licenses/LICENSE-2.0 17 | ;;; 18 | ;;; Unless required by applicable law or agreed to in writing, 19 | ;;; software distributed under the License is distributed on an 20 | ;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 21 | ;;; KIND, either express or implied. See the License for the 22 | ;;; specific language governing permissions and limitations 23 | ;;; under the License. 24 | 25 | 26 | (asdf:defsystem :thrift 27 | :depends-on (;; use this puri version to support thrift uri class 28 | #-:asdf.hierarchical-names :puri-ppcre 29 | #+:asdf.hierarchical-names :com.b9.puri.puri-ppcre 30 | :usocket 31 | :closer-mop 32 | :trivial-utf-8) 33 | :description "org.apache.thrift implements a Common Lisp binding for the Apache Thrift cross-language 34 | services protocol." 35 | :serial t 36 | :components ((:file "package") 37 | (:file "symbols") 38 | (:file "types") 39 | (:file "parameters") 40 | (:file "classes") 41 | (:file "float") 42 | (:file "definition-operators") 43 | (:file "transport") 44 | (:file "conditions") 45 | (:file "protocol") 46 | (:file "binary-protocol") 47 | (:file "vector-protocol") 48 | (:file "client") 49 | (:file "server")) 50 | 51 | :long-description 52 | "This library uses the Thrift[[1]],[[2]] protocol to implement Common Lisp support for cross-language 53 | access to remote services. See README.md for more information. 54 | 55 | [1]: http://incubator.apache.org/thrift/static/thrift-20070401.pdf 56 | [2]: http://wiki.apache.org/thrift/ 57 | ") 58 | 59 | -------------------------------------------------------------------------------- /test/gen-cl/DocTest-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-enum "Numberz" 9 | (("ONE" . 1) 10 | ("TWO" . 2) 11 | ("THREE" . 3) 12 | ("FIVE" . 5) 13 | ("SIX" . 6) 14 | ("EIGHT" . 8))) 15 | 16 | (thrift:def-struct "xtruct" 17 | "And this is where you would document a struct 18 | " 19 | (("string_thing" nil :type string :id 1 :documentation "And the members of a struct 20 | ") 21 | ("byte_thing" nil :type byte :id 4 :documentation "doct text goes before a comma 22 | ") 23 | ("i32_thing" nil :type i32 :id 9) 24 | ("i64_thing" nil :type i64 :id 11))) 25 | 26 | (thrift:def-struct "xtruct2" 27 | (("byte_thing" nil :type byte :id 1) 28 | ("struct_thing" nil :type (struct "xtruct") :id 2) 29 | ("i32_thing" nil :type i32 :id 3))) 30 | 31 | (thrift:def-struct "insanity" 32 | "Struct insanity 33 | " 34 | (("userMap" nil :type (map (enum "Numberz") i64) :id 1 :documentation "This is doc for field 1 35 | ") 36 | ("xtructs" nil :type (list (struct "xtruct")) :id 2 :documentation "And this is doc for field 2 37 | "))) 38 | 39 | (thrift:def-exception "xception" 40 | (("errorCode" nil :type i32 :id 1) 41 | ("message" nil :type string :id 2))) 42 | 43 | (thrift:def-exception "xception2" 44 | (("errorCode" nil :type i32 :id 1) 45 | ("struct_thing" nil :type (struct "xtruct") :id 2))) 46 | 47 | (thrift:def-struct "emptystruct" 48 | "Doc 49 | " 50 | ()) 51 | 52 | (thrift:def-struct "onefield" 53 | (("field" nil :type (struct "emptystruct") :id 1))) 54 | 55 | (thrift:def-service "ThriftTest" nil(:documentation "This is where you would document a Service 56 | ") 57 | (:method "testVoid" (() void)) 58 | (:method "testString" ((("thing" string 1)) string)) 59 | (:method "testByte" ((("thing" byte 1)) byte)) 60 | (:method "testI32" ((("thing" i32 1)) i32)) 61 | (:method "testI64" ((("thing" i64 1)) i64)) 62 | (:method "testDouble" ((("thing" double 1)) double)) 63 | (:method "testStruct" ((("thing" (struct "xtruct") 1)) (struct "xtruct"))) 64 | (:method "testNest" ((("thing" (struct "xtruct2") 1)) (struct "xtruct2"))) 65 | (:method "testMap" ((("thing" (map i32 i32) 1)) (map i32 i32))) 66 | (:method "testSet" ((("thing" (set i32) 1)) (set i32))) 67 | (:method "testList" ((("thing" (list i32) 1)) (list i32))) 68 | (:method "testEnum" ((("thing" (enum "Numberz") 1)) (enum "Numberz"))) 69 | (:method "testTypedef" ((("thing" i64 1)) i64)) 70 | (:method "testMapMap" ((("hello" i32 1)) (map i32 (map i32 i32)))) 71 | (:method "testInsanity" ((("argument" (struct "insanity") 1)) (map i64 (map (enum "Numberz") (struct "insanity")))))) 72 | -------------------------------------------------------------------------------- /READMES/readme-cassandra.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: cl-user; -*- 2 | 3 | (in-package :cl-user) 4 | 5 | #+(or ccl sbcl sbcl) /development/source/library/ 6 | (load "build-init.lisp") 7 | 8 | ;;; ! first, select the api version in the cassandra system definition 9 | ;;; as only one should be loaded at a time. 10 | (asdf:load-system :de.setf.cassandra) 11 | 12 | (in-package :de.setf.cassandra) 13 | 14 | (defparameter *c-location* 15 | ;; remote 16 | ;; #u"thrift://ec2-174-129-66-148.compute-1.amazonaws.com:9160" 17 | ;; local 18 | #u"thrift://127.0.0.1:9160" 19 | "A cassandra service location - either the local one or a remote service 20 | - always a 'thrift' uri.") 21 | 22 | (defparameter *c* (thrift:client *c-location*)) 23 | 24 | 25 | (cassandra:describe-keyspaces *c*) 26 | ;; => ("Keyspace1" "system") 27 | 28 | (cassandra:describe-cluster-name *c*) 29 | ;; =>"Test Cluster" 30 | 31 | (cassandra:describe-version *c*) 32 | ;; => "2.1.0" 33 | 34 | (loop for space in (cassandra:describe-keyspaces *c*) 35 | collect (loop for key being each hash-key of (cassandra:describe-keyspace *c* space) 36 | using (hash-value value) 37 | collect (cons key 38 | (loop for key being each hash-key of value 39 | using (hash-value value) 40 | collect (cons key value))))) 41 | 42 | 43 | (close *c*) 44 | 45 | (defun describe-cassandra (location &optional (stream *standard-output*)) 46 | "Print the first-order store metadata for a cassandra LOCATION." 47 | 48 | (thrift:with-client (cassandra location) 49 | (let* ((keyspace-names (cassandra:describe-keyspaces cassandra)) 50 | (cluster (cassandra:describe-cluster-name cassandra)) 51 | (version (cassandra:describe-version cassandra)) 52 | (keyspace-descriptions (loop for space in keyspace-names 53 | collect (cons space 54 | (loop for key being each hash-key 55 | of (cassandra:describe-keyspace cassandra space) 56 | using (hash-value value) 57 | collect (cons key 58 | (loop for key being each hash-key of value 59 | using (hash-value value) 60 | collect (cons key value)))))))) 61 | (format stream "~&connection to : ~a" cassandra) 62 | (format stream "~&version : ~a" version) 63 | (format stream "~&cluster : ~a" cluster) 64 | (format stream "~&keyspaces~{~{~%~%space: ~a~@{~% ~{~a :~@{~20t~:w~^~%~}~}~}~}~}" keyspace-descriptions)))) 65 | 66 | ;;; (describe-cassandra *c-location*) 67 | -------------------------------------------------------------------------------- /client.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- 2 | 3 | (in-package :org.apache.thrift.implementation) 4 | 5 | ;;; This file defines client operators for the `org.apache.thrift` library. 6 | ;;; 7 | ;;; copyright 2010 [james anderson](james.anderson@setf.de) 8 | ;;; 9 | ;;; Licensed to the Apache Software Foundation (ASF) under one 10 | ;;; or more contributor license agreements. See the NOTICE file 11 | ;;; distributed with this work for additional information 12 | ;;; regarding copyright ownership. The ASF licenses this file 13 | ;;; to you under the Apache License, Version 2.0 (the 14 | ;;; "License"); you may not use this file except in compliance 15 | ;;; with the License. You may obtain a copy of the License at 16 | ;;; 17 | ;;; http://www.apache.org/licenses/LICENSE-2.0 18 | ;;; 19 | ;;; Unless required by applicable law or agreed to in writing, 20 | ;;; software distributed under the License is distributed on an 21 | ;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 22 | ;;; KIND, either express or implied. See the License for the 23 | ;;; specific language governing permissions and limitations 24 | ;;; under the License. 25 | 26 | 27 | 28 | (defgeneric client (location &key protocol direction element-type &allow-other-keys) 29 | (:method ((location puri:uri) &rest initargs &key (direction :io) (element-type 'unsigned-byte et-s) &allow-other-keys) 30 | (when et-s 31 | (setf initargs (copy-list initargs)) 32 | (remf initargs :element-type)) 33 | (apply #'client (socket-transport location :element-type element-type :direction direction) 34 | :direction direction 35 | initargs)) 36 | 37 | (:method ((location pathname) &rest initargs &key (direction :io) (element-type 'unsigned-byte et-s) &allow-other-keys) 38 | (when et-s 39 | (setf initargs (copy-list initargs)) 40 | (remf initargs :element-type)) 41 | (apply #'client (make-instance 'file-transport 42 | :pathname location :element-type element-type :direction direction) 43 | :direction direction 44 | initargs)) 45 | 46 | (:method ((instance protocol) &rest initargs 47 | &key (protocol (class-of instance) p-s) (direction (stream-direction instance)) &allow-other-keys) 48 | "Given a protocol INSTANCE, and a PROTOCOL class, make a new protocol instance which reuses 49 | the given instance's transports." 50 | (when p-s 51 | (setf initargs (copy-list initargs)) 52 | (remf initargs :protocol)) 53 | (apply #'make-instance protocol 54 | :input-transport (thrift:protocol-input-transport protocol) 55 | :output-transport (thrift:protocol-output-transport protocol) 56 | :direction direction 57 | initargs)) 58 | 59 | (:method ((instance binary-transport) &rest initargs 60 | &key (protocol 'binary-protocol p-s) (direction (stream-direction instance)) &allow-other-keys) 61 | (when p-s 62 | (setf initargs (copy-list initargs)) 63 | (remf initargs :protocol)) 64 | (apply #'make-instance protocol :transport instance :direction direction 65 | initargs))) 66 | 67 | 68 | (defmacro with-client ((protocol &rest args) &body body) 69 | (with-gensyms (op) 70 | `(flet ((,op (,protocol) ,@body)) 71 | (declare (dynamic-extent #',op)) 72 | (call-with-client #',op ,@args)))) 73 | 74 | 75 | (defun call-with-client (op &rest args) 76 | (declare (dynamic-extent args)) 77 | (let ((protocol (apply #'client args))) 78 | (unwind-protect (funcall op protocol) 79 | (when (open-stream-p protocol) 80 | (close protocol))))) -------------------------------------------------------------------------------- /test/gen-cl/ThriftTest-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-enum "Numberz" 9 | (("ONE" . 1) 10 | ("TWO" . 2) 11 | ("THREE" . 3) 12 | ("FIVE" . 5) 13 | ("SIX" . 6) 14 | ("EIGHT" . 8))) 15 | 16 | (thrift:def-struct "bonk" 17 | (("message" nil :type string :id 1) 18 | ("type" nil :type i32 :id 2))) 19 | 20 | (thrift:def-struct "bools" 21 | (("im_true" nil :type bool :id 1) 22 | ("im_false" nil :type bool :id 2))) 23 | 24 | (thrift:def-struct "xtruct" 25 | (("string_thing" nil :type string :id 1) 26 | ("byte_thing" nil :type byte :id 4) 27 | ("i32_thing" nil :type i32 :id 9) 28 | ("i64_thing" nil :type i64 :id 11))) 29 | 30 | (thrift:def-struct "xtruct2" 31 | (("byte_thing" nil :type byte :id 1) 32 | ("struct_thing" nil :type (struct "xtruct") :id 2) 33 | ("i32_thing" nil :type i32 :id 3))) 34 | 35 | (thrift:def-struct "xtruct3" 36 | (("string_thing" nil :type string :id 1) 37 | ("changed" nil :type i32 :id 4) 38 | ("i32_thing" nil :type i32 :id 9) 39 | ("i64_thing" nil :type i64 :id 11))) 40 | 41 | (thrift:def-struct "insanity" 42 | (("userMap" nil :type (map (enum "Numberz") i64) :id 1) 43 | ("xtructs" nil :type (list (struct "xtruct")) :id 2))) 44 | 45 | (thrift:def-struct "crazynesting" 46 | (("string_field" nil :type string :id 1) 47 | ("set_field" nil :type (set (struct "insanity")) :id 2) 48 | ("list_field" nil :type (list (map (set i32) (map i32 (set (list (map (struct "insanity") string)))))) :id 3))) 49 | 50 | (thrift:def-exception "xception" 51 | (("errorCode" nil :type i32 :id 1) 52 | ("message" nil :type string :id 2))) 53 | 54 | (thrift:def-exception "xception2" 55 | (("errorCode" nil :type i32 :id 1) 56 | ("struct_thing" nil :type (struct "xtruct") :id 2))) 57 | 58 | (thrift:def-struct "emptystruct" 59 | ()) 60 | 61 | (thrift:def-struct "onefield" 62 | (("field" nil :type (struct "emptystruct") :id 1))) 63 | 64 | (thrift:def-struct "versioningtestv1" 65 | (("begin_in_both" nil :type i32 :id 1) 66 | ("old_string" nil :type string :id 3) 67 | ("end_in_both" nil :type i32 :id 12))) 68 | 69 | (thrift:def-struct "versioningtestv2" 70 | (("begin_in_both" nil :type i32 :id 1) 71 | ("newint" nil :type i32 :id 2) 72 | ("newbyte" nil :type byte :id 3) 73 | ("newshort" nil :type i16 :id 4) 74 | ("newlong" nil :type i64 :id 5) 75 | ("newdouble" nil :type double :id 6) 76 | ("newstruct" nil :type (struct "bonk") :id 7) 77 | ("newlist" nil :type (list i32) :id 8) 78 | ("newset" nil :type (set i32) :id 9) 79 | ("newmap" nil :type (map i32 i32) :id 10) 80 | ("newstring" nil :type string :id 11) 81 | ("end_in_both" nil :type i32 :id 12))) 82 | 83 | (thrift:def-struct "listtypeversioningv1" 84 | (("myints" nil :type (list i32) :id 1) 85 | ("hello" nil :type string :id 2))) 86 | 87 | (thrift:def-struct "listtypeversioningv2" 88 | (("strings" nil :type (list string) :id 1) 89 | ("hello" nil :type string :id 2))) 90 | 91 | (thrift:def-service "ThriftTest" nil 92 | (:method "testVoid" (() void)) 93 | (:method "testString" ((("thing" string 1)) string)) 94 | (:method "testByte" ((("thing" byte 1)) byte)) 95 | (:method "testI32" ((("thing" i32 1)) i32)) 96 | (:method "testI64" ((("thing" i64 1)) i64)) 97 | (:method "testDouble" ((("thing" double 1)) double)) 98 | (:method "testStruct" ((("thing" (struct "xtruct") 1)) (struct "xtruct"))) 99 | (:method "testNest" ((("thing" (struct "xtruct2") 1)) (struct "xtruct2"))) 100 | (:method "testMap" ((("thing" (map i32 i32) 1)) (map i32 i32))) 101 | (:method "testSet" ((("thing" (set i32) 1)) (set i32))) 102 | (:method "testList" ((("thing" (list i32) 1)) (list i32))) 103 | (:method "testEnum" ((("thing" (enum "Numberz") 1)) (enum "Numberz"))) 104 | (:method "testTypedef" ((("thing" i64 1)) i64)) 105 | (:method "testMapMap" ((("hello" i32 1)) (map i32 (map i32 i32)))) 106 | (:method "testInsanity" ((("argument" (struct "insanity") 1)) (map i64 (map (enum "Numberz") (struct "insanity"))))) 107 | (:method "testMulti" ((("arg0" byte 1) ("arg1" i32 2) ("arg2" i64 3) ("arg3" (map i16 string) 4) ("arg4" (enum "Numberz") 5) ("arg5" i64 6)) (struct "xtruct"))) 108 | (:method "testException" ((("arg" string 1)) void) 109 | :exceptions (("err1" nil :type (struct "xception") :id 1))) 110 | (:method "testMultiException" ((("arg0" string 1) ("arg1" string 2)) (struct "xtruct")) 111 | :exceptions (("err1" nil :type (struct "xception") :id 1) 112 | ("err2" nil :type (struct "xception2") :id 2))) 113 | (:method "testOneway" ((("secondsToSleep" i32 1)) void) 114 | :oneway t)) 115 | (thrift:def-service "SecondService" nil 116 | (:method "blahBlah" (() void))) 117 | -------------------------------------------------------------------------------- /test/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: thrift-test; -*- 2 | 3 | (in-package :thrift-test) 4 | 5 | ;;; this file defines tests for exception classes. 6 | ;;; (run-tests "conditions/.*") 7 | 8 | 9 | (test conditions/thrift-error 10 | (stringp (princ-to-string (make-condition 'thrift-error)))) 11 | 12 | 13 | (test conditions/application-error 14 | (stringp (princ-to-string (make-condition 'application-error 15 | :condition (nth-value 1 (ignore-errors (error "testing errors"))))))) 16 | 17 | (test conditions/protocol-error 18 | (stringp (princ-to-string (make-condition 'protocol-error 19 | :protocol (make-test-protocol))))) 20 | 21 | (test conditions/transport-error 22 | (stringp (princ-to-string (make-condition 'transport-error)))) 23 | 24 | (test conditions/class-not-found-error 25 | (and (stringp (princ-to-string (make-condition 'class-not-found-error 26 | :protocol (make-test-protocol) 27 | :identifier "UnknownClass"))) 28 | (typep (nth-value 1 (ignore-errors (class-not-found (make-test-protocol) "UnknownClass"))) 29 | 'class-not-found-error))) 30 | 31 | (test conditions/protocol-version-error 32 | (and (stringp (princ-to-string (make-condition 'protocol-version-error 33 | :protocol (make-test-protocol) 34 | :datum '(0 . 0) :expected-type '(1 . 1)))) 35 | (typep (nth-value 1 (ignore-errors (invalid-protocol-version (make-test-protocol) 0 0))) 36 | 'protocol-version-error))) 37 | 38 | (test conditions/element-type-error 39 | (and (stringp (princ-to-string (make-condition 'element-type-error 40 | :protocol (make-test-protocol) 41 | :container-type 'list :expected-type 'bool :element-type 'i16))) 42 | (typep (nth-value 1 (ignore-errors (invalid-element-type (make-test-protocol) 'list 'bool 'i16))) 43 | 'element-type-error))) 44 | 45 | (test conditions/enum-type-error 46 | (and (stringp (princ-to-string (make-condition 'enum-type-error 47 | :protocol (make-test-protocol) 48 | :datum 3 :expected-type '(enum "x")))) 49 | (typep (nth-value 1 (ignore-errors (invalid-enum (make-test-protocol) '(enum "x") 3))) 50 | 'enum-type-error))) 51 | 52 | (test conditions/field-size-error 53 | (and (stringp (princ-to-string (make-condition 'field-size-error 54 | :protocol (make-test-protocol) 55 | :name "fieldex" :number -1 56 | :datum most-negative-fixnum :expected-type `(integer 0 ,most-positive-fixnum)))) 57 | (typep (nth-value 1 (ignore-errors (invalid-field-size (make-test-protocol) -1 "fieldex" `(integer 0 ,most-positive-fixnum) most-negative-fixnum))) 58 | 'field-size-error))) 59 | 60 | (test conditions/field-type-error 61 | (and (stringp (princ-to-string (make-condition 'field-type-error 62 | :protocol (make-test-protocol) 63 | :structure-type 'test-struct :name "fieldex" :number 17 64 | :expected-type 'bool :datum 12345))) 65 | (typep (nth-value 1 (ignore-errors (invalid-field-type (make-test-protocol) 'test-struct 17 "fieldex" 'bool 12345))) 66 | 'field-type-error))) 67 | 68 | (test conditions/unknown-field-error 69 | (and (stringp (princ-to-string (make-condition 'unknown-field-error 70 | :protocol (make-test-protocol) 71 | :structure-type 'test-struct :name "fieldex" :number 17 :datum 12345))) 72 | (typep (nth-value 1 (ignore-errors (unknown-field (make-test-protocol) 17 "fieldex" 'i16 12345))) 73 | 'null))) 74 | 75 | (test conditions/unknown-method-error 76 | (and (stringp (princ-to-string (make-condition 'unknown-method-error 77 | :protocol (make-test-protocol) 78 | :identifier "methodex" :request t))) 79 | (typep (nth-value 1 (ignore-errors (unknown-method (make-test-protocol) "methodex" 12345 t))) 80 | 'unknown-method-error))) 81 | 82 | 83 | (test conditions/struct-type-error 84 | (and (stringp (princ-to-string (make-condition 'struct-type-error 85 | :protocol (make-test-protocol) 86 | :expected-type 'test-struct :datum t))) 87 | (typep (nth-value 1 (ignore-errors (invalid-struct-type (make-test-protocol) 'test-struct t))) 88 | 'struct-type-error))) 89 | -------------------------------------------------------------------------------- /test/gen-cl/DebugProtoTest-vars.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (in-package :thrift-generated) 7 | 8 | (thrift:def-constant "COMPACT_TEST" (make-instance 'compactprototeststruct 9 | :a_byte 127 10 | :a_i16 32000 11 | :a_i32 1000000000 12 | :a_i64 1099511627775 13 | :a_double 5.6789 14 | :a_string "my string" 15 | :true_field t 16 | :false_field nil 17 | :empty_struct_field (make-instance 'empty 18 | ) 19 | :byte_list (thrift:list 20 | -127 21 | -1 22 | 0 23 | 1 24 | 127 25 | ) 26 | :i16_list (thrift:list 27 | -1 28 | 0 29 | 1 30 | 32767 31 | ) 32 | :i32_list (thrift:list 33 | -1 34 | 0 35 | 255 36 | 65535 37 | 16777215 38 | 2147483647 39 | ) 40 | :i64_list (thrift:list 41 | -1 42 | 0 43 | 255 44 | 65535 45 | 16777215 46 | 4294967295 47 | 1099511627775 48 | 281474976710655 49 | 72057594037927935 50 | 9223372036854775807 51 | ) 52 | :double_list (thrift:list 53 | 0.1 54 | 0.2 55 | 0.3 56 | ) 57 | :string_list (thrift:list 58 | "first" 59 | "second" 60 | "third" 61 | ) 62 | :boolean_list (thrift:list 63 | t 64 | t 65 | t 66 | nil 67 | nil 68 | nil 69 | ) 70 | :struct_list (thrift:list 71 | (make-instance 'empty 72 | ) 73 | (make-instance 'empty 74 | ) 75 | ) 76 | :byte_set (thrift:set 77 | -127 78 | -1 79 | 0 80 | 1 81 | 127 82 | ) 83 | :i16_set (thrift:set 84 | -1 85 | 0 86 | 1 87 | 32767 88 | ) 89 | :i32_set (thrift:set 90 | 1 91 | 2 92 | 3 93 | ) 94 | :i64_set (thrift:set 95 | -1 96 | 0 97 | 255 98 | 65535 99 | 16777215 100 | 4294967295 101 | 1099511627775 102 | 281474976710655 103 | 72057594037927935 104 | 9223372036854775807 105 | ) 106 | :double_set (thrift:set 107 | 0.1 108 | 0.2 109 | 0.3 110 | ) 111 | :string_set (thrift:set 112 | "first" 113 | "second" 114 | "third" 115 | ) 116 | :boolean_set (thrift:set 117 | t 118 | nil 119 | ) 120 | :struct_set (thrift:set 121 | (make-instance 'empty 122 | ) 123 | ) 124 | :byte_byte_map (thrift:map 125 | (cl:cons 1 2) ) 126 | :i16_byte_map (thrift:map 127 | (cl:cons 1 1) 128 | (cl:cons -1 1) 129 | (cl:cons 32767 1) ) 130 | :i32_byte_map (thrift:map 131 | (cl:cons 1 1) 132 | (cl:cons -1 1) 133 | (cl:cons 2147483647 1) ) 134 | :i64_byte_map (thrift:map 135 | (cl:cons 0 1) 136 | (cl:cons 1 1) 137 | (cl:cons -1 1) 138 | (cl:cons 9223372036854775807 1) ) 139 | :double_byte_map (thrift:map 140 | (cl:cons -1.1 1) 141 | (cl:cons 1.1 1) ) 142 | :string_byte_map (thrift:map 143 | (cl:cons "first" 1) 144 | (cl:cons "second" 2) 145 | (cl:cons "third" 3) 146 | (cl:cons "" 0) ) 147 | :boolean_byte_map (thrift:map 148 | (cl:cons t 1) 149 | (cl:cons nil 0) ) 150 | :byte_i16_map (thrift:map 151 | (cl:cons 1 1) 152 | (cl:cons 2 -1) 153 | (cl:cons 3 32767) ) 154 | :byte_i32_map (thrift:map 155 | (cl:cons 1 1) 156 | (cl:cons 2 -1) 157 | (cl:cons 3 2147483647) ) 158 | :byte_i64_map (thrift:map 159 | (cl:cons 1 1) 160 | (cl:cons 2 -1) 161 | (cl:cons 3 9223372036854775807) ) 162 | :byte_double_map (thrift:map 163 | (cl:cons 1 0.1) 164 | (cl:cons 2 -0.1) 165 | (cl:cons 3 1e+06) ) 166 | :byte_string_map (thrift:map 167 | (cl:cons 1 "") 168 | (cl:cons 2 "blah") 169 | (cl:cons 3 "loooooooooooooong string") ) 170 | :byte_boolean_map (thrift:map 171 | (cl:cons 1 t) 172 | (cl:cons 2 nil) ) 173 | :list_byte_map (thrift:map 174 | (cl:cons (thrift:list 175 | 1 176 | 2 177 | 3 178 | ) 1) 179 | (cl:cons (thrift:list 180 | 0 181 | 1 182 | ) 2) 183 | (cl:cons (thrift:list 184 | ) 0) ) 185 | :set_byte_map (thrift:map 186 | (cl:cons (thrift:set 187 | 1 188 | 2 189 | 3 190 | ) 1) 191 | (cl:cons (thrift:set 192 | 0 193 | 1 194 | ) 2) 195 | (cl:cons (thrift:set 196 | ) 0) ) 197 | :map_byte_map (thrift:map 198 | (cl:cons (thrift:map 199 | (cl:cons 1 1) ) 1) 200 | (cl:cons (thrift:map 201 | (cl:cons 2 2) ) 2) 202 | (cl:cons (thrift:map ) 0) ) 203 | :byte_map_map (thrift:map 204 | (cl:cons 0 (thrift:map )) 205 | (cl:cons 1 (thrift:map 206 | (cl:cons 1 1) )) 207 | (cl:cons 2 (thrift:map 208 | (cl:cons 1 1) 209 | (cl:cons 2 2) )) ) 210 | :byte_set_map (thrift:map 211 | (cl:cons 0 (thrift:set 212 | )) 213 | (cl:cons 1 (thrift:set 214 | 1 215 | )) 216 | (cl:cons 2 (thrift:set 217 | 1 218 | 2 219 | )) ) 220 | :byte_list_map (thrift:map 221 | (cl:cons 0 (thrift:list 222 | )) 223 | (cl:cons 1 (thrift:list 224 | 1 225 | )) 226 | (cl:cons 2 (thrift:list 227 | 1 228 | 2 229 | )) ) 230 | )) 231 | 232 | (thrift:def-constant "MYCONST" 2) 233 | 234 | (thrift:def-constant "MY_SOME_ENUM" 1) 235 | 236 | (thrift:def-constant "MY_SOME_ENUM_1" 1) 237 | 238 | (thrift:def-constant "MY_ENUM_MAP" (thrift:map 239 | (cl:cons 1 2))) 240 | 241 | (thrift:def-constant "EXTRA_CRAZY_MAP" (thrift:map 242 | (cl:cons 1 (make-instance 'structwithsomeenum 243 | :blah 2 244 | )))) 245 | 246 | -------------------------------------------------------------------------------- /test/definition-operators.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: thrift-test; -*- 2 | 3 | (in-package :thrift-test) 4 | 5 | ;;; tests for definition operators 6 | ;;; (run-tests "def-.*") 7 | 8 | (test def-package.1 9 | (progn (def-package :test-package) 10 | (prog1 (and (find-package :test-package) 11 | (find-package :test-package-implementation) 12 | (find-package :test-package-response)) 13 | (delete-package :test-package) 14 | (delete-package :test-package-implementation) 15 | (delete-package :test-package-response)))) 16 | 17 | (test def-package.2 18 | ;; redfinition should succeed 19 | (progn (def-package :test-package) 20 | (def-package :test-package) 21 | (prog1 (and (find-package :test-package) 22 | (find-package :test-package-implementation) 23 | (find-package :test-package-response)) 24 | (delete-package :test-package) 25 | (delete-package :test-package-implementation) 26 | (delete-package :test-package-response)))) 27 | ;;; (run-tests "def-package.*") 28 | 29 | (test def-enum 30 | (progn (def-enum "TestEnum" ((first . 1) (second . 2))) 31 | (prog1 (and (eql (symbol-value 'test-enum.first) 1) 32 | (eql (symbol-value 'test-enum.second) 2))))) 33 | ;;; (run-tests "def-enum") 34 | 35 | (test def-constant 36 | (progn (def-constant "aConstant" 1) 37 | (prog1 (eql (symbol-value 'a-constant) 1) 38 | (unintern 'a-constant)))) 39 | 40 | 41 | (defgeneric test-struct-too-field1 (struct)) 42 | (defgeneric test-struct-too-field2 (struct)) 43 | (defgeneric test-struct-too-field3 (struct)) 44 | (defgeneric (setf test-struct-too-field2) (value struct)) 45 | 46 | (test def-struct 47 | (progn 48 | (def-struct "testStructToo" ()) 49 | (def-struct "testStructToo" 50 | (("field1" 0 :type i32 :id 1) 51 | ("field2" nil :type i16 :id 2 :optional t) 52 | ("field3" "string value" :type string :id 3))) 53 | (let ((struct (make-instance 'test-struct-too :field1 -1))) 54 | (prog1 (and (equal (test-struct-too-field3 struct) "string value") 55 | (not (slot-boundp struct 'field2)) 56 | (equal (test-struct-too-field1 struct) -1) 57 | (typep (nth-value 1 (ignore-errors (setf (test-struct-too-field2 struct) 1.1))) 58 | ;; some implementation may not constrain 59 | ;; some signal a type error 60 | #+ccl 'type-error 61 | #+sbcl 'null)) ; how to enable slot type checks? 62 | (mapc #'(lambda (method) (remove-method (c2mop:method-generic-function method) method)) 63 | (c2mop:specializer-direct-methods (find-class 'test-struct-too))) 64 | (setf (find-class 'test-struct-too) nil))))) 65 | ;;; (run-tests "def-struct") 66 | 67 | (defgeneric test-exception-reason (exception)) 68 | 69 | (test def-exception 70 | (progn 71 | (eval '(def-exception "testException" (("reason" nil :type string :id 1)))) 72 | (let ((ex (make-condition 'test-exception :reason "testing"))) 73 | (prog1 (and (equal (test-exception-reason ex) "testing") 74 | (eq (cl:type-of (nth-value 1 (ignore-errors (error ex)))) 75 | 'test-exception) 76 | (stringp (princ-to-string ex))) 77 | (mapc #'(lambda (method) (remove-method (c2mop:method-generic-function method) method)) 78 | (c2mop:specializer-direct-methods (find-class 'test-exception))) 79 | (mapc #'(lambda (method) (remove-method (c2mop:method-generic-function method) method)) 80 | (c2mop:specializer-direct-methods (find-class 'test-exception-exception-class))) 81 | (setf (find-class 'test-exception) nil) 82 | (setf (find-class 'test-exception-exception-class) nil))))) 83 | 84 | 85 | 86 | (test def-service 87 | (progn (defun thrift-test-implementation::test-method (arg1 arg2) (format nil "~a ~a" arg1 arg2)) 88 | (eval '(def-service "TestService" nil 89 | (:method "testMethod" ((("arg1" i32 1) ("arg2" string 2)) string)))) 90 | (let (request-protocol 91 | response-protocol 92 | (run-response-result nil)) 93 | (flet ((run-response (request-stream) 94 | (rewind request-stream) 95 | (multiple-value-bind (identifier type seq) 96 | (stream-read-message-begin response-protocol) 97 | (cond ((and (equal identifier "testMethod") (eq type 'call)) 98 | (setf run-response-result 99 | (funcall 'thrift-test-response::test-method t seq response-protocol))) 100 | (t 101 | (unknown-method response-protocol identifier seq 102 | (prog1 (stream-read-struct response-protocol) 103 | (stream-read-message-end response-protocol)))))))) 104 | 105 | (multiple-value-setq (request-protocol response-protocol) 106 | (make-test-protocol-peers :request-hook #'run-response)) 107 | 108 | (prog1 (and (equal (funcall 'thrift-test::test-method request-protocol 1 "testing") 109 | "1 testing") 110 | ;; if the first test succeed, this should also be true 111 | (equal run-response-result "1 testing")) 112 | (fmakunbound 'thrift-test-implementation::test-method) 113 | (fmakunbound 'thrift-test::test-method) 114 | (fmakunbound 'thrift-test-response::test-method) 115 | ))))) 116 | ;;; (run-tests "def-service") 117 | 118 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: common-lisp-user; -*- 2 | 3 | (in-package :common-lisp-user) 4 | 5 | ;;; This file defines the packages for the `org.apache.thrift` library. 6 | ;;; 7 | ;;; copyright 2010 [james anderson](james.anderson@setf.de) 8 | ;;; 9 | ;;; Licensed to the Apache Software Foundation (ASF) under one 10 | ;;; or more contributor license agreements. See the NOTICE file 11 | ;;; distributed with this work for additional information 12 | ;;; regarding copyright ownership. The ASF licenses this file 13 | ;;; to you under the Apache License, Version 2.0 (the 14 | ;;; "License"); you may not use this file except in compliance 15 | ;;; with the License. You may obtain a copy of the License at 16 | ;;; 17 | ;;; http://www.apache.org/licenses/LICENSE-2.0 18 | ;;; 19 | ;;; Unless required by applicable law or agreed to in writing, 20 | ;;; software distributed under the License is distributed on an 21 | ;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 22 | ;;; KIND, either express or implied. See the License for the 23 | ;;; specific language governing permissions and limitations 24 | ;;; under the License. 25 | 26 | (defpackage :org.apache.thrift 27 | (:nicknames :thrift) 28 | (:use) 29 | 30 | (:documentation "This is the home package for the symbols in the library's interface. 31 | It uses no packages, but imports 'string' from :cl. It does export some symbols 32 | particular to Thrift types and/or operators which conflict with standard Common Lisp symbols. 33 | These must be selectively shadowed as per application requirements in a using package.") 34 | 35 | (:import-from :common-lisp 36 | :string) 37 | #+ccl 38 | (:import-from :ccl 39 | :stream-direction) 40 | ;; digitools stream-write-string signature requires four arguments. leave it to be shadowed 41 | #+sbcl 42 | (:import-from :sb-gray 43 | :stream-write-string) 44 | #+lispworks 45 | (:import-from :stream 46 | :stream-write-string) 47 | (:export 48 | :*binary-transport-element-type* 49 | :application-error 50 | :binary-protocol 51 | :binary-transport 52 | :binary 53 | :bool 54 | :byte 55 | :call 56 | :class-condition-class 57 | :class-field-definitions 58 | :class-identifier 59 | :class-not-found 60 | :class-not-found-error 61 | :client with-client 62 | :def-constant 63 | :def-enum 64 | :def-exception 65 | :def-package 66 | :def-service 67 | :def-struct 68 | :direct-field-definition 69 | :double 70 | :effective-field-definition 71 | :element-type-error 72 | :enum 73 | :enum-type-error 74 | :exception 75 | :field-definition-identifier 76 | :field-definition-identifier-number 77 | :field-definition-initarg 78 | :field-definition-name 79 | :field-definition-optional 80 | :field-definition-reader 81 | :field-definition-type 82 | :field-size-error 83 | :field-type-error 84 | :float 85 | :method-definition 86 | :i08 87 | :i16 88 | :i32 89 | :i64 90 | :invalid-element-type 91 | :invalid-enum 92 | :invalid-field-size 93 | :invalid-field-type 94 | :invalid-protocol-version 95 | :invalid-struct-type 96 | :list 97 | :map 98 | :map-get 99 | :protocol 100 | :protocol-error 101 | :protocol-field-id-mode 102 | :protocol-input-transport 103 | :protocol-output-transport 104 | :protocol-version-error 105 | :reply 106 | :serve 107 | :serve simple-server handler 108 | :service 109 | :service-base-services 110 | :service-identifier 111 | :service-package 112 | :set 113 | :shared-service 114 | :stream-direction 115 | :stream-read-binary 116 | :stream-read-bool 117 | :stream-read-double 118 | :stream-read-field 119 | :stream-read-field-begin 120 | :stream-read-field-end 121 | :stream-read-float 122 | :stream-read-i08 123 | :stream-read-i16 124 | :stream-read-i32 125 | :stream-read-i64 126 | :stream-read-list 127 | :stream-read-list-begin 128 | :stream-read-list-end 129 | :stream-read-map 130 | :stream-read-map-begin 131 | :stream-read-map-end 132 | :stream-read-message 133 | :stream-read-message-begin 134 | :stream-read-message-end 135 | :stream-read-message-type 136 | :stream-read-set 137 | :stream-read-set-begin 138 | :stream-read-set-end 139 | :stream-read-string 140 | :stream-read-struct 141 | :stream-read-struct-begin 142 | :stream-read-struct-end 143 | :stream-read-type 144 | :stream-read-type-value 145 | :stream-write-binary 146 | :stream-write-bool 147 | :stream-write-double 148 | :stream-write-field 149 | :stream-write-float 150 | :stream-write-i08 151 | :stream-write-i16 152 | :stream-write-i32 153 | :stream-write-i64 154 | :stream-write-list 155 | :stream-write-map 156 | :stream-write-message 157 | :stream-write-message-type 158 | :stream-write-set 159 | :stream-write-string 160 | :stream-write-struct 161 | :stream-write-type 162 | :stream-write-type-value 163 | :string 164 | :struct 165 | :struct-name 166 | :struct-type-error 167 | :thrift 168 | :thrift-class 169 | :thrift-error 170 | :thrift-object 171 | :thrift-struct-class 172 | :thrift-exception-class 173 | :transport 174 | :transport-error 175 | :type-of 176 | :unknown-field 177 | :unknown-field-error 178 | :unknown-method 179 | :unknown-method-error 180 | :vector-input-stream 181 | :vector-output-stream 182 | :vector-stream-transport 183 | :vector-stream-vector 184 | :void 185 | )) 186 | 187 | 188 | (defpackage :org.apache.thrift.implementation 189 | (:use :common-lisp :org.apache.thrift) 190 | (:nicknames :thrift.implementation) 191 | 192 | (:documentation "The is the package for the thrift implementation. It exports nothing, uses the 193 | :common-lisp and :thrift package for access to the respective interfaces. Those names which conflict, eg. 194 | cl:list v/s thrift:list, are imported the :common-lisp package and referenced with an explicit prefix 195 | from the :thrift package. 196 | It also imports names as required per run-time for access to standard floating point constants and gray 197 | stream operators.") 198 | 199 | (:shadowing-import-from :common-lisp :byte :set :list :map :type-of :float) 200 | 201 | (:import-from :de.setf.utility 202 | :stream-reader 203 | :stream-writer 204 | ) 205 | #+ccl 206 | (:import-from :ccl 207 | :stream-write-byte :stream-read-byte 208 | :stream-direction 209 | :stream-position 210 | :stream-force-output :stream-finish-output) 211 | #+mcl 212 | (:import-from :ccl 213 | :stream-close 214 | :stream-read-sequence :stream-write-sequence 215 | :stream-tyi :stream-tyo :stream-untyi) 216 | #+clozure 217 | (:import-from :ccl 218 | :double-float-positive-infinity 219 | :double-float-negative-infinity 220 | #+ccl-1.4 :double-float-nan) 221 | #+sbcl 222 | (:import-from :sb-ext 223 | :double-float-positive-infinity 224 | :double-float-negative-infinity 225 | :single-float-positive-infinity 226 | :single-float-negative-infinity) 227 | #+sbcl 228 | (:import-from :sb-gray 229 | :stream-write-byte :stream-read-byte 230 | :stream-read-sequence :stream-write-sequence 231 | :stream-force-output :stream-finish-output) 232 | ) 233 | -------------------------------------------------------------------------------- /parameters.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- 2 | 3 | (in-package :org.apache.thrift.implementation) 4 | 5 | ;;; This file defines global variables for the `org.apache.thrift` library. 6 | ;;; 7 | ;;; copyright 2010 [james anderson](james.anderson@setf.de) 8 | ;;; 9 | ;;; Licensed to the Apache Software Foundation (ASF) under one 10 | ;;; or more contributor license agreements. See the NOTICE file 11 | ;;; distributed with this work for additional information 12 | ;;; regarding copyright ownership. The ASF licenses this file 13 | ;;; to you under the Apache License, Version 2.0 (the 14 | ;;; "License"); you may not use this file except in compliance 15 | ;;; with the License. You may obtain a copy of the License at 16 | ;;; 17 | ;;; http://www.apache.org/licenses/LICENSE-2.0 18 | ;;; 19 | ;;; Unless required by applicable law or agreed to in writing, 20 | ;;; software distributed under the License is distributed on an 21 | ;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 22 | ;;; KIND, either express or implied. See the License for the 23 | ;;; specific language governing permissions and limitations 24 | ;;; under the License. 25 | 26 | 27 | (defparameter *binary-transport-types* 28 | '((stop . 0) 29 | (void . 1) 30 | (bool . 2) 31 | (thrift:byte . 3) 32 | (i08 . 3) 33 | (double . 4) 34 | (thrift:float . 5) ; this is not standard 35 | (i16 . 6) 36 | (enum . 6) 37 | (i32 . 8) 38 | (u64 . 9) 39 | (i64 . 10) 40 | (string . 11) 41 | (utf7 . 11) 42 | (binary . 11) 43 | (struct . 12) 44 | (thrift:map . 13) 45 | (thrift:set . 14) 46 | (thrift:list . 15) 47 | (utf8 . 16) 48 | (utf16 . 17))) 49 | 50 | 51 | (defparameter *binary-message-types* 52 | '((call . 1) 53 | (reply . 2) 54 | (exception . 3) 55 | (oneway . 4) 56 | (unknown . -1))) 57 | 58 | (defparameter *types-classes* 59 | '((stop . 0) 60 | (void . null) 61 | (bool . symbol) 62 | (thrift:byte . fixnum) 63 | (i08 . fixnum) 64 | (double . float) 65 | (i16 . fixnum) 66 | (enum . fixnum) 67 | (i32 . integer) 68 | (u64 . integer) 69 | (i64 . integer) 70 | (string . string) 71 | (utf7 . string) 72 | (binary . vector) 73 | (struct . standard-object) 74 | (thrift:map . cl:list) 75 | (thrift:set . cl:list) 76 | (thrift:list . cl:list) 77 | (utf8 . vector) 78 | (utf16 . vector))) 79 | 80 | (defparameter *protocol-ex-unknown* 0) 81 | (defparameter *protocol-ex-invalid-data* 1) 82 | (defparameter *protocol-ex-negative-size* 2) 83 | (defparameter *protocol-ex-size-limit* 3) 84 | (defparameter *protocol-ex-bad-version* 4) 85 | 86 | (defparameter *application-ex-unknown* 0) 87 | (defparameter *application-ex-unknown-method* 1) 88 | (defparameter *application-ex-invalid-message-type* 2) 89 | (defparameter *application-ex-wrong-method-name* 3) 90 | (defparameter *application-ex-bad-sequence-id* 4) 91 | (defparameter *application-ex-missing-result* 5) 92 | 93 | (defparameter *application-ex-unknown-field* 6) 94 | (defparameter *application-ex-invalid-field-type* 7) 95 | 96 | (defparameter *transport-ex-unknown* 0) 97 | (defparameter *transport-ex-not-open* 1) 98 | (defparameter *transport-ex-already-open* 2) 99 | (defparameter *transport-ex-timed-out* 3) 100 | (defparameter *transport-ex-end-of-file* 4) 101 | 102 | (defparameter *whitespace* #(#\space #\tab #\linefeed #\return)) 103 | 104 | (defparameter *response-exception-type* 'response-exception) 105 | 106 | ;;; the thrfit class registry binds class names (_not identifiers_) to either the 107 | ;;; 108 | (defvar *thrift-classes* (make-hash-table :test 'eq) 109 | "Registers defined struct classes. This includes 110 | 111 | * classes with the class thrift-struct-class, as defined by def-struct 112 | * classes of the class thrift-exception-class, as defined by def-exception 113 | 114 | The keys are the symbols which as named by the class identifier in the respective IDL def-* forms. 115 | These respect the IDL file's package, whereby the .thrift -> .lisp translator qualifies any 116 | cross-referenced names explicitly, which makes the (symbol x class) relation global. 117 | (see str-sym and find-thrift-class.) 118 | 119 | The values are either the struct class itself or, in the case of exceptions, the proxy exception 120 | class. An exception class is keyed by the name of its respective condition and serves to 121 | guide code operation and/or generation. Instantiation delegates to the actual condition class. 122 | (see make-struct.)") 123 | 124 | 125 | ;;; 126 | ;;; floating point support 127 | 128 | 129 | #+mcl 130 | (unless (boundp 'double-float-positive-infinity) 131 | (eval-when (:compile-toplevel :load-toplevel :execute) 132 | (defconstant double-float-positive-infinity 133 | (unwind-protect 134 | (progn 135 | (ccl::set-fpu-mode :division-by-zero nil) 136 | (funcall '/ 0d0)) 137 | (ccl::set-fpu-mode :division-by-zero t))) 138 | 139 | (defconstant double-float-negative-infinity 140 | (unwind-protect 141 | (progn 142 | (ccl::set-fpu-mode :division-by-zero nil) 143 | (funcall '/ -0d0)) 144 | (ccl::set-fpu-mode :division-by-zero t))))) 145 | 146 | #+(or mcl (and clozure (not ccl-1.4))) 147 | (unless (boundp 'double-float-nan) 148 | (defconstant double-float-nan 149 | (unwind-protect 150 | (locally (declare (special double-float-positive-infinity double-float-negative-infinity)) 151 | (ccl::set-fpu-mode :invalid nil) 152 | (funcall '+ double-float-positive-infinity double-float-negative-infinity)) 153 | (ccl::set-fpu-mode :invalid t)))) 154 | 155 | #+(or mcl clozure) 156 | (unless (boundp 'single-float-positive-infinity) 157 | (eval-when (:compile-toplevel :load-toplevel :execute) 158 | (defconstant single-float-positive-infinity 159 | (unwind-protect 160 | (progn 161 | (ccl::set-fpu-mode :division-by-zero nil) 162 | (funcall '/ 0s0)) 163 | (ccl::set-fpu-mode :division-by-zero t))) 164 | 165 | (defconstant single-float-negative-infinity 166 | (unwind-protect 167 | (progn 168 | (ccl::set-fpu-mode :division-by-zero nil) 169 | (funcall '/ -0s0)) 170 | (ccl::set-fpu-mode :division-by-zero t))))) 171 | 172 | #+(or mcl clozure) 173 | (unless (boundp 'single-float-nan) 174 | (defconstant single-float-nan 175 | (unwind-protect 176 | (locally (declare (special single-float-positive-infinity single-float-negative-infinity)) 177 | (ccl::set-fpu-mode :invalid nil) 178 | (funcall '+ single-float-positive-infinity single-float-negative-infinity)) 179 | (ccl::set-fpu-mode :invalid t)))) 180 | 181 | #+sbcl ;; works on osx and linux 182 | (unless (boundp 'single-float-nan) 183 | (sb-vm::with-float-traps-masked (:invalid) 184 | (defconstant single-float-nan 185 | (eval '(+ single-float-positive-infinity single-float-negative-infinity))) 186 | (defconstant double-float-nan 187 | (eval '(+ double-float-positive-infinity double-float-negative-infinity))))) 188 | 189 | #+lispworks 190 | (progn 191 | (defconstant double-float-positive-infinity system::*plus-infinity-double*) 192 | (defconstant double-float-negative-infinity system::*minus-infinity-double*) 193 | (defconstant single-float-positive-infinity (coerce system::*plus-infinity-double* 'single-float)) 194 | (defconstant single-float-negative-infinity (coerce system::*minus-infinity-double* 'single-float)) 195 | 196 | (defconstant single-float-nan (+ single-float-positive-infinity single-float-negative-infinity)) 197 | (defconstant double-float-nan (+ double-float-positive-infinity double-float-negative-infinity)) 198 | ) 199 | -------------------------------------------------------------------------------- /symbols.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- 2 | 3 | (in-package :org.apache.thrift.implementation) 4 | 5 | ;;; This file defines symbols construction operators for the `org.apache.thrift` library. 6 | ;;; 7 | ;;; copyright 2010 [james anderson](james.anderson@setf.de) 8 | ;;; 9 | ;;; Licensed to the Apache Software Foundation (ASF) under one 10 | ;;; or more contributor license agreements. See the NOTICE file 11 | ;;; distributed with this work for additional information 12 | ;;; regarding copyright ownership. The ASF licenses this file 13 | ;;; to you under the Apache License, Version 2.0 (the 14 | ;;; "License"); you may not use this file except in compliance 15 | ;;; with the License. You may obtain a copy of the License at 16 | ;;; 17 | ;;; http://www.apache.org/licenses/LICENSE-2.0 18 | ;;; 19 | ;;; Unless required by applicable law or agreed to in writing, 20 | ;;; software distributed under the License is distributed on an 21 | ;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 22 | ;;; KIND, either express or implied. See the License for the 23 | ;;; specific language governing permissions and limitations 24 | ;;; under the License. 25 | 26 | ;;; The IDL translator emits definition forms which retain the original identifer 27 | ;;; strings. These operators perform symbol name canonicalization, and symbol construction. 28 | ;;; They are used at compile-time by the IDL macros to construct symbols for classes, fields, 29 | ;;; and methods. Cross-references between namespaces are implemented as prefixed identifiers. 30 | ;;; The resective operators cache the original identifiers in metaobjects for use at run-time 31 | ;;; to decode/encode messages. 32 | 33 | 34 | (eval-when (:compile-toplevel :load-toplevel :execute) ; for batch compilation 35 | 36 | (defun implementation-package () 37 | (let ((package (concatenate 'string (package-name *package*) (string :-implementation)))) 38 | (or (find-package package) 39 | (make-package package :use nil)))) 40 | 41 | (defun response-package () 42 | (let ((package (concatenate 'string (package-name *package*) (string :-response)))) 43 | (or (find-package package) 44 | (make-package package :use nil)))) 45 | 46 | (defun canonicalize-name (string) 47 | "Replace a camel-case pattern with lower case and '-' separation." 48 | (let ((result (make-array (length string) :element-type 'character :fill-pointer 0 :adjustable t)) 49 | (case :upper)) 50 | (loop for c across string 51 | do (ecase case 52 | (:lower (cond ((upper-case-p c) 53 | (setf case :upper) 54 | (vector-push-extend #\- result) 55 | (vector-push-extend (char-downcase c) result)) 56 | ((eql c #\_) 57 | (vector-push-extend #\- result)) 58 | (t 59 | (vector-push-extend c result)))) 60 | (:upper (cond ((upper-case-p c) 61 | (vector-push-extend (char-downcase c) result)) 62 | ((eql c #\_) 63 | (vector-push-extend #\- result)) 64 | (t 65 | (setf case :lower) 66 | (vector-push-extend c result)))))) 67 | (subseq result 0))) 68 | 69 | (defun cons-symbol (package &rest args) 70 | "Construct a symbol given string designators. If package is null, the symbol is 71 | a new, uninterned symbol." 72 | (declare (dynamic-extent args)) 73 | 74 | (flet ((element-length (element) 75 | (if element (length (string element)) 0))) 76 | (declare (dynamic-extent #'element-length)) 77 | (setf args (mapcar #'(lambda (elt) 78 | (etypecase elt 79 | (null nil) ; ignored 80 | (symbol (symbol-name elt)) ; use literal name 81 | (string (canonicalize-name elt)))) ; canonicalize strings 82 | args)) 83 | (let* ((length (reduce #'+ args :key #'element-length :initial-value 0)) 84 | (name (make-string length)) 85 | (position 0)) 86 | (declare (dynamic-extent name)) 87 | (dolist (el args) 88 | (when el 89 | (replace name el :start1 position) 90 | (incf position (length el)))) 91 | (ecase (readtable-case *readtable*) 92 | (:upcase (map-into name #'char-upcase name)) 93 | (:downcase (map-into name #'char-downcase name)) 94 | (:preserve ) 95 | (:invert (flet ((char-invert (c) 96 | (cond ((upper-case-p c) (char-downcase c)) 97 | ((lower-case-p c) (char-upcase c)) 98 | (t c)))) 99 | (declare (dynamic-extent #'char-invert)) 100 | (map-into name #'char-invert name)))) 101 | (if package 102 | (or (find-symbol name package) 103 | (intern (copy-seq name) package)) 104 | (make-symbol (copy-seq name)))))) 105 | 106 | (defun str-sym (&rest strs) 107 | "Given a sequence of symbol name consititents, construct a symbol observing current 108 | reader case settings. By default intern the symbol in the current *package*. 109 | Iff the first constituent includes a ':' use that as the symbol prefix." 110 | (declare (dynamic-extent strs)) 111 | (when strs ; if none are given, return nil 112 | (if (and (symbolp (first strs)) (null (rest strs))) 113 | (first strs) 114 | (let* ((first (pop strs)) 115 | (colon (position #\: first))) 116 | (if colon 117 | ;; extract the package prefix from the first constituent 118 | ;; pass it as a constructed symbol to observe current read case rules 119 | (apply #'cons-symbol (cons-symbol :keyword (subseq first 0 colon)) 120 | (subseq first (1+ colon)) strs) 121 | (apply #'cons-symbol *package* first strs)))))) 122 | 123 | ;;; (assert (equal (list (str-sym "keyword:a") (str-sym "keyword:" "a") (str-sym "a" "sdf")) '(:a :a thrift-generated::asdf))) 124 | 125 | (defun implementation-str-sym (&rest identifiers) 126 | (let* ((*package* (implementation-package)) 127 | (sym (apply #'str-sym identifiers))) 128 | (export sym *package*) 129 | sym)) 130 | 131 | (defun response-str-sym (&rest identifiers) 132 | (let* ((*package* (response-package)) 133 | (sym (apply #'str-sym identifiers))) 134 | (export sym *package*) 135 | sym)) 136 | 137 | (defun strs-syms (strs &key (key #'identity)) 138 | (mapcar #'str-sym (mapcar key strs))) 139 | 140 | (defmacro with-gensyms (syms &body b) 141 | `(let ,(mapcar #'(lambda (s) `(,s (gensym ,(string s)))) syms) 142 | ,@b)) 143 | 144 | (defmacro with-optional-gensyms (symbol-list env form) 145 | "for any symbol in the list, iff it is bound to a for or to a symbol-macro, bind a gensym for at and 146 | effect the substitution in the body" 147 | `(let ((rebindings ())) 148 | ,@(loop for sym in symbol-list 149 | collect `(unless (and (symbolp ,sym) (eq (macroexpand-1 ,sym ,env) ,sym)) 150 | (push (list (if (symbolp ,sym) (gensym (string ,sym)) (gensym)) ,sym) rebindings))) 151 | (let ((form ,form)) 152 | (if rebindings 153 | (let ((rewritten-form (loop for (gensym original) in rebindings 154 | do (setf form (subst gensym original form)) 155 | finally (return form)))) 156 | (case (first rewritten-form) 157 | (progn (list* 'let* rebindings (cdr rewritten-form))) 158 | ;; presumes all the let cases are ok as let* as well 159 | ((let let*) (list* 'let* (append rebindings (second rewritten-form)) (cddr rewritten-form))) 160 | (t (list 'let rebindings rewritten-form)))) 161 | form)))) 162 | 163 | (defun str (&rest args) 164 | (declare (dynamic-extent args)) 165 | (apply #'concatenate 'string args)) 166 | ) 167 | -------------------------------------------------------------------------------- /types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- 2 | 3 | (in-package :org.apache.thrift.implementation) 4 | 5 | ;;; This file defines types for the `org.apache.thrift` library. 6 | ;;; 7 | ;;; copyright 2010 [james anderson](james.anderson@setf.de) 8 | ;;; 9 | ;;; Licensed to the Apache Software Foundation (ASF) under one 10 | ;;; or more contributor license agreements. See the NOTICE file 11 | ;;; distributed with this work for additional information 12 | ;;; regarding copyright ownership. The ASF licenses this file 13 | ;;; to you under the Apache License, Version 2.0 (the 14 | ;;; "License"); you may not use this file except in compliance 15 | ;;; with the License. You may obtain a copy of the License at 16 | ;;; 17 | ;;; http://www.apache.org/licenses/LICENSE-2.0 18 | ;;; 19 | ;;; Unless required by applicable law or agreed to in writing, 20 | ;;; software distributed under the License is distributed on an 21 | ;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 22 | ;;; KIND, either express or implied. See the License for the 23 | ;;; specific language governing permissions and limitations 24 | ;;; under the License. 25 | 26 | ;;; Define type analogues between thrift and lisp types. 27 | ;;; The container types are defined to accept element type constraints. 28 | ;;; Distinguish those types which are lisp/thrift homologues. 29 | ;;; Define types for the type specifiers themselves for use at compile-time. 30 | 31 | 32 | (deftype bool () 'boolean) 33 | (deftype thrift:byte () '(signed-byte 8)) 34 | (deftype i08 () '(signed-byte 8)) 35 | (deftype i16 () '(signed-byte 16)) 36 | (deftype i32 () '(signed-byte 32)) 37 | (deftype i64 () '(signed-byte 64)) 38 | (deftype thrift:float () 39 | "distinguish float from double for explicit struct codecs" 40 | 'single-float) 41 | ;; string is standard 42 | (deftype double () 'double-float) 43 | ;;; this is not what the spec says (it claims i08), but that makes no sense 44 | (deftype binary () '(array (unsigned-byte 8) (*))) 45 | 46 | 47 | (deftype thrift:list (&optional element-type) 48 | "The thrift:list container type is implemented as a cl:list. The element type 49 | serves for declaration, but not discrimination. An empty list should conform." 50 | (declare (ignore element-type)) 51 | 'list) 52 | 53 | (deftype thrift:set (&optional element-type) 54 | "The thrift:set container type is implemented as a cl:list. The element type 55 | serves for declaration, but not discrimination. an empty set should conform." 56 | (declare (ignore element-type)) 57 | 'list) 58 | 59 | (deftype thrift:map (&optional key-type value-type) 60 | "The thrift:map container type is implemented as a association list. The key and value types 61 | serve for declaration, but not discrimination. An empty map should conform." 62 | (declare (ignore key-type value-type)) 63 | 'list) 64 | 65 | 66 | (deftype base-type () 67 | "Indicates the union of thrift base (atomic) types." 68 | '(member bool thrift:byte i08 i16 i32 i64 double thrift:float string binary)) 69 | 70 | (defun base-type-p (type) 71 | (typep type 'base-type)) 72 | 73 | (deftype container-type () '(cons (member thrift:set thrift:list thrift:map))) 74 | 75 | (defun container-type-p (type) 76 | (typep type 'container-type)) 77 | 78 | (deftype struct-type () '(cons (eql struct))) 79 | 80 | (defun struct-type-p (type) 81 | (typep type 'struct-type)) 82 | 83 | (deftype enum-type () '(cons (eql enum))) 84 | 85 | (defun enum-type-p (type) 86 | (typep type 'enum-type)) 87 | 88 | (deftype primitive-type () `(or base-type container-type enum-type)) 89 | 90 | (defun primitive-type-p (type) 91 | (typep type 'primitive-type)) 92 | 93 | (deftype thrift-type () '(or primitive-type struct-type)) 94 | 95 | (defun thrift-type-p (type) 96 | (typep type 'thrift-type)) 97 | 98 | (deftype enum (set-name) 99 | (etypecase set-name 100 | (symbol ) 101 | (string (setf set-name (str-sym set-name)))) 102 | `(member ,@(get set-name 'thrift::enum-members))) 103 | 104 | (deftype struct (&optional identifier) 105 | "The exception class hierarchy is disjount for that of strucs as data." 106 | (etypecase identifier 107 | (string (str-sym identifier)) 108 | (null '(or thrift-object thrift-error)) 109 | (symbol identifier))) 110 | 111 | 112 | (defparameter *container-limit* nil 113 | "When non-null, the integer value limits the permissible container size.") 114 | 115 | (deftype field-size () `(satisfies field-size-p)) 116 | 117 | (defun field-size-p (x) 118 | "True for integers if within any asserted size limit." 119 | (and (integerp x) 120 | (>= x 0) 121 | (or (null *container-limit*) 122 | (< x *container-limit*)))) 123 | 124 | ;;; 125 | ;;; type-of equivalent which is specific to thrift types 126 | 127 | (defgeneric thrift:type-of (object) 128 | (:documentation "Implements an equivalent to cl:type-of, but return the most specific thrift 129 | type instead of the cl type. This is used to determine the encoding for dynamically generated 130 | messages.") 131 | 132 | (:method ((value null)) 133 | 'bool) 134 | (:method ((value (eql t))) 135 | 'bool) 136 | (:method ((value integer)) 137 | (etypecase value 138 | (i08 'thrift:byte) 139 | (i16 'i16) 140 | (i32 'i32) 141 | (i64 'i64))) 142 | (:method ((value float)) 143 | "return double for all floats as the single form is non-standard" 144 | 'double) 145 | (:method ((value string)) 146 | 'string) 147 | (:method ((value vector)) 148 | 'binary) 149 | (:method ((value list)) 150 | (if (consp (first value)) 151 | 'thrift:map 152 | 'thrift:list))) 153 | 154 | 155 | (defgeneric type-name-class (type-name) 156 | (:documentation "Return the lisp type equivalent for the given thrift type. 157 | The value is universal. it is used to construct generic function lambda lists. 158 | Signal an error If no equivalent exists.") 159 | 160 | (:method ((type-name symbol)) 161 | (declare (special *types-classes*)) 162 | (or (cdr (assoc type-name *types-classes* :test #'eql)) 163 | (error "Invalid type name: ~s." type-name))) 164 | 165 | (:method ((type-name cons)) 166 | (ecase (first type-name) 167 | (enum 'integer) 168 | (struct (str-sym (second type-name))) 169 | ((thrift:list thrift:set) 'list) 170 | (thrift:map 'list)))) 171 | 172 | 173 | (defgeneric type-category (type) 174 | (:documentation "Return the type name to match decoded values.") 175 | 176 | (:method ((type symbol)) type) 177 | 178 | (:method ((type cons)) (first type))) 179 | 180 | ;;; 181 | ;;; primitive constructors 182 | 183 | (defun thrift:map (&rest pairs) 184 | "Represent map objects as association lists. 185 | NB. in order to effect equality when the keys themselves are maps, this and the transport operations 186 | would need to maintain a global registry." 187 | (if (consp (first pairs)) 188 | pairs 189 | (loop for (key value) on pairs by #'cddr 190 | ;; nb. does not test for completeness 191 | collect (cons key value)))) 192 | 193 | (defun thrift:list (&rest values) 194 | values) 195 | 196 | (defun thrift:set (&rest values) 197 | values) 198 | 199 | 200 | ;;; 201 | ;;; primitive accessors 202 | ;;; --- in prepration to support association lists as maps 203 | 204 | (defun map-get (map key &optional default) 205 | "Retrieve the map entry for a given key." 206 | 207 | (let ((pair (assoc key map :test #'equalp))) 208 | (if pair 209 | (rest pair) 210 | default))) 211 | 212 | (defun map-set (map key value) 213 | (let ((pair (assoc key map :test #'equalp))) 214 | (if pair 215 | (setf (rest pair) value) 216 | (setf map (acons key value map))) 217 | map)) 218 | 219 | (define-setf-expander map-get (map key &environment env) 220 | (multiple-value-bind (temps vals stores 221 | store-form access-form) 222 | (get-setf-expansion map env) 223 | (let ((store (gensym)) 224 | (stemp (first stores)) 225 | (ktemp (gensym))) 226 | (values (cons ktemp temps) (cons key vals) (list store) 227 | `(let ((,stemp (map-set ,access-form ,ktemp ,store))) 228 | ,store-form 229 | ,store) 230 | `(map-get ,access-form ,ktemp))))) 231 | 232 | 233 | (defun map-map (function map) 234 | (loop for (key . value) in map 235 | do (funcall function key value)) 236 | nil) 237 | 238 | 239 | (defun map-size (map) 240 | (length map)) 241 | 242 | -------------------------------------------------------------------------------- /test/gen-cl/DebugProtoTest.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-enum "SomeEnum" 9 | (("ONE" . 1) 10 | ("TWO" . 2))) 11 | 12 | (thrift:def-struct "doubles" 13 | (("nan" nil :type double :id 1) 14 | ("inf" nil :type double :id 2) 15 | ("neginf" nil :type double :id 3) 16 | ("repeating" nil :type double :id 4) 17 | ("big" nil :type double :id 5) 18 | ("small" nil :type double :id 6) 19 | ("zero" nil :type double :id 7) 20 | ("negzero" nil :type double :id 8))) 21 | 22 | (thrift:def-struct "oneofeach" 23 | (("im_true" nil :type bool :id 1) 24 | ("im_false" nil :type bool :id 2) 25 | ("a_bite" 200 :type byte :id 3) 26 | ("integer16" 33000 :type i16 :id 4) 27 | ("integer32" nil :type i32 :id 5) 28 | ("integer64" 10000000000 :type i64 :id 6) 29 | ("double_precision" nil :type double :id 7) 30 | ("some_characters" nil :type string :id 8) 31 | ("zomg_unicode" nil :type string :id 9) 32 | ("what_who" nil :type bool :id 10) 33 | ("base64" nil :type string :id 11) 34 | ("byte_list" (thrift:list 35 | 1 36 | 2 37 | 3 38 | ) :type (list byte) :id 12) 39 | ("i16_list" (thrift:list 40 | 1 41 | 2 42 | 3 43 | ) :type (list i16) :id 13) 44 | ("i64_list" (thrift:list 45 | 1 46 | 2 47 | 3 48 | ) :type (list i64) :id 14))) 49 | 50 | (thrift:def-struct "bonk" 51 | (("type" nil :type i32 :id 1) 52 | ("message" nil :type string :id 2))) 53 | 54 | (thrift:def-struct "nesting" 55 | (("my_bonk" nil :type (struct "bonk") :id 1) 56 | ("my_ooe" nil :type (struct "oneofeach") :id 2))) 57 | 58 | (thrift:def-struct "holymoley" 59 | (("big" nil :type (list (struct "oneofeach")) :id 1) 60 | ("contain" nil :type (set (list string)) :id 2) 61 | ("bonks" nil :type (map string (list (struct "bonk"))) :id 3))) 62 | 63 | (thrift:def-struct "backwards" 64 | (("first_tag2" nil :type i32 :id 2) 65 | ("second_tag1" nil :type i32 :id 1))) 66 | 67 | (thrift:def-struct "empty" 68 | ()) 69 | 70 | (thrift:def-struct "wrapper" 71 | (("foo" nil :type (struct "empty") :id 1))) 72 | 73 | (thrift:def-struct "randomstuff" 74 | (("a" nil :type i32 :id 1) 75 | ("b" nil :type i32 :id 2) 76 | ("c" nil :type i32 :id 3) 77 | ("d" nil :type i32 :id 4) 78 | ("myintlist" nil :type (list i32) :id 5) 79 | ("maps" nil :type (map i32 (struct "wrapper")) :id 6) 80 | ("bigint" nil :type i64 :id 7) 81 | ("triple" nil :type double :id 8))) 82 | 83 | (thrift:def-struct "base64" 84 | (("a" nil :type i32 :id 1) 85 | ("b1" nil :type string :id 2) 86 | ("b2" nil :type string :id 3) 87 | ("b3" nil :type string :id 4) 88 | ("b4" nil :type string :id 5) 89 | ("b5" nil :type string :id 6) 90 | ("b6" nil :type string :id 7))) 91 | 92 | (thrift:def-struct "compactprototeststruct" 93 | (("a_byte" nil :type byte :id 1) 94 | ("a_i16" nil :type i16 :id 2) 95 | ("a_i32" nil :type i32 :id 3) 96 | ("a_i64" nil :type i64 :id 4) 97 | ("a_double" nil :type double :id 5) 98 | ("a_string" nil :type string :id 6) 99 | ("a_binary" nil :type string :id 7) 100 | ("true_field" nil :type bool :id 8) 101 | ("false_field" nil :type bool :id 9) 102 | ("empty_struct_field" nil :type (struct "empty") :id 10) 103 | ("byte_list" nil :type (list byte) :id 11) 104 | ("i16_list" nil :type (list i16) :id 12) 105 | ("i32_list" nil :type (list i32) :id 13) 106 | ("i64_list" nil :type (list i64) :id 14) 107 | ("double_list" nil :type (list double) :id 15) 108 | ("string_list" nil :type (list string) :id 16) 109 | ("binary_list" nil :type (list string) :id 17) 110 | ("boolean_list" nil :type (list bool) :id 18) 111 | ("struct_list" nil :type (list (struct "empty")) :id 19) 112 | ("byte_set" nil :type (set byte) :id 20) 113 | ("i16_set" nil :type (set i16) :id 21) 114 | ("i32_set" nil :type (set i32) :id 22) 115 | ("i64_set" nil :type (set i64) :id 23) 116 | ("double_set" nil :type (set double) :id 24) 117 | ("string_set" nil :type (set string) :id 25) 118 | ("binary_set" nil :type (set string) :id 26) 119 | ("boolean_set" nil :type (set bool) :id 27) 120 | ("struct_set" nil :type (set (struct "empty")) :id 28) 121 | ("byte_byte_map" nil :type (map byte byte) :id 29) 122 | ("i16_byte_map" nil :type (map i16 byte) :id 30) 123 | ("i32_byte_map" nil :type (map i32 byte) :id 31) 124 | ("i64_byte_map" nil :type (map i64 byte) :id 32) 125 | ("double_byte_map" nil :type (map double byte) :id 33) 126 | ("string_byte_map" nil :type (map string byte) :id 34) 127 | ("binary_byte_map" nil :type (map string byte) :id 35) 128 | ("boolean_byte_map" nil :type (map bool byte) :id 36) 129 | ("byte_i16_map" nil :type (map byte i16) :id 37) 130 | ("byte_i32_map" nil :type (map byte i32) :id 38) 131 | ("byte_i64_map" nil :type (map byte i64) :id 39) 132 | ("byte_double_map" nil :type (map byte double) :id 40) 133 | ("byte_string_map" nil :type (map byte string) :id 41) 134 | ("byte_binary_map" nil :type (map byte string) :id 42) 135 | ("byte_boolean_map" nil :type (map byte bool) :id 43) 136 | ("list_byte_map" nil :type (map (list byte) byte) :id 44) 137 | ("set_byte_map" nil :type (map (set byte) byte) :id 45) 138 | ("map_byte_map" nil :type (map (map byte byte) byte) :id 46) 139 | ("byte_map_map" nil :type (map byte (map byte byte)) :id 47) 140 | ("byte_set_map" nil :type (map byte (set byte)) :id 48) 141 | ("byte_list_map" nil :type (map byte (list byte)) :id 49))) 142 | 143 | (thrift:def-exception "exceptionwithamap" 144 | (("blah" nil :type string :id 1) 145 | ("map_field" nil :type (map string string) :id 2))) 146 | 147 | (thrift:def-struct "blowup" 148 | (("b1" nil :type (map (list i32) (set (map i32 string))) :id 1) 149 | ("b2" nil :type (map (list i32) (set (map i32 string))) :id 2) 150 | ("b3" nil :type (map (list i32) (set (map i32 string))) :id 3) 151 | ("b4" nil :type (map (list i32) (set (map i32 string))) :id 4))) 152 | 153 | (thrift:def-struct "reverseorderstruct" 154 | (("first" nil :type string :id 4) 155 | ("second" nil :type i16 :id 3) 156 | ("third" nil :type i32 :id 2) 157 | ("fourth" nil :type i64 :id 1))) 158 | 159 | (thrift:def-struct "structwithsomeenum" 160 | (("blah" nil :type (enum "SomeEnum") :id 1))) 161 | 162 | (thrift:def-struct "testunion" 163 | (("string_field" nil :type string :id 1) 164 | ("i32_field" nil :type i32 :id 2) 165 | ("struct_field" nil :type (struct "oneofeach") :id 3) 166 | ("struct_list" nil :type (list (struct "randomstuff")) :id 4) 167 | ("other_i32_field" nil :type i32 :id 5) 168 | ("enum_field" nil :type (enum "SomeEnum") :id 6) 169 | ("i32_set" nil :type (set i32) :id 7) 170 | ("i32_map" nil :type (map i32 i32) :id 8))) 171 | 172 | (thrift:def-struct "testunionminusstringfield" 173 | (("i32_field" nil :type i32 :id 2) 174 | ("struct_field" nil :type (struct "oneofeach") :id 3) 175 | ("struct_list" nil :type (list (struct "randomstuff")) :id 4) 176 | ("other_i32_field" nil :type i32 :id 5) 177 | ("enum_field" nil :type (enum "SomeEnum") :id 6) 178 | ("i32_set" nil :type (set i32) :id 7) 179 | ("i32_map" nil :type (map i32 i32) :id 8))) 180 | 181 | (thrift:def-struct "comparableunion" 182 | (("string_field" nil :type string :id 1) 183 | ("binary_field" nil :type string :id 2))) 184 | 185 | (thrift:def-struct "structwithaunion" 186 | (("test_union" nil :type (struct "testunion") :id 1))) 187 | 188 | (thrift:def-struct "primitivethenstruct" 189 | (("blah" nil :type i32 :id 1) 190 | ("blah2" nil :type i32 :id 2) 191 | ("bw" nil :type (struct "backwards") :id 3))) 192 | 193 | (thrift:def-struct "structwithasomemap" 194 | (("somemap_field" nil :type (map i32 i32) :id 1))) 195 | 196 | (thrift:def-struct "bigfieldidstruct" 197 | (("field1" nil :type string :id 1) 198 | ("field2" nil :type string :id 45))) 199 | 200 | (thrift:def-struct "breaksrubycompactprotocol" 201 | (("field1" nil :type string :id 1) 202 | ("field2" nil :type (struct "bigfieldidstruct") :id 2) 203 | ("field3" nil :type i32 :id 3))) 204 | 205 | (thrift:def-service "ServiceForExceptionWithAMap" nil 206 | (:method "methodThatThrowsAnException" (() void) 207 | :exceptions (("xwamap" nil :type (struct "exceptionwithamap") :id 1)))) 208 | (thrift:def-service "Srv" nil 209 | (:method "Janky" ((("arg" i32 1)) i32)) 210 | (:method "voidMethod" (() void)) 211 | (:method "primitiveMethod" (() i32)) 212 | (:method "structMethod" (() (struct "compactprototeststruct"))) 213 | (:method "methodWithDefaultArgs" ((("something" i32 1)) void)) 214 | (:method "onewayMethod" (() void) 215 | :oneway t)) 216 | (thrift:def-service "Inherited" "Srv" 217 | (:method "identity" ((("arg" i32 1)) i32))) 218 | (thrift:def-service "EmptyService" nil) 219 | (thrift:def-service "ReverseOrderService" nil 220 | (:method "myMethod" ((("first" string 4) ("second" i16 3) ("third" i32 2) ("fourth" i64 1)) void))) 221 | -------------------------------------------------------------------------------- /test/gen-cl/DebugProtoTest-types.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Package: thrift-generated -*- 2 | ;;; 3 | ;;; Autogenerated by Thrift 4 | ;;; DO NOT EDIT UNLESS YOU ARE SURE THAT YOU KNOW WHAT YOU ARE DOING 5 | 6 | (def-package :thrift-generated) 7 | 8 | (thrift:def-enum "SomeEnum" 9 | (("ONE" . 1) 10 | ("TWO" . 2))) 11 | 12 | (thrift:def-struct "doubles" 13 | (("nan" nil :type double :id 1) 14 | ("inf" nil :type double :id 2) 15 | ("neginf" nil :type double :id 3) 16 | ("repeating" nil :type double :id 4) 17 | ("big" nil :type double :id 5) 18 | ("small" nil :type double :id 6) 19 | ("zero" nil :type double :id 7) 20 | ("negzero" nil :type double :id 8))) 21 | 22 | (thrift:def-struct "oneofeach" 23 | (("im_true" nil :type bool :id 1) 24 | ("im_false" nil :type bool :id 2) 25 | ("a_bite" 200 :type byte :id 3) 26 | ("integer16" 33000 :type i16 :id 4) 27 | ("integer32" nil :type i32 :id 5) 28 | ("integer64" 10000000000 :type i64 :id 6) 29 | ("double_precision" nil :type double :id 7) 30 | ("some_characters" nil :type string :id 8) 31 | ("zomg_unicode" nil :type string :id 9) 32 | ("what_who" nil :type bool :id 10) 33 | ("base64" nil :type string :id 11) 34 | ("byte_list" (thrift:list 35 | 1 36 | 2 37 | 3 38 | ) :type (list byte) :id 12) 39 | ("i16_list" (thrift:list 40 | 1 41 | 2 42 | 3 43 | ) :type (list i16) :id 13) 44 | ("i64_list" (thrift:list 45 | 1 46 | 2 47 | 3 48 | ) :type (list i64) :id 14))) 49 | 50 | (thrift:def-struct "bonk" 51 | (("type" nil :type i32 :id 1) 52 | ("message" nil :type string :id 2))) 53 | 54 | (thrift:def-struct "nesting" 55 | (("my_bonk" nil :type (struct "bonk") :id 1) 56 | ("my_ooe" nil :type (struct "oneofeach") :id 2))) 57 | 58 | (thrift:def-struct "holymoley" 59 | (("big" nil :type (list (struct "oneofeach")) :id 1) 60 | ("contain" nil :type (set (list string)) :id 2) 61 | ("bonks" nil :type (map string (list (struct "bonk"))) :id 3))) 62 | 63 | (thrift:def-struct "backwards" 64 | (("first_tag2" nil :type i32 :id 2) 65 | ("second_tag1" nil :type i32 :id 1))) 66 | 67 | (thrift:def-struct "empty" 68 | ()) 69 | 70 | (thrift:def-struct "wrapper" 71 | (("foo" nil :type (struct "empty") :id 1))) 72 | 73 | (thrift:def-struct "randomstuff" 74 | (("a" nil :type i32 :id 1) 75 | ("b" nil :type i32 :id 2) 76 | ("c" nil :type i32 :id 3) 77 | ("d" nil :type i32 :id 4) 78 | ("myintlist" nil :type (list i32) :id 5) 79 | ("maps" nil :type (map i32 (struct "wrapper")) :id 6) 80 | ("bigint" nil :type i64 :id 7) 81 | ("triple" nil :type double :id 8))) 82 | 83 | (thrift:def-struct "base64" 84 | (("a" nil :type i32 :id 1) 85 | ("b1" nil :type string :id 2) 86 | ("b2" nil :type string :id 3) 87 | ("b3" nil :type string :id 4) 88 | ("b4" nil :type string :id 5) 89 | ("b5" nil :type string :id 6) 90 | ("b6" nil :type string :id 7))) 91 | 92 | (thrift:def-struct "compactprototeststruct" 93 | (("a_byte" nil :type byte :id 1) 94 | ("a_i16" nil :type i16 :id 2) 95 | ("a_i32" nil :type i32 :id 3) 96 | ("a_i64" nil :type i64 :id 4) 97 | ("a_double" nil :type double :id 5) 98 | ("a_string" nil :type string :id 6) 99 | ("a_binary" nil :type string :id 7) 100 | ("true_field" nil :type bool :id 8) 101 | ("false_field" nil :type bool :id 9) 102 | ("empty_struct_field" nil :type (struct "empty") :id 10) 103 | ("byte_list" nil :type (list byte) :id 11) 104 | ("i16_list" nil :type (list i16) :id 12) 105 | ("i32_list" nil :type (list i32) :id 13) 106 | ("i64_list" nil :type (list i64) :id 14) 107 | ("double_list" nil :type (list double) :id 15) 108 | ("string_list" nil :type (list string) :id 16) 109 | ("binary_list" nil :type (list string) :id 17) 110 | ("boolean_list" nil :type (list bool) :id 18) 111 | ("struct_list" nil :type (list (struct "empty")) :id 19) 112 | ("byte_set" nil :type (set byte) :id 20) 113 | ("i16_set" nil :type (set i16) :id 21) 114 | ("i32_set" nil :type (set i32) :id 22) 115 | ("i64_set" nil :type (set i64) :id 23) 116 | ("double_set" nil :type (set double) :id 24) 117 | ("string_set" nil :type (set string) :id 25) 118 | ("binary_set" nil :type (set string) :id 26) 119 | ("boolean_set" nil :type (set bool) :id 27) 120 | ("struct_set" nil :type (set (struct "empty")) :id 28) 121 | ("byte_byte_map" nil :type (map byte byte) :id 29) 122 | ("i16_byte_map" nil :type (map i16 byte) :id 30) 123 | ("i32_byte_map" nil :type (map i32 byte) :id 31) 124 | ("i64_byte_map" nil :type (map i64 byte) :id 32) 125 | ("double_byte_map" nil :type (map double byte) :id 33) 126 | ("string_byte_map" nil :type (map string byte) :id 34) 127 | ("binary_byte_map" nil :type (map string byte) :id 35) 128 | ("boolean_byte_map" nil :type (map bool byte) :id 36) 129 | ("byte_i16_map" nil :type (map byte i16) :id 37) 130 | ("byte_i32_map" nil :type (map byte i32) :id 38) 131 | ("byte_i64_map" nil :type (map byte i64) :id 39) 132 | ("byte_double_map" nil :type (map byte double) :id 40) 133 | ("byte_string_map" nil :type (map byte string) :id 41) 134 | ("byte_binary_map" nil :type (map byte string) :id 42) 135 | ("byte_boolean_map" nil :type (map byte bool) :id 43) 136 | ("list_byte_map" nil :type (map (list byte) byte) :id 44) 137 | ("set_byte_map" nil :type (map (set byte) byte) :id 45) 138 | ("map_byte_map" nil :type (map (map byte byte) byte) :id 46) 139 | ("byte_map_map" nil :type (map byte (map byte byte)) :id 47) 140 | ("byte_set_map" nil :type (map byte (set byte)) :id 48) 141 | ("byte_list_map" nil :type (map byte (list byte)) :id 49))) 142 | 143 | (thrift:def-exception "exceptionwithamap" 144 | (("blah" nil :type string :id 1) 145 | ("map_field" nil :type (map string string) :id 2))) 146 | 147 | (thrift:def-struct "blowup" 148 | (("b1" nil :type (map (list i32) (set (map i32 string))) :id 1) 149 | ("b2" nil :type (map (list i32) (set (map i32 string))) :id 2) 150 | ("b3" nil :type (map (list i32) (set (map i32 string))) :id 3) 151 | ("b4" nil :type (map (list i32) (set (map i32 string))) :id 4))) 152 | 153 | (thrift:def-struct "reverseorderstruct" 154 | (("first" nil :type string :id 4) 155 | ("second" nil :type i16 :id 3) 156 | ("third" nil :type i32 :id 2) 157 | ("fourth" nil :type i64 :id 1))) 158 | 159 | (thrift:def-struct "structwithsomeenum" 160 | (("blah" nil :type (enum "SomeEnum") :id 1))) 161 | 162 | (thrift:def-struct "testunion" 163 | (("string_field" nil :type string :id 1) 164 | ("i32_field" nil :type i32 :id 2) 165 | ("struct_field" nil :type (struct "oneofeach") :id 3) 166 | ("struct_list" nil :type (list (struct "randomstuff")) :id 4) 167 | ("other_i32_field" nil :type i32 :id 5) 168 | ("enum_field" nil :type (enum "SomeEnum") :id 6) 169 | ("i32_set" nil :type (set i32) :id 7) 170 | ("i32_map" nil :type (map i32 i32) :id 8))) 171 | 172 | (thrift:def-struct "testunionminusstringfield" 173 | (("i32_field" nil :type i32 :id 2) 174 | ("struct_field" nil :type (struct "oneofeach") :id 3) 175 | ("struct_list" nil :type (list (struct "randomstuff")) :id 4) 176 | ("other_i32_field" nil :type i32 :id 5) 177 | ("enum_field" nil :type (enum "SomeEnum") :id 6) 178 | ("i32_set" nil :type (set i32) :id 7) 179 | ("i32_map" nil :type (map i32 i32) :id 8))) 180 | 181 | (thrift:def-struct "comparableunion" 182 | (("string_field" nil :type string :id 1) 183 | ("binary_field" nil :type string :id 2))) 184 | 185 | (thrift:def-struct "structwithaunion" 186 | (("test_union" nil :type (struct "testunion") :id 1))) 187 | 188 | (thrift:def-struct "primitivethenstruct" 189 | (("blah" nil :type i32 :id 1) 190 | ("blah2" nil :type i32 :id 2) 191 | ("bw" nil :type (struct "backwards") :id 3))) 192 | 193 | (thrift:def-struct "structwithasomemap" 194 | (("somemap_field" nil :type (map i32 i32) :id 1))) 195 | 196 | (thrift:def-struct "bigfieldidstruct" 197 | (("field1" nil :type string :id 1) 198 | ("field2" nil :type string :id 45))) 199 | 200 | (thrift:def-struct "breaksrubycompactprotocol" 201 | (("field1" nil :type string :id 1) 202 | ("field2" nil :type (struct "bigfieldidstruct") :id 2) 203 | ("field3" nil :type i32 :id 3))) 204 | 205 | (thrift:def-service "ServiceForExceptionWithAMap" nil 206 | (:method "methodThatThrowsAnException" (() void) 207 | :exceptions (("xwamap" nil :type (struct "exceptionwithamap") :id 1)))) 208 | (thrift:def-service "Srv" nil 209 | (:method "Janky" ((("arg" i32 1)) i32)) 210 | (:method "voidMethod" (() void)) 211 | (:method "primitiveMethod" (() i32)) 212 | (:method "structMethod" (() (struct "compactprototeststruct"))) 213 | (:method "methodWithDefaultArgs" ((("something" i32 1)) void)) 214 | (:method "onewayMethod" (() void) 215 | :oneway t)) 216 | (thrift:def-service "Inherited" "Srv" 217 | (:method "identity" ((("arg" i32 1)) i32))) 218 | (thrift:def-service "EmptyService" nil) 219 | (thrift:def-service "ReverseOrderService" nil 220 | (:method "myMethod" ((("first" string 4) ("second" i16 3) ("third" i32 2) ("fourth" i64 1)) void))) 221 | -------------------------------------------------------------------------------- /vector-protocol.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- 2 | 3 | (in-package :org.apache.thrift.implementation) 4 | 5 | ;;; define a binary stream to wrap a vector for use in tests. 6 | ;;; adapted from the cl-xml version to restrict i/o to unsigned byte operations. 7 | ;;; this version uses a signed byte stream, as that's the basis of the thrift binary transport 8 | ;;; 9 | 10 | 11 | ;;; 12 | ;;; abstract 13 | 14 | (defclass vector-stream () 15 | ((position 16 | :initform 0 17 | :reader get-stream-position :writer setf-stream-position) 18 | (vector 19 | :reader get-vector-stream-vector :writer setf-vector-stream-vector 20 | :type vector) 21 | (force-output-hook 22 | :initform nil :initarg :force-output-hook 23 | :accessor stream-force-output-hook 24 | :documentation "A function of one argument, the stream, called as the 25 | base implementation of stream-force-output.") 26 | #+(or CMU sbcl lispworks) (direction :initarg :direction) 27 | ) 28 | (:default-initargs 29 | #+CormanLisp :element-type #+CormanLisp 'character)) 30 | 31 | (defClass vector-input-stream (vector-stream 32 | #+ALLEGRO excl::fundamental-binary-input-stream 33 | #+LispWorks stream:fundamental-stream 34 | #+(and MCL digitool) ccl::input-binary-stream 35 | #+(and MCL openmcl) fundamental-binary-input-stream 36 | #+CMU extensions:fundamental-binary-input-stream 37 | #+sbcl sb-gray:fundamental-binary-input-stream 38 | #+CormanLisp stream 39 | ) 40 | () 41 | (:default-initargs :direction :input)) 42 | 43 | (defClass vector-output-stream (vector-stream 44 | #+ALLEGRO excl::fundamental-binary-output-stream 45 | #+LispWorks stream:fundamental-stream 46 | #+(and MCL digitool) ccl::output-binary-stream 47 | #+(and MCL openmcl) fundamental-binary-output-stream 48 | #+CMU extensions:fundamental-binary-output-stream 49 | #+sbcl sb-gray:fundamental-binary-output-stream 50 | #+CormanLisp stream 51 | ) 52 | () 53 | (:default-initargs :direction :output)) 54 | 55 | (defclass vector-stream-transport (vector-input-stream vector-output-stream binary-transport) 56 | ((stream :initform nil))) 57 | 58 | 59 | (defun make-vector-stream-buffer (length &optional (type *binary-transport-element-type*)) 60 | (make-array length :element-type type :initial-element 0)) 61 | 62 | (defmethod shared-initialize 63 | ((instance vector-stream) (slots t) &key (vector nil vector-s) (length 128)) 64 | (with-slots (position) instance 65 | (setf position 0) 66 | (when vector-s 67 | (setf-vector-stream-vector 68 | (etypecase vector 69 | (string (map-into (make-vector-stream-buffer (length vector)) #'char-code vector)) 70 | (cl:cons (map-into (make-vector-stream-buffer (length vector)) 71 | #'(lambda (datum) 72 | (etypecase datum 73 | (fixnum datum) 74 | (character (char-code datum)))) 75 | vector)) 76 | (vector vector) 77 | (null (make-vector-stream-buffer length))) 78 | instance)) 79 | (call-next-method) 80 | (unless (slot-boundp instance 'vector) 81 | (setf-vector-stream-vector (make-vector-stream-buffer length) instance)))) 82 | 83 | #+cmu 84 | (let ((old-definition (fdefinition 'stream-element-type))) 85 | (unless (typep old-definition 'generic-function) 86 | (fmakunbound 'stream-element-type) 87 | (defgeneric stream-element-type (stream)) 88 | (setf (documentation 'stream-element-type 'function) 89 | (documentation old-definition 'function)) 90 | (defmethod stream-element-type (stream) 91 | (funcall old-definition stream)))) 92 | 93 | (defmethod stream-element-type ((stream vector-stream)) 94 | *binary-transport-element-type*) 95 | 96 | (defmethod stream-position ((stream vector-stream) &optional new) 97 | (with-slots (vector) stream 98 | (if new 99 | (setf-stream-position (min (length vector) new) stream) 100 | (get-stream-position stream)))) 101 | 102 | (defmethod stream-eofp ((stream vector-stream)) 103 | (with-slots (position vector) stream 104 | (>= position (length vector)))) 105 | 106 | (defmethod stream-finish-output ((stream vector-stream)) 107 | nil) 108 | 109 | (defmethod print-object 110 | ((vs vector-stream) (stream t) 111 | &aux (*print-array* t) (*print-length* 32) (*print-base* 16)) 112 | (print-unreadable-object (vs stream :type t) 113 | (princ (get-vector-stream-vector vs) stream))) 114 | 115 | (defmethod stream-force-output ((stream vector-stream)) 116 | (let ((hook (stream-force-output-hook stream))) 117 | (when hook (funcall hook stream)))) 118 | 119 | #-mcl 120 | (defmethod open-stream-p ((stream vector-stream)) 121 | t) 122 | 123 | (defgeneric vector-stream-vector (vector-stream) 124 | (:documentation "Return the written subsequence and reset the position") 125 | (:method ((stream vector-stream)) 126 | (with-slots (vector position) stream 127 | (prog1 (subseq vector 0 position) 128 | (setf position 0))))) 129 | 130 | (defgeneric (setf vector-stream-vector) (vector vector-stream) 131 | (:method ((new-vector vector) (stream vector-stream)) 132 | (assert (equal (array-element-type new-vector) *binary-transport-element-type*) () 133 | "Invalid vector stream element type: ~s." (array-element-type new-vector)) 134 | (with-slots (vector position) stream 135 | (setf position 0 136 | vector new-vector)))) 137 | 138 | ;;; 139 | ;;; input 140 | 141 | (defmethod stream-read-byte ((stream vector-input-stream)) 142 | (with-slots (position vector) stream 143 | (when (< position (length vector)) 144 | (let ((byte (aref vector position))) 145 | (incf position) 146 | (if (> byte 127) 147 | (- (logxor 255 (1- byte))) 148 | byte))))) 149 | 150 | (defmethod stream-read-unsigned-byte ((stream vector-input-stream)) 151 | (with-slots (position vector) stream 152 | (when (< position (length vector)) 153 | (let ((byte (aref vector position))) 154 | (incf position) 155 | byte)))) 156 | 157 | #+mcl 158 | (defmethod ccl:stream-tyi ((stream vector-input-stream)) 159 | (stream-read-byte stream)) 160 | 161 | (defmethod stream-reader ((stream vector-input-stream)) 162 | (values #'(lambda (stream) 163 | (with-slots (position vector) stream 164 | (when (< position (length vector)) 165 | (let ((byte (aref vector position))) 166 | (incf position) 167 | byte)))) 168 | stream)) 169 | 170 | 171 | (defmethod stream-read-sequence ((stream vector-input-stream) (sequence vector) 172 | #+mcl &key #-mcl &optional (start 0) (end nil)) 173 | (unless end (setf end (length sequence))) 174 | (assert (typep start '(integer 0))) 175 | (assert (>= end start)) 176 | (with-slots (vector position) stream 177 | (let* ((new-position (min (+ position (- end start)) (length vector)))) 178 | (when (> new-position position) 179 | (replace sequence vector 180 | :start1 start :end1 end 181 | :start2 position :end2 new-position) 182 | (setf position new-position)) 183 | new-position))) 184 | 185 | 186 | ;;; 187 | ;;; output 188 | 189 | 190 | (defmethod stream-write-byte ((stream vector-output-stream) (datum integer) &aux next) 191 | (with-slots (position vector) stream 192 | (unless (< (setf next (1+ position)) (length vector)) 193 | (setf vector 194 | (adjust-array vector (+ next (floor (/ next 4))) 195 | :element-type *binary-transport-element-type*))) 196 | (setf (aref vector position) 197 | (logand #xff datum)) 198 | (setf position next))) 199 | 200 | 201 | #+mcl 202 | (defmethod ccl:stream-tyo ((stream vector-output-stream) byte) 203 | (stream-write-byte stream byte)) 204 | 205 | (defmethod stream-writer ((stream vector-output-stream)) 206 | (values #'(lambda (stream byte &aux next) 207 | (with-slots (position vector) stream 208 | (unless (< (setf next (1+ position)) (length vector)) 209 | (setf vector 210 | (adjust-array vector (+ next (floor (/ next 4))) 211 | :element-type *binary-transport-element-type*))) 212 | (setf (aref vector position) 213 | (logand #xff byte)) 214 | (setf position next))) 215 | stream)) 216 | 217 | (defmethod stream-write-sequence ((stream vector-output-stream) (sequence vector) 218 | #+mcl &key #-mcl &optional (start 0) (end nil)) 219 | (unless end (setf end (length sequence))) 220 | (assert (typep start '(integer 0))) 221 | (assert (>= end start)) 222 | (with-slots (vector position) stream 223 | (let* ((new-position (+ position (- end start)))) 224 | (when (> new-position position) 225 | (unless (< new-position (length vector)) 226 | (setf vector 227 | (adjust-array vector (floor (+ new-position (floor (/ new-position 4)))) 228 | :element-type *binary-transport-element-type*))) 229 | (replace vector sequence 230 | :start1 position :end1 new-position 231 | :start2 start :end2 end) 232 | (setf position new-position)) 233 | new-position))) 234 | -------------------------------------------------------------------------------- /test/test.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: thrift-test; -*- 2 | 3 | (in-package :thrift-test) 4 | 5 | ;;; (run-tests "setup/.*") 6 | ;;; (thrift-test::run-tests) 7 | ;;; (pprint-tabular t (sort (loop for key being each hash-key of *tests* collect (string key)) #'string-lessp)) 8 | 9 | (defparameter *test-root-pathname* 10 | (make-pathname :name nil :type nil :defaults (or *compile-file-pathname* *load-pathname*))) 11 | 12 | (defvar *tests* (make-hash-table)) 13 | 14 | (defvar *test-location* #u"thrift://127.0.0.1:9091") 15 | 16 | (defvar *test-service* (make-instance 'service :identifier "Test Root")) 17 | 18 | (defvar *test-server-process* nil) 19 | 20 | (defvar *test-break-on-errors* t) 21 | 22 | (defun find-test (name) (gethash name *tests*)) 23 | 24 | (defun (setf find-test) (test-function name) 25 | (if (null test-function) 26 | (remhash name *tests*) 27 | (setf (gethash name *tests*) test-function))) 28 | 29 | (defgeneric run-test (test) 30 | (:method ((name symbol)) 31 | (let ((test-function (find-test name))) 32 | (if test-function 33 | (run-test test-function) 34 | (warn "test not found: ~s." name)))) 35 | (:method ((test-function function)) 36 | )) 37 | 38 | (defun run-tests (&rest test-names) 39 | (let ((succeeded 0) 40 | (failed ()) 41 | (errored ())) 42 | (flet ((run-test (test-function) 43 | (multiple-value-bind (result condition name form) 44 | (funcall test-function) 45 | (cond (result 46 | (incf succeeded)) 47 | (condition 48 | (format *trace-output* "~%test (~a) signaled:~%~:w~%~a" name form condition) 49 | (push name errored)) 50 | (t 51 | (format *trace-output* "~&~%test (~a) failed:~%~:w" name form) 52 | (push name failed)))))) 53 | (if test-names 54 | (dolist (pattern test-names) 55 | (etypecase pattern 56 | (symbol 57 | (run-test (or (find-test pattern) (error "test not found: ~s." pattern)))) 58 | (string 59 | (let ((scanner (ppcre:create-scanner (string-upcase pattern)))) 60 | (flet ((run-if-matched (name function) 61 | (let* ((namestring (string name)) 62 | (matched-string (cl-ppcre:scan-to-strings scanner namestring))) 63 | (when (string-equal namestring matched-string) 64 | (run-test function))))) 65 | (maphash #'run-if-matched *tests*)))))) 66 | (loop for test being each hash-value of *tests* do (run-test test)))) 67 | `(,(or test-names ".*") 68 | ,(if (or failed errored) :count :succeeded) ,(+ succeeded (length failed) (length errored)) 69 | ,@(when failed `(:failed (,(length failed) ,@failed))) 70 | ,@(when errored `(:errored (,(length errored) ,@errored)))))) 71 | 72 | (defmacro test (name form) 73 | `(progn (setf (find-test ',name) 74 | #'(lambda (&aux (name ',name) (form ',form)) 75 | (multiple-value-bind (result error) 76 | (block :do-test 77 | (handler-bind ((error (lambda (c) 78 | (when *test-break-on-errors* 79 | (break "~%~a signaled ~a." ',name c)) 80 | (return-from :do-test (values nil c))))) 81 | ,form)) 82 | (cond (error 83 | (values nil error name form)) 84 | (result 85 | (values result nil name form)) 86 | (t 87 | (values nil nil name form)))))) 88 | ',name)) 89 | 90 | #+digitool 91 | (setf (ccl:assq 'test ccl:*fred-special-indent-alist*) 1) 92 | 93 | 94 | 95 | ;;; 96 | ;;; 97 | 98 | (defclass test-struct (thrift-object) 99 | ((field1 :type string :initarg :field1 :accessor test-struct-field1 100 | :identifier-number 1 :identifier "fieldOne") 101 | (field2 :type i16 :initarg :field2 :accessor test-struct-field2 102 | :identifier-number 2 :identifier "fieldTwo")) 103 | (:metaclass thrift-struct-class) 104 | (:identifier "TestStruct") 105 | (:documentation "a simple srtuct class for tests")) 106 | 107 | (defclass test-large-struct (thrift-object) 108 | ((field1 :type i16 :initarg :field1 :accessor test-struct-field1 109 | :identifier-number 1 :identifier "fieldOne" :optional t) 110 | (field2 :type i16 :initarg :field2 :accessor test-struct-field2 111 | :identifier-number 2 :identifier "fieldTwo" :optional t) 112 | (field3 :type i16 :initarg :field3 :accessor test-struct-field3 113 | :identifier-number 3 :identifier "fieldThree" :optional t) 114 | (field4 :type i16 :initarg :field4 :accessor test-struct-field4 115 | :identifier-number 4 :identifier "fieldfour" :optional t) 116 | (field5 :type i16 :initarg :field5 :accessor test-struct-field5 117 | :identifier-number 5 :identifier "fieldFive" :optional t) 118 | (field6 :type i16 :initarg :field6 :accessor test-struct-field6 119 | :identifier-number 6 :identifier "fieldSix" :optional t) 120 | (field7 :type i16 :initarg :field7 :accessor test-struct-field7 121 | :identifier-number 7 :identifier "fieldSeven" :optional t) 122 | (field8 :type i16 :initarg :field8 :accessor test-struct-field8 123 | :identifier-number 8 :identifier "fieldEight" :optional t) 124 | (field9 :type i16 :initarg :field9 :accessor test-struct-field9 125 | :identifier-number 9 :identifier "fieldNine" :optional t) 126 | (field10 :type i16 :initarg :field10 :accessor test-struct-field10 127 | :identifier-number 10 :identifier "fieldTen" :optional t)) 128 | (:metaclass thrift-struct-class) 129 | (:identifier "TestLargeStruct") 130 | (:documentation "A struct class for use in timing tests and to test 131 | optional field codecs - thus no initforms.")) 132 | 133 | 134 | 135 | (defun make-test-transport (&rest initargs) 136 | (apply #'make-instance 'vector-stream-transport initargs)) 137 | 138 | (defun make-test-protocol (&rest initargs &key 139 | (direction :io) 140 | (input-transport (make-test-transport)) 141 | (output-transport input-transport)) 142 | (apply #'make-instance 'binary-protocol 143 | :direction direction 144 | :input-transport input-transport 145 | :output-transport output-transport 146 | initargs)) 147 | 148 | (defun make-test-protocol-peers (&key (request-hook 'rewind) (response-hook 'rewind)) 149 | (let ((request-transport (make-test-transport :force-output-hook request-hook)) 150 | (response-transport (make-test-transport :force-output-hook response-hook))) 151 | (values (make-test-protocol :output-transport request-transport 152 | :input-transport response-transport) 153 | (make-test-protocol :output-transport response-transport 154 | :input-transport request-transport)))) 155 | 156 | (defgeneric rewind (stream) 157 | (:method ((protocol protocol)) 158 | (rewind (protocol-input-transport protocol)) 159 | (rewind (protocol-output-transport protocol)) 160 | protocol) 161 | 162 | (:method ((stream vector-stream)) 163 | (stream-position stream 0) 164 | stream)) 165 | 166 | (defgeneric reset (stream) 167 | (:method ((protocol protocol)) 168 | (rewind protocol) 169 | (reset (protocol-output-transport protocol)) 170 | protocol) 171 | 172 | (:method ((stream vector-stream)) 173 | (fill (get-vector-stream-vector stream) 0) 174 | stream)) 175 | 176 | 177 | (defun test-server (&optional (location *test-location*)) 178 | (setq *test-location* location) 179 | (or *test-server-process* 180 | (setq *test-server-process* (bt:make-thread #'(lambda () (serve location *test-service*)))))) 181 | 182 | (defun stop-test-server () 183 | (when (typep *test-server-process* 'bt:thread) 184 | (bt:destroy-thread *test-server-process*) 185 | (setq *test-server-process* nil))) 186 | ;;; (stop-test-server) 187 | 188 | (defun call-with-test-services (function &rest services) 189 | (declare (dynamic-extent function)) 190 | (unwind-protect (progn (setf (service-base-services *test-service*) 191 | (union (service-base-services *test-service*) 192 | services)) 193 | (funcall function)) 194 | (setf (service-base-services *test-service*) 195 | (set-difference (service-base-services *test-service*) 196 | services)))) 197 | 198 | (defmacro with-test-services ((protocol &rest services) &body body) 199 | (let ((op (gensym))) 200 | `(flet ((,op () (with-client (,protocol *test-location*) ,@body))) 201 | ;; (test-server) doesn't work as the connect beats the accept and the client hangs 202 | (call-with-test-services #',op ,@services)))) 203 | 204 | 205 | 206 | ;;; 207 | 208 | (test setup/thrift-class 209 | (let ((class (find-class 'test-struct))) 210 | (and (equal (class-identifier class) "TestStruct") 211 | (every #'(lambda (id name) 212 | (equal (field-definition-identifier 213 | (find id (class-field-definitions class) 214 | :key #'field-definition-identifier-number)) 215 | name)) 216 | '(1 2) 217 | '("fieldOne" "fieldTwo"))))) 218 | 219 | (test setup/test-transport 220 | (typep (make-test-transport) 'binary-transport)) 221 | 222 | (test setup/test-protocol 223 | (typep (make-test-protocol) 'binary-protocol)) 224 | 225 | 226 | -------------------------------------------------------------------------------- /transport.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- 2 | 3 | (in-package :org.apache.thrift.implementation) 4 | 5 | ;;; This file defines the core of the 'transport' layer for the `org.apache.thrift` library. 6 | ;;; 7 | ;;; copyright 2010 [james anderson](james.anderson@setf.de) 8 | ;;; 9 | ;;; Licensed to the Apache Software Foundation (ASF) under one 10 | ;;; or more contributor license agreements. See the NOTICE file 11 | ;;; distributed with this work for additional information 12 | ;;; regarding copyright ownership. The ASF licenses this file 13 | ;;; to you under the Apache License, Version 2.0 (the 14 | ;;; "License"); you may not use this file except in compliance 15 | ;;; with the License. You may obtain a copy of the License at 16 | ;;; 17 | ;;; http://www.apache.org/licenses/LICENSE-2.0 18 | ;;; 19 | ;;; Unless required by applicable law or agreed to in writing, 20 | ;;; software distributed under the License is distributed on an 21 | ;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 22 | ;;; KIND, either express or implied. See the License for the 23 | ;;; specific language governing permissions and limitations 24 | ;;; under the License. 25 | 26 | 27 | ;;; The transport operators focus on the stream interface and supply the equivalents to the 28 | ;;; Thrift standard operators in terms of the gray stream interface: 29 | ;;; 30 | ;;; * open is superfluous. there is no use case for it, as they are not reused. 31 | ;;; the respective stream is opened as a side-effect of make-instance. 32 | ;;; * isOpen is implemented as methods for open-stream-p 33 | ;;; * close is implemented as transport-close to which stream-close/close delegates as per runtime 34 | ;;; * read-byte is implemented as methods for stream-read-byte 35 | ;;; * read-sequence is implemented as methods for stream-read-sequence 36 | ;;; * write-byte is implemented as methods for stream-write-byte 37 | ;;; * write-sequence is implemented as methods for stream-write-sequence 38 | ;;; * flush is implemented as a method on stream-finish-output 39 | 40 | 41 | ;;; 42 | ;;; macros 43 | 44 | (macrolet ((def-signed-byte (bit-count) 45 | (let ((name (cons-symbol :org.apache.thrift.implementation 46 | :signed-byte- (prin1-to-string bit-count))) 47 | (max-positive (1- (expt 2 (1- bit-count)))) 48 | (mask (1- (expt 2 bit-count)))) 49 | `(progn (defun ,name (byte) 50 | (if (> byte ,max-positive) ; convert 51 | (- (logxor ,mask (1- byte))) 52 | byte)) 53 | (define-compiler-macro ,name (byte &environment env) 54 | (let* ((var (if (and (symbolp byte) (eq (macroexpand-1 byte env) byte)) byte (gensym))) 55 | (form `(if (> ,var ,,max-positive) ; convert 56 | (- (logxor ,,mask (1- ,var))) 57 | ,var))) 58 | (if (eq byte var) 59 | form 60 | `(let ((,var ,byte)) ,form)))))))) 61 | (def-signed-byte 8) 62 | (def-signed-byte 16) 63 | (def-signed-byte 32) 64 | (def-signed-byte 64)) 65 | 66 | (defun unsigned-byte-8 (datum) 67 | (logand datum #xff)) 68 | 69 | (define-compiler-macro unsigned-byte-8 (datum) 70 | `(logand ,datum #xff)) 71 | 72 | 73 | ;;; 74 | ;;; classes 75 | 76 | (defclass transport (#+sbcl sb-gray:fundamental-stream #+ccl stream) 77 | ((stream :reader transport-stream) 78 | (direction :initarg :direction :accessor stream-direction)) 79 | (:documentation "The abstract transport class is a specialized stream which wraps a base binary 80 | stream - a file or a socket, with methods which codec operators for primitive data types.")) 81 | 82 | 83 | (defclass binary-transport (transport) 84 | ()) 85 | 86 | 87 | (defclass socket-transport (binary-transport) 88 | () 89 | (:documentation "A specialzed transport which wraps a socket and its stream.")) 90 | 91 | 92 | (defclass file-transport (binary-transport) 93 | ((pathname :initarg :pathname :accessor transport-pathname :initform (error "pathname is required.")) 94 | ;; delegation, as make-instance does not return a usable stream in all implementations 95 | (stream :accessor transport-stream))) 96 | 97 | 98 | ;;; 99 | ;;; initialization 100 | 101 | (defvar *binary-transport-element-type* '(unsigned-byte 8)) 102 | 103 | (defmethod initialize-instance ((transport socket-transport) &key socket) 104 | (call-next-method) 105 | (setf (slot-value transport 'stream) (usocket:socket-stream socket))) 106 | 107 | 108 | (defun socket-transport (location &rest initargs 109 | &key (element-type *binary-transport-element-type*) (direction :io d-s)) 110 | (when d-s 111 | (setf initargs (copy-list initargs)) 112 | (remf initargs :direction)) 113 | 114 | (make-instance 'socket-transport 115 | :direction direction 116 | :socket (apply #'usocket:socket-connect (puri:uri-host location) (puri:uri-port location) 117 | :element-type element-type 118 | initargs))) 119 | 120 | 121 | 122 | (defmethod initialize-instance ((transport file-transport) &key pathname stream 123 | (direction :output) 124 | (element-type *binary-transport-element-type*) 125 | (if-exists :supersede) (if-does-not-exist :create)) 126 | (call-next-method) 127 | (setf (slot-value transport 'stream) 128 | (or stream 129 | (open (or pathname (error "A pathname is required.")) 130 | :direction direction :element-type element-type 131 | :if-exists if-exists :if-does-not-exist if-does-not-exist)))) 132 | 133 | 134 | (defun file-transport (pathname &rest initargs 135 | &key (element-type *binary-transport-element-type*)) 136 | (apply #'make-instance 'file-transport 137 | :pathname pathname :element-type element-type 138 | initargs)) 139 | 140 | 141 | ;;; open-stream-p is the only operator which guards against an unbound slot. 142 | ;;; stream-close checks that the stream is still open 143 | ;;; all other presume it is open. 144 | 145 | #-mcl ;; mcl defines a plain function in terms of stream-direction 146 | (defmethod open-stream-p ((transport transport)) 147 | (when (slot-boundp transport 'stream) 148 | (open-stream-p (transport-stream transport)))) 149 | 150 | (defun transport-close (transport &key abort) 151 | "The transport close implementation is used by whichever interface the runtime presents for extensions. 152 | as per the gray interface, close is replaced with a generic function. in other cases, stream-close 153 | is a generic operator." 154 | (when (open-stream-p transport) 155 | (close (transport-stream transport) :abort abort) 156 | (setf (slot-value transport 'direction) :closed) 157 | (slot-makunbound transport 'stream))) 158 | 159 | (when (fboundp 'stream-close) 160 | (defmethod stream-close ((transport transport)) 161 | (when (next-method-p) (call-next-method)) 162 | (transport-close transport))) 163 | 164 | (when (typep #'close 'generic-function) 165 | (defmethod close ((stream transport) &rest args) 166 | (when (next-method-p) (call-next-method)) 167 | (apply #'transport-close stream args) 168 | t)) 169 | 170 | 171 | #-sbcl 172 | (defmethod stream-finish-output ((transport transport)) 173 | (stream-finish-output (transport-stream transport))) 174 | #+sbcl 175 | (defmethod stream-finish-output ((transport transport)) 176 | (finish-output (transport-stream transport))) 177 | 178 | #-sbcl 179 | (defmethod stream-force-output ((transport transport)) 180 | (stream-force-output (transport-stream transport))) 181 | #+sbcl 182 | (defmethod stream-force-output ((transport transport)) 183 | (force-output (transport-stream transport))) 184 | 185 | 186 | ;;; 187 | ;;; input 188 | 189 | #-sbcl 190 | (defmethod stream-read-byte ((transport binary-transport)) 191 | (let ((unsigned-byte (stream-read-byte (transport-stream transport)))) 192 | (if unsigned-byte 193 | (signed-byte-8 unsigned-byte) 194 | (error 'end-of-file :stream (transport-stream transport))))) 195 | #+sbcl 196 | (defmethod stream-read-byte ((transport binary-transport)) 197 | (let ((unsigned-byte (read-byte (transport-stream transport)))) 198 | (signed-byte-8 unsigned-byte))) 199 | 200 | 201 | #-(or mcl sbcl) 202 | (defmethod stream-read-sequence ((transport binary-transport) (sequence vector) &optional (start 0) (end nil)) 203 | (stream-read-sequence (transport-stream transport) sequence start end)) 204 | 205 | #+mcl 206 | (defmethod stream-read-sequence ((transport binary-transport) (sequence vector) &rest args) 207 | (declare (dynamic-extent args)) 208 | (apply #'stream-read-sequence (transport-stream transport) sequence args)) 209 | 210 | #+sbcl 211 | (defmethod stream-read-sequence ((transport binary-transport) (sequence vector) &optional (start 0) (end nil)) 212 | (unless (= (read-sequence sequence (transport-stream transport) :start start :end end) 213 | (or end (length sequence))) 214 | (error 'end-of-file :stream (transport-stream transport)))) 215 | 216 | ;;; 217 | ;;; output 218 | 219 | #-sbcl 220 | (defmethod stream-write-byte ((transport binary-transport) byte) 221 | (stream-write-byte (transport-stream transport) (unsigned-byte-8 byte))) 222 | #+sbcl 223 | (defmethod stream-write-byte ((transport binary-transport) byte) 224 | (write-byte (unsigned-byte-8 byte) (transport-stream transport))) 225 | 226 | 227 | #-(or mcl sbcl) 228 | (defmethod stream-write-sequence ((transport binary-transport) (sequence vector) &optional (start 0) (end nil)) 229 | (stream-write-sequence (transport-stream transport) sequence start end)) 230 | 231 | #+mcl 232 | (defmethod stream-write-sequence ((transport binary-transport) (sequence vector) &rest args) 233 | (declare (dynamic-extent args)) 234 | (apply #'stream-write-sequence (transport-stream transport) sequence args)) 235 | 236 | #+sbcl 237 | (defmethod stream-write-sequence ((transport binary-transport) (sequence vector) &optional (start 0) (end nil)) 238 | (write-sequence sequence (transport-stream transport) :start start :end end)) 239 | -------------------------------------------------------------------------------- /test/protocol.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: thrift-test; -*- 2 | 3 | (in-package :thrift-test) 4 | 5 | ;;; tests for transport operations 6 | ;;; (run-tests "protocol.*") 7 | 8 | 9 | (defvar *string-w/euro* (cl:map 'string #'code-char '(48 46 57 57 57 8364))) 10 | 11 | (test protocol.open-stream-p 12 | (open-stream-p (make-test-transport))) 13 | 14 | (defun test-read-write-equivalence (protocol reader writer &rest values) 15 | (let ((transport (protocol-output-transport protocol))) 16 | (dolist (value values t) 17 | (reset protocol) 18 | (funcall writer protocol value) 19 | (rewind protocol) 20 | (let ((read (funcall reader protocol))) 21 | (unless (equalp read value) 22 | (format *trace-output* "failed: ~a/~a ~s ~s ~s" 23 | reader writer value read (subseq (get-vector-stream-vector transport) 0 (stream-position transport))) 24 | (return nil)))))) 25 | 26 | 27 | ;;; 28 | 29 | (test protocol.stream-read/write-integer 30 | (let ((stream (make-test-protocol))) 31 | (every #'(lambda (entry) 32 | (apply #'test-read-write-equivalence stream entry)) 33 | `((stream-read-bool stream-write-bool t nil) 34 | (stream-read-type stream-write-type thrift:byte thrift:map thrift:list thrift:set struct) 35 | (stream-read-message-type stream-write-message-type call) 36 | (stream-read-i08 stream-write-i08 ,(- (expt 2 7)) -1 0 1 ,(1- (expt 2 7))) 37 | (stream-read-i16 stream-write-i16 ,(- (expt 2 15)) -1 0 1 ,(1- #x70f0) ,(1- (expt 2 15))) 38 | (stream-read-i32 stream-write-i32 ,(- (expt 2 31)) -1 0 1 ,(1- #x7700ff00) ,(1- (expt 2 31))) 39 | (stream-read-i64 stream-write-i64 ,(- (expt 2 63)) -1 0 1 ,(1- #x77770000ffff0000) ,(1- (expt 2 63))))))) 40 | 41 | 42 | (test protocol.stream-read/write-double 43 | (let ((stream (make-test-protocol))) 44 | (every #'(lambda (entry) 45 | (apply #'test-read-write-equivalence stream entry)) 46 | `((stream-read-double stream-write-double 47 | ,most-negative-double-float ,least-negative-double-float 48 | ,most-positive-double-float ,least-positive-double-float 49 | 0.0d0 1.0d0 -1.0d0))))) 50 | 51 | 52 | (test protocol.stream-read/write-string 53 | (let ((stream (make-test-protocol))) 54 | (every #'(lambda (entry) 55 | (apply #'test-read-write-equivalence stream entry)) 56 | `((stream-read-string stream-write-string "a" "0123456789" ,*string-w/euro*))))) 57 | 58 | 59 | (test protocol.stream-read/write-binary 60 | (let ((stream (make-test-protocol))) 61 | (every #'(lambda (entry) 62 | (apply #'test-read-write-equivalence stream entry)) 63 | ;; presuming (unsigned-bte 8) 64 | `((stream-read-binary stream-write-binary #( 0 1 255)))))) 65 | 66 | 67 | (test protocol.stream-read/write-message 68 | (let ((struct (make-instance 'test-struct :field1 "one" :field2 2)) 69 | (stream (make-test-protocol))) 70 | (stream-write-message stream struct 'call) 71 | (rewind stream) 72 | (multiple-value-bind (name type sequence response) 73 | (stream-read-message stream) 74 | (and (equal name 'test-struct) 75 | (eq type 'call) 76 | (eql sequence 1) 77 | (typep response 'test-struct) 78 | (equal (test-struct-field1 response) "one") 79 | (equal (test-struct-field2 response) 2))))) 80 | 81 | 82 | (test protocol.stream-read/write-struct 83 | (let ((struct (make-instance 'test-struct :field1 "one" :field2 2)) 84 | (stream (make-test-protocol))) 85 | (stream-write-struct stream struct) 86 | (rewind stream) 87 | (let* ((type 'test-struct) 88 | (result (stream-read-struct stream type))) 89 | (and (typep result 'test-struct) 90 | (equal (test-struct-field1 result) "one") 91 | (equal (test-struct-field2 result) 2))))) 92 | ;;; (run-tests "protocol.stream-read/write-struct") 93 | 94 | (test protocol.stream-read/write-struct.inline 95 | (let ((struct (make-instance 'test-struct :field1 "one" :field2 2)) 96 | (stream (make-test-protocol))) 97 | (stream-write-struct stream struct 'test-struct) 98 | (rewind stream) 99 | (let ((result (stream-read-struct stream 'test-struct))) 100 | (and (typep result 'test-struct) 101 | (equal (test-struct-field1 result) "one") 102 | (equal (test-struct-field2 result) 2))))) 103 | ;;; (run-tests "protocol.stream-read/write-struct.inline") 104 | 105 | 106 | (test protocol.stream-read/write-struct.optional 107 | (let ((struct (make-instance 'test-large-struct :field1 1 :field2 2)) 108 | (stream (make-test-protocol))) 109 | (assert (not (slot-boundp struct 'field3))) 110 | (stream-write-struct stream struct 'test-large-struct) 111 | (rewind stream) 112 | (let ((result (stream-read-struct stream 'test-large-struct))) 113 | (and (typep result 'test-large-struct) 114 | (not (slot-boundp result 'field3)) 115 | (equal (test-struct-field1 result) 1) 116 | (equal (test-struct-field2 result) 2))))) 117 | 118 | 119 | (test protocol.stream-read/write-field 120 | (let ((stream (make-test-protocol))) 121 | (every #'(lambda (entry) 122 | (apply #'test-read-write-equivalence stream entry)) 123 | `((,(lambda (p) (multiple-value-bind (value name id) 124 | (stream-read-field p) 125 | (when (ecase (protocol-field-id-mode stream) 126 | (:identifier-name (and (equal name "test") (null id))) 127 | (:identifier-number (and (null name) (equal id 10)))) 128 | value))) 129 | ,(lambda (p v) (stream-write-field p v :identifier-name "test" :identifier-number 10)) 130 | "a" "0123456789" ,*string-w/euro*))))) 131 | 132 | 133 | (test protocol.stream-read/write-map 134 | (let ((stream (make-test-protocol))) 135 | (every #'(lambda (entry) 136 | (apply #'test-read-write-equivalence stream entry)) 137 | `((stream-read-map stream-write-map ,(thrift:map 1 "a" 2 "b")))))) 138 | ;;; (run-tests "protocol.stream-read/write-map") 139 | 140 | 141 | 142 | (test protocol.stream-read/write-list 143 | (let ((stream (make-test-protocol))) 144 | (every #'(lambda (entry) 145 | (apply #'test-read-write-equivalence stream entry)) 146 | `((stream-read-list stream-write-list 147 | (t nil) (1 2 3) (32767 1 -1 -32768) 148 | (,(expt 2 33) ,(- (expt 2 33))) 149 | ("asdf" ,*string-w/euro*) 150 | ;; no test for binary ! there is no type code 151 | ;; and the java and cpp versions just send it as a string 152 | ;; (#(1 2 3) #(4 5 6)) 153 | (1.0d0 -1.0d0) 154 | (,(thrift:map 1 "a" 2 "b"))))))) 155 | 156 | 157 | (test protocol.stream-read/write-set 158 | (let ((stream (make-test-protocol))) 159 | (every #'(lambda (entry) 160 | (apply #'test-read-write-equivalence stream entry)) 161 | `((stream-read-set stream-write-set 162 | (t nil) (1 2 3) (32767 1 -1 -32768)))))) 163 | 164 | 165 | #+(or ccl sbcl) 166 | (defun time-struct-io (&optional (count 1024)) 167 | (let ((initargs '(:field1 1 :field2 2 :field3 3 :field4 4 :field5 5 168 | :field6 6 :field7 7 :field8 8 :field9 9 :field10 10)) 169 | (stream (make-test-protocol)) 170 | (bound-count 0) 171 | (gctime nil) 172 | (slot-count 10)) 173 | (flet ((gctime () #+ccl (ccl::gctime) #+sbcl sb-ext:*GC-RUN-TIME*) 174 | (gcbytes () #+ccl (ccl::total-bytes-allocated) 175 | #+sbcl (nth-value 3 (sb-impl::time-get-sys-info)))) 176 | (format *trace-output* "~&slots,~10Tbound,~20Tdynamic-ms,~36Tstatic-ms,~52Tstatic/w-ms,~68Tdynamic-kb,~84Tstatic-kb,~100Tstatic/w-kb") 177 | (loop (when (eql gctime (setf gctime (gctime))) 178 | (incf bound-count) 179 | (when (> bound-count 10) (return))) 180 | (let ((struct (apply #'make-instance 'test-large-struct 181 | (subseq initargs 0 (* bound-count 2)))) 182 | (result (apply #'make-instance 'test-large-struct nil)) 183 | (dynamic-time 0) 184 | (static-time 0) 185 | (static-with-time 0) 186 | (dynamic-bytes 0) 187 | (static-bytes 0) 188 | (static-with-bytes 0)) 189 | (let ((time (get-internal-run-time)) 190 | (bytes (gcbytes))) 191 | (dotimes (i count) 192 | (rewind stream) 193 | (stream-write-struct stream struct) 194 | (rewind stream) 195 | (stream-read-struct stream)) 196 | (setf dynamic-time (- (get-internal-run-time) time) 197 | dynamic-bytes (- (gcbytes) bytes))) 198 | (let ((time (get-internal-run-time)) 199 | (bytes (gcbytes))) 200 | (dotimes (i count) 201 | (rewind stream) 202 | (stream-write-struct stream struct 'test-large-struct) 203 | (rewind stream) 204 | (stream-read-struct stream 'test-large-struct)) 205 | (setf static-time (- (get-internal-run-time) time) 206 | static-bytes (- (gcbytes) bytes))) 207 | (let ((time (get-internal-run-time)) 208 | (bytes (gcbytes))) 209 | (dotimes (i count) 210 | (rewind stream) 211 | (stream-write-struct stream struct 'test-large-struct) 212 | (rewind stream) 213 | (stream-read-struct stream 'test-large-struct result)) 214 | (setf static-with-time (- (get-internal-run-time) time) 215 | static-with-bytes (- (gcbytes) bytes))) 216 | (format *trace-output* "~%~d,~10T~d,~20T~d,~36T~d,~52T~d,~68T~d,~84T~d,~100T~d" 217 | slot-count bound-count 218 | dynamic-time static-time static-with-time 219 | dynamic-bytes static-bytes static-with-bytes)))))) 220 | ;;; (time-struct-io) -------------------------------------------------------------------------------- /server.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- 2 | 3 | (in-package :org.apache.thrift.implementation) 4 | 5 | ;;; This file implements service instance and a server interface for the `org.apache.thrift` library. 6 | ;;; 7 | ;;; copyright 2010 [james anderson](james.anderson@setf.de) 8 | ;;; 9 | ;;; Licensed to the Apache Software Foundation (ASF) under one 10 | ;;; or more contributor license agreements. See the NOTICE file 11 | ;;; distributed with this work for additional information 12 | ;;; regarding copyright ownership. The ASF licenses this file 13 | ;;; to you under the Apache License, Version 2.0 (the 14 | ;;; "License"); you may not use this file except in compliance 15 | ;;; with the License. You may obtain a copy of the License at 16 | ;;; 17 | ;;; http://www.apache.org/licenses/LICENSE-2.0 18 | ;;; 19 | ;;; Unless required by applicable law or agreed to in writing, 20 | ;;; software distributed under the License is distributed on an 21 | ;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 22 | ;;; KIND, either express or implied. See the License for the 23 | ;;; specific language governing permissions and limitations 24 | ;;; under the License. 25 | 26 | 27 | ;;; The principal Thrift entity for reomte interaction is the `service`. A service is a named 28 | ;;; collection of operations. A server associates a service with a listening port, accepts 29 | ;;; request for named operations, decodes and dsipatchs data to the service's operations, 30 | ;;; encodes the results and returns them them to thr requesting client. 31 | 32 | 33 | (defclass service () 34 | ((identifier 35 | :initform nil :initarg :identifier 36 | :reader service-identifier 37 | :documentation "The service's external identifier, as specified in its definition. 38 | It appears in descriptions only and otherwise does not figure in the protocol.") 39 | (package 40 | :initform *package* :initarg :package 41 | :type package 42 | :reader service-package 43 | :documentation "The 'namespace' within which the service's constituent methods and types are defined. 44 | It is asserted when encoding/decoding a message intended for / generated by the service.") 45 | (base-services 46 | :initform nil :initarg :base-services 47 | :type list 48 | :accessor service-base-services) 49 | (methods 50 | :reader service-methods 51 | :type hash-table 52 | :documentation "An equal hash table which registers the methods defined directly for the 53 | service. The keys are strings, since, at the point when the message start is read, the package for 54 | just the immediate service is known. This would make the symbols from a single included base service 55 | visible, but not those of anything which it includes. Only one a method has been identified does its 56 | its package determine the home package to intern names.") 57 | (documentation 58 | :initform nil :initarg :documentation 59 | :accessor service-documentation)) 60 | (:documentation "A named service associates methods with their names. When created with def-service 61 | each service is bound to a global parameter named as its Lisp equivalent. A service can also 62 | serve as the root for a set of subsidiary services, to which it defers method look-ups.")) 63 | 64 | 65 | (defclass server () 66 | ((services 67 | :initform nil :initarg :services 68 | :accessor server-services 69 | :documentation "A sequence of services, each of which binds its set of operators 70 | to external names. When accepting a message, the server locates some service which 71 | can respond toit, and delegates the processing to that service. If none is found 72 | an exception is returned.")) 73 | (:documentation "A server associates a root service with a request transport.")) 74 | 75 | 76 | (defclass socket-server (server) 77 | ((socket :accessor server-socket :initarg :socket)) 78 | (:documentation "The server class which combines services with a listening socket.")) 79 | 80 | 81 | (defclass thrift (puri:uri) 82 | () 83 | (:documentation "A specialized URI class to distinguish Thrift locations when constructing a 84 | server.")) 85 | 86 | 87 | ;;; 88 | ;;; service operators 89 | 90 | (defmethod initialize-instance :after ((instance service) &key methods) 91 | (etypecase methods 92 | (hash-table (setf (slot-value instance 'methods) methods)) 93 | (list (setf (slot-value instance 'methods) 94 | (let ((map (make-hash-table :test 'equal))) 95 | (loop for (name . implementation) in methods 96 | do (setf (gethash name map) implementation)) 97 | map))))) 98 | 99 | (defmethod print-object ((object service) stream) 100 | (print-unreadable-object (object stream :identity t :type t) 101 | (format stream "~@[~a~]" (service-identifier object)))) 102 | 103 | (defgeneric method-definition (service identifier) 104 | (:method ((service service) (identifier string)) 105 | (let ((fun (gethash identifier (service-methods service)))) 106 | (if fun 107 | (values fun service) 108 | (dolist (base-service (service-base-services service)) 109 | (multiple-value-bind (fun service) 110 | (method-definition identifier base-service) 111 | (when fun (return-from method-definition (values fun service))))))))) 112 | 113 | (defgeneric (setf method-definition) (function service identifier) 114 | (:method ((function thrift-generic-function) (service service) (identifier string)) 115 | (setf (gethash identifier (service-methods service)) function)) 116 | (:method ((function null) (service service) (identifier string)) 117 | (remhash identifier (service-methods service)))) 118 | 119 | 120 | ;;; 121 | ;;; server operators 122 | 123 | (defgeneric server-input-transport (server connection) 124 | (:method ((server socket-server) (socket usocket:usocket)) 125 | (make-instance 'socket-transport :socket socket :direction :input))) 126 | 127 | (defgeneric server-output-transport (server connection) 128 | (:method ((server socket-server) (socket usocket:usocket)) 129 | (make-instance 'socket-transport :socket socket :direction :output))) 130 | 131 | 132 | (defmethod accept-connection ((s socket-server)) 133 | (usocket:socket-accept (server-socket s) :element-type 'unsigned-byte)) 134 | 135 | (defmethod server-close ((s socket-server)) 136 | (usocket:socket-close (server-socket s))) 137 | 138 | (defgeneric server-protocol (server input output) 139 | (:method ((server socket-server) input output) 140 | (make-instance 'binary-protocol :input-transport input :output-transport output 141 | :direction :io))) 142 | 143 | 144 | (defparameter *debug-server* t) 145 | 146 | (defgeneric serve (connection-server service) 147 | (:documentation "Accept to a CONNECTION-SERVER, configure the CLIENT's transport and protocol 148 | in combination with the connection, and process messages until the connection closes.") 149 | 150 | (:method ((location thrift) service) 151 | "Given a basic thrift uri, open a binary socket server and listen on the port." 152 | (let ((server (make-instance 'socket-server 153 | :socket (usocket:socket-listen (puri:uri-host location) (puri:uri-port location) 154 | :element-type 'unsigned-byte 155 | :reuseaddress t)))) 156 | (unwind-protect (serve server service) 157 | (server-close server)))) 158 | 159 | (:method ((s socket-server) (service service)) 160 | (loop 161 | (let ((connection (accept-connection s))) 162 | (if (open-stream-p (usocket:socket-stream connection)) 163 | (let* ((input-transport (server-input-transport s connection)) 164 | (output-transport (server-output-transport s connection)) 165 | (protocol (server-protocol s input-transport output-transport))) 166 | (unwind-protect (block :process-loop 167 | (handler-bind ((end-of-file (lambda (eof) 168 | (declare (ignore eof)) 169 | (return-from :process-loop))) 170 | (error (lambda (error) 171 | (if *debug-server* 172 | (break "Server error: ~s: ~a" s error) 173 | (warn "Server error: ~s: ~a" s error)) 174 | (stream-write-exception protocol error) 175 | (return-from :process-loop)))) 176 | (loop (unless (open-stream-p input-transport) (return)) 177 | (process service protocol)))) 178 | (close input-transport) 179 | (close output-transport))) 180 | ;; listening socket closed 181 | (return)))))) 182 | 183 | 184 | (defgeneric process (service protocol) 185 | (:documentation "Combine a service PEER with an input-protocol and an output-protocol to control processing 186 | the next message on the peer's input connection. The base method reads the message, decodes the 187 | function and the arguments, invokes the method, and replies with the results. 188 | The protocols are initially those of the peer itself, but they are passed her in order to permit 189 | wrapping for logging, etc.") 190 | 191 | (:method ((service service) (protocol t)) 192 | (flet ((consume-message () 193 | (prog1 (stream-read-struct protocol) 194 | (stream-read-message-end protocol)))) 195 | (multiple-value-bind (request-identifier type sequence-number) 196 | (stream-read-message-begin protocol) 197 | (ecase type 198 | ((call oneway) 199 | (multiple-value-bind (request-method service) 200 | (method-definition service request-identifier) 201 | (cond (request-method 202 | (let ((*package* (service-package service))) 203 | (funcall request-method service sequence-number protocol))) 204 | (t 205 | (unknown-method protocol request-identifier sequence-number (consume-message)))))) 206 | (reply 207 | (unexpected-response protocol request-identifier sequence-number (consume-message))) 208 | (exception 209 | (request-exception protocol request-identifier sequence-number (consume-message)))))))) 210 | 211 | 212 | -------------------------------------------------------------------------------- /conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- 2 | 3 | (in-package :org.apache.thrift.implementation) 4 | 5 | ;;; This file defines exception classes and signaling operators for the `org.apache.thrift` library. 6 | ;;; 7 | ;;; copyright 2010 [james anderson](james.anderson@setf.de) 8 | ;;; 9 | ;;; Licensed to the Apache Software Foundation (ASF) under one 10 | ;;; or more contributor license agreements. See the NOTICE file 11 | ;;; distributed with this work for additional information 12 | ;;; regarding copyright ownership. The ASF licenses this file 13 | ;;; to you under the Apache License, Version 2.0 (the 14 | ;;; "License"); you may not use this file except in compliance 15 | ;;; with the License. You may obtain a copy of the License at 16 | ;;; 17 | ;;; http://www.apache.org/licenses/LICENSE-2.0 18 | ;;; 19 | ;;; Unless required by applicable law or agreed to in writing, 20 | ;;; software distributed under the License is distributed on an 21 | ;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 22 | ;;; KIND, either express or implied. See the License for the 23 | ;;; specific language governing permissions and limitations 24 | ;;; under the License. 25 | 26 | 27 | ;;; The exception hierarchy is rooted in thrift-error and mixes in other standard 28 | ;;; conditions as appropriate for the excpetion attributes 29 | ;;; 30 | ;;; thrift-error 31 | ;;; - application-error 32 | ;;; - protocol-error 33 | ;;; - protocol-version-error 34 | ;;; - protocol-type-error (type-error) 35 | ;;; - unknown-field-error (cell-error) 36 | ;;; - field-type-error (type-error) 37 | ;;; - transport-error 38 | ;;; 39 | 40 | 41 | ;;; abstract exceptions 42 | 43 | (define-condition thrift-error (simple-error) 44 | ((type 45 | :initform *protocol-ex-unknown* 46 | :reader thrift-error-type)) 47 | (:report (lambda (error stream) 48 | (apply #'format stream (thrift-error-format-control error) 49 | (thrift-error-format-arguments error))))) 50 | 51 | (defgeneric thrift-error-format-control (error) 52 | (:method ((error thrift-error)) 53 | "~(~a~): ~a.")) 54 | 55 | (defgeneric thrift-error-format-arguments (error) 56 | (:method ((error thrift-error)) 57 | (list (type-of error) (thrift-error-type error)))) 58 | 59 | 60 | 61 | (define-condition protocol-error (thrift-error) 62 | ((protocol :initarg :protocol :initform nil 63 | :reader protocol-error-protocol))) 64 | 65 | (defmethod thrift-error-format-control ((error protocol-error)) 66 | (concatenate 'string (call-next-method) 67 | " connection: ~a.")) 68 | 69 | (defmethod thrift-error-format-arguments ((error protocol-error)) 70 | (append (call-next-method) 71 | (list (protocol-error-protocol error)))) 72 | 73 | 74 | 75 | (define-condition transport-error (thrift-error) ()) 76 | 77 | 78 | 79 | (define-condition application-error (protocol-error) 80 | ((type :initform *application-ex-unknown*) 81 | (condition :initform nil :initarg :condition :reader application-error-condition))) 82 | 83 | (defmethod thrift-error-format-control ((error application-error)) 84 | (concatenate 'string (call-next-method) 85 | "~@[ condition: ~a.~]")) 86 | 87 | (defmethod thrift-error-format-arguments ((error application-error)) 88 | (append (call-next-method) 89 | (list (application-error-condition error)))) 90 | 91 | 92 | (defmethod thrift:type-of ((value thrift-error)) 93 | 'struct) 94 | 95 | 96 | ;;; 97 | ;;; general exception response 98 | 99 | (thrift:def-exception "ResponseException" 100 | "The general 'exception' response exception" 101 | (("why" nil :id 1 :type string) 102 | ("id" nil :id 2 :type i16))) 103 | 104 | ;;; 105 | ;;; concrete exceptions 106 | 107 | (define-condition class-not-found-error (protocol-error) 108 | ((identifier 109 | :initarg :identifier :reader class-not-found-error-identifier 110 | :documentation "The external identifier name for the unknown class."))) 111 | 112 | (defmethod thrift-error-format-control ((error class-not-found-error)) 113 | (concatenate 'string (call-next-method) 114 | " class not found: ~a.")) 115 | 116 | (defmethod thrift-error-format-arguments ((error class-not-found-error)) 117 | (append (call-next-method) 118 | (list (class-not-found-error-identifier error)))) 119 | 120 | 121 | 122 | (define-condition protocol-version-error (protocol-error type-error) 123 | ((type :initform *protocol-ex-bad-version*))) 124 | 125 | (defmethod thrift-error-format-control ((error protocol-version-error)) 126 | (concatenate 'string (call-next-method) 127 | " protocol version does not match: ~s, expected ~s.")) 128 | 129 | (defmethod thrift-error-format-arguments ((error protocol-version-error)) 130 | (append (call-next-method) 131 | (list (type-error-datum error) (type-error-expected-type error)))) 132 | 133 | 134 | 135 | 136 | (define-condition element-type-error (protocol-error type-error) 137 | ((type :initform *protocol-ex-invalid-data*) 138 | (element-type :initarg :element-type :reader element-type-error-element-type) 139 | (container-type :initarg :container-type :reader element-type-error-container-type))) 140 | 141 | (defmethod thrift-error-format-control ((error element-type-error)) 142 | (concatenate 'string (call-next-method) 143 | " element type is invalid for container: ~s: ~s, ~s.")) 144 | 145 | (defmethod thrift-error-format-arguments ((error element-type-error)) 146 | (append (call-next-method) 147 | (list (element-type-error-container-type error) 148 | (element-type-error-element-type error) 149 | (type-error-expected-type error)))) 150 | 151 | 152 | 153 | (define-condition enum-type-error (protocol-error type-error) 154 | ((type :initform *protocol-ex-invalid-data*))) 155 | 156 | (defmethod thrift-error-format-control ((error enum-type-error)) 157 | (concatenate 'string (call-next-method) 158 | " value not of enum type: ~s, expected ~s.")) 159 | 160 | (defmethod thrift-error-format-arguments ((error enum-type-error)) 161 | (append (call-next-method) 162 | (list (type-error-datum error) (type-error-expected-type error)))) 163 | 164 | 165 | 166 | (define-condition field-size-error (protocol-error type-error cell-error) 167 | ((type :initform *protocol-ex-size-limit*) 168 | (number :initarg :number :reader field-size-error-number)) 169 | (:default-initargs :expected-type 'field-size)) 170 | 171 | (defmethod thrift-error-format-control ((error field-size-error)) 172 | (concatenate 'string (call-next-method) 173 | " field size invalid: (~s: ~a): ~s, expected ~s.")) 174 | 175 | (defmethod thrift-error-format-arguments ((error field-size-error)) 176 | (append (call-next-method) 177 | (list (field-size-error-number error) 178 | (cell-error-name error) 179 | (type-error-datum error) 180 | (type-error-expected-type error)))) 181 | 182 | 183 | 184 | (define-condition field-type-error (protocol-error type-error cell-error) 185 | ((type :initform *protocol-ex-invalid-data*) 186 | (structure-type :initarg :structure-type :reader field-type-error-structure-type) 187 | (number :initarg :number :reader field-type-error-number))) 188 | 189 | (defmethod thrift-error-format-control ((error field-type-error)) 190 | (concatenate 'string (call-next-method) 191 | " field value type is invalid for structure: ~s: (~s: ~a ~a) = ~s.")) 192 | 193 | (defmethod thrift-error-format-arguments ((error field-type-error)) 194 | (append (call-next-method) 195 | (list (field-type-error-structure-type error) 196 | (field-type-error-number error) 197 | (type-error-expected-type error) 198 | (cell-error-name error) 199 | (type-error-datum error)))) 200 | 201 | 202 | 203 | (define-condition sequence-number-error (application-error) 204 | ((type :initform *application-ex-bad-sequence-id*) 205 | (number :initarg :number :reader sequence-number-error-number) 206 | (expected-number :initarg :expected-number :reader sequence-number-error-expected-number))) 207 | 208 | 209 | (defmethod thrift-error-format-control ((error sequence-number-error)) 210 | (concatenate 'string (call-next-method) 211 | " sequence number does not match: ~s, expected ~s.")) 212 | 213 | (defmethod thrift-error-format-arguments ((error sequence-number-error)) 214 | (append (call-next-method) 215 | (list (sequence-number-error-number error) (sequence-number-error-expected-number error)))) 216 | 217 | 218 | 219 | 220 | (define-condition unknown-field-error (protocol-error cell-error) 221 | ((type :initform *protocol-ex-invalid-data*) 222 | (structure-type :initarg :structure-type :reader unknown-field-error-structure-type) 223 | (number :initarg :number :reader unknown-field-error-number) 224 | (datum :initarg :datum :reader unknown-field-error-datum))) 225 | 226 | (defmethod thrift-error-format-control ((error unknown-field-error)) 227 | (concatenate 'string (call-next-method) 228 | " field is not defined for struct type: ~s: (~s: ~a) = ~s.")) 229 | 230 | (defmethod thrift-error-format-arguments ((error unknown-field-error)) 231 | (append (call-next-method) 232 | (list (unknown-field-error-structure-type error) 233 | (unknown-field-error-number error) 234 | (cell-error-name error) 235 | (unknown-field-error-datum error)))) 236 | 237 | 238 | 239 | (define-condition unknown-method-error (protocol-error ) 240 | ((type :initform *application-ex-unknown-method*) 241 | (identifier :initarg :identifier :reader unknown-method-error-identifier) 242 | (request :initarg :request :reader unknown-method-error-request))) 243 | 244 | (defmethod thrift-error-format-control ((error unknown-method-error)) 245 | (concatenate 'string (call-next-method) 246 | " unknown method in request: ~s, ~s.")) 247 | 248 | (defmethod thrift-error-format-arguments ((error unknown-method-error)) 249 | (append (call-next-method) 250 | (list (unknown-method-error-identifier error) 251 | (unknown-method-error-request error)))) 252 | 253 | 254 | 255 | (define-condition struct-type-error (protocol-error type-error) 256 | ((type :initform *protocol-ex-invalid-data*))) 257 | 258 | (defmethod thrift-error-format-control ((error struct-type-error)) 259 | (concatenate 'string (call-next-method) 260 | " struct is not expected type: ~s, expected ~s.")) 261 | 262 | (defmethod thrift-error-format-arguments ((error struct-type-error)) 263 | (append (call-next-method) 264 | (list (type-error-datum error) 265 | (type-error-expected-type error)))) 266 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Thrift Common Lisp Library 2 | 3 | License 4 | ======= 5 | 6 | Licensed to the Apache Software Foundation (ASF) under one 7 | or more contributor license agreements. See the NOTICE file 8 | distributed with this work for additional information 9 | regarding copyright ownership. The ASF licenses this file 10 | to you under the Apache License, Version 2.0 (the 11 | "License"); you may not use this file except in compliance 12 | with the License. You may obtain a copy of the License at 13 | 14 | http://www.apache.org/licenses/LICENSE-2.0 15 | 16 | Unless required by applicable law or agreed to in writing, 17 | software distributed under the License is distributed on an 18 | "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 19 | KIND, either express or implied. See the License for the 20 | specific language governing permissions and limitations 21 | under the License. 22 | 23 | 24 | 25 | Using Trift with Common Lisp 26 | ============================ 27 | 28 | Thrift is a protocol and library for language-independent communication between cooperating 29 | processes. The communication takes the form of request and response messages, of which the forms 30 | are specified in advance throufh a shared interface definition. A Thrift definition file is translated 31 | into Lisp source files, which comprise several definitions: 32 | 33 | * Three packages, one for the namespace of the implementation operators, and one each for request and 34 | response operators. 35 | * Various type definitions as implementations for Thrift typedef and enum definitions. 36 | * DEF-STRUCT and DEF-EXCEPTION forms for Thrift struct and exception definitions. 37 | * DEF-SERVICE forms for thrift service definitions. 38 | 39 | Each service definition expands in a collection of generic function definitions. For each `op` 40 | in the service definition, two functions are defined 41 | 42 | * `op`-request is defined for use by a client. It accepts an additional initial `protocol` argument, 43 | to act as the client proxy for the operation and mediate the interaction with a remote process 44 | through a Thrift-encoded transport stream. 45 | * `op`-response is defined for use by a server. It accepts a single `protocol` argument. A server 46 | uses it to decode the request message, invoke the base `op` function with the message arguments, 47 | encode and send the the result as a response, and handles exceptions. 48 | 49 | The client interface is one operator 50 | 51 | * `with-client (variable location) . body` : creates a connection in a dynamic context and closes it 52 | upon exit. The variable is bound to a client proxy stream/protocol instance, which wraps the 53 | base i/o stream - socket, file, etc, with an operators which implement the Thrift protocol 54 | and transport mechanisms. 55 | 56 | The server interface combines server and service objects 57 | 58 | * `serve (location service)` : accepts connections on the designated port and responds to 59 | requests of the service's operations. 60 | 61 | 62 | Building 63 | -------- 64 | 65 | The Thrift Common Lisp library is packaged as the ASDF[[1]] system `thrift`. 66 | It depends on the systems 67 | 68 | * puri-ppcre[[2]] : for the thrift uri class 69 | * closer-mop[[3]] : for class metadata 70 | * trivial-utf-8[[4]] : for string codecs 71 | 72 | In order to build it, register those systems with ASDF and evaluate 73 | 74 | (asdf:load-system :thrift) 75 | 76 | This will compile and load the Lisp compiler for Thrift definition files, the 77 | transport and protocol implementations, and the client and server interface 78 | functions. In order to use Thrift in an application, one must also author and/or 79 | load the interface definitions for the remote service.[[5]] If one is implementing a service, 80 | one must also define the actual functions to which Thrift is to act as the proxy 81 | interface. The remainder of this document follows the Thrift tutorial to illustrate how 82 | to perform the steps 83 | 84 | * implement the service 85 | * translate the Thrift IDL 86 | * load the Lisp service interfaces 87 | * run a server for the service 88 | * use a client to access the service remotely 89 | 90 | Note that, if one is to implement a new service, one will also need to author the 91 | IDL files, as there is no facility to generate them from a service implementation. 92 | 93 | 94 | Implement the Service 95 | --------------------- 96 | 97 | The tutorial comprises serveral functions: `add`, `ping`, `zip`, and `calculate`. 98 | Each translatd IDL corresponds to three packages. In this case, the packages 99 | 100 | * :tutorial 101 | * :tutorial-implementation 102 | * :tutorial-response 103 | 104 | The first package is for the service implementation. 105 | 106 | ;; define the base operations 107 | 108 | (in-package :tutorial-implementation) 109 | 110 | (defun add ( num1 num2) 111 | (format t "~&Asked to add ~A and ~A." num1 num2) 112 | (+ num1 num2)) 113 | 114 | (defun ping () 115 | (print :ping)) 116 | 117 | (defun zip () 118 | (print :zip)) 119 | 120 | (defun calculate (logid task) 121 | (calculate-op (work-op task) (work-num1 task) (work-num2 task))) 122 | 123 | (defgeneric calculate-op (op arg1 arg2) 124 | (:method :around (op arg1 arg2) 125 | (let ((result (call-next-method))) 126 | (format t "~&Asked to calculate: ~d on ~A and ~A = ~d." op arg1 arg2 result) 127 | result)) 128 | 129 | (:method ((op (eql operation.add)) arg1 arg2) 130 | (+ arg1 arg2)) 131 | (:method ((op (eql operation.subtract)) arg1 arg2) 132 | (- arg1 arg2)) 133 | (:method ((op (eql operation.multiply)) arg1 arg2) 134 | (* arg1 arg2)) 135 | (:method ((op (eql operation.divide)) arg1 arg2) 136 | (/ arg1 arg2))) 137 | 138 | (defun zip () (print 'zip)) 139 | 140 | 141 | Translate the Thrift IDL 142 | ------------------------ 143 | 144 | IDL files employ the file type `thrift`. In this case, there are two files to translate 145 | * `tutorial.thrift` 146 | * `shared.thrift` 147 | As the former includes the latter, one uses it to generate the interfaces: 148 | 149 | $THRIFT/bin/thrift -O ./ --gen cl $THRIFT/tutorial/tutorial.thrift 150 | 151 | For the moment, the Lisp backend is present here as #P"THRIFT:compiler;cpp;src;generate;t_cl_generator.cc". 152 | In order to use it, copy that file into the analogous location in the Thrift release tree prior to 153 | making thrift. 154 | 155 | 156 | Load the Lisp translated service interfaces 157 | ------------------------------------------- 158 | 159 | The translator generates two files for each IDL file. For example `tutorial-types.lisp` and 160 | `tutorial-vars.lisp`. As the parameter definitions may istantiate objects defined in the `-types` 161 | file, the ASDF dependencies must reflect this constraint. For the tutorial, the system could be 162 | defined as 163 | 164 | (asdf:defsystem :thrift-tutorial 165 | :depends-on (:thrift) 166 | :serial t 167 | :components ((:file "tutorial") 168 | (:file "tutorial-types") 169 | (:file "tutorial-vars"))) 170 | 171 | 172 | Run a Server for the Service 173 | ---------------------------- 174 | 175 | The actual service name, as specified in the `def-service` form in `tutorial.lisp`, is `calculator`. 176 | Each service definition defines a global variable with the service name and binds it to a 177 | service instance whch describes the operations. 178 | 179 | In order to start a service, specify a location and the service instance. 180 | 181 | (in-package :tutorial) 182 | (serve #u"thrift://127.0.0.1:9091" calculator) 183 | 184 | 185 | Use a Client to Access the Service Remotely 186 | ------------------------------------------- 187 | 188 | 189 | [in some other process] run the client 190 | 191 | (in-package :cl-user) 192 | (use-package :tutorial-request) 193 | 194 | (macrolet ((show (form) 195 | `(format *trace-output* "~%~s =>~{ ~s~}" 196 | ',form 197 | (multiple-value-list (ignore-errors ,form))))) 198 | (with-client (protocol #u"thrift://127.0.0.1:9091") 199 | (show (ping protocol)) 200 | (show (add protocol 1 2)) 201 | (show (add protocol 1 4)) 202 | 203 | (show (shared:get-struct protocol 1)) 204 | 205 | (let ((task (make-instance 'work 206 | :op operation.subtract :num1 15 :num2 10))) 207 | (show (calculate protocol task)) 208 | 209 | (setf (work-op task) operation.divide 210 | (work-num1 task) 1 211 | (work-num2 task) 0) 212 | (show (calculate protocol task))) 213 | 214 | (show (zip protocol)))) 215 | 216 | 217 | Status 218 | ====== 219 | 220 | The initial library version serves as an interface to Cassandra[[6]] in order to provide access to 221 | Datagraph's Cassandra-based RDF store[[7]]. The code evolved from an initial version which had been 222 | submitted to Thift in 2008[[8]]. 223 | 224 | A demonstration of access through the Cassandra API is among the READMES[[9]]. 225 | 226 | Issues 227 | ------ 228 | 229 | ### optional fields 230 | Where the IDL declares a field options, the def-struct form includes no 231 | initform for the slot and the encoding operator skips an unbound slot. This leave some ambiguity 232 | with bool fields. 233 | 234 | ### namespace - package equivalence 235 | The IDL specifies a single namespace. The Lisp binding uses 236 | three: the implementation, the request interface, and the response interface. 237 | The current pattern is: 238 | 239 | * _namespace_ : request proxy function, structure types and accessors, exception types, 240 | enum types, constants; use `:thrift` 241 | * _namespace_`-implementation` : implementation function, use `:thrift`, use _namespace_, but 242 | shadow all implementation function names. 243 | * _namespace_`-response` : response functions 244 | 245 | ### instantiation protocol : 246 | struct classes are standard classes and exception classes are 247 | whatever the implementation prescribes. decoders apply make-struct to an initargs list. 248 | particularly at the service end, there are advantages to resourcing structs and decoding 249 | with direct side-effects on slot-values 250 | 251 | ### maps: 252 | 253 | Maps are now represented as hash tables. As data through the call/reply interface is all statically 254 | typed, it is not necessary for the objects to themselves indicate the coding form. Association lists 255 | would be sufficient. As the key type is arbitrary, property lists offer no additional convenience: 256 | as `getf` operates with `eq` a new access interface would be necessary and they would not be 257 | available for function application. 258 | 259 | 260 | [1]: www.common-lisp.net/asdf 261 | [2]: http://github.com/lisp/com.b9.puri.ppcre 262 | [3]: www.common-lisp.net/closer-mop 263 | [4]: trivial-utf-8 264 | [5]: http://wiki.apache.org/thrift/ThriftGeneration 265 | [6]: http://wiki.apache.org/cassandra/FrontPage 266 | [7]: http://github.com/bendiken/rdf-cassandra 267 | [8]: http://markmail.org/thread/4tfa3zbweyg2qwne: thrift jira lisp issue 268 | [9]: ./READMES/readme-cassandra.lisp 269 | -------------------------------------------------------------------------------- /float.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- 2 | 3 | (in-package :org.apache.thrift.implementation) 4 | 5 | ;;; This file defines codec operators for ieee short and long float data for the `org.apache.thrift` library. 6 | ;;; 7 | ;;; copyright 2010 [james anderson](james.anderson@setf.de) 8 | ;;; 9 | ;;; Licensed to the Apache Software Foundation (ASF) under one 10 | ;;; or more contributor license agreements. See the NOTICE file 11 | ;;; distributed with this work for additional information 12 | ;;; regarding copyright ownership. The ASF licenses this file 13 | ;;; to you under the Apache License, Version 2.0 (the 14 | ;;; "License"); you may not use this file except in compliance 15 | ;;; with the License. You may obtain a copy of the License at 16 | ;;; 17 | ;;; http://www.apache.org/licenses/LICENSE-2.0 18 | ;;; 19 | ;;; Unless required by applicable law or agreed to in writing, 20 | ;;; software distributed under the License is distributed on an 21 | ;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 22 | ;;; KIND, either express or implied. See the License for the 23 | ;;; specific language governing permissions and limitations 24 | ;;; under the License. 25 | ;;; 26 | ;;; 2010-06-29 excerpted from de.setf.amqp;data-wire-coding.lisp. 27 | ;;; validated for mcl-5.2, clozure-1.4, sbcl-1.0.35 28 | ;;; 29 | ;;; 30 | ;;; these functions implement portable translation from integer values and long/short floating point values 31 | ;;; float construction as described in the wikipedia pages. Translation in the other direction relies on 32 | ;;; runtime-specific access to the unmodified float components, as the standard deconstruction operators 33 | ;;; do not return the raw values and those changes would need to be inverted. 34 | ;;; 35 | ;;; there are various sources for information: 36 | ;;; * http://en.wikipedia.org/wiki/IEEE_754-2008 37 | ;;; * http://www.validlab.com/754R/nonabelian.com/754/comments/Q754.129.pdf 38 | ;;; * http://en.wikipedia.org/wiki/Single_precision_floating-point_format 39 | ;;; * http://en.wikipedia.org/wiki/Double_precision_floating-point_format 40 | ;;; * http://babbage.cs.qc.cuny.edu/IEEE-754/References.xhtml 41 | ;;; 42 | ;;; the latter is most directly useful as it depicts the corner-values for the respective domains 43 | ;;; and includes several pages for interactive conversions. 44 | ;;; 45 | ;;; internal operators: deconstruct a float value 46 | ;;; raw-decode-short-float 47 | ;;; raw-decode-long-float 48 | ;;; 49 | ;;; interface operators: convert between short/long float and integer 50 | ;;; ieee-754-32-integer-to-float 51 | ;;; ieee-754-64-integer-to-float 52 | ;;; ieee-754-32-float-to-integer 53 | ;;; ieee-754-64-float-to-integer 54 | ;;; 55 | ;;; test/examples forms are included inline conditional on :test.thrift 56 | ;;; 57 | 58 | 59 | (defun raw-decode-short-float (float) 60 | (etypecase float 61 | (short-float ) 62 | (long-float (setf float (float float 1.0s0)))) 63 | #+ccl (multiple-value-bind (fraction exponent sign) 64 | (ccl::fixnum-decode-short-float float) 65 | (values fraction exponent (plusp sign))) 66 | ;; from sbcl:src;code;float.lisp 67 | #+sbcl (let* ((bits (sb-kernel::single-float-bits (abs float))) 68 | (exp (ldb sb-vm:single-float-exponent-byte bits)) 69 | (sig (ldb sb-vm:single-float-significand-byte bits)) 70 | (sign (minusp (float-sign float)))) 71 | (values sig exp sign)) 72 | #-(or ccl sbcl) (error "NYI: fixnum-decode-short-float")) 73 | 74 | (defun raw-decode-long-float (float) 75 | (etypecase float 76 | (short-float (setf float (float float 1.0d0))) 77 | (long-float )) 78 | #+ccl (multiple-value-bind (hi lo exp sign) (ccl::%integer-decode-double-float float) 79 | (values (logior (ash hi 28) lo) exp (minusp sign))) 80 | #+sbcl (let* ((abs (abs float)) 81 | (hi (sb-kernel::double-float-high-bits abs)) 82 | (lo (sb-kernel::double-float-low-bits abs)) 83 | (exp (ldb sb-vm:double-float-exponent-byte hi)) 84 | ;(sig (ldb sb-vm:double-float-significand-byte hi)) 85 | (sign (minusp (float-sign float)))) 86 | (values 87 | (logior (ash (logior (ldb sb-vm:double-float-significand-byte hi) 88 | sb-vm:double-float-hidden-bit) 89 | 32) 90 | lo) 91 | exp sign)) 92 | #-(or ccl sbcl) (error "NYI: fixnum-decode-long-float")) 93 | 94 | 95 | 96 | (defun ieee-754-32-integer-to-float (integer) 97 | (let* ((negative-p (logbitp 31 integer)) 98 | (sign (if negative-p -1 +1)) 99 | (raw-exponent (ash (logand #x7f800000 integer) -23)) 100 | (exponent (- raw-exponent 127)) 101 | (fraction (logand #x007fffff integer))) 102 | (case raw-exponent 103 | (#xff 104 | (if (zerop fraction) 105 | (if negative-p single-float-negative-infinity single-float-positive-infinity) 106 | #-sbcl single-float-nan 107 | #+sbcl (eval 'single-float-nan))) 108 | (#x00 109 | ;; (print (cl:list :to-float sign raw-exponent exponent fraction)) 110 | (if (zerop fraction) 111 | (if negative-p -0.0s0 0.0s0) 112 | (float (* sign (* fraction (expt 2 (- exponent 22)))) single-float-epsilon))) 113 | (t 114 | ;; (print (cl:list :to-float sign raw-exponent exponent fraction)) 115 | (float (* sign (1+ (* fraction #.(expt 2 -23))) (expt 2 exponent)) 116 | single-float-epsilon))))) 117 | 118 | #+thrift.test 119 | (mapcar #'(lambda (x) (cl:list (format nil "#x~8,'0x" x) (ieee-754-32-integer-to-float x))) 120 | '(;; would need to bind more nan constants to distinguish the variations 121 | ;; (format nil "#x~8,'0x" (ieee-754-32-float-to-integer (ieee-754-32-integer-to-float #xffffffff))) quiet 122 | ;; (format nil "#x~8,'0x" (ieee-754-32-float-to-integer (ieee-754-32-integer-to-float #xFFC00000))) indeterminate 123 | ;; (format nil "#x~8,'0x" (ieee-754-32-float-to-integer (ieee-754-32-integer-to-float #xFF800001))) signaling 124 | #xFFFFFFFF #xFFC00001 #xFFC00000 #xFFBFFFFF #xFF800001 #xFF800000 125 | #xFF7FFFFF #x80800000 #x807FFFFF #x80000001 126 | #x80000000 #x0000000 127 | #x00000001 #x007FFFFF #x00800000 #x7F7FFFFF 128 | #x7F800000 #x7f800001 #x7FBFFFFF #x7FC00000 #x7fffffff 129 | ;; various numbers 130 | #x41c80000 #xc1c80000 #x3f800000 #xbf800000 131 | #x40000000 #xc0000000 #x3eaaaaab #xbeaaaaab)) 132 | 133 | 134 | (defun ieee-754-64-integer-to-float (integer) 135 | (let* ((negative-p (logbitp 63 integer)) 136 | (sign (if negative-p -1 +1)) 137 | (raw-exponent (ash (logand #x7ff0000000000000 integer) -52)) 138 | (exponent (- raw-exponent 1023)) 139 | (fraction (logand #x000fffffffffffff integer))) 140 | (case raw-exponent 141 | (#x7ff 142 | (if (zerop fraction) 143 | (if negative-p double-float-negative-infinity double-float-positive-infinity) 144 | #-sbcl double-float-nan 145 | #+sbcl (eval 'double-float-nan))) 146 | (#x000 147 | ;; (print (cl:list :to-float sign raw-exponent exponent fraction)) 148 | (if (zerop fraction) 149 | (if negative-p -0.0d0 0.0d0) 150 | (float (* sign (* fraction (expt 2 (- exponent 51)))) double-float-epsilon))) 151 | (t 152 | ;; (print (cl:list :to-float sign raw-exponent exponent fraction)) 153 | (float (* sign (1+ (* fraction #.(expt 2 -52))) (expt 2 exponent)) 154 | double-float-epsilon))))) 155 | 156 | #+thrift.test 157 | (mapcar #'(lambda (x) (cl:list (format nil "#x~16,'0x" x) (ieee-754-64-integer-to-float x))) 158 | '(#xFFFFFFFFFFFFFFFF #xFFF8000000000001 #xFFF8000000000000 #xFFF7FFFFFFFFFFFF #xFFF0000000000001 #xFFF0000000000000 159 | #xFFEFFFFFFFFFFFFF #x8010000000000000 #x800FFFFFFFFFFFFF #x8000000000000001 160 | #x8000000000000000 #x0000000000000000 161 | #x0000000000000001 #x000FFFFFFFFFFFFF #x0010000000000000 #x7FEFFFFFFFFFFFFF 162 | #x7FF0000000000000 #x7FF0000000000001 #x7FF7FFFFFFFFFFFF #x7FF8000000000000 #x7FFFFFFFFFFFFFFF 163 | #x4039000000000000 #xC039000000000000 #x3FF0000000000000 #xBFF0000000000000 164 | #x4000000000000000 #xC000000000000000 #x3FD5555555555555 #xBFD5555555555555)) 165 | 166 | 167 | (defun ieee-754-32-float-to-integer (float) 168 | (cond ((= float single-float-negative-infinity) 169 | #xff800000) 170 | ((= float single-float-positive-infinity) 171 | #x7f800000) 172 | ;; allow for sbcl inability to compile code with nan constants 173 | (#-sbcl (eql float single-float-nan) 174 | #+sbcl (sb-ext:float-nan-p float) 175 | ;; http://en.wikipedia.org/wiki/NaN#Encodings 176 | ;; http://java.sun.com/javase/6/docs/api/java/lang/Double.html#doubleToLongBits(double) 177 | #x7fc00000) 178 | ((= float 0.0s0) 179 | (if (minusp (float-sign float)) #x80000000 #x00000000)) 180 | (t 181 | (multiple-value-bind (fraction exponent sign) 182 | (raw-decode-short-float float) 183 | (if (zerop exponent) 184 | (logior (if sign #x80000000 0) 185 | (logand fraction #x007fffff)) 186 | (logior (if sign #x80000000 0) 187 | (ash exponent 23) 188 | (logand fraction #x007fffff))))))) 189 | 190 | #+thrift.test 191 | (remove t '(;; all NAN are encoded as positive silent 192 | #xFF800000 193 | #xFF7FFFFF #x80800000 #x807FFFFF #x80000001 194 | #x80000000 #x0000000 195 | #x00000001 #x007FFFFF #x00800000 #x7F7FFFFF 196 | #x7F800000 197 | ;; various numbers 198 | #x41c80000 #xc1c80000 #x3f800000 #xbf800000 199 | #x40000000 #xc0000000 #x3eaaaaab #xbeaaaaab) 200 | :key #'(lambda (x) 201 | (cond ((eql (ieee-754-32-float-to-integer (ieee-754-32-integer-to-float x)) x)) 202 | (t 203 | (warn "ieee-754-32 failed: #x~8,'0x -> ~d -> #x~8,'0x, ~d" 204 | x (ieee-754-32-integer-to-float x) 205 | (ieee-754-32-float-to-integer (ieee-754-32-integer-to-float x)) 206 | (ieee-754-32-integer-to-float (ieee-754-32-float-to-integer (ieee-754-32-integer-to-float x)))) 207 | x)))) 208 | 209 | 210 | (defun ieee-754-64-float-to-integer (float) 211 | (cond ((= float double-float-negative-infinity) 212 | #xfff0000000000000) 213 | ((= float double-float-positive-infinity) 214 | #x7ff0000000000000) 215 | ;; allow for sbcl inability to compile code with nan constants 216 | (#-sbcl (eql float double-float-nan) 217 | #+sbcl (sb-ext:float-nan-p float) 218 | ;; http://en.wikipedia.org/wiki/NaN#Encodings 219 | ;; http://java.sun.com/javase/6/docs/api/java/lang/Double.html#doubleToLongBits(double) 220 | #x7ff8000000000000) 221 | ((= float 0.0d0) 222 | (if (minusp (float-sign float)) #x8000000000000000 #x0000000000000000)) 223 | (t 224 | (multiple-value-bind (fraction exponent sign) 225 | (raw-decode-long-float float) 226 | (if (zerop exponent) 227 | (logior (if sign #x8000000000000000 0) 228 | (logand fraction #x000fffffffffffff)) 229 | (logior (if sign #x8000000000000000 0) 230 | (ash exponent 52) 231 | (logand fraction #x000fffffffffffff))))))) 232 | 233 | #+thrift.test 234 | (remove t '(;; all NAN are encoded as positive silent 235 | #xFFF0000000000000 236 | #xFFEFFFFFFFFFFFFF #x8010000000000000 #x800FFFFFFFFFFFFF #x8000000000000001 237 | #x8000000000000000 #x0000000000000000 238 | #x0000000000000001 #x000FFFFFFFFFFFFF #x0010000000000000 #x7FEFFFFFFFFFFFFF 239 | #x7FF8000000000000 240 | #x4039000000000000 #xC039000000000000 #x3FF0000000000000 #xBFF0000000000000 241 | #x4000000000000000 #xC000000000000000 #x3FD5555555555555 #xBFD5555555555555) 242 | :key #'(lambda (x) 243 | (cond ((eql (ieee-754-64-float-to-integer (ieee-754-64-integer-to-float x)) x)) 244 | (t 245 | (warn "ieee-754-64 failed: #x~16,'0x -> ~d -> #x~16,'0x, ~d" 246 | x (ieee-754-64-integer-to-float x) 247 | (ieee-754-64-float-to-integer (ieee-754-64-integer-to-float x)) 248 | (ieee-754-64-integer-to-float (ieee-754-64-float-to-integer (ieee-754-64-integer-to-float x)))) 249 | x)))) 250 | 251 | ;;; (ieee-754-64-integer-to-float #xFFF0000000000001) 252 | 253 | -------------------------------------------------------------------------------- /binary-protocol.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.apache.thrift.implementation; -*- 2 | 3 | (in-package :org.apache.thrift.implementation) 4 | 5 | ;;; This file defines the concrete `binary-protocol` layer for the `org.apache.thrift` library. 6 | ;;; 7 | ;;; copyright 2010 [james anderson](james.anderson@setf.de) 8 | ;;; 9 | ;;; Licensed to the Apache Software Foundation (ASF) under one 10 | ;;; or more contributor license agreements. See the NOTICE file 11 | ;;; distributed with this work for additional information 12 | ;;; regarding copyright ownership. The ASF licenses this file 13 | ;;; to you under the Apache License, Version 2.0 (the 14 | ;;; "License"); you may not use this file except in compliance 15 | ;;; with the License. You may obtain a copy of the License at 16 | ;;; 17 | ;;; http://www.apache.org/licenses/LICENSE-2.0 18 | ;;; 19 | ;;; Unless required by applicable law or agreed to in writing, 20 | ;;; software distributed under the License is distributed on an 21 | ;;; "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 22 | ;;; KIND, either express or implied. See the License for the 23 | ;;; specific language governing permissions and limitations 24 | ;;; under the License. 25 | 26 | ;;; 27 | ;;; classes 28 | 29 | (defclass binary-protocol (encoded-protocol) 30 | ((field-id-mode :initform :identifier-number :allocation :class) 31 | (struct-id-mode :initform :none :allocation :class)) 32 | (:default-initargs 33 | :version-id #x80 34 | :version-number #x01)) 35 | 36 | 37 | 38 | ;;; 39 | ;;; type code <-> name operators are specific to each protocol 40 | 41 | (defmethod type-code-name ((protocol binary-protocol) (type-code fixnum)) 42 | (or (car (rassoc type-code *binary-transport-types* :test #'eql)) 43 | (error "Invalid type code: ~s." type-code))) 44 | 45 | 46 | (defmethod type-name-code ((protocol binary-protocol) (type-name symbol)) 47 | (or (cdr (assoc type-name *binary-transport-types*)) 48 | (error "Invalid type name: ~s." type-name))) 49 | 50 | (defmethod type-name-code ((transport binary-protocol) (type-name cons)) 51 | (type-name-code transport (first type-name))) 52 | 53 | 54 | (defmethod message-type-code ((protocol binary-protocol) (message-name symbol)) 55 | (or (cdr (assoc message-name *binary-message-types*)) 56 | (error "Invalid message type name: ~s." message-name))) 57 | 58 | (defmethod message-type-name ((protocol binary-protocol) (type-code fixnum)) 59 | (or (car (rassoc type-code *binary-message-types* :test 'eql)) 60 | (error "Invalid message type code: ~s." type-code))) 61 | 62 | 63 | ;;; input 64 | 65 | (defmethod stream-read-type ((protocol binary-protocol)) 66 | (type-code-name protocol (stream-read-byte (protocol-input-transport protocol)))) 67 | 68 | (defmethod stream-read-message-type ((protocol binary-protocol)) 69 | (message-type-name protocol (stream-read-i16 protocol))) 70 | 71 | 72 | (defmethod stream-read-bool ((protocol binary-protocol)) 73 | (= (stream-read-byte (protocol-input-transport protocol)) 1)) 74 | 75 | (defmethod stream-read-i08 ((protocol binary-protocol)) 76 | (stream-read-byte (protocol-input-transport protocol))) 77 | 78 | (macrolet ((read-and-decode-integer (protocol byte-count &aux (bit-count (* byte-count 8))) 79 | `(let ((value 0) 80 | (buffer (make-array ,byte-count :element-type '(unsigned-byte 8)))) 81 | (declare (dynamic-extent buffer) 82 | (type (simple-array (unsigned-byte 8) (,byte-count)) buffer) 83 | (type (unsigned-byte ,(* byte-count 8)) value)) 84 | (stream-read-sequence (protocol-input-transport ,protocol) buffer) 85 | ,@(loop for i from 0 below byte-count 86 | collect `(setf value ,(if (= i 0) 87 | `(aref buffer ,i) 88 | `(+ (ash value 8) (aref buffer ,i))))) 89 | ;; (format *trace-output* "(in 0x~16,'0x)" value) 90 | (,(cons-symbol :org.apache.thrift.implementation 91 | :signed-byte- (prin1-to-string bit-count)) value)))) 92 | (defmethod stream-read-i16 ((protocol binary-protocol)) 93 | (read-and-decode-integer protocol 2)) 94 | 95 | (defmethod stream-read-i32 ((protocol binary-protocol)) 96 | (read-and-decode-integer protocol 4)) 97 | 98 | (defmethod stream-read-i64 ((protocol binary-protocol)) 99 | (read-and-decode-integer protocol 8))) 100 | 101 | 102 | (defmethod stream-read-double ((protocol binary-protocol)) 103 | #+allegro (let* ((buffer (make-array 8 :element-type *binary-transport-element-type*)) 104 | (b (stream-read-sequence protocol buffer))) 105 | (declare (dynamic-extent buffer)) 106 | (apply #'excl:shorts-to-double-float 107 | (mapcar #'bytes-int (list (subseq b 0 2) (subseq b 2 4) 108 | (subseq b 4 6) (subseq b 6 8))))) 109 | #-allegro (let ((value 0) 110 | (buffer (make-array 8 :element-type '(unsigned-byte 8)))) 111 | (declare (dynamic-extent buffer) 112 | (type (simple-array (unsigned-byte 8) (8)) buffer) 113 | (type (unsigned-byte 64) value)) 114 | (stream-read-sequence (protocol-input-transport protocol) buffer) 115 | ;; it it matters, could unwrap it with fewer intermediates saves 116 | (macrolet ((unpack-buffer () 117 | `(progn 118 | ,@(loop for i from 0 below 8 119 | collect `(setf value ,(if (= i 0) 120 | `(aref buffer ,i) 121 | `(+ (ash value 8) (aref buffer ,i)))))))) 122 | (unpack-buffer) 123 | (ieee-754-64-integer-to-float value)))) 124 | 125 | (defmethod stream-read-float ((protocol binary-protocol)) 126 | "As a special for for use with rdf - not part of the thrift. used just for specifically 127 | coded struct declarations." 128 | ;; this is not part of the thrift spec, but is useful elsewhere 129 | (let ((value 0) 130 | (buffer (make-array 4 :element-type '(unsigned-byte 8)))) 131 | (declare (dynamic-extent buffer) 132 | (type (simple-array (unsigned-byte 8) (4)) buffer) 133 | (type (unsigned-byte 32) value)) 134 | (stream-read-sequence (protocol-input-transport protocol) buffer) 135 | ;; it it matters, could unwrap it with fewer intermediates saves 136 | (macrolet ((unpack-buffer () 137 | `(progn 138 | ,@(loop for i from 0 below 4 139 | collect `(setf value ,(if (= i 0) 140 | `(aref buffer ,i) 141 | `(+ (ash value 8) (aref buffer ,i)))))))) 142 | (unpack-buffer) 143 | (ieee-754-32-integer-to-float value)))) 144 | 145 | 146 | (defmethod stream-read-string ((protocol binary-protocol)) 147 | (let* ((l (stream-read-i32 protocol)) 148 | (a (make-array l :element-type *binary-transport-element-type*))) 149 | (declare (dynamic-extent a)) 150 | (stream-read-sequence (protocol-input-transport protocol) a) 151 | (funcall (transport-string-decoder protocol) a))) 152 | 153 | 154 | (defmethod stream-read-binary ((protocol binary-protocol)) 155 | "Read an 'unencoded' binary array. 156 | Although the spec describes a 'byte' array, and elsewhere specifies bytes to be signed, that makes no 157 | sense. It contradicts the encoding for UTF and would be generally useless for binary data. The various 158 | extant language bindings read as if they either the issue or cast." 159 | 160 | (let* ((l (stream-read-i32 protocol)) 161 | (result (make-array l :element-type *binary-transport-element-type*))) 162 | ;; would need to check the length before trying stack allocation 163 | (stream-read-sequence (protocol-input-transport protocol) result) 164 | result)) 165 | 166 | 167 | 168 | 169 | ;;; output 170 | 171 | 172 | (defmethod stream-write-type ((protocol binary-protocol) type-name) 173 | (stream-write-byte (protocol-output-transport protocol) (type-name-code protocol type-name)) 174 | 1) 175 | 176 | (defmethod stream-write-message-type ((protocol binary-protocol) message-type-name) 177 | (stream-write-i16 protocol (message-type-code protocol message-type-name))) 178 | 179 | 180 | 181 | (defmethod stream-write-bool ((protocol binary-protocol) val) 182 | (stream-write-byte (protocol-output-transport protocol) (if val 1 0)) 183 | 1) 184 | 185 | 186 | (defmethod stream-write-i08 ((protocol binary-protocol) val) 187 | (stream-write-byte (protocol-output-transport protocol) val) 188 | 1) 189 | 190 | 191 | (macrolet ((encode-and-write-integer (protocol value byte-count) 192 | `(let ((buffer (make-array ,byte-count :element-type '(unsigned-byte 8)))) 193 | (declare (dynamic-extent buffer) 194 | (type (simple-array (unsigned-byte 8) (,byte-count)) buffer)) 195 | (assert (typep ,value '(signed-byte ,(* byte-count 8))) () 196 | 'type-error :datum ,value :expected-type '(signed-byte ,(* byte-count 8))) 197 | (locally (declare (type (signed-byte ,(* byte-count 8)) ,value)) 198 | ;; (format *trace-output* "~%(out 0x~16,'0x)" ,value) 199 | ,@(loop for i from (1- byte-count) downto 0 200 | append `((setf (aref buffer ,i) (logand #xff ,value)) 201 | (setf ,value (ash ,value -8)))) 202 | (stream-write-sequence (protocol-output-transport ,protocol) buffer) 203 | ,byte-count)))) 204 | ;; no sign conversion as shift&mask encodes the sign bit 205 | (defmethod stream-write-i16 ((protocol binary-protocol) val) 206 | (encode-and-write-integer protocol val 2)) 207 | 208 | (defmethod stream-write-i32 ((protocol binary-protocol) val) 209 | (encode-and-write-integer protocol val 4)) 210 | 211 | (defmethod stream-write-i64 ((protocol binary-protocol) val) 212 | (encode-and-write-integer protocol val 8))) 213 | 214 | 215 | (defmethod stream-write-double ((protocol binary-protocol) val) 216 | #+allegro (dolist (b (mapcar #'(lambda (x) (int-bytes x 2)) 217 | (multiple-value-list (excl:double-float-to-shorts 218 | (coerce val 'double-float))))) 219 | (stream-write-byte protocol b)) 220 | ;; distinct from i64, as it's unsigned 221 | #-allegro (let ((buffer (make-array 8 :element-type '(unsigned-byte 8))) 222 | (int-value (ieee-754-64-float-to-integer val))) 223 | (declare (dynamic-extent buffer) 224 | (type (simple-array (unsigned-byte 8) (8)) buffer) 225 | (type (unsigned-byte 64) int-value)) 226 | ;; if the conversion is correct, this is redundant, sbcl eliminate it 227 | (assert (typep int-value '(unsigned-byte 64)) () 228 | 'type-error :datum int-value :expected-type '(unsigned-byte 64)) 229 | ;; (format *trace-output* "~%(out 0x~16,'0x)" int-value) 230 | (macrolet ((pack-buffer () 231 | `(progn ,@(loop for i from 7 downto 0 232 | append `((setf (aref buffer ,i) (logand #xff int-value)) 233 | (setf int-value (ash int-value -8))))))) 234 | (pack-buffer)) 235 | (stream-write-sequence (protocol-output-transport protocol) buffer) 236 | 8)) 237 | 238 | (defmethod stream-write-float ((protocol binary-protocol) val) 239 | " Not part of the spec, but is useful elsewhere" 240 | ;; distinct from i34, as it's unsigned 241 | (let ((buffer (make-array 4 :element-type '(unsigned-byte 8))) 242 | (int-value (ieee-754-32-float-to-integer val))) 243 | (declare (dynamic-extent buffer) 244 | (type (simple-array (unsigned-byte 8) (4)) buffer) 245 | (type (unsigned-byte 32) int-value)) 246 | ;; if the conversion is correct, this is redundant, sbcl eliminate it 247 | (assert (typep int-value '(unsigned-byte 32)) () 248 | 'type-error :datum int-value :expected-type '(unsigned-byte 64)) 249 | ;; (format *trace-output* "~%(out 0x~16,'0x)" int-value) 250 | (macrolet ((pack-buffer () 251 | `(progn ,@(loop for i from 3 downto 0 252 | append `((setf (aref buffer ,i) (logand #xff int-value)) 253 | (setf int-value (ash int-value -8))))))) 254 | (pack-buffer)) 255 | (stream-write-sequence (protocol-output-transport protocol) buffer) 256 | 4)) 257 | 258 | 259 | (defmethod stream-write-string ((protocol binary-protocol) (string string) &optional (start 0) end) 260 | (assert (and (zerop start) (or (null end) (= end (length string)))) () 261 | "Substring writes are not supported.") 262 | (let ((bytes (funcall (transport-string-encoder protocol) string))) 263 | (stream-write-i32 protocol (length bytes)) 264 | (stream-write-sequence (protocol-output-transport protocol) bytes) 265 | (+ 4 (length bytes)))) 266 | 267 | (defmethod stream-write-string ((protocol binary-protocol) (bytes vector) &optional (start 0) end) 268 | (assert (and (zerop start) (or (null end) (= end (length bytes)))) () 269 | "Substring writes are not supported.") 270 | (stream-write-i32 protocol (length bytes)) 271 | (stream-write-sequence (protocol-output-transport protocol) bytes) 272 | (+ 4 (length bytes))) 273 | 274 | 275 | (defmethod stream-write-binary ((protocol binary-protocol) (bytes vector)) 276 | (let ((unsigned-bytes (make-array (length bytes) :element-type '(unsigned-byte 8)))) 277 | (stream-write-i32 protocol (length bytes)) 278 | (map-into unsigned-bytes #'unsigned-byte-8 bytes) 279 | (stream-write-sequence (protocol-output-transport protocol) unsigned-bytes) 280 | (+ 4 (length bytes)))) 281 | 282 | (defmethod stream-write-binary ((protocol binary-protocol) (string string)) 283 | (let ((bytes (funcall (transport-string-encoder protocol) string))) 284 | (stream-write-i32 protocol (length bytes)) 285 | (stream-write-sequence (protocol-output-transport protocol) bytes) 286 | (+ 4 (length bytes)))) 287 | --------------------------------------------------------------------------------