s-xml-rpc-cvs

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

36 discussions

[s-xml-rpc-cvs] CVS update: s-xml-rpc/test/test-extensions.lisp s-xml-rpc/test/all-tests.lisp
by Rudi Schlatte 17 Jun '04

17 Jun '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/test In directory common-lisp.net:/tmp/cvs-serv10345/test Modified Files: all-tests.lisp Added Files: test-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/test/all-tests.lisp diff -u s-xml-rpc/test/all-tests.lisp:1.1.1.1 s-xml-rpc/test/all-tests.lisp:1.2 --- s-xml-rpc/test/all-tests.lisp:1.1.1.1 Wed Jun 9 02:02:40 2004 +++ s-xml-rpc/test/all-tests.lisp Thu Jun 17 12:43:11 2004 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: all-tests.lisp,v 1.1.1.1 2004/06/09 09:02:40 scaekenberghe Exp $ +;;;; $Id: all-tests.lisp,v 1.2 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; Load and execute all unit and functional tests ;;;; @@ -12,5 +12,6 @@ (load (merge-pathnames "test-base64" *load-pathname*) :verbose t) (load (merge-pathnames "test-xml-rpc" *load-pathname*) :verbose t) +(load (merge-pathnames "test-extensions" *load-pathname*) :verbose t) ;;;; eof

1 0

[s-xml-rpc-cvs] CVS update: public_html/S-XML-RPC.html public_html/index.html
by Sven Van Caekenberghe 14 Jun '04

14 Jun '04

Update of /project/s-xml-rpc/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv26117 Modified Files: index.html Added Files: S-XML-RPC.html Log Message: updated docs with API reference, etc... Date: Mon Jun 14 13:25:18 2004 Author: scaekenberghe Index: public_html/index.html diff -u public_html/index.html:1.2 public_html/index.html:1.3 --- public_html/index.html:1.2 Sun Jun 13 10:02:14 2004 +++ public_html/index.html Mon Jun 14 13:25:18 2004 @@ -15,11 +15,6 @@ <p>S-XML-RPC is an implementation of <a href="http://www.xmlrpc.com">XML-RPC</a> in Common Lisp for both client and server.</p> - <p> - <em>This project is starting up</em> - and is currently available via <a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/?cvsroot=s-xml-rpc">CVS</a>. - </p> - <p> XML-RPC is a de facto standard for making remote procedure calls between software running on disparate operating systems, running in different environments and implemented using different languages. XML-RPC is using HTTP as the transport and XML as the encoding. XML-RPC is designed to be as simple as possible, while allowing complex data structures to be transmitted, processed and returned. The protocol is described in detail on <a href="http://www.xmlrpc.com/">http://www.xmlrpc.com/</a>. Some key features (both positive and negative) of the XML-RPC protocol are: <ul> @@ -33,6 +28,20 @@ </ul> </p> +<h3>Download</h3> +<p> + You can download the LLGPL source code and documentation as <a href="s-xml-rpc.tgz">s-xml-rpc.tgz</a> + (signature: <a href="s-xml-rpc.tgz.asc">s-xml-rpc.tgz.asc</a>) + (build and/or install with ASDF). + There is also <a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/?cvsroot=s-xml-rpc">CVS</a> access. +</p> + +<h3>API</h3> +<p> + The plain API exported by the package S-XML-RPC (automatically generated by LispDoc) + is available in <a href="S-XML-RPC.html">S-XML-RPC.html</a>. +</p> + <h2> Usage </h2> @@ -236,7 +245,29 @@ The code in the package "S-BASE64" is an implementation of Base64 encoding and decoding (part of RFC 1521). Encoding takes bytes (a binary stream or a byte array) and produces characters (a character stream or a string). Decoding goes the other way. </p> - <p>CVS version $Id: index.html,v 1.2 2004/06/13 17:02:14 rschlatte Exp $</p> +<h3>Release History</h3> + +<ul> + <li>today: project moved to common-lisp.net</li> + <li>release 8, May 9, 2004: added *xml-rpc-authorization* header option (contributed by Nik Gaffney)</li> + <li>release 7, March 10, 2004: reorganized code to facilitate porting (added package.lisp and sysdeps.lisp, removed run-xml-rpc-server), integrated contributions from Rudi Schlatte and Brian Mastenbrook; SBCL is now supported; fixed a bug where empty strings were turned into nil, added a test</li> + <li>release 6, Januari 21, 2004: ported to LispWorks, added *xml-rpc-package*, *xml-rpc-call-hook* and execute-xml-rpc-call</li> + <li>release 5, Januari 20, 2004: added ASDF support, included some contributed patches</li> + <li>release 4, June 10, 2003: tracking a minor, but incompatible change in the XML parser</li> + <li>release 3, May 25, 2003: the XML parser has been put in a separate package, we are using the more efficient SAX interface of the parser, improved documentation</li> + <li>release 2, Januari 6, 2003: we now pass the <a href="http://validator.xmlrpc.com">XML-RPC validator tests</a>, various important bug fixes, improved documentation</li> + <li>release 1, December 15, 2002: first public release of working code, not optimized, limited testing</li> +</ul> + +<h3>Mailing Lists</h3> + +<ul> + <li><a href="http://common-lisp.net/mailman/listinfo/s-xml-rpc-cvs">S-XML-RPC-CVS mailing list info</a></li> + <li><a href="http://common-lisp.net/mailman/listinfo/s-xml-rpc-devel">S-XML-RPC-DEVEL mailing list info</a></li> + <li><a href="http://common-lisp.net/mailman/listinfo/s-xml-rpc-announce">S-XML-RPC-ANNOUNCE mailing list info</a></li> +</ul> + + <p>CVS version $Id: index.html,v 1.3 2004/06/14 20:25:18 scaekenberghe Exp $</p> <div class="footer"> <p>Back to <a href="http://common-lisp.net/">Common-lisp.net</a>.</p>

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/Makefile
by Sven Van Caekenberghe 14 Jun '04

14 Jun '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc In directory common-lisp.net:/tmp/cvs-serv25695 Modified Files: Makefile Log Message: added release target Date: Mon Jun 14 13:24:37 2004 Author: scaekenberghe Index: s-xml-rpc/Makefile diff -u s-xml-rpc/Makefile:1.1.1.1 s-xml-rpc/Makefile:1.2 --- s-xml-rpc/Makefile:1.1.1.1 Wed Jun 9 02:02:39 2004 +++ s-xml-rpc/Makefile Mon Jun 14 13:24:37 2004 @@ -16,3 +16,14 @@ clean: clean-openmcl clean-lw clean-emacs +# +# This can obviously only be done by a specific person in a very specific context ;-) +# + +release: + rm -rf /tmp/s-xml-rpc /tmp/public_html /tmp/s-xml-rpc.tgz /tmp/s-xml-rpc.tgz.asc + cd /tmp; cvs export -r HEAD s-xml-rpc; cvs export -r HEAD public_html + mv /tmp/public_html /tmp/s-xml-rpc/doc + cd /tmp; gnutar cvfz s-xml-rpc.tgz s-xml-rpc; gpg -a -b s-xml-rpc.tgz + scp /tmp/s-xml-rpc.tgz scaekenberghe@common-lisp.net:/project/s-xml-rpc/public_html + scp /tmp/s-xml-rpc.tgz.asc scaekenberghe@common-lisp.net:/project/s-xml-rpc/public_html

1 0

[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/validator1-client.lisp s-xml-rpc/src/validator1-server.lisp s-xml-rpc/src/validator1.lisp
by Sven Van Caekenberghe 14 Jun '04

14 Jun '04

Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src In directory common-lisp.net:/tmp/cvs-serv10381/src Added Files: validator1-client.lisp validator1-server.lisp Removed Files: validator1.lisp Log Message: refactored validator1 into client and server part now using new s-xml-rpc-exports package Date: Mon Jun 14 13:11:55 2004 Author: scaekenberghe

1 0

[s-xml-rpc-cvs] CVS update: public_html/index.html
by Rudi Schlatte 13 Jun '04

13 Jun '04

Update of /project/s-xml-rpc/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv4833 Modified Files: index.html Log Message: Update documentation: by default, almost nothing is exported now. Show how to make common-lisp available, like before. Date: Sun Jun 13 10:02:14 2004 Author: rschlatte Index: public_html/index.html diff -u public_html/index.html:1.1.1.1 public_html/index.html:1.2 --- public_html/index.html:1.1.1.1 Wed Jun 9 02:02:08 2004 +++ public_html/index.html Sun Jun 13 10:02:14 2004 @@ -66,7 +66,7 @@ The function <tt>xml-rpc-aserve:xml-rpc-call-aserve</tt> does the same thing, but uses the (portable) aserve HTTP client API for the networking. </p> <p> - Unit tests throughout the source code (marked by <tt>#+unit-test</tt> and usually wrapped inside an <tt>assert</tt>) can serve as (executable) examples. A more complicated example is the server and client implementation of some tests in <tt>validator1.lisp</tt>. Remember that XML-RPC method (function) names are case-sensitive, as are the names of XML-RPC structure members. + The unit tests in the subdirectory <tt>test</tt> can serve as (executable) examples. A more complicated example is the server and client implementation of some tests in <tt>validator1.lisp</tt>. Remember that XML-RPC method (function) names are case-sensitive, as are the names of XML-RPC structure members. </p> <h3> @@ -74,26 +74,42 @@ </h3> <p> Only a single function call is needed to get the server up and running: - <pre>? (start-xml-rpc-server :port 8080)</pre> - From now on, your lisp image becomes an XML-RPC server, listening for HTTP requests on port 8080. - By default each function in your lisp image becomes available remotely, provided its signature is compatible. - The is not very secure, but it is easy and powerful. - You should customize this behavior for production usage. + <pre>? (start-xml-rpc-server :port 8080)</pre> From now on, your + lisp image becomes an XML-RPC server, listening for HTTP + requests on port 8080. By default the + functions <tt>system.listMethods</tt>, <tt>system.methodSignature</tt>, + <tt>system.methodHelp</tt> and <tt>system.multicall</tt> are + available. You can export additional functions from the server + by importing symbols in the package contained + in <tt>*xml-rpc-package*</tt> (by default, this is the package + S-XML-RPC-EXPORTS). <tt>(use-package :common-lisp + :s-xml-rpc-exports)</tt> makes all of Common Lisp available via + xml-rpc. + </p> + <p> In more detail, this is what happens: <ul> <li>The XML-RPC call arrives as XML encoded characters in the body of an HTTP POST request</li> <li>The characters received are parsed by the XML parser and decoded on the fly (using a SAX-like interface) following XML-RPC semantics into a a string method name and a possibly empty list of Lisp objects that are the arguments</li> <li>The value of <tt>*xml-rpc-call-hook*</tt> is applied on the string method name and optional argument list</li> - <li>The default value of <tt>*xml-rpc-call-hook*</tt> is <tt>execute-xml-rpc-call</tt> which interns the method name in the package <tt>*xml-rpc-package*</tt> (whose default value is the XML-RPC package itself) and applies the function bound to that name to the argument list (if any)</li> + <li>The default value of <tt>*xml-rpc-call-hook*</tt> + is <tt>execute-xml-rpc-call</tt> which looks for a function + with the given name in the package <tt>*xml-rpc-package*</tt> + (whose default value is the XML-RPC-EXPORTS package) and + applies the function bound to that name to the argument list + (if any)</li> <li>The result is encoded as an XML-RPC result and returned to the client</li> - <li>If anything goes wrong in any of these steps, a Lisp condition is thrown which is catched and then encoded as an XML-RPC fault and returned to the client</li> + <li>If anything goes wrong in any of these steps, a Lisp + condition is thrown which is caught and then encoded as an XML-RPC fault and returned to the client</li> </ul> - Customization points are <tt>*xml-rpc-package*</tt> or <tt>*xml-rpc-call-hook*</tt>. + Customization points are <tt>*xml-rpc-package*</tt> and <tt>*xml-rpc-call-hook*</tt>. Setting the variable <tt>xml-rpc::*xml-rpc-debug*</tt> to <tt>t</tt> makes the server more verbose. Note that XML-RPC method names are case sensitive: for example, clients have specify "LISP-IMPLEMENTATION-TYPE" for the corresponding Lisp function; a server has to define a function named <tt>|login|</tt> if his clients look for an implementation of "login". </p> <p> -AppleScript can make client-side XML-RPC calls. So provided you have your lisp XML-RPC server running, you can have lisp to the math like this: + AppleScript can make client-side XML-RPC calls. So provided you + have your lisp XML-RPC server running and have imported + in + XML-RPC-EXPORTS, you can have lisp do the math like this: <pre>tell application "http://localhost:8080/RPC2" set call_result to call xmlrpc {method name:"+", parameters:{10, 20, 30}} end tell @@ -220,7 +236,7 @@ The code in the package "S-BASE64" is an implementation of Base64 encoding and decoding (part of RFC 1521). Encoding takes bytes (a binary stream or a byte array) and produces characters (a character stream or a string). Decoding goes the other way. </p> - <p>CVS version $Id: index.html,v 1.1.1.1 2004/06/09 09:02:08 scaekenberghe Exp $</p> + <p>CVS version $Id: index.html,v 1.2 2004/06/13 17:02:14 rschlatte Exp $</p> <div class="footer"> <p>Back to <a href="http://common-lisp.net/">Common-lisp.net</a>.</p>

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-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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

s-xml-rpc-cvs