Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv10345/src

Modified Files: xml-rpc.lisp package.lisp Added Files: extensions.lisp Log Message:

- Add extensions.lisp, for the various add-on specs floating around that cluttered xml-rpc.lisp

- New file test-extensions.lisp, for testing them

- Add support for symbols client-side (encode them as strings)

- Extension system.getCapabilities: implemented, spec at http://groups.yahoo.com/group/xml-rpc/message/2897

- Add passing of symbols (encode them as strings)- Use standard error codes (spec at http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php), wonder about semantics of "internal xml-rpc error" vs "application error", pick one arbitrarily

Date: Thu Jun 17 12:43:11 2004 Author: rschlatte

Index: s-xml-rpc/src/xml-rpc.lisp diff -u s-xml-rpc/src/xml-rpc.lisp:1.3 s-xml-rpc/src/xml-rpc.lisp:1.4 --- s-xml-rpc/src/xml-rpc.lisp:1.3 Sun Jun 13 09:12:03 2004 +++ s-xml-rpc/src/xml-rpc.lisp Thu Jun 17 12:43:11 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xml-rpc.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $ +;;;; $Id: xml-rpc.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC protocol, ;;;; as documented on the website http://www.xmlrpc.com @@ -133,7 +133,7 @@

(defun print-xml-rpc-struct (xml-element stream depth) (declare (ignore depth)) - (format stream "#<XML-RPC-STRUCT~{ ~s~}>" (xml-rpc-struct-alist xml-element))) + (format stream "#<XML-RPC-STRUCT~{ ~S~}>" (xml-rpc-struct-alist xml-element)))

(defun get-xml-rpc-struct-member (struct member) "Get the value of a specific member of an XML-RPC-STRUCT" @@ -188,9 +188,9 @@

(defun encode-xml-rpc-value (arg stream) (princ "<value>" stream) - (cond ((stringp arg) + (cond ((or (stringp arg) (symbolp arg)) (princ "<string>" stream) - (print-string-xml arg stream) + (print-string-xml (string arg) stream) (princ "</string>" stream)) ((integerp arg) (format stream "<int>~d</int>" arg)) ((floatp arg) (format stream "<double>~f</double>" arg)) @@ -455,70 +455,44 @@ (let ((sym (find-symbol method-name *xml-rpc-package*))) (if (fboundp sym) sym nil)))

-;;; Introspection methods from http://xmlrpc.usefulinc.com/doc/reserved.html -;;; To be imported in *xml-rpc-package*. - -(defun |system.listMethods| () - "List the methods that are available on this server." - (let ((result nil)) - (do-symbols (sym *xml-rpc-package* (sort result #'string-lessp)) - (when (and (fboundp sym) (valid-xml-rpc-method-name-p (symbol-name sym))) - (push (symbol-name sym) result))))) - -(defun |system.methodSignature| (method-name) - "Dummy system.methodSignature implementation. There's no way - to get (and no concept of) required argument types in Lisp, so - this function always returns nil or errors." - (let ((method (find-xml-rpc-method method-name))) - (if method - ;; http://xmlrpc.usefulinc.com/doc/sysmethodsig.html says to - ;; return a non-array if the signature is not available - "n/a" - (error "Method ~A not found." method-name)))) - -(defun |system.methodHelp| (method-name) - "Returns the function documentation for the given method." - (let ((method (find-xml-rpc-method method-name))) - (if method - (or (documentation method 'function) "") - (error "Method ~A not found." method-name)))) - -(defun do-one-multicall (call-struct) - (let ((name (get-xml-rpc-struct-member call-struct :|methodName|)) - (params (get-xml-rpc-struct-member call-struct :|params|))) - (handler-bind - ((error #'(lambda (c) - (format-debug - (or *xml-rpc-debug-stream* t) - "A call in a system.multicall failed with ~a~%" c) - (return-from do-one-multicall - (xml-literal - (encode-xml-rpc-fault-value (format nil "~a" c))))))) - (format-debug (or *xml-rpc-debug-stream* t) - "system.multicall calling ~a with ~s~%" name params) - (let ((result (apply *xml-rpc-call-hook* name params))) - (list result))))) - -(defun |system.multicall| (calls) - "Implement system.multicall; see http://www.xmlrpc.com/discuss/msgReader$1208 - for the specification." - (mapcar #'do-one-multicall calls)) - (defun execute-xml-rpc-call (method-name &rest arguments) "Execute method METHOD-NAME on ARGUMENTS, or raise an error if no such method exists in *XML-RPC-PACKAGE*" (let ((method (find-xml-rpc-method method-name))) (if method (apply method arguments) - (error "Method ~A not found." method-name)))) + ;; http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php + ;; -32601 ---> server error. requested method not found + (error 'xml-rpc-fault :code -32601 + :string (format nil "Method ~A not found." method-name)))))

(defun handle-xml-rpc-call (in id) "Handle an actual call, reading XML from in and returning the XML-encoded result." - (handler-bind ((error #'(lambda (c) - (format-debug (or *xml-rpc-debug-stream* t) "~a call failed with ~a~%" id c) - (return-from handle-xml-rpc-call - (encode-xml-rpc-fault (format nil "~a" c)))))) + ;; Try to conform to + ;; http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php + (handler-bind ((s-xml:xml-parser-error + #'(lambda (c) + (format-debug (or *xml-rpc-debug-stream* t) + "~a request parsing failed with ~a~%" + id c) + (return-from handle-xml-rpc-call + ;; -32700 ---> parse error. not well formed + (encode-xml-rpc-fault (format nil "~a" c) -32700)))) + (xml-rpc-fault + #'(lambda (c) + (format-debug (or *xml-rpc-debug-stream* t) + "~a call failed with ~a~%" id c) + (return-from handle-xml-rpc-call + (encode-xml-rpc-fault (xml-rpc-fault-string c) + (xml-rpc-fault-code c))))) + (error + #'(lambda (c) + (format-debug (or *xml-rpc-debug-stream* t) + "~a call failed with ~a~%" id c) + (return-from handle-xml-rpc-call + ;; -32603 ---> server error. internal xml-rpc error + (encode-xml-rpc-fault (format nil "~a" c) -32603))))) (let ((call (decode-xml-rpc (debug-stream in)))) (format-debug (or *xml-rpc-debug-stream* t) "~a received call ~s~%" id call) (let ((result (apply *xml-rpc-call-hook* @@ -530,7 +504,7 @@ (defun xml-rpc-implementation-version () "Identify ourselves" (concatenate 'string - "$Id: xml-rpc.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $" + "$Id: xml-rpc.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $" " " (lisp-implementation-type) " "

Index: s-xml-rpc/src/package.lisp diff -u s-xml-rpc/src/package.lisp:1.3 s-xml-rpc/src/package.lisp:1.4 --- s-xml-rpc/src/package.lisp:1.3 Sun Jun 13 09:12:03 2004 +++ s-xml-rpc/src/package.lisp Thu Jun 17 12:43:11 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: package.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $ +;;;; $Id: package.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; S-XML-RPC package definition ;;;; @@ -36,13 +36,14 @@ #:*xml-rpc-package* #:*xml-rpc-call-hook* #:execute-xml-rpc-call #:stop-server #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp| - #:|system.multicall|) + #:|system.multicall| #:|system.getCapabilities|) (:documentation "An implementation of the standard XML-RPC protocol for both client and server"))

(defpackage s-xml-rpc-exports (:use) (:import-from :s-xml-rpc #:|system.listMethods| #:|system.methodSignature| - #:|system.methodHelp| #:|system.multicall|) + #:|system.methodHelp| #:|system.multicall| + #:|system.getCapabilities|) (:documentation "This package contains the functions callable via xml-rpc."))

;;;; eof