From ddb83b1fb2d305e0c06fc067d82d6bab5458b0fd Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Fri, 30 Oct 2009 20:52:07 +0100
Subject: Add third-party XML processing libraries.
Ignore-this: 5ca28497555bf944858ca2f58bc8a62b
darcs-hash:a0b0f9baa7c9b1259e755435db1fb17123630a6c
---
third-party/s-xml-rpc/src/aserve.lisp | 79 +++
.../s-xml-rpc/src/define-xmlrpc-method.lisp | 30 ++
third-party/s-xml-rpc/src/extensions.lisp | 107 ++++
third-party/s-xml-rpc/src/package.lisp | 49 ++
third-party/s-xml-rpc/src/validator1-client.lisp | 182 +++++++
third-party/s-xml-rpc/src/validator1-server.lisp | 90 ++++
third-party/s-xml-rpc/src/xml-rpc.lisp | 586 +++++++++++++++++++++
7 files changed, 1123 insertions(+)
create mode 100644 third-party/s-xml-rpc/src/aserve.lisp
create mode 100644 third-party/s-xml-rpc/src/define-xmlrpc-method.lisp
create mode 100644 third-party/s-xml-rpc/src/extensions.lisp
create mode 100644 third-party/s-xml-rpc/src/package.lisp
create mode 100644 third-party/s-xml-rpc/src/validator1-client.lisp
create mode 100644 third-party/s-xml-rpc/src/validator1-server.lisp
create mode 100644 third-party/s-xml-rpc/src/xml-rpc.lisp
(limited to 'third-party/s-xml-rpc/src')
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
--
cgit v1.2.3