Ignore:
Timestamp:
07/25/09 16:09:02 (12 years ago)
Author:
sjamaan
Message:

Implement request/response handler

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/xml-rpc/trunk/xml-rpc-server.scm

    r15222 r15249  
    4040
    4141(module xml-rpc-server
    42   (call-xml-rpc-proc xml-rpc-call->xml-rpc-response)
     42  (call-xml-rpc-proc xml-rpc-call->xml-rpc-response
     43   make-xml-rpc-request-handler)
    4344
    4445(import chicken scheme)
    45 (use extras data-structures xml-rpc-lolevel sxpath-lolevel)
     46(use srfi-13 extras data-structures xml-rpc-lolevel sxpath-lolevel ssax intarweb)
    4647
    4748(define (call-xml-rpc-proc call-sxml procedures)
     
    8384                    values)))))))
    8485
     86;; Unfortunately, we need this; spec says "Content-Length" header is required
     87(define (sxml->string sxml)
     88  (string-concatenate (flatten (sxml:sxml->xml sxml))))
     89
     90(define (read-request-data request)
     91  (let ((len (header-value 'content-length (request-headers request))))
     92    ;; If the header is not available, this will read until EOF
     93    (read-string len (request-port request))))
     94
     95(define (make-xml-rpc-request-handler procedures)
     96  (lambda (req resp)
     97    (if (not (eq? (request-method req) 'POST))
     98        (let* ((err "XML-RPC requests must use the POST method!\n")
     99               (_ (read-request-data req))
     100               (resp (write-response
     101                      (update-response
     102                       resp
     103                       code: 405 message: "Method not allowed"
     104                       headers: (headers
     105                                 `((allow POST)
     106                                   (content-type text/plain)
     107                                   (content-length ,(string-length err)))
     108                                 (response-headers resp))))))
     109          (unless (eq? (request-method req) 'HEAD)
     110            (display err (response-port resp)))
     111          resp)
     112        (let* ((sxml-response
     113                 (handle-exceptions exn
     114                   `(methodResponse
     115                     (fault
     116                      (value (struct
     117                              (member (name "faultCode")
     118                                      (value (i4 "3")))
     119                              (member (name "faultString")
     120                                      (value (string "Invalid request XML")))))))
     121                   (xml-rpc-call->xml-rpc-response
     122                    (ssax:xml->sxml (request-port req) '())
     123                    procedures)))
     124               (xml-string (string-append
     125                            "<?xml version=\"1.0\"?>\n"
     126                            (sxml->string sxml-response)))
     127               (resp (write-response
     128                      (update-response
     129                       resp
     130                       headers:
     131                       (headers
     132                        `((content-type text/xml)
     133                          (content-length ,(string-length xml-string)))
     134                        (response-headers resp))))))
     135          (display xml-string (response-port resp))
     136          resp))))
     137
    85138)
Note: See TracChangeset for help on using the changeset viewer.