From: Taylor R. Campbell <net/mumble/campbell>
Date: Sat, 4 Nov 2006 20:23:19 +0000 (+0000)
Subject: Implement a simple XML-RPC client.
X-Git-Tag: 20090517-FFI~848
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0241ccc1ceaad4b8f3872bc4fc111073b01d5093;p=mit-scheme.git

Implement a simple XML-RPC client.
---

diff --git a/v7/src/xml/xml-rpc.scm b/v7/src/xml/xml-rpc.scm
index 711a96222..c21133181 100644
--- a/v7/src/xml/xml-rpc.scm
+++ b/v7/src/xml/xml-rpc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-rpc.scm,v 1.7 2006/08/01 04:23:41 cph Exp $
+$Id: xml-rpc.scm,v 1.8 2006/11/04 20:23:19 riastradh Exp $
 
 Copyright 2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -23,10 +23,51 @@ USA.
 
 |#
 
-;;;; XML-RPC message codecs
+;;;; XML-RPC
 
 (declare (usual-integrations))
 
+(define (xml-rpc uri request #!optional header-fields)
+  (let* ((request (->xml-rpc-request request 'XML-RPC)))
+    (call-with-http-response:post uri
+                                  (xml-rpc:header-fields header-fields)
+                                  (xml->string request)
+      (lambda (http-response content-port)
+        (if (not (= 200 (http-response/status-code http-response)))
+            (error "HTTP error:" (http-response/reason http-response)))
+        (xml-rpc:parse-response (read-xml content-port))))))
+
+(define (->xml-rpc-request request #!optional caller)
+  (cond ((list? request)
+         (apply xml-rpc:request request))
+        ((or (xml-document? request)
+             (xml-element? request))
+         request)
+        (else
+         (error:wrong-type-argument request
+                                    "XML-RPC request"
+                                    caller))))
+
+(define (xml-rpc:header-fields #!optional header-fields)
+  (adjoin-http-header-fields
+   ;; The XML-RPC specification mandates at least User-Agent, Host,
+   ;; Content-Type, and Content-Length.  The HTTP client abstraction
+   ;; automatically supplies Host, and also Content-Length if the
+   ;; content is passed as a string (which it is).
+   `((USER-AGENT ,(xml-rpc:default-scheme-user-agent-string)))
+   (if (default-object? header-fields)
+       '()
+       (begin
+         (guarantee-list-of-type header-fields
+                                 valid-http-header-field?
+                                 "HTTP header fields")
+         header-fields))
+   '((CONTENT-TYPE "text/xml"))))
+
+(define (xml-rpc:default-scheme-user-agent-string)
+  (string-append "MIT-Scheme/"
+                 (get-subsystem-version-string "release")))
+
 (define (xml-rpc:request name . objects)
   (rpc-elt:method-call (rpc-elt:method-name name)
 		       (rpc-elt:params (map (lambda (object)
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 054f360ed..911a668b3 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.86 2006/10/29 06:20:11 cph Exp $
+$Id: xml.pkg,v 1.87 2006/11/04 20:23:19 riastradh Exp $
 
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -510,6 +510,7 @@ USA.
 	  *xml-rpc:encode-value-handler*
 	  condition-type:bad-xml-rpc-message
 	  condition-type:xml-rpc-fault
+	  xml-rpc
 	  xml-rpc:condition->fault
 	  xml-rpc:fault
 	  xml-rpc:parse-request