7 files changed, 1123 insertions, 0 deletions
diff --git a/third-party/s-xml-rpc/src/aserve.lisp b/third-party/s-xml-rpc/src/aserve.lisp
new file mode 100644
index 0000000..ecd9073
--- /dev/null
+++ b/third-party/s-xml-rpc/src/aserve.lisp
@@ -0,0 +1,79 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: aserve.lisp,v 1.1.1.1 2004-06-09 09:02:39 scaekenberghe Exp $
+;;;;
+;;;; This file implements XML-RPC client and server networking based
+;;;; on (Portable) AllegroServe (see http://opensource.franz.com/aserve/
+;;;; or http://sourceforge.net/projects/portableaserve/), which you have
+;;;; to install first.
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(defpackage xml-rpc-aserve
+  (:use common-lisp net.aserve.client net.aserve xml-rpc)
+  (:export
+   "XML-RPC-CALL"
+   "START-XML-RPC-ASERVE"
+   "PUBLISH-ASERVE-XML-RPC-HANDLER"))
+
+(in-package :xml-rpc-aserve)
+
+(defun xml-rpc-call-aserve (encoded &key
+				    (url *xml-rpc-url*)
+				    (agent *xml-rpc-agent*)
+				    (host *xml-rpc-host*)
+				    (port *xml-rpc-port*)
+                                    (basic-autorization *xml-rpc-authorization*)
+				    (proxy))
+  (let ((xml (print-xml-string encoded)))
+    (multiple-value-bind (response response-code headers uri)
+	(do-http-request
+	 (format nil "http://~a:~d~a" host port url)
+	 :method :post
+	 :protocol :http/1.0
+	 :user-agent agent
+	 :content-type "text/xml"
+         :basic-authorization basic-autorization
+	 :content xml
+	 :proxy proxy)
+      (declare (ignore headers uri))
+      (if (= response-code 200)
+          (let ((result (decode-xml-rpc (make-string-input-stream response))))
+            (if (typep result 'xml-rpc-fault)
+                (error result)
+              (car result)))
+	(error "http-error:~d" response-code)))))
+
+(defun start-xml-rpc-aserve (&key (port *xml-rpc-port*))
+  (process-run-function "aserve-xml-rpc" 
+			#'(lambda ()
+			    (start :port port 
+				   :listeners 4 
+				   :chunking nil 
+				   :keep-alive nil))))
+
+(defun publish-aserve-xml-rpc-handler (&key (url *xml-rpc-url*) (agent *xml-rpc-agent*))
+  (declare (ignore agent))
+  (publish :path url
+	   :content-type "text/xml"
+	   :function #'aserve-xml-rpc-handler))
+
+(defun aserve-xml-rpc-handler (request entity)
+  (with-http-response (request
+		       entity
+		       :response (if (eq :post (request-method request))
+				     *response-ok*
+				   *response-bad-request*))
+    (with-http-body (request entity)
+      (let ((body (get-request-body request))
+	    (id (process-name *current-process*)))
+	(with-input-from-string (in body)
+	  (let ((xml (handle-xml-rpc-call in id)))
+	    (format-debug t "~d sending ~a~%" id xml)
+	    (princ xml *html-stream*)))))))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/define-xmlrpc-method.lisp b/third-party/s-xml-rpc/src/define-xmlrpc-method.lisp
new file mode 100644
index 0000000..74a3bc3
--- /dev/null
+++ b/third-party/s-xml-rpc/src/define-xmlrpc-method.lisp
@@ -0,0 +1,30 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: define-xmlrpc-method.lisp,v 1.1 2004-07-08 19:45:25 scaekenberghe Exp $
+;;;;
+;;;; The code in this file adds a very handly define-xmlrpc-method macro.
+;;;;
+;;;; (define-xmlrpc-method get-state-name (state)
+;;;;   :url #u"http://betty.userland.com/RPC2"
+;;;;   :method "examples.getStateName")
+;;;;
+;;;; (define-xmlrpc-method get-time ()
+;;;;   :url #u"http://time.xmlrpc.com/RPC2"
+;;;;   :method "currentTime.getCurrentTime")
+;;;;
+;;;; It require the PURI package.
+;;;;
+;;;; Copyright (C) 2004 Frederic Brunel.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(defmacro define-xmlrpc-method (name args &key url method)
+  `(defun ,name ,args
+     (xml-rpc-call (encode-xml-rpc-call ,method ,@args)
+       :url ,(puri:uri-path url)
+       :host ,(puri:uri-host url)
+       :port ,(cond ((puri:uri-port url)) (t 80)))))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/extensions.lisp b/third-party/s-xml-rpc/src/extensions.lisp
new file mode 100644
index 0000000..fa961e2
--- /dev/null
+++ b/third-party/s-xml-rpc/src/extensions.lisp
@@ -0,0 +1,107 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: extensions.lisp,v 1.1 2004-06-17 19:43:11 rschlatte Exp $
+;;;;
+;;;; Extensions for xml-rpc:
+;;;;
+;;;; Server introspection:
+;;;; http://xmlrpc.usefulinc.com/doc/reserved.html
+;;;;
+;;;; Multicall:
+;;;; http://www.xmlrpc.com/discuss/msgReader$1208
+;;;;
+;;;; Capabilities:
+;;;; http://groups.yahoo.com/group/xml-rpc/message/2897
+;;;; 
+;;;;
+;;;; Copyright (C) 2004 Rudi Schlatte
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml-rpc)
+
+;;; Introspection
+
+(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))))
+
+;;; system.multicall
+
+(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
+        ((xml-rpc-fault
+          #'(lambda (c)
+              (format-debug (or *xml-rpc-debug-stream* t)
+                            "Call to ~A in system.multicall failed with ~a~%"
+                            name c)
+              (return-from do-one-multicall
+                (xml-literal
+                 (encode-xml-rpc-fault-value (xml-rpc-fault-string c)
+                                             (xml-rpc-fault-code c))))))
+         (error
+          #'(lambda (c)
+              (format-debug
+               (or *xml-rpc-debug-stream* t)
+               "Call to ~A in system.multicall failed with ~a~%" name c)
+              (return-from do-one-multicall
+                (xml-literal
+                 (encode-xml-rpc-fault-value
+                  ;; -32603 ---> server error. internal xml-rpc error
+                  (format nil "~a" c) -32603))))))
+      (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))
+
+;;; system.getCapabilities
+
+(defun |system.getCapabilities| ()
+  "Get a list of supported capabilities; see
+  http://groups.yahoo.com/group/xml-rpc/message/2897 for the
+  specification."
+  (let ((capabilities
+         '("xmlrpc" ("specUrl" "http://www.xmlrpc.com/spec"
+                     "specVersion" 1)
+           "introspect" ("specUrl" "http://xmlrpc.usefulinc.com/doc/reserved.html"
+                         "specVersion" 1)
+           "multicall" ("specUrl" "http://www.xmlrpc.com/discuss/msgReader$1208"
+                        "specVersion" 1)
+           "faults_interop" ("specUrl" "http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php"
+                             "specVersion" 20010516))))
+    (apply #'xml-rpc-struct
+           (loop for (name description) on capabilities by #'cddr
+                collecting name
+                collecting (apply #'xml-rpc-struct description)))))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/package.lisp b/third-party/s-xml-rpc/src/package.lisp
new file mode 100644
index 0000000..e3d2568
--- /dev/null
+++ b/third-party/s-xml-rpc/src/package.lisp
@@ -0,0 +1,49 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: package.lisp,v 1.4 2004-06-17 19:43:11 rschlatte Exp $
+;;;;
+;;;; S-XML-RPC package definition
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(defpackage s-xml-rpc
+  (:use 
+   common-lisp 
+   #+ccl ccl 
+   #+lispworks mp
+   #+lispworks comm
+   s-xml 
+   s-base64)
+  (:export
+   #:xml-rpc-call
+   #:encode-xml-rpc-call
+   #:call-xml-rpc-server
+   #:xml-rpc-condition
+   #:xml-rpc-fault #:xml-rpc-fault-code #:xml-rpc-fault-string
+   #:xml-rpc-error #:xml-rpc-error-place #:xml-rpc-error-data
+   #:start-xml-rpc-server
+   #:xml-rpc-time #:xml-rpc-time-p
+   #:xml-rpc-time-universal-time
+   #:xml-rpc-struct #:xml-rpc-struct-p
+   #:xml-rpc-struct-alist #:get-xml-rpc-struct-member #:xml-rpc-struct-equal
+   #:*xml-rpc-host* #:*xml-rpc-port* #:*xml-rpc-url* #:*xml-rpc-agent*
+   #:*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
+   #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp|
+   #:|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.getCapabilities|)
+  (:documentation "This package contains the functions callable via xml-rpc."))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/validator1-client.lisp b/third-party/s-xml-rpc/src/validator1-client.lisp
new file mode 100644
index 0000000..8800671
--- /dev/null
+++ b/third-party/s-xml-rpc/src/validator1-client.lisp
@@ -0,0 +1,182 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: validator1-client.lisp,v 1.1 2004-06-14 20:11:55 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of the XML-RPC 'validator1'
+;;;; server test suite, as live testable from the website
+;;;; http://validator.xmlrpc.com and documented on the web page
+;;;; http://www.xmlrpc.com/validator1Docs
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml-rpc)
+
+(defun random-string (&optional (length 8))
+  (with-output-to-string (stream)
+    (dotimes (i (random length))
+      (write-char (code-char (+ 32 (random 95)))
+		  stream))))
+
+(defun echo-struct-test ()
+  (let* ((struct (xml-rpc-struct :|foo| (random 1000000)
+				 :|bar| (random-string)
+				 :|fooBar| (list (random 100) (random 100))))
+	 (result (xml-rpc-call (encode-xml-rpc-call :|validator1.echoStructTest|
+						    struct))))
+    (format t "validator1.echoStructTest(~s)=~s~%" struct result)
+    (assert (xml-rpc-struct-equal struct result))))
+	     
+(defun easy-struct-test ()
+  (let* ((moe (random 1000))
+	 (larry (random 1000))
+	 (curry (random 1000))
+	 (struct (xml-rpc-struct :|moe| moe
+				 :|larry| larry
+				 :|curly| curry))
+	 (result (xml-rpc-call (encode-xml-rpc-call :|validator1.easyStructTest|
+						    struct))))
+    (format t "validator1.easyStructTest(~s)=~s~%" struct result) 
+    (assert (= (+ moe larry curry) result))))
+
+(defun count-the-entities ()
+  (let* ((string (random-string 512))
+	 (left-angle-brackets (count #\< string))
+	 (right-angle-brackets (count #\> string))
+	 (apostrophes (count #\' string))
+	 (quotes (count #\" string))
+	 (ampersands (count #\& string))
+	 (result (xml-rpc-call (encode-xml-rpc-call :|validator1.countTheEntities|
+						    string))))
+    (format t "validator1.countTheEntitities(~s)=~s~%" string result)
+    (assert
+     (and (xml-rpc-struct-p result)
+	  (= left-angle-brackets
+	     (get-xml-rpc-struct-member result :|ctLeftAngleBrackets|))
+	  (= right-angle-brackets
+	     (get-xml-rpc-struct-member result :|ctRightAngleBrackets|))
+	  (= apostrophes
+	     (get-xml-rpc-struct-member result :|ctApostrophes|))
+	  (= quotes
+	     (get-xml-rpc-struct-member result :|ctQuotes|))
+	  (= ampersands
+	     (get-xml-rpc-struct-member result :|ctAmpersands|))))))
+
+(defun array-of-structs-test ()
+  (let ((array (make-array (random 32)))
+	(sum 0))
+    (dotimes (i (length array))
+      (setf (aref array i)
+	    (xml-rpc-struct :|moe| (random 1000)
+			    :|larry| (random 1000)
+			    :|curly| (random 1000)))
+      (incf sum (get-xml-rpc-struct-member (aref array i)
+					   :|curly|)))
+    (let ((result (xml-rpc-call (encode-xml-rpc-call :|validator1.arrayOfStructsTest|
+						     array))))
+      (format t "validator1.arrayOfStructsTest(~s)=~s~%" array result)
+      (assert (= result sum)))))
+
+(defun random-bytes (&optional (length 16))
+  (let ((bytes (make-array (random length) :element-type '(unsigned-byte 8))))
+    (dotimes (i (length bytes) bytes)
+      (setf (aref bytes i) (random 256)))))
+
+(defun many-types-test ()
+  (let* ((integer (random 10000))
+	 (boolean (if (zerop (random 2)) t nil))
+	 (string (random-string))
+	 (double (random 10000.0))
+	 (dateTime (xml-rpc-time))
+	 (base64 (random-bytes))
+	 (result (xml-rpc-call (encode-xml-rpc-call :|validator1.manyTypesTest|
+						    integer
+						    boolean
+						    string
+						    double
+						    dateTime
+						    base64))))
+    (format t
+	    "validator1.manyTypesTest(~s,~s,~s,~s,~s,~s)=~s~%"
+	    integer
+	    boolean
+	    string
+	    double
+	    dateTime
+	    base64
+	    result)
+    (assert (equal integer (elt result 0)))
+    (assert (equal boolean (elt result 1)))
+    (assert (equal string (elt result 2)))
+    (assert (equal double (elt result 3)))
+    (assert (equal (xml-rpc-time-universal-time dateTime)
+		   (xml-rpc-time-universal-time (elt result 4))))
+    (assert (reduce #'(lambda (x y) (and x y))
+		    (map 'list #'= base64 (elt result 5))
+		    :initial-value t))))
+
+(defun simple-struct-return-test ()
+  (let* ((number (random 1000))
+	 (result (xml-rpc-call (encode-xml-rpc-call :|validator1.simpleStructReturnTest| number))))
+    (format t "validator1.simpleStructReturnTest(~s)=~s~%" number result)
+    (assert
+     (and (= (* number 10)
+	     (get-xml-rpc-struct-member result :|times10|))
+	  (= (* number 100)
+	     (get-xml-rpc-struct-member result :|times100|))
+	  (= (* number 1000)
+	     (get-xml-rpc-struct-member result :|times1000|))))))
+
+(defun moderate-size-array-check ()
+  (let ((array (make-array (+ 100 (random 100))
+			   :element-type 'string)))
+    (dotimes (i (length array))
+      (setf (aref array i) (random-string)))
+    (let ((result (xml-rpc-call (encode-xml-rpc-call :|validator1.moderateSizeArrayCheck|
+						     array))))
+      (format t "validator1.moderateSizeArrayCheck(~s)=~s~%" array result)
+      (assert
+       (equal (concatenate 'string (elt array 0) (elt array (1- (length array))))
+	      result)))))
+
+(defun nested-struct-test ()
+  (let* ((moe (random 1000))
+	 (larry (random 1000))
+	 (curry (random 1000))
+	 (struct (xml-rpc-struct :|moe| moe
+				 :|larry| larry
+				 :|curly| curry))
+	 (first (xml-rpc-struct :\01 struct))
+	 (april (xml-rpc-struct :\04 first))
+	 (year (xml-rpc-struct :\2000 april))
+	 (result (xml-rpc-call (encode-xml-rpc-call :|validator1.nestedStructTest|
+						    year))))
+    (format t "validator1.nestedStructTest(~s)=~s~%" year result) 
+    (assert (= (+ moe larry curry) result))))
+
+(defun test-run (&optional (runs 1))
+  (dotimes (i runs t)
+    (echo-struct-test)
+    (easy-struct-test)
+    (count-the-entities)
+    (array-of-structs-test)
+    (many-types-test)
+    (simple-struct-return-test)
+    (moderate-size-array-check)
+    (nested-struct-test)))
+
+(defun timed-test-run (&optional (runs 1))
+  (dotimes (i runs t)
+    (time (echo-struct-test))
+    (time (easy-struct-test))
+    (time (count-the-entities))
+    (time (array-of-structs-test))
+    (time (many-types-test))
+    (time (simple-struct-return-test))
+    (time (moderate-size-array-check))
+    (time (nested-struct-test))))
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/validator1-server.lisp b/third-party/s-xml-rpc/src/validator1-server.lisp
new file mode 100644
index 0000000..2833b8d
--- /dev/null
+++ b/third-party/s-xml-rpc/src/validator1-server.lisp
@@ -0,0 +1,90 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: validator1-server.lisp,v 1.1 2004-06-14 20:11:55 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of the XML-RPC 'validator1'
+;;;; server test suite, as live testable from the website
+;;;; http://validator.xmlrpc.com and documented on the web page
+;;;; http://www.xmlrpc.com/validator1Docs
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml-rpc)
+
+(defun |validator1.echoStructTest| (struct)
+  (assert (xml-rpc-struct-p struct))
+  struct)
+
+(defun |validator1.easyStructTest| (struct)
+  (assert (xml-rpc-struct-p struct))
+  (+ (get-xml-rpc-struct-member struct :|moe|)
+     (get-xml-rpc-struct-member struct :|larry|)
+     (get-xml-rpc-struct-member struct :|curly|)))
+
+(defun |validator1.countTheEntities| (string)
+  (assert (stringp string))
+  (let ((left-angle-brackets (count #\< string))
+	(right-angle-brackets (count #\> string))
+	(apostrophes (count #\' string))
+	(quotes (count #\" string))
+	(ampersands (count #\& string)))
+    (xml-rpc-struct :|ctLeftAngleBrackets| left-angle-brackets
+		    :|ctRightAngleBrackets| right-angle-brackets
+		    :|ctApostrophes| apostrophes
+		    :|ctQuotes| quotes
+		    :|ctAmpersands| ampersands)))
+
+(defun |validator1.manyTypesTest| (number boolean string double dateTime base64)
+  (assert
+   (and (integerp number)
+	(or (null boolean) (eq boolean t))
+	(stringp string)
+	(floatp double)
+	(xml-rpc-time-p dateTime)
+	(and (arrayp base64)
+	     (= (array-rank base64) 1)
+	     (subtypep (array-element-type base64)
+		       '(unsigned-byte 8)))))
+  (list number boolean string double dateTime base64))
+
+(defun |validator1.arrayOfStructsTest| (array)
+  (assert (listp array))
+  (reduce #'+
+	  (mapcar #'(lambda (struct)
+		      (assert (xml-rpc-struct-p struct))
+		      (get-xml-rpc-struct-member struct :|curly|))
+		  array)
+	  :initial-value 0))
+
+(defun |validator1.simpleStructReturnTest| (number)
+  (assert (integerp number))
+  (xml-rpc-struct :|times10| (* number 10)
+		  :|times100| (* number 100)
+		  :|times1000| (* number 1000)))
+
+(defun |validator1.moderateSizeArrayCheck| (array)
+  (assert (listp array))
+  (concatenate 'string (first array) (first (last array))))
+
+(defun |validator1.nestedStructTest| (struct)
+  (assert (xml-rpc-struct-p struct))
+  (let* ((year (get-xml-rpc-struct-member struct :\2000))
+	 (april (get-xml-rpc-struct-member year :\04))
+	 (first (get-xml-rpc-struct-member april :\01)))
+    (|validator1.easyStructTest| first)))
+
+(import '(|validator1.echoStructTest| 
+          |validator1.easyStructTest| 
+          |validator1.countTheEntities| 
+          |validator1.manyTypesTest| 
+          |validator1.arrayOfStructsTest|
+          |validator1.simpleStructReturnTest|
+          |validator1.moderateSizeArrayCheck|
+          |validator1.nestedStructTest|)
+        :s-xml-rpc-exports)
+
+;;;; eof
diff --git a/third-party/s-xml-rpc/src/xml-rpc.lisp b/third-party/s-xml-rpc/src/xml-rpc.lisp
new file mode 100644
index 0000000..b65d2c0
--- /dev/null
+++ b/third-party/s-xml-rpc/src/xml-rpc.lisp
@@ -0,0 +1,586 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: xml-rpc.lisp,v 1.11 2008-02-15 15:42:40 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of the XML-RPC protocol,
+;;;; as documented on the website http://www.xmlrpc.com
+;;;; This implementation includes both a client and server part.
+;;;; A Base64 encoder/decoder and a minimal XML parser are required.
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml-rpc)
+
+;;; conditions
+
+(define-condition xml-rpc-condition (error)
+  ()
+  (:documentation "Parent condition for all conditions thrown by the XML-RPC package"))
+
+(define-condition xml-rpc-fault (xml-rpc-condition)
+  ((code :initarg :code :reader xml-rpc-fault-code)
+   (string :initarg :string :reader xml-rpc-fault-string))
+  (:report (lambda (condition stream)
+	     (format stream
+		     "XML-RPC fault with message '~a' and code ~d."
+		     (xml-rpc-fault-string condition)
+		     (xml-rpc-fault-code condition))))
+  (:documentation "This condition is thrown when the XML-RPC server returns a fault"))
+
+(setf (documentation 'xml-rpc-fault-code 'function) "Get the code from an XML-RPC fault")
+(setf (documentation 'xml-rpc-fault-string 'function) "Get the string from an XML-RPC fault")
+
+(define-condition xml-rpc-error (xml-rpc-condition)
+  ((place :initarg :code :reader xml-rpc-error-place)
+   (data :initarg :data :reader xml-rpc-error-data))
+  (:report (lambda (condition stream)
+	     (format stream
+		     "XML-RPC error ~a at ~a."
+		     (xml-rpc-error-data condition)
+		     (xml-rpc-error-place condition))))
+  (:documentation "This condition is thrown when an XML-RPC protocol error occurs"))
+
+(setf (documentation 'xml-rpc-error-place 'function)
+      "Get the place from an XML-RPC error"
+      (documentation 'xml-rpc-error-data 'function)
+      "Get the data from an XML-RPC error")
+
+;;; whitespace handling support
+
+(defparameter +whitespace-characters+
+  '(#\Tab #\Space #\Page #\Return #\Newline #\Linefeed)
+  "The list of characters that we consider as whitespace")
+ 
+(defun whitespace-char? (char) 
+  "Return t when char is considered whitespace"
+  (member char +whitespace-characters+ :test #'char=))
+
+(defun whitespace-string? (str)
+  "Return t when str consists of nothing but whitespace characters"
+  (every #'whitespace-char? str))
+
+;;; iso8601 support (the xml-rpc variant)
+
+(defun universal-time->iso8601 (time &optional (stream nil))
+  "Convert a Common Lisp universal time to a string in the XML-RPC variant of ISO8601"
+  (multiple-value-bind (second minute hour date month year)
+      (decode-universal-time time)
+    (format stream
+	    "~d~2,'0d~2,'0dT~2,'0d:~2,'0d:~2,'0d"
+	    year
+	    month
+	    date
+	    hour
+	    minute
+	    second)))
+
+(defun iso8601->universal-time (string)
+  "Convert string in the XML-RPC variant of ISO8601 to a Common Lisp universal time"
+  (let (year month date (hour 0) (minute 0) (second 0))
+    (setf string (string-trim +whitespace-characters+ string))
+    (when (< (length string) 9)
+      (error "~s is to short to represent an iso8601" string))
+    (setf year (parse-integer string :start 0 :end 4)
+	  month (parse-integer string :start 4 :end 6)
+	  date (parse-integer string :start 6 :end 8))
+    (when (and (>= (length string) 17) (char= #\T (char string 8)))
+      (setf hour (parse-integer string :start 9 :end 11)
+	    minute (parse-integer string :start 12 :end 14)
+	    second (parse-integer string :start 15 :end 17)))
+    (encode-universal-time second minute hour date month year)))
+
+(defstruct (xml-rpc-time (:print-function print-xml-rpc-time))
+  "A wrapper around a Common Lisp universal time to be interpreted as an XML-RPC-TIME"
+  universal-time)
+
+(setf (documentation 'xml-rpc-time-p 'function)
+      "Return T when the argument is an XML-RPC time"
+      (documentation 'xml-rpc-time-universal-time 'function)
+      "Return the universal time from an XML-RPC time")
+
+(defun print-xml-rpc-time (xml-rpc-time stream depth)
+  (declare (ignore depth))
+  (format stream
+	  "#<XML-RPC-TIME ~a>"
+	  (universal-time->iso8601 (xml-rpc-time-universal-time xml-rpc-time))))
+
+(defun xml-rpc-time (&optional (universal-time (get-universal-time)))
+  "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))
+  "An XML-RPC-STRUCT is an associative map of member names and values"
+  alist)
+
+(setf (documentation 'xml-rpc-struct-p 'function)
+      "Return T when the argument is an XML-RPC struct"
+      (documentation 'xml-rpc-struct-alist 'function)
+      "Return the alist of member names and values from an XML-RPC struct")
+
+(defun print-xml-rpc-struct (xml-element stream depth)
+  (declare (ignore depth))
+  (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"
+  (cdr (assoc member (xml-rpc-struct-alist struct))))
+
+(defun (setf get-xml-rpc-struct-member) (value struct member)
+  "Set the value of a specific member of an XML-RPC-STRUCT"
+  (let ((pair (assoc member (xml-rpc-struct-alist struct))))
+    (if pair
+	(rplacd pair value)
+        (push (cons member value) (xml-rpc-struct-alist struct)))
+    value))
+
+(defun xml-rpc-struct (&rest args)
+  "Create a new XML-RPC-STRUCT from the arguments: alternating member names and values"
+  (unless (evenp (length args))
+    (error "~s must contain an even number of elements" args))
+  (let (alist)
+    (loop
+       (if (null args)
+           (return)
+           (push (cons (pop args) (pop args)) alist)))
+    (make-xml-rpc-struct :alist alist)))
+
+(defun xml-rpc-struct-equal (struct1 struct2)
+  "Compare two XML-RPC-STRUCTs for equality"
+  (if (and (xml-rpc-struct-p struct1)
+	   (xml-rpc-struct-p struct2)
+	   (= (length (xml-rpc-struct-alist struct1))
+	      (length (xml-rpc-struct-alist struct2))))
+      (dolist (assoc (xml-rpc-struct-alist struct1) t)
+	(unless (equal (get-xml-rpc-struct-member struct2 (car assoc))
+		       (cdr assoc))
+	  (return-from xml-rpc-struct-equal nil)))
+      nil))
+
+;;; encoding support
+
+(defun encode-xml-rpc-struct (struct stream)
+  (write-string "<struct>" stream)
+  (dolist (member (xml-rpc-struct-alist struct))
+    (write-string "<member>" stream)
+    (format stream "<name>~a</name>" (car member)) ; assuming name contains no special characters
+    (encode-xml-rpc-value (cdr member) stream)
+    (write-string "</member>" stream))
+  (write-string "</struct>" stream))
+
+(defun encode-xml-rpc-array (sequence stream)
+  (write-string "<array><data>" stream)
+  (map 'nil #'(lambda (element) (encode-xml-rpc-value element stream)) sequence)
+  (write-string "</data></array>" stream))
+
+(defun encode-xml-rpc-value (arg stream)
+  (write-string "<value>" stream)
+  (cond ((or (null arg) (eql arg t))
+	 (write-string "<boolean>" stream)
+	 (write-string (if arg "1" "0") stream)
+	 (write-string "</boolean>" stream))
+	((or (stringp arg) (symbolp arg))
+	 (write-string "<string>" stream)
+	 (print-string-xml (string arg) stream)
+	 (write-string "</string>" stream))
+	((integerp arg) (format stream "<int>~d</int>" arg))
+	((floatp arg) (format stream "<double>~f</double>" arg))
+	((and (arrayp arg)
+	      (= (array-rank arg) 1)
+	      (subtypep (array-element-type arg)
+			'(unsigned-byte 8)))
+	 (write-string "<base64>" stream)
+	 (encode-base64-bytes arg stream)
+	 (write-string "</base64>" stream))
+	((xml-rpc-time-p arg)
+	 (write-string "<dateTime.iso8601>" stream)
+	 (universal-time->iso8601 (xml-rpc-time-universal-time arg) stream)
+	 (write-string "</dateTime.iso8601>" stream))
+        ((xml-literal-p arg)
+         (write-string (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
+	(t (error "cannot encode ~s" arg)))
+  (write-string "</value>" stream))
+
+(defun encode-xml-rpc-args (args stream)
+  (write-string "<params>" stream)
+  (dolist (arg args)
+    (write-string "<param>" stream)
+    (encode-xml-rpc-value arg stream)
+    (write-string "</param>" stream))
+  (write-string "</params>" stream))
+
+(defun encode-xml-rpc-call (name &rest args)
+  "Encode an XML-RPC call with name and args as an XML string"
+  (with-output-to-string (stream)
+    (write-string "<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))
+    (write-string "</methodCall>" stream)))
+
+(defun encode-xml-rpc-result (value)
+  (with-output-to-string (stream)
+    (write-string "<methodResponse>" stream)
+    (encode-xml-rpc-args (list value) stream)
+    (write-string "</methodResponse>" stream)))
+
+(defun encode-xml-rpc-fault-value (fault-string &optional (fault-code 0))
+  ;; for system.multicall
+  (with-output-to-string (stream)
+    (write-string "<struct>" stream)
+    (format stream "<member><name>faultCode</name><value><int>~d</int></value></member>" fault-code)
+    (write-string "<member><name>faultString</name><value><string>" stream)
+    (print-string-xml fault-string stream)
+    (write-string "</string></value></member>" stream)
+    (write-string "</struct>" stream)))
+
+(defun encode-xml-rpc-fault (fault-string &optional (fault-code 0))
+  (with-output-to-string (stream)
+    (write-string "<methodResponse><fault><value>" stream)
+    (write-string (encode-xml-rpc-fault-value fault-string fault-code) stream)
+    (write-string "</value></fault></methodResponse>" stream)))
+
+;;; decoding support
+
+(defun decode-xml-rpc-new-element (name attributes seed)
+  (declare (ignore seed name attributes))
+  '())
+
+(defun decode-xml-rpc-finish-element (name attributes parent-seed seed)
+  (declare (ignore attributes))
+  (cons (case name
+	  ((:|int| :|i4|) (parse-integer seed))
+	  (:|double| (let ((*read-eval* nil)
+                           (*read-default-float-format* 'double-float))
+                       (read-from-string seed)))
+	  (:|boolean| (= 1 (parse-integer seed)))
+	  (:|string| (if (null seed) "" seed))
+	  (:|dateTime.iso8601| (xml-rpc-time (iso8601->universal-time seed)))
+	  (:|base64| (if (null seed)
+			 (make-array 0 :element-type '(unsigned-byte 8))
+		       (with-input-from-string (in seed)
+			 (decode-base64-bytes in))))
+	  (:|array| (car seed))
+	  (:|data| (unless (stringp seed) (nreverse seed)))
+	  (:|value| (cond ((stringp seed) seed)
+                          ((null seed) "")
+                          (t (car seed))))
+	  (:|struct| (make-xml-rpc-struct :alist seed))
+	  (:|member| (cons (cadr seed) (car seed)))
+	  (:|name| (intern seed :keyword))
+	  (:|params| (nreverse seed))
+	  (:|param| (car seed))
+	  (:|fault| (make-condition 'xml-rpc-fault
+				    :string (get-xml-rpc-struct-member (car seed) :|faultString|)
+				    :code (get-xml-rpc-struct-member (car seed) :|faultCode|)))
+	  (:|methodName| seed)
+	  (:|methodCall| (let ((pair (nreverse seed)))
+			   (cons (car pair) (cadr pair))))
+	  (:|methodResponse| (car seed)))
+	parent-seed))
+
+(defun decode-xml-rpc-text (string seed)
+  (declare (ignore seed))
+  string)
+
+(defun decode-xml-rpc (stream)
+  (car (start-parse-xml stream
+                        (make-instance 'xml-parser-state
+                                       :new-element-hook #'decode-xml-rpc-new-element
+                                       :finish-element-hook #'decode-xml-rpc-finish-element
+                                       :text-hook #'decode-xml-rpc-text))))
+
+;;; networking basics
+
+(defparameter *xml-rpc-host* "localhost"
+  "String naming the default XML-RPC host to use")
+
+(defparameter *xml-rpc-port* 80
+  "Integer specifying the default XML-RPC port to use")
+
+(defparameter *xml-rpc-url* "/RPC2"
+  "String specifying the default XML-RPC URL to use")
+
+(defparameter *xml-rpc-agent* (concatenate 'string
+					   (lisp-implementation-type)
+					   " "
+					   (lisp-implementation-version))
+  "String specifying the default XML-RPC agent to include in server responses")
+
+(defvar *xml-rpc-debug* nil
+  "When T the XML-RPC client and server part will be more verbose about their protocol")
+
+(defvar *xml-rpc-debug-stream* nil
+  "When not nil it specifies where debugging output should be written to")
+
+(defparameter *xml-rpc-proxy-host* nil
+  "When not null, a string naming the XML-RPC proxy host to use")
+
+(defparameter *xml-rpc-proxy-port* nil
+  "When not null, an integer specifying the XML-RPC proxy port to use")
+
+(defparameter *xml-rpc-package* (find-package :s-xml-rpc-exports)
+  "Package for XML-RPC callable functions")
+
+(defparameter *xml-rpc-authorization* nil
+  "When not null, a string to be used as Authorization header")
+
+(defun format-debug (&rest args)
+  (when *xml-rpc-debug*
+    (apply #'format args)))
+
+(defparameter +crlf+ (make-array 2
+                                 :element-type 'character
+                                 :initial-contents '(#\return #\linefeed)))
+
+(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))))))
+
+(defun format-header (stream headers)
+  (mapc #'(lambda (header)
+            (cond ((null (rest header)) (write-string (first header) stream) (write-string +crlf+ stream))
+                  ((second header) (apply #'format stream header) (write-string +crlf+ stream))))
+	headers)
+  (write-string +crlf+ stream))
+
+(defun debug-stream (in)
+  (if *xml-rpc-debug*
+      (make-echo-stream in *standard-output*)
+    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*))
+  "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-stream  (connection (s-sysdeps:open-socket-stream (if proxy-host proxy-host host)
+                                                                    (if proxy-port proxy-port port)))
+      (format-debug (or *xml-rpc-debug-stream* t) "POST ~a HTTP/1.0~%Host: ~a:~d~%" uri host port)
+      (format-header connection `(("POST ~a HTTP/1.0" ,uri)
+				  ("User-Agent: ~a" ,agent)
+				  ("Host: ~a:~d" ,host ,port)
+                                  ("Authorization: ~a" ,authorization)
+				  ("Content-Type: text/xml")
+				  ("Content-Length: ~d" ,(length encoded))))
+      (write-string encoded connection)
+      (finish-output connection)
+      (format-debug (or *xml-rpc-debug-stream* t) "Sending ~a~%~%" encoded)
+      (let ((header (read-line connection nil nil)))
+	(when (null header) (error "no response from server"))
+	(format-debug (or *xml-rpc-debug-stream* t) "~a~%" header)
+	(setf header (tokens header))
+	(unless (and (>= (length header) 3)
+		     (string-equal (second header) "200")
+		     (string-equal (third header) "OK"))
+	  (error "http-error:~{ ~a~}" header)))
+      (do ((line (read-line connection nil nil)
+		 (read-line connection nil nil)))
+	  ((or (null line) (<= (length line) 1)))
+	(format-debug (or *xml-rpc-debug-stream* t) "~a~%" line))
+      (let ((result (decode-xml-rpc (debug-stream connection))))
+	(if (typep result 'xml-rpc-fault)
+	    (error 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"
+  (apply #'xml-rpc-call
+	 (cons (apply #'encode-xml-rpc-call (cons name args))
+	       server-keywords)))
+
+(defun describe-server (&key (host *xml-rpc-host*) (port *xml-rpc-port*) (url *xml-rpc-url*))
+  "Tries to describe a remote server using system.* methods"
+  (dolist (method (xml-rpc-call (encode-xml-rpc-call "system.listMethods")
+				:host host
+				:port port
+				:url url))
+    (format t
+	    "Method ~a ~a~%~a~%~%"
+	    method
+	    (xml-rpc-call (encode-xml-rpc-call "system.methodSignature" method)
+			  :host host
+			  :port port
+			  :url url)
+	    (xml-rpc-call (encode-xml-rpc-call "system.methodHelp" method)
+			  :host host
+			  :port port
+			  :url url))))
+
+
+;;; 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_.:/")
+
+(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*.
+  Returns the symbol named METHOD-NAME if it exists and is
+  fbound, or NIL if not."
+  (let ((sym (find-symbol method-name *xml-rpc-package*)))
+    (if (fboundp sym) sym nil)))
+
+(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)
+        ;; 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."
+  ;; 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*
+                           (first call)
+			   (rest call))))
+	(format-debug (or *xml-rpc-debug-stream* t) "~a call result is ~s~%" id result)
+	(encode-xml-rpc-result result)))))
+
+(defun xml-rpc-implementation-version ()
+  "Identify ourselves"
+  (concatenate 'string
+	       "$Id: xml-rpc.lisp,v 1.11 2008-02-15 15:42:40 scaekenberghe Exp $"
+	       " "
+	       (lisp-implementation-type)
+	       " "
+	       (lisp-implementation-version)))
+
+(defun xml-rpc-server-connection-handler (connection id agent url)
+  "Handle an incoming connection, doing both all HTTP and XML-RPC stuff"
+  (handler-bind ((error #'(lambda (c)
+			    (format-debug (or *xml-rpc-debug-stream* t)
+                                          "xml-rpc server connection handler failed with ~a~%" c)
+                            (error c)
+			    (return-from xml-rpc-server-connection-handler nil))))
+    (let ((header (read-line connection nil nil)))
+      (when (null header) (error "no request from client"))
+      (setf header (tokens header))
+      (if (and (>= (length header) 3)
+	       (string-equal (first header) "POST")
+	       (string-equal (second header) url))
+	  (progn
+	    (do ((line (read-line connection nil nil)
+		       (read-line connection nil nil)))
+		((or (null line) (<= (length line) 1)))
+	      (format-debug (or *xml-rpc-debug-stream* t) "~d ~a~%" id line))
+	    (let ((xml (handle-xml-rpc-call connection id)))
+	      (format-header connection
+			     `(("HTTP/1.0 200 OK")
+			       ("Server: ~a" ,agent)
+			       ("Connection: close")
+			       ("Content-Type: text/xml")
+			       ("Content-Length: ~d" ,(length xml))))
+	      (write-string 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)))
+      (force-output connection)
+      (close connection))))
+
+(defparameter *counter* 0 "Unique ID for incoming connections")
+
+(defun start-xml-rpc-server (&key (port *xml-rpc-port*) (url *xml-rpc-url*) (agent *xml-rpc-agent*))
+  "Start an XML-RPC server in a separate process"
+  (s-sysdeps:start-standard-server
+   :name (format nil "xml-rpc server ~a:~d" url port)
+   :port port
+   :connection-handler #'(lambda (client-stream)
+                           (let ((id (incf *counter*)))
+                             (format-debug (or *xml-rpc-debug-stream* t) "spawned connection handler ~d~%" id)
+                             (s-sysdeps:run-process (format nil "xml-rpc-server-connection-handler-~d" id)
+                                                    #'xml-rpc-server-connection-handler
+                                                    client-stream
+                                                    id
+                                                    agent
+                                                    url)))))
+
+;;;; eof