Implement new, properly tested, version of xml-rpc based on http-client and sxpath. TODO: documentation and xml-rpc-server module

5 files changed, 642 insertions, 0 deletions

diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..5e887b9
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,305 @@
+(use test)
+;; Should use numbers, but that's a whole new can of worms...
+
+(load "../xml-rpc-lolevel")
+(import xml-rpc-lolevel)
+
+(test-group "Marshaling"
+  (test "integer"
+        `(i4 "1")
+        (value->xml-rpc-fragment 1))
+  (test "double"
+        `(double "1.2345")
+        (value->xml-rpc-fragment 1.2345))
+  (test "double exact->inexact"
+        `(double ,(number->string (exact->inexact 1/3)))
+        (value->xml-rpc-fragment 1/3))
+  (test "empty string" 
+        `(string "") ;; Or (string) ?
+        (value->xml-rpc-fragment ""))
+  (test "string"
+        `(string "fubar")
+        (value->xml-rpc-fragment "fubar"))
+  (test "empty symbol"
+        `(string "") ;; Or (string) ?
+        (value->xml-rpc-fragment '||))
+  (test "symbol"
+        `(string "fubar")
+        (value->xml-rpc-fragment 'fubar))
+  (test "empty u8vector"
+        `(base64 "")
+        (value->xml-rpc-fragment (u8vector)))
+  (test "u8vector"
+        `(base64 "YWJj")
+        (value->xml-rpc-fragment (u8vector 97 98 99)))
+  (test "empty blob"
+        `(base64 "")
+        (value->xml-rpc-fragment (string->blob "")))
+  (test "blob"
+        `(base64 "YWJj")
+        (value->xml-rpc-fragment (string->blob "abc")))
+  (test "empty vector"
+        `(array (data))
+        (value->xml-rpc-fragment (vector)))
+  (test "vector"
+        `(array (data
+                 (value (string "one"))
+                 (value (i4 "2"))))
+        (value->xml-rpc-fragment (vector "one" 2)))
+  (test "nested vector"
+        `(array (data
+                 (value (array (data (value (string "one")))))))
+        (value->xml-rpc-fragment (vector (vector "one"))))
+  (test "empty list"
+        `(array (data))
+        (value->xml-rpc-fragment '()))
+  (test "list"
+        `(array (data
+                 (value (string "one"))
+                 (value (i4 "2"))))
+        (value->xml-rpc-fragment '("one" 2)))
+  (test "nested list"
+        `(array (data
+                 (value (array (data (value (string "one")))))))
+        (value->xml-rpc-fragment '(("one"))))  
+  (test "empty hash table"
+        `(struct)
+        (value->xml-rpc-fragment (alist->hash-table `())))
+  (test "simple hash table"
+        ;; XXX: Hash ordering can change! Test is too specific
+        `(struct
+          (member
+           (name "qux")
+           (value (i4 "1")))
+          (member
+           (name "foo")
+           (value (string "bar"))))
+        (value->xml-rpc-fragment
+         (alist->hash-table `((qux . 1) (foo . "bar")))))
+  (test "nested hash table"
+        `(struct
+          (member
+           (name "foo")
+           (value (struct
+                   (member
+                    (name "bar")
+                    (value (string "qux")))))))
+        (value->xml-rpc-fragment
+         (alist->hash-table `((foo . ,(alist->hash-table `((bar . "qux"))))))))
+  (test "hash table with vector array"
+        `(struct
+          (member
+           (name "foo")
+           (value (array
+                   (data
+                    (value (string "bar"))
+                    (value (string "qux")))))))
+        (value->xml-rpc-fragment
+         (alist->hash-table `((foo . ,(vector "bar" "qux"))))))
+  (test "vector array with hash tables"
+        `(array
+          (data
+           (value
+            (struct
+             (member
+              (name "foo")
+              (value (string "bar")))))
+           (value
+            (struct
+             (member
+              (name "qux")
+              (value (string "mooh")))))))
+        (value->xml-rpc-fragment
+         (vector (alist->hash-table `((foo . "bar")))
+                 (alist->hash-table `((qux . "mooh"))))))
+  (test "simple alist"
+        `(struct
+          (member
+           (name "qux")
+           (value (i4 "1")))
+          (member
+           (name "foo")
+           (value (string "bar"))))
+        (value->xml-rpc-fragment `((qux . 1) (foo . "bar"))))
+  (test "nested alist"
+        `(struct
+          (member
+           (name "foo")
+           (value (struct
+                   (member
+                    (name "bar")
+                    (value (string "qux")))))))
+        (value->xml-rpc-fragment `((foo . ((bar . "qux"))))))
+  (test "alist with vector array"
+        `(struct
+          (member
+           (name "foo")
+           (value (array
+                   (data
+                    (value (string "bar"))
+                    (value (string "qux")))))))
+        (value->xml-rpc-fragment `((foo . ,(vector "bar" "qux")))))
+  (test "vector array with alist"
+        `(array
+          (data
+           (value
+            (struct
+             (member
+              (name "foo")
+              (value (string "bar")))))
+           (value
+            (struct
+             (member
+              (name "qux")
+              (value (string "mooh")))))))
+        (value->xml-rpc-fragment
+         (vector '((foo . "bar")) '((qux . "mooh")))))
+  (test "ISO8601"
+        `(dateTime.iso8601 "19980717T14:08:55")
+        (parameterize ((xml-rpc-unparsers
+                        `((,vector? . ,vector->xml-rpc-iso8601))))
+          (value->xml-rpc-fragment (vector 55 8 14 17 6 98 0 0 #f 0))))
+  (define-record foo bar)
+  (test-error "unknown type gives error"
+              (value->xml-rpc-fragment (make-foo 1))))
+
+(test-group "Unmarshaling"
+  (test "integer (i4)"
+        123
+        (xml-rpc-fragment->value `(i4 "123")))
+  (test "integer (int)"
+        123
+        (xml-rpc-fragment->value `(int "123")))
+  (test "double"
+        123.456
+        (xml-rpc-fragment->value `(double "123.456")))
+  (test "boolean false"
+        #f
+        (xml-rpc-fragment->value `(boolean "0")))
+  (test "boolean true (correct)"
+        #t
+        (xml-rpc-fragment->value `(boolean "1")))
+  (test "boolean true (liberal)"
+        #t
+        (xml-rpc-fragment->value `(boolean "2")))
+  (test "empty string"
+        ""
+        (xml-rpc-fragment->value `(string)))
+  (test "empty string (explicit data)"
+        ""
+        (xml-rpc-fragment->value `(string "")))
+  (test "base64"
+        (u8vector 97 98 99)
+        (xml-rpc-fragment->value `(base64 "YWJj")))
+  (test "empty array"
+        (vector)
+        (xml-rpc-fragment->value `(array (data))))
+  (test "simple array"
+        (vector 1 "abc")
+        (xml-rpc-fragment->value `(array (data (value (int "1"))
+                                               (value (string "abc"))))))
+  (test "nested array"
+        (vector (vector 1 2) (vector "abc" "def") "ghi")
+        (xml-rpc-fragment->value `(array (data
+                                          (value (array
+                                                  (data
+                                                   (value (int "1"))
+                                                   (value (int "2")))))
+                                          (value (array
+                                                  (data
+                                                   (value (string "abc"))
+                                                   (value (string "def")))))
+                                          (value (string "ghi"))))))
+  (test "nasty nested array with attrs"
+        (vector (vector 1 2) (vector "abc" "def") "ghi")
+        (xml-rpc-fragment->value `(array (@ (type "list"))
+                                         (data (@ (type "nested"))
+                                          (value (array
+                                                  (data (@ (type "flat"))
+                                                   (value (int
+                                                           (@ (bit "signed"))
+                                                           "1"))
+                                                   (value (int "2")))))
+                                          (value (array
+                                                  (data
+                                                   (value (string "abc"))
+                                                   (value (string "def")))))
+                                          (value (string "ghi"))))))
+  (test "empty struct"
+        (alist->hash-table '())
+        (xml-rpc-fragment->value `(struct)))
+  (test "simple struct"
+        (alist->hash-table '((foo . "bar")))
+        (xml-rpc-fragment->value `(struct (member (name "foo")
+                                                  (value (string "bar"))))))
+  (test "simple struct - rearranged name/value"
+        (alist->hash-table '((foo . "bar")))
+        (xml-rpc-fragment->value `(struct (member (value (string "bar"))
+                                                  (name "foo")))))
+  (test "nested struct"
+        (alist->hash-table `((foo . ,(alist->hash-table '((bar . "qux"))))))
+        (xml-rpc-fragment->value `(struct
+                                   (member
+                                    (name "foo")
+                                    (value (struct
+                                            (member
+                                             (name "bar")
+                                             (value (string "qux")))))))))
+  (test "nasty nested struct with attrs"
+        (alist->hash-table `((foo . ,(alist->hash-table '((bar . "qux"))))))
+        (xml-rpc-fragment->value `(struct (@ (lang "en"))
+                                   (member
+                                    (name (@ (dir "rtl")) "foo")
+                                    (value (@ (type "dictionary"))
+                                           (struct
+                                            (member
+                                             (name "bar")
+                                             (value (string "qux")))))))))
+  ;; Try other different notations (ISO8601 has a variety of notations)
+  (test "datetime"
+        (vector 55 8 14 17 6 98 0 0 #f 0)
+        (xml-rpc-fragment->value
+         `(dateTime.iso8601 "19980717T14:08:55"))))
+
+(load "../xml-rpc-client")
+(import xml-rpc-client)
+
+(test-group "response handling"
+  (test "simple response"
+        '("test")
+        (receive params
+          (handle-xml-rpc-response
+          `(*TOP*
+            (*PI* xml "version=\"1.0\"")
+            (methodResponse
+             (params
+              (param (value (string "test")))))))
+          params))
+  (test "multi-param response (chicken extension)"
+        '("test" 1 2 3)
+        (receive params
+          (handle-xml-rpc-response
+           `(*TOP*
+             (*PI* xml "version=\"1.0\"")
+             (methodResponse
+              (params
+               (param (value (string "test")))
+               (param (value (i4 "1")))
+               (param (value (int "2")))
+               (param (value (int "3")))))))
+          params))
+  (test-error "fault code throws exception"
+              (receive params
+                (handle-xml-rpc-response
+                 `(*TOP*
+                   (*PI* xml "version=\"1.0\"")
+                   (methodResponse
+                    (fault
+                     (value (struct
+                             (member
+                              (name "faultCode")
+                              (value (int "10")))
+                             (member
+                              (name "faultString")
+                              (value (string "there was an error")))))))))
+                params)))
\ No newline at end of file
diff --git a/xml-rpc-client.scm b/xml-rpc-client.scm
new file mode 100644
index 0000000..a946b9c
--- /dev/null
+++ b/xml-rpc-client.scm
@@ -0,0 +1,107 @@
+;;;; xml-rpc-client.scm
+;
+;; An implementation of the XML-RPC protocol
+;;
+;; This file contains a client implementation.
+;
+; Copyright (c) 2009, Peter Bex
+; Parts Copyright (c) Felix Winkelmann
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; 1. Redistributions of source code must retain the above copyright
+;    notice, this list of conditions and the following disclaimer.
+; 2. Redistributions in binary form must reproduce the above copyright
+;    notice, this list of conditions and the following disclaimer in the
+;    documentation and/or other materials provided with the distribution.
+; 3. Neither the name of the author nor the names of its
+;    contributors may be used to endorse or promote products derived
+;    from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+; OF THE POSSIBILITY OF SUCH DAMAGE.
+;
+; Please report bugs, suggestions and ideas to the Chicken Trac
+; ticket tracking system (assign tickets to user 'sjamaan'):
+; http://trac.callcc.org
+
+(module xml-rpc-client
+  (xml-rpc-server xml-rpc-response->values)
+
+(import chicken scheme)
+(use srfi-13 data-structures http-client uri-common intarweb
+     xml-rpc-lolevel ssax sxpath-lolevel)
+
+(define (xml-rpc-response->values response-sxml)
+  (let* ((resp ((select-first-kid (ntype?? 'methodResponse)) response-sxml)))
+    (cond
+     (((select-first-kid (ntype?? 'fault)) resp) =>
+      (lambda (fault)
+        ;; Ensure the unparsing of the fault is handled so we can understand
+        ;; the result value.
+        (parameterize ((xml-rpc-parsers `((i4 . ,xml-rpc-int->number)
+                                          (int . ,xml-rpc-int->number)
+                                          (struct . ,xml-rpc-struct->alist)
+                                          (string . ,xml-rpc-string->string))))
+          (let ((val (xml-rpc-fragment->value
+                      (car ((node-join (select-first-kid (ntype?? 'value))
+                                       sxml:content)
+                            fault)))))
+            (signal-xml-rpc-error (alist-ref 'faultCode val)
+                                  (alist-ref 'faultString val))))))
+     (((select-first-kid (ntype?? 'params)) resp) =>
+      (lambda (params)
+        (apply values
+               (map
+                xml-rpc-fragment->value
+                ((node-join
+                  (select-kids (ntype?? 'param))
+                  (select-first-kid (ntype?? 'value))
+                  sxml:content)
+                 params)))))
+     (else (signal-xml-rpc-error 0 "Malformed response data" resp)))))
+
+;; Unfortunately, we need this; spec says "Content-Length" header is required
+(define (sxml->string sxml)
+  (string-concatenate (flatten (sxml:sxml->xml sxml))))
+
+(define (xml-rpc-server uri)
+  (set! uri (uri-reference uri))
+  (lambda (method-name)
+    (lambda args
+      (let* ((xml
+              (string-append
+               "<?xml version=\"1.0\"?>\n"
+               (sxml->string
+                (if (null? args)
+                    `(methodCall (methodName ,method-name))
+                    `(methodCall
+                      (methodName ,method-name)
+                      (params
+                       ,(map (lambda (p)
+                               `(param
+                                 (value ,(value->xml-rpc-fragment p))))
+                             args)))))))
+             (req (make-request
+                   method: 'POST uri: uri
+                   headers: (headers `((content-length ,(string-length xml)))))))
+        (xml-rpc-response->values
+         (call-with-input-request
+          req
+          (lambda (p) (display xml p))
+          (lambda (p) (ssax:xml->sxml p '()))))))))
+
+)
\ No newline at end of file
diff --git a/xml-rpc-lolevel.scm b/xml-rpc-lolevel.scm
new file mode 100644
index 0000000..e5565b5
--- /dev/null
+++ b/xml-rpc-lolevel.scm
@@ -0,0 +1,197 @@
+;;;; xml-rpc-lolevel.scm
+;
+;; An implementation of the XML-RPC protocol
+;;
+;; This file contains the plumbing for XML RPC value marshaling/unmarshaling.
+;
+; Copyright (c) 2009, Peter Bex
+; Parts Copyright (c) Felix Winkelmann
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; 1. Redistributions of source code must retain the above copyright
+;    notice, this list of conditions and the following disclaimer.
+; 2. Redistributions in binary form must reproduce the above copyright
+;    notice, this list of conditions and the following disclaimer in the
+;    documentation and/or other materials provided with the distribution.
+; 3. Neither the name of the author nor the names of its
+;    contributors may be used to endorse or promote products derived
+;    from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+; OF THE POSSIBILITY OF SUCH DAMAGE.
+;
+; Please report bugs, suggestions and ideas to the Chicken Trac
+; ticket tracking system (assign tickets to user 'sjamaan'):
+; http://trac.callcc.org
+
+(provide 'xml-rpc-lolevel)
+
+(module xml-rpc-lolevel
+  (signal-xml-rpc-error
+   xml-rpc-unparsers value->xml-rpc-fragment
+   list->xml-rpc-array vector->xml-rpc-array
+   number->xml-rpc-int number->xml-rpc-double
+   boolean->xml-rpc-boolean ->xml-rpc-string
+   u8vector->xml-rpc-base64 blob->xml-rpc-base64
+   alist->xml-rpc-struct hash-table->xml-rpc-struct
+   vector->xml-rpc-iso8601
+   nonempty-symbol-keyed-alist?
+
+   xml-rpc-parsers xml-rpc-fragment->value
+   xml-rpc-int->number xml-rpc-double->number
+   xml-rpc-boolean->number xml-rpc-string->string
+   xml-rpc-array->vector xml-rpc-array->list
+   xml-rpc-struct->alist xml-rpc-struct->hash-table
+   xml-rpc-base64->string xml-rpc-base64->u8vector xml-rpc-base64->blob
+   xml-rpc-datetime->vector)
+
+(import chicken scheme)
+(use data-structures posix srfi-1 srfi-4 srfi-69 base64 sxpath-lolevel)
+
+(define (signal-xml-rpc-error code msg . args)
+  (signal
+   (make-composite-condition
+    (make-property-condition 'exn 'message msg 'arguments args)
+    (make-property-condition 'xml-rpc 'code code))))
+
+(define (list->xml-rpc-array v)
+  `(array (data ,@(map (lambda (el)
+                         `(value ,(value->xml-rpc-fragment el)))
+                       v))))
+
+(define (vector->xml-rpc-array v)
+  (list->xml-rpc-array (vector->list v)))
+
+(define (number->xml-rpc-int v)
+  `(i4 ,(number->string (inexact->exact (round v)))))
+
+(define (number->xml-rpc-double v)
+  `(double ,(number->string (exact->inexact v))))
+
+(define (boolean->xml-rpc-boolean v)
+  `(boolean ,(if v "1" "0")))
+
+(define (->xml-rpc-string v)
+  `(string ,(->string v)))
+
+(define (u8vector->xml-rpc-base64 v)
+  (blob->xml-rpc-base64 (u8vector->blob/shared v)))
+
+(define (blob->xml-rpc-base64 v)
+  `(base64 ,(base64-encode (blob->string v))))
+
+(define (alist->xml-rpc-struct v)
+  `(struct ,@(map (lambda (p)
+                    `(member
+                      (name ,(->string (car p)))
+                      (value ,(value->xml-rpc-fragment (cdr p)))))
+                  v)))
+
+(define (hash-table->xml-rpc-struct v)
+  (alist->xml-rpc-struct (hash-table->alist v)))
+
+(define (vector->xml-rpc-iso8601 v)
+  `(dateTime.iso8601 ,(time->string v "%Y%m%dT%H:%M:%S")))
+
+(define (nonempty-symbol-keyed-alist? v)
+  (and (not (null? v))
+       (list? v)
+       (every (lambda (p)
+                (and (pair? p) (symbol? (car p))))
+              v)))
+
+(define xml-rpc-unparsers
+  (make-parameter `((,vector? . ,vector->xml-rpc-array)
+                    (,(conjoin number? exact?) . ,number->xml-rpc-int)
+                    (,number? . ,number->xml-rpc-double)
+                    (,boolean? . ,boolean->xml-rpc-boolean)
+                    (,string? . ,->xml-rpc-string)
+                    (,symbol? . ,->xml-rpc-string)
+                    (,u8vector? . ,u8vector->xml-rpc-base64)
+                    (,blob? . ,blob->xml-rpc-base64)
+                    (,hash-table? . ,hash-table->xml-rpc-struct)
+                    (,nonempty-symbol-keyed-alist? . ,alist->xml-rpc-struct)
+                    (,list? . ,list->xml-rpc-array))))
+
+(define (value->xml-rpc-fragment value)
+  ((alist-ref value (xml-rpc-unparsers)
+              (lambda (pred? v) (pred? v))
+              (lambda _ (error "No parser for value " value)))
+   value))
+
+(define (xml-rpc-int->number fragment)
+  (string->number (sxml:text fragment)))
+
+(define (xml-rpc-double->number fragment)
+  (string->number (sxml:text fragment)))
+
+(define (xml-rpc-boolean->number fragment)
+  (not (= (string->number (sxml:text fragment)) 0)))
+
+(define xml-rpc-string->string sxml:text)
+
+(define (xml-rpc-base64->string fragment)
+  (base64-decode (sxml:text fragment)))
+
+(define (xml-rpc-base64->u8vector fragment)
+  (blob->u8vector/shared (string->blob (base64-decode (sxml:text fragment)))))
+
+(define (xml-rpc-array->vector fragment)
+  (list->vector (xml-rpc-array->list fragment)))
+
+(define (xml-rpc-array->list fragment)
+  (map (lambda (v)
+         (xml-rpc-fragment->value v))
+       ((node-join (select-first-kid (ntype?? 'data))
+                   (select-kids (ntype?? 'value))
+                   sxml:content)
+        fragment)))
+
+(define (xml-rpc-struct->alist fragment)
+  (map (lambda (v)
+         (cons (string->symbol
+                (sxml:text ((select-first-kid (ntype?? 'name)) v)))
+               (xml-rpc-fragment->value
+                (car (sxml:content ((select-first-kid (ntype?? 'value)) v))))))
+       (sxml:content fragment)))
+
+(define (xml-rpc-struct->hash-table fragment)
+  (alist->hash-table (xml-rpc-struct->alist fragment)))
+
+(define (xml-rpc-base64->blob fragment)
+  (u8vector->blob/shared (base64-decode (cadr fragment))))
+
+(define (xml-rpc-datetime->vector fragment)
+  (string->time (cadr fragment) "%Y%m%dT%H:%M:%S"))
+
+(define xml-rpc-parsers
+  (make-parameter `((i4 . ,xml-rpc-int->number)
+                    (int . ,xml-rpc-int->number)
+                    (double . ,xml-rpc-double->number)
+                    (boolean . ,xml-rpc-boolean->number)
+                    (string . ,xml-rpc-string->string)
+                    (base64 . ,xml-rpc-base64->u8vector)
+                    (dateTime.iso8601 . ,xml-rpc-datetime->vector)
+                    (array . ,xml-rpc-array->vector)
+                    (struct . ,xml-rpc-struct->hash-table))))
+
+(define (xml-rpc-fragment->value fragment)
+  ((alist-ref (sxml:element-name fragment) (xml-rpc-parsers) eq?
+              (lambda _ (error "No unparser for tag " (car fragment))))
+   fragment))
+
+)
\ No newline at end of file
diff --git a/xml-rpc.meta b/xml-rpc.meta
new file mode 100644
index 0000000..88670c7
--- /dev/null
+++ b/xml-rpc.meta
@@ -0,0 +1,15 @@
+;;; xml-rpc.meta -*- Hen -*-
+
+((egg "xml-rpc.egg")
+ (synopsis "XML-RPC client/server")
+ (category web)
+ (needs base64 http-client ssax sxpath)
+ (test-depends test) ; numbers
+ (doc-from-wiki)
+ (license "BSD")
+ (author "Peter Bex")
+ (files "xml-rpc.setup"
+	"xml-rpc.html"
+        "xml-rpc-client.scm"
+        "xml-rpc-server.scm"
+        "xml-rpc-lolevel.scm"))
diff --git a/xml-rpc.setup b/xml-rpc.setup
new file mode 100644
index 0000000..4f07842
--- /dev/null
+++ b/xml-rpc.setup
@@ -0,0 +1,18 @@
+;-*- Scheme -*-
+
+(compile -s -O2 xml-rpc-lolevel.scm -j xml-rpc-lolevel)
+(compile -s -O2 xml-rpc-lolevel.import.scm)
+
+(compile -s -O2 xml-rpc-client.scm -j xml-rpc-client)
+(compile -s -O2 xml-rpc-client.import.scm)
+
+(compile -s -O2 xml-rpc-server.scm -j xml-rpc-server)
+(compile -s -O2 xml-rpc-server.import.scm)
+
+(install-extension
+  'xml-rpc
+  '("xml-rpc-lolevel.so" "xml-rpc-lolevel.import.so"
+    "xml-rpc-client.so" "xml-rpc-client.import.so"
+    "xml-rpc-server.so" "xml-rpc-server.import.so")
+  `((version 2.0)
+    (documentation "xml-rpc.html")))
\ No newline at end of file