Implement request/response handler

3 files changed, 131 insertions, 11 deletions

diff --git a/tests/run.scm b/tests/run.scm
index 3d747cf..6d45135 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,4 +1,4 @@
-(use test)
+(use test ssax intarweb sxpath-lolevel)
 ;; Should use numbers, but that's a whole new can of worms...
 
 (load "../xml-rpc-lolevel")
@@ -305,8 +305,8 @@
                               (value (string "there was an error")))))))))
                 params)))
 
-(test-group "request handling"
-  (test "simple request"
+(test-group "xml call handling"
+  (test "simple call"
         '(1 2 3)
         (call-xml-rpc-proc
          `(*TOP*
@@ -338,7 +338,7 @@
                    (param (value (int "2")))
                    (param (value (int "3"))))))
                `((scheme.List . ,list))))
-  (test-error "malformed request error"
+  (test-error "malformed xml error"
               (call-xml-rpc-proc
                `(*TOP*
                  (*PI* xml "version=\"1.0\"")
@@ -349,8 +349,8 @@
                    (param (value (int "3"))))))
                `((scheme.List . ,list)))))
 
-(test-group "request to xml conversion"
-  (test "simple request"
+(test-group "call to xml conversion"
+  (test "simple call"
         `(methodResponse
           (params
            (param (value (array (data (value (i4 "1"))
@@ -386,7 +386,7 @@
              (param (value (int "2")))
              (param (value (int "3"))))))
          `((scheme.List . ,list))))
-  (test "malformed request"
+  (test "malformed xml"
         `(methodResponse
           (fault
            (value (struct
@@ -425,4 +425,71 @@
              (param (value (int "1")))
              (param (value (int "2")))
              (param (value (int "3"))))))
-         `((scheme.List . ,(lambda _ (error "Error in procedure")))))))
\ No newline at end of file
+         `((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) '())))))))))
\ No newline at end of file
diff --git a/xml-rpc-server.scm b/xml-rpc-server.scm
index 3471376..f582e11 100644
--- a/xml-rpc-server.scm
+++ b/xml-rpc-server.scm
@@ -39,10 +39,11 @@
 ; http://trac.callcc.org
 
 (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)
   (or (and-let* ((call ((select-first-kid (ntype?? 'methodCall)) call-sxml))
@@ -82,4 +83,56 @@
                       `(param (value ,(value->xml-rpc-fragment p))))
                     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))))
+
 )
\ No newline at end of file
diff --git a/xml-rpc.meta b/xml-rpc.meta
index 88670c7..41e5277 100644
--- a/xml-rpc.meta
+++ b/xml-rpc.meta
@@ -3,7 +3,7 @@
 ((egg "xml-rpc.egg")
  (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)
  (license "BSD")