Changeset 15249 in project


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

Implement request/response handler

Location:
release/4/xml-rpc/trunk
Files:
3 edited

Legend:

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

    r15222 r15249  
    1 (use test)
     1(use test ssax intarweb sxpath-lolevel)
    22;; Should use numbers, but that's a whole new can of worms...
    33
     
    306306                params)))
    307307
    308 (test-group "request handling"
    309   (test "simple request"
     308(test-group "xml call handling"
     309  (test "simple call"
    310310        '(1 2 3)
    311311        (call-xml-rpc-proc
     
    339339                   (param (value (int "3"))))))
    340340               `((scheme.List . ,list))))
    341   (test-error "malformed request error"
     341  (test-error "malformed xml error"
    342342              (call-xml-rpc-proc
    343343               `(*TOP*
     
    350350               `((scheme.List . ,list)))))
    351351
    352 (test-group "request to xml conversion"
    353   (test "simple request"
     352(test-group "call to xml conversion"
     353  (test "simple call"
    354354        `(methodResponse
    355355          (params
     
    387387             (param (value (int "3"))))))
    388388         `((scheme.List . ,list))))
    389   (test "malformed request"
     389  (test "malformed xml"
    390390        `(methodResponse
    391391          (fault
     
    427427             (param (value (int "3"))))))
    428428         `((scheme.List . ,(lambda _ (error "Error in procedure")))))))
     429
     430(define handler (make-xml-rpc-request-handler `((scheme.List . ,list))))
     431
     432(test-group "Request handling"
     433  (call-with-input-string "doesn't matter"
     434    (lambda (in)
     435      (let* ((resp #f)
     436             (out (call-with-output-string
     437                    (lambda (out)
     438                      (set! resp
     439                            (handler
     440                             (make-request port: in method: 'GET)
     441                             (make-response port: out)))))))
     442        (test 405 (response-code resp)))))
     443  (call-with-input-string "invalid XML"
     444    (lambda (in)
     445      (let* ((resp #f)
     446             (out (call-with-output-string
     447                    (lambda (out)
     448                      (set! resp
     449                            (handler
     450                             (make-request port: in method: 'POST)
     451                             (make-response port: out)))))))
     452        (test 200 (response-code resp))
     453        (test "Invalid XML"
     454              `(*TOP*
     455                (*PI* xml "version=\"1.0\"")
     456                (methodResponse
     457                 (fault
     458                  (value
     459                   (struct (member (name "faultCode")
     460                                   (value (i4 "3")))
     461                           (member (name "faultString")
     462                                   (value (string "Invalid request XML"))))))))
     463              (call-with-input-string out
     464                (lambda (in)
     465                  (let ((resp (read-response in)))
     466                    (ssax:xml->sxml (response-port resp) '()))))))))
     467  (define (sxml->string sxml)
     468    (string-concatenate (flatten (sxml:sxml->xml sxml))))
     469  (call-with-input-string (sxml->string `(methodCall
     470                                          (methodName "scheme.List")
     471                                          (params
     472                                           (param (value (int "1")))
     473                                           (param (value (int "2")))
     474                                           (param (value (int "3"))))))
     475    (lambda (in)
     476      (let* ((resp #f)
     477             (out (call-with-output-string
     478                    (lambda (out)
     479                      (set! resp
     480                            (handler
     481                             (make-request port: in method: 'POST)
     482                             (make-response port: out)))))))
     483        (test 200 (response-code resp))
     484        (test "Correct response to valid request"
     485              `(*TOP*
     486                (*PI* xml "version=\"1.0\"")
     487                (methodResponse
     488                 (params
     489                  (param (value (array (data (value (i4 "1"))
     490                                             (value (i4 "2"))
     491                                             (value (i4 "3")))))))))
     492              (call-with-input-string out
     493                (lambda (in)
     494                  (let ((resp (read-response in)))
     495                    (ssax:xml->sxml (response-port resp) '())))))))))
  • 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)
  • release/4/xml-rpc/trunk/xml-rpc.meta

    r15214 r15249  
    44 (synopsis "XML-RPC client/server")
    55 (category web)
    6  (needs base64 http-client ssax sxpath)
     6 (needs base64 http-client intarweb ssax sxpath)
    77 (test-depends test) ; numbers
    88 (doc-from-wiki)
Note: See TracChangeset for help on using the changeset viewer.