From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 24 Aug 2008 07:21:03 +0000 (+0000)
Subject: Change to use new http-client support.
X-Git-Tag: 20090517-FFI~229
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=05d365b3a5a2adf42ac9df2cd1f57689596e07f7;p=mit-scheme.git

Change to use new http-client support.
---

diff --git a/v7/src/xml/xml-rpc.scm b/v7/src/xml/xml-rpc.scm
index 785c79e39..346179840 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.11 2008/01/30 20:02:42 cph Exp $
+$Id: xml-rpc.scm,v 1.12 2008/08/24 07:21:03 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -28,47 +28,25 @@ USA.
 ;;;; 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 uri request #!optional headers)
+  (let ((response
+	 (http-post uri
+		    `(,@(if (default-object? headers) '() headers)
+		      (CONTENT-TYPE "text/xml"))
+		    (xml->octets (->request request 'XML-RPC)))))
+    (if (not (= 200 (http-response-status response)))
+	(error "HTTP error:" (http-response-reason response)))
+    (xml-rpc:parse-response (read-xml (http-entity-body-port response)))))
+
+(define (->request request caller)
+  (cond ((or (xml-document? request)
+	     (xml-element? request))
+	 request)
+	((list? request)
+	 (apply xml-rpc:request request))
+	(else
+	 (error:wrong-type-argument request "XML-RPC request" caller))))
 
 (define (xml-rpc:request name . objects)
   (rpc-elt:method-call (rpc-elt:method-name name)