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