Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv8306/src
Modified Files: xml-rpc.lisp package.lisp Log Message: Implement system.multicall
Date: Sun Jun 13 09:12:04 2004 Author: rschlatte
Index: s-xml-rpc/src/xml-rpc.lisp diff -u s-xml-rpc/src/xml-rpc.lisp:1.2 s-xml-rpc/src/xml-rpc.lisp:1.3 --- s-xml-rpc/src/xml-rpc.lisp:1.2 Sun Jun 13 07:14:47 2004 +++ s-xml-rpc/src/xml-rpc.lisp Sun Jun 13 09:12:03 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xml-rpc.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $ +;;;; $Id: xml-rpc.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC protocol, ;;;; as documented on the website http://www.xmlrpc.com @@ -97,6 +97,29 @@ "Create a new XML-RPC-TIME struct with the universal time specified, defaulting to now" (make-xml-rpc-time :universal-time universal-time))
+;;; a wrapper for literal strings, where escaping #< and #& is not +;;; desired + +(defstruct (xml-literal (:print-function print-xml-literal)) + "A wrapper around a Common Lisp string that will be sent over + the wire unescaped" + content) + +(setf (documentation 'xml-literal-p 'function) + "Return T when the argument is an unescaped xml string" + (documentation 'xml-literal-content 'function) + "Return the content of a literal xml string") + +(defun print-xml-literal (xml-literal stream depth) + (declare (ignore depth)) + (format stream + "#<XML-LITERAL "~a" >" + (xml-literal-content xml-literal))) + +(defun xml-literal (content) + "Create a new XML-LITERAL struct with the specified content." + (make-xml-literal :content content)) + ;;; an extra datatype for xml-rpc structures (associative maps)
(defstruct (xml-rpc-struct (:print-function print-xml-rpc-struct)) @@ -186,6 +209,8 @@ (princ "<dateTime.iso8601>" stream) (universal-time->iso8601 (xml-rpc-time-universal-time arg) stream) (princ "</dateTime.iso8601>" stream)) + ((xml-literal-p arg) + (princ (xml-literal-content arg) stream)) ((or (listp arg) (vectorp arg)) (encode-xml-rpc-array arg stream)) ((xml-rpc-struct-p arg) (encode-xml-rpc-struct arg stream)) ;; add generic method call @@ -218,14 +243,21 @@ (encode-xml-rpc-args (list value) stream) (princ "</methodResponse>" stream)))
-(defun encode-xml-rpc-fault (fault-string &optional (fault-code 0)) +(defun encode-xml-rpc-fault-value (fault-string &optional (fault-code 0)) + ;; for system.multicall (with-output-to-string (stream) - (princ "<methodResponse><fault><value><struct>" stream) + (princ "<struct>" stream) (format stream "<member><name>faultCode</name><value><int>~d</int></value></member>" fault-code) (princ "<member><name>faultString</name><value><string>" stream) (print-string-xml fault-string stream) (princ "</string></value></member>" stream) - (princ "</struct></value></fault></methodResponse>" stream))) + (princ "</struct>" stream))) + +(defun encode-xml-rpc-fault (fault-string &optional (fault-code 0)) + (with-output-to-string (stream) + (princ "<methodResponse><fault><value>" stream) + (princ (encode-xml-rpc-fault-value fault-string fault-code) stream) + (princ "</value></fault></methodResponse>" stream)))
;;; decoding support
@@ -290,10 +322,10 @@ (lisp-implementation-version)) "String specifying the default XML-RPC agent to include in server responses")
-(defparameter *xml-rpc-debug* nil +(defvar *xml-rpc-debug* nil "When T the XML-RPC client and server part will be more verbose about their protocol")
-(defparameter *xml-rpc-debug-stream* nil +(defvar *xml-rpc-debug-stream* nil "When not nil it specifies where debugging output should be written to")
(defparameter *xml-rpc-proxy-host* nil @@ -407,6 +439,9 @@
;;; server API
+(defvar *xml-rpc-call-hook* 'execute-xml-rpc-call + "A function to execute the xml-rpc call and return the result, accepting a method-name string and a optional argument list") + (defparameter +xml-rpc-method-characters+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_.:/")
@@ -438,7 +473,7 @@ (if method ;; http://xmlrpc.usefulinc.com/doc/sysmethodsig.html says to ;; return a non-array if the signature is not available - nil + "n/a" (error "Method ~A not found." method-name))))
(defun |system.methodHelp| (method-name) @@ -448,6 +483,27 @@ (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*" @@ -456,9 +512,6 @@ (apply method arguments) (error "Method ~A not found." method-name))))
-(defvar *xml-rpc-call-hook* 'execute-xml-rpc-call - "A function to execute the xml-rpc call and return the result, accepting a method-name string and a optional argument list") - (defun handle-xml-rpc-call (in id) "Handle an actual call, reading XML from in and returning the XML-encoded result." @@ -477,7 +530,7 @@ (defun xml-rpc-implementation-version () "Identify ourselves" (concatenate 'string - "$Id: xml-rpc.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $" + "$Id: xml-rpc.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $" " " (lisp-implementation-type) " "
Index: s-xml-rpc/src/package.lisp diff -u s-xml-rpc/src/package.lisp:1.2 s-xml-rpc/src/package.lisp:1.3 --- s-xml-rpc/src/package.lisp:1.2 Sun Jun 13 07:14:47 2004 +++ s-xml-rpc/src/package.lisp Sun Jun 13 09:12:03 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: package.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $ +;;;; $Id: package.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $ ;;;; ;;;; S-XML-RPC package definition ;;;; @@ -35,13 +35,14 @@ #:*xml-rpc-debug* #:*xml-rpc-debug-stream* #:*xml-rpc-package* #:*xml-rpc-call-hook* #:execute-xml-rpc-call #:stop-server - #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp|) + #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp| + #:|system.multicall|) (: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.methodHelp| #:|system.multicall|) (:documentation "This package contains the functions callable via xml-rpc."))
;;;; eof