From scaekenberghe at common-lisp.net  Wed Jun  9 09:02:08 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Wed, 09 Jun 2004 02:02:08 -0700
Subject: [s-xml-rpc-cvs] CVS update: Module imported: public_html
Message-ID: <E1BXyyG-0005K5-00@common-lisp.net>

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



From scaekenberghe at common-lisp.net  Wed Jun  9 09:02:41 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Wed, 09 Jun 2004 02:02:41 -0700
Subject: [s-xml-rpc-cvs] CVS update: Module imported: s-xml-rpc
Message-ID: <E1BXyyn-0005RC-00@common-lisp.net>

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



From rschlatte at common-lisp.net  Sun Jun 13 14:14:47 2004
From: rschlatte at common-lisp.net (Rudi Schlatte)
Date: Sun, 13 Jun 2004 07:14:47 -0700
Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/src/xml-rpc.lisp
	s-xml-rpc/src/package.lisp 
Message-ID: <E1BZVl1-0005Wi-00@common-lisp.net>

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




From rschlatte at common-lisp.net  Sun Jun 13 14:14:47 2004
From: rschlatte at common-lisp.net (Rudi Schlatte)
Date: Sun, 13 Jun 2004 07:14:47 -0700
Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/ChangeLog 
Message-ID: <E1BZVl1-0005Wu-00@common-lisp.net>

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





From rschlatte at common-lisp.net  Sun Jun 13 16:12:04 2004
From: rschlatte at common-lisp.net (Rudi Schlatte)
Date: Sun, 13 Jun 2004 09:12:04 -0700
Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/ChangeLog 
Message-ID: <E1BZXaW-0002Ar-00@common-lisp.net>

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




From rschlatte at common-lisp.net  Sun Jun 13 16:12:04 2004
From: rschlatte at common-lisp.net (Rudi Schlatte)
Date: Sun, 13 Jun 2004 09:12:04 -0700
Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/src/xml-rpc.lisp
	s-xml-rpc/src/package.lisp 
Message-ID: <E1BZXaW-0002AA-00@common-lisp.net>

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




From rschlatte at common-lisp.net  Sun Jun 13 17:02:14 2004
From: rschlatte at common-lisp.net (Rudi Schlatte)
Date: Sun, 13 Jun 2004 10:02:14 -0700
Subject: [s-xml-rpc-cvs] CVS update: public_html/index.html 
Message-ID: <E1BZYN4-0001I7-00@common-lisp.net>

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>  




From scaekenberghe at common-lisp.net  Mon Jun 14 20:11:55 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 14 Jun 2004 13:11:55 -0700
Subject: [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 
Message-ID: <E1BZxoB-0002mP-00@common-lisp.net>

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









From scaekenberghe at common-lisp.net  Mon Jun 14 20:24:37 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 14 Jun 2004 13:24:37 -0700
Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/Makefile 
Message-ID: <E1BZy0T-0006hJ-00@common-lisp.net>

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 at common-lisp.net:/project/s-xml-rpc/public_html
+	scp /tmp/s-xml-rpc.tgz.asc scaekenberghe at common-lisp.net:/project/s-xml-rpc/public_html




From scaekenberghe at common-lisp.net  Mon Jun 14 20:25:18 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 14 Jun 2004 13:25:18 -0700
Subject: [s-xml-rpc-cvs] CVS update: public_html/S-XML-RPC.html
	public_html/index.html 
Message-ID: <E1BZy18-0006yd-00@common-lisp.net>

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>  




From rschlatte at common-lisp.net  Thu Jun 17 19:43:11 2004
From: rschlatte at common-lisp.net (Rudi Schlatte)
Date: Thu, 17 Jun 2004 12:43:11 -0700
Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/test/test-extensions.lisp
	s-xml-rpc/test/all-tests.lisp 
Message-ID: <E1Bb2n1-0002h9-00@common-lisp.net>

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




From rschlatte at common-lisp.net  Thu Jun 17 19:43:11 2004
From: rschlatte at common-lisp.net (Rudi Schlatte)
Date: Thu, 17 Jun 2004 12:43:11 -0700
Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/src/extensions.lisp
	s-xml-rpc/src/xml-rpc.lisp s-xml-rpc/src/package.lisp 
Message-ID: <E1Bb2n1-0002hQ-00@common-lisp.net>

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




From rschlatte at common-lisp.net  Thu Jun 17 19:43:11 2004
From: rschlatte at common-lisp.net (Rudi Schlatte)
Date: Thu, 17 Jun 2004 12:43:11 -0700
Subject: [s-xml-rpc-cvs] CVS update: s-xml-rpc/s-xml-rpc.asd
	s-xml-rpc/ChangeLog 
Message-ID: <E1Bb2n1-0002hg-00@common-lisp.net>

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

Modified Files:
	s-xml-rpc.asd ChangeLog 
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/s-xml-rpc.asd
diff -u s-xml-rpc/s-xml-rpc.asd:1.1.1.1 s-xml-rpc/s-xml-rpc.asd:1.2
--- s-xml-rpc/s-xml-rpc.asd:1.1.1.1	Wed Jun  9 02:02:39 2004
+++ s-xml-rpc/s-xml-rpc.asd	Thu Jun 17 12:43:11 2004
@@ -1,6 +1,6 @@
 ;;;; -*- Mode: LISP -*-
 ;;;;
-;;;; $Id: s-xml-rpc.asd,v 1.1.1.1 2004/06/09 09:02:39 scaekenberghe Exp $
+;;;; $Id: s-xml-rpc.asd,v 1.2 2004/06/17 19:43:11 rschlatte Exp $
 ;;;;
 ;;;; The S-XML-RPC ASDF system definition
 ;;;;
@@ -27,7 +27,8 @@
     :components ((:file "base64")
                  (:file "package" :depends-on ("base64"))
                  (:file "sysdeps" :depends-on ("package"))
-                 (:file "xml-rpc" :depends-on ("package" "sysdeps" "base64")))))
+                 (:file "xml-rpc" :depends-on ("package" "sysdeps" "base64"))
+                 (:file "extensions" :depends-on ("package" "xml-rpc")))))
   :depends-on (:s-xml #+sbcl :sb-bsd-sockets))
 
 ;;;; eof


Index: s-xml-rpc/ChangeLog
diff -u s-xml-rpc/ChangeLog:1.2 s-xml-rpc/ChangeLog:1.3
--- s-xml-rpc/ChangeLog:1.2	Sun Jun 13 09:12:04 2004
+++ s-xml-rpc/ChangeLog	Thu Jun 17 12:43:11 2004
@@ -1,3 +1,17 @@
+2004-06-17  Rudi Schlatte  <rudi at constantly.at>
+
+	* src/package.lisp: Add system.getCapabilities.
+
+	* src/extensions.lisp: Create, move server extensions from
+	xml-rpc.lisp here.
+	(do-one-multicall): Raise standard fault codes.
+	(|system.getCapabilities|): Implement.
+	
+	* src/xml-rpc.lisp: Remove server extensions.
+	(encode-xml-rpc-value): Encode symbols as strings
+	(execute-xml-rpc-call, handle-xml-rpc-call): Raise standard fault
+	codes.
+
 2004-06-13  Rudi Schlatte  <rudi at constantly.at>
 
 	* src/xml-rpc.lisp (xml-literal): new datatype for unescaped