Changeset 15249 in project

Timestamp:

07/25/09 16:09:02 (11 years ago)

Author:

sjamaan

Message:

Implement request/response handler

Location:

release/4/xml-rpc/trunk

Files:

• tests/run.scm (modified) (6 diffs)
• xml-rpc-server.scm (modified) (2 diffs)
• xml-rpc.meta (modified) (1 diff)

release/4/xml-rpc/trunk/tests/run.scm

@@ -1 @@
-(use test)
+(use test ssax intarweb sxpath-lolevel)
 ;; Should use numbers, but that's a whole new can of worms...
 
@@ -306 +306 @@
                 params)))
 
-(test-group "request handling"
-  (test "simple request"
+(test-group "xml call handling"
+  (test "simple call"
         '(1 2 3)
         (call-xml-rpc-proc
@@ -339 +339 @@
                    (param (value (int "3"))))))
                `((scheme.List . ,list))))
-  (test-error "malformed request error"
+  (test-error "malformed xml error"
               (call-xml-rpc-proc
                `(*TOP*
@@ -350 +350 @@
                `((scheme.List . ,list)))))
 
-(test-group "request to xml conversion"
-  (test "simple request"
+(test-group "call to xml conversion"
+  (test "simple call"
         `(methodResponse
           (params
@@ -387 +387 @@
              (param (value (int "3"))))))
          `((scheme.List . ,list))))
-  (test "malformed request"
+  (test "malformed xml"
         `(methodResponse
           (fault
@@ -427 +427 @@
              (param (value (int "3"))))))
          `((scheme.List . ,(lambda _ (error "Error in procedure")))))))
+
+(define handler (make-xml-rpc-request-handler `((scheme.List . ,list))))
+
+(test-group "Request handling"
+  (call-with-input-string "doesn't matter"
+    (lambda (in)
+      (let* ((resp #f)
+             (out (call-with-output-string
+                    (lambda (out)
+                      (set! resp
+                            (handler
+                             (make-request port: in method: 'GET)
+                             (make-response port: out)))))))
+        (test 405 (response-code resp)))))
+  (call-with-input-string "invalid XML"
+    (lambda (in)
+      (let* ((resp #f)
+             (out (call-with-output-string
+                    (lambda (out)
+                      (set! resp
+                            (handler
+                             (make-request port: in method: 'POST)
+                             (make-response port: out)))))))
+        (test 200 (response-code resp))
+        (test "Invalid XML"
+              `(*TOP*
+                (*PI* xml "version=\"1.0\"")
+                (methodResponse
+                 (fault
+                  (value
+                   (struct (member (name "faultCode")
+                                   (value (i4 "3")))
+                           (member (name "faultString")
+                                   (value (string "Invalid request XML"))))))))
+              (call-with-input-string out
+                (lambda (in)
+                  (let ((resp (read-response in)))
+                    (ssax:xml->sxml (response-port resp) '()))))))))
+  (define (sxml->string sxml)
+    (string-concatenate (flatten (sxml:sxml->xml sxml))))
+  (call-with-input-string (sxml->string `(methodCall
+                                          (methodName "scheme.List")
+                                          (params
+                                           (param (value (int "1")))
+                                           (param (value (int "2")))
+                                           (param (value (int "3"))))))
+    (lambda (in)
+      (let* ((resp #f)
+             (out (call-with-output-string
+                    (lambda (out)
+                      (set! resp
+                            (handler
+                             (make-request port: in method: 'POST)
+                             (make-response port: out)))))))
+        (test 200 (response-code resp))
+        (test "Correct response to valid request"
+              `(*TOP*
+                (*PI* xml "version=\"1.0\"")
+                (methodResponse
+                 (params
+                  (param (value (array (data (value (i4 "1"))
+                                             (value (i4 "2"))
+                                             (value (i4 "3")))))))))
+              (call-with-input-string out
+                (lambda (in)
+                  (let ((resp (read-response in)))
+                    (ssax:xml->sxml (response-port resp) '())))))))))

release/4/xml-rpc/trunk/xml-rpc-server.scm

@@ -40 +40 @@
 
 (module xml-rpc-server
-  (call-xml-rpc-proc xml-rpc-call->xml-rpc-response)
+  (call-xml-rpc-proc xml-rpc-call->xml-rpc-response
+   make-xml-rpc-request-handler)
 
 (import chicken scheme)
-(use extras data-structures xml-rpc-lolevel sxpath-lolevel)
+(use srfi-13 extras data-structures xml-rpc-lolevel sxpath-lolevel ssax intarweb)
 
 (define (call-xml-rpc-proc call-sxml procedures)
@@ -83 +84 @@
                     values)))))))
 
+;; Unfortunately, we need this; spec says "Content-Length" header is required
+(define (sxml->string sxml)
+  (string-concatenate (flatten (sxml:sxml->xml sxml))))
+
+(define (read-request-data request)
+  (let ((len (header-value 'content-length (request-headers request))))
+    ;; If the header is not available, this will read until EOF
+    (read-string len (request-port request))))
+
+(define (make-xml-rpc-request-handler procedures)
+  (lambda (req resp)
+    (if (not (eq? (request-method req) 'POST))
+        (let* ((err "XML-RPC requests must use the POST method!\n")
+               (_ (read-request-data req))
+               (resp (write-response
+                      (update-response
+                       resp
+                       code: 405 message: "Method not allowed"
+                       headers: (headers
+                                 `((allow POST)
+                                   (content-type text/plain)
+                                   (content-length ,(string-length err)))
+                                 (response-headers resp))))))
+          (unless (eq? (request-method req) 'HEAD)
+            (display err (response-port resp)))
+          resp)
+        (let* ((sxml-response
+                 (handle-exceptions exn
+                   `(methodResponse
+                     (fault
+                      (value (struct
+                              (member (name "faultCode")
+                                      (value (i4 "3")))
+                              (member (name "faultString")
+                                      (value (string "Invalid request XML")))))))
+                   (xml-rpc-call->xml-rpc-response
+                    (ssax:xml->sxml (request-port req) '())
+                    procedures)))
+               (xml-string (string-append
+                            "<?xml version=\"1.0\"?>\n"
+                            (sxml->string sxml-response)))
+               (resp (write-response
+                      (update-response
+                       resp
+                       headers:
+                       (headers
+                        `((content-type text/xml)
+                          (content-length ,(string-length xml-string)))
+                        (response-headers resp))))))
+          (display xml-string (response-port resp))
+          resp))))
+
 )

release/4/xml-rpc/trunk/xml-rpc.meta

@@ -4 +4 @@
  (synopsis "XML-RPC client/server")
  (category web)
- (needs base64 http-client ssax sxpath)
+ (needs base64 http-client intarweb ssax sxpath)
  (test-depends test) ; numbers
  (doc-from-wiki)