- s-xml-rpc-cvs@common-lisp.net - mailman3.common-lisp.net

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/xml-rpc.lisp s-xml-rpc/src/package.lisp
by Rudi Schlatte 13 Jun '04

13 Jun '04

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

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/ChangeLog
by Rudi Schlatte 13 Jun '04

13 Jun '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc In directory common-lisp.net:/tmp/cvs-serv8306 Modified Files: ChangeLog Log Message: Implement system.multicall Date: Sun Jun 13 09:12:04 2004 Author: rschlatte Index: s-xml-rpc/ChangeLog diff -u s-xml-rpc/ChangeLog:1.1 s-xml-rpc/ChangeLog:1.2 --- s-xml-rpc/ChangeLog:1.1 Sun Jun 13 07:14:47 2004 +++ s-xml-rpc/ChangeLog Sun Jun 13 09:12:04 2004 @@ -1,5 +1,12 @@ 2004-06-13 Rudi Schlatte <rudi(a)constantly.at> + * src/xml-rpc.lisp (xml-literal): new datatype for unescaped + strings (used by system.multicall to pass back encoded fault structs) + (encode-xml-rpc-value): handle it. + (encode-xml-rpc-fault-value, encode-xml-rpc-fault): separate + encoding of fault and methodResponse for system.multicall + (do-one-multicall, |system.multicall|): Implement system.multicall. + * src/package.lisp (s-xml-rpc-exports): New package -- don't export the whole common-lisp package by default ;) @@ -9,7 +16,8 @@ (|system.methodSignature|, |system.methodHelp|): Added introspection methods, to be imported in *xml-rpc-package*. - * src/package.lisp (s-xml-rpc): ... export them. + * src/package.lisp (s-xml-rpc): ... export them, and also + |system.multicall| * src/xml-rpc.lisp: Some indentation frobs.

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/ChangeLog
by Rudi Schlatte 13 Jun '04

13 Jun '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc In directory common-lisp.net:/tmp/cvs-serv21201 Added Files: ChangeLog Log Message: * src/package.lisp (s-xml-rpc-exports): New package -- don't export the whole common-lisp package by default ;) * src/xml-rpc.lisp (*xml-rpc-package*): ... use it. * src/xml-rpc.lisp (|system.listMethods|) (|system.methodSignature|, |system.methodHelp|): Added introspection methods, to be imported in *xml-rpc-package*. * src/package.lisp (s-xml-rpc): ... export them. * src/xml-rpc.lisp: Some indentation frobs. Date: Sun Jun 13 07:14:47 2004 Author: rschlatte

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/xml-rpc.lisp s-xml-rpc/src/package.lisp
by Rudi Schlatte 13 Jun '04

13 Jun '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv21201/src Modified Files: xml-rpc.lisp package.lisp Log Message: * src/package.lisp (s-xml-rpc-exports): New package -- don't export the whole common-lisp package by default ;) * src/xml-rpc.lisp (*xml-rpc-package*): ... use it. * src/xml-rpc.lisp (|system.listMethods|) (|system.methodSignature|, |system.methodHelp|): Added introspection methods, to be imported in *xml-rpc-package*. * src/package.lisp (s-xml-rpc): ... export them. * src/xml-rpc.lisp: Some indentation frobs. Date: Sun Jun 13 07:14:47 2004 Author: rschlatte Index: s-xml-rpc/src/xml-rpc.lisp diff -u s-xml-rpc/src/xml-rpc.lisp:1.1.1.1 s-xml-rpc/src/xml-rpc.lisp:1.2 --- s-xml-rpc/src/xml-rpc.lisp:1.1.1.1 Wed Jun 9 02:02:40 2004 +++ s-xml-rpc/src/xml-rpc.lisp Sun Jun 13 07:14:47 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xml-rpc.lisp,v 1.1.1.1 2004/06/09 09:02:40 scaekenberghe Exp $ +;;;; $Id: xml-rpc.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC protocol, ;;;; as documented on the website http://www.xmlrpc.com @@ -121,7 +121,7 @@ (let ((pair (assoc member (xml-rpc-struct-alist struct)))) (if pair (rplacd pair value) - (push (cons member value) (xml-rpc-struct-alist struct))) + (push (cons member value) (xml-rpc-struct-alist struct))) value)) (defun xml-rpc-struct (&rest args) @@ -130,9 +130,9 @@ (error "~s must contain an even number of elements" args)) (let (alist) (loop - (if (null args) - (return) - (push (cons (pop args) (pop args)) alist))) + (if (null args) + (return) + (push (cons (pop args) (pop args)) alist))) (make-xml-rpc-struct :alist alist))) (defun xml-rpc-struct-equal (struct1 struct2) @@ -145,7 +145,7 @@ (unless (equal (get-xml-rpc-struct-member struct2 (car assoc)) (cdr assoc)) (return-from xml-rpc-struct-equal nil))) - nil)) + nil)) ;;; encoding support @@ -204,6 +204,9 @@ "Encode an XML-RPC call with name and args as an XML string" (with-output-to-string (stream) (princ "<methodCall>" stream) + ;; Spec says: The string may only contain identifier characters, + ;; upper and lower-case A-Z, the numeric characters, 0-9, + ;; underscore, dot, colon and slash. (format stream "<methodName>~a</methodName>" (string name)) ; assuming name contains no special characters (when args (encode-xml-rpc-args args stream)) @@ -299,7 +302,7 @@ (defparameter *xml-rpc-proxy-port* nil "When not null, an integer specifying the XML-RPC proxy port to use") -(defparameter *xml-rpc-package* *package* +(defparameter *xml-rpc-package* (find-package :s-xml-rpc-exports) "Package for XML-RPC callable functions") (defparameter *xml-rpc-authorization* nil @@ -316,13 +319,13 @@ (defun tokens (string &key (start 0) (separators (list #\space #\return #\linefeed #\tab))) (if (= start (length string)) '() - (let ((p (position-if #'(lambda (char) (find char separators)) string :start start))) - (if p - (if (= p start) - (tokens string :start (1+ start) :separators separators) - (cons (subseq string start p) - (tokens string :start (1+ p) :separators separators))) - (list (subseq string start)))))) + (let ((p (position-if #'(lambda (char) (find char separators)) string :start start))) + (if p + (if (= p start) + (tokens string :start (1+ start) :separators separators) + (cons (subseq string start p) + (tokens string :start (1+ p) :separators separators))) + (list (subseq string start)))))) (defun format-header (stream headers) (mapc #'(lambda (header) @@ -334,18 +337,18 @@ (defun debug-stream (in) (if *xml-rpc-debug* (make-echo-stream in *standard-output*) - in)) + in)) ;;; client API (defun xml-rpc-call (encoded &key - (url *xml-rpc-url*) - (agent *xml-rpc-agent*) - (host *xml-rpc-host*) - (port *xml-rpc-port*) - (authorization *xml-rpc-authorization*) - (proxy-host *xml-rpc-proxy-host*) - (proxy-port *xml-rpc-proxy-port*)) + (url *xml-rpc-url*) + (agent *xml-rpc-agent*) + (host *xml-rpc-host*) + (port *xml-rpc-port*) + (authorization *xml-rpc-authorization*) + (proxy-host *xml-rpc-proxy-host*) + (proxy-port *xml-rpc-proxy-port*)) "Execute an already encoded XML-RPC call and return the decoded result" (let ((uri (if proxy-host (format nil "http://~a:~d~a" host port url) url))) (with-open-socket-stream (connection (if proxy-host proxy-host host) @@ -375,7 +378,7 @@ (let ((result (decode-xml-rpc (debug-stream connection)))) (if (typep result 'xml-rpc-fault) (error result) - (car result)))))) + (car result)))))) (defun call-xml-rpc-server (server-keywords name &rest args) "Encode and execute an XML-RPC call with name and args, using the list of server-keywords" @@ -401,18 +404,64 @@ :port port :url url)))) + ;;; server API +(defparameter +xml-rpc-method-characters+ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_.:/") + +(defun valid-xml-rpc-method-name-p (method-name) + (not (find-if-not (lambda (c) (find c +xml-rpc-method-characters+)) + method-name))) + +(defun find-xml-rpc-method (method-name) + "Looks for a method with the given name in *xml-rpc-package*, + except that colons in the name get converted to hyphens." + (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 + nil + (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 execute-xml-rpc-call (method-name &rest arguments) - "Intern method-name in *xml-rpc-package* and apply that function on arguments" - (apply (intern method-name *xml-rpc-package*) - 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)))) (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 calll, reading XML from in and writing XML to in" + "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 @@ -428,7 +477,7 @@ (defun xml-rpc-implementation-version () "Identify ourselves" (concatenate 'string - "$Id: xml-rpc.lisp,v 1.1.1.1 2004/06/09 09:02:40 scaekenberghe Exp $" + "$Id: xml-rpc.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $" " " (lisp-implementation-type) " " @@ -461,12 +510,12 @@ ("Content-Length: ~d" ,(length xml)))) (princ xml connection) (format-debug (or *xml-rpc-debug-stream* t) "~d sending ~a~%" id xml))) - (progn - (format-header connection - `(("HTTP/1.0 400 Bad Request") - ("Server: ~a" ,agent) - ("Connection: close"))) - (format-debug (or *xml-rpc-debug-stream* t) "~d got a bad request~%" id))) + (progn + (format-header connection + `(("HTTP/1.0 400 Bad Request") + ("Server: ~a" ,agent) + ("Connection: close"))) + (format-debug (or *xml-rpc-debug-stream* t) "~d got a bad request~%" id))) (force-output connection) (close connection)))) Index: s-xml-rpc/src/package.lisp diff -u s-xml-rpc/src/package.lisp:1.1.1.1 s-xml-rpc/src/package.lisp:1.2 --- s-xml-rpc/src/package.lisp:1.1.1.1 Wed Jun 9 02:02:39 2004 +++ s-xml-rpc/src/package.lisp Sun Jun 13 07:14:47 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: package.lisp,v 1.1.1.1 2004/06/09 09:02:39 scaekenberghe Exp $ +;;;; $Id: package.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $ ;;;; ;;;; S-XML-RPC package definition ;;;; @@ -34,7 +34,14 @@ #:*xml-rpc-proxy-host* #:*xml-rpc-proxy-port* #:*xml-rpc-authorization* #:*xml-rpc-debug* #:*xml-rpc-debug-stream* #:*xml-rpc-package* #:*xml-rpc-call-hook* - #:execute-xml-rpc-call #:stop-server) + #:execute-xml-rpc-call #:stop-server + #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp|) (: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|) + (:documentation "This package contains the functions callable via xml-rpc.")) ;;;; eof

1 0

[s-xml-rpc-cvs] CVS update: Module imported: s-xml-rpc
by Sven Van Caekenberghe 09 Jun '04

09 Jun '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc In directory common-lisp.net:/tmp/cvs-serv20900 Log Message: Project Creation Status: Vendor Tag: svc Release Tags: start N s-xml-rpc/Makefile N s-xml-rpc/s-xml-rpc.asd N s-xml-rpc/src/aserve.lisp N s-xml-rpc/src/base64.lisp N s-xml-rpc/src/package.lisp N s-xml-rpc/src/sysdeps.lisp N s-xml-rpc/src/validator1.lisp N s-xml-rpc/src/xml-rpc.lisp N s-xml-rpc/test/all-tests.lisp N s-xml-rpc/test/test-base64.lisp N s-xml-rpc/test/test-xml-rpc.lisp N s-xml-rpc/test/test.b64 No conflicts created by this import Date: Wed Jun 9 02:02:41 2004 Author: scaekenberghe New module s-xml-rpc added

1 0

[s-xml-rpc-cvs] CVS update: Module imported: public_html
by Sven Van Caekenberghe 09 Jun '04

09 Jun '04

Update of /project/s-xml-rpc/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv20456 Log Message: Project Creation Status: Vendor Tag: svc Release Tags: start N public_html/index.html N public_html/style.css No conflicts created by this import Date: Wed Jun 9 02:02:08 2004 Author: scaekenberghe New module public_html added

1 0