Changeset 15249 in project
- Timestamp:
- 07/25/09 16:09:02 (12 years ago)
- 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) 2 2 ;; Should use numbers, but that's a whole new can of worms... 3 3 … … 306 306 params))) 307 307 308 (test-group " requesthandling"309 (test "simple request"308 (test-group "xml call handling" 309 (test "simple call" 310 310 '(1 2 3) 311 311 (call-xml-rpc-proc … … 339 339 (param (value (int "3")))))) 340 340 `((scheme.List . ,list)))) 341 (test-error "malformed requesterror"341 (test-error "malformed xml error" 342 342 (call-xml-rpc-proc 343 343 `(*TOP* … … 350 350 `((scheme.List . ,list))))) 351 351 352 (test-group " requestto xml conversion"353 (test "simple request"352 (test-group "call to xml conversion" 353 (test "simple call" 354 354 `(methodResponse 355 355 (params … … 387 387 (param (value (int "3")))))) 388 388 `((scheme.List . ,list)))) 389 (test "malformed request"389 (test "malformed xml" 390 390 `(methodResponse 391 391 (fault … … 427 427 (param (value (int "3")))))) 428 428 `((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 40 40 41 41 (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) 43 44 44 45 (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) 46 47 47 48 (define (call-xml-rpc-proc call-sxml procedures) … … 83 84 values))))))) 84 85 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 85 138 ) -
release/4/xml-rpc/trunk/xml-rpc.meta
r15214 r15249 4 4 (synopsis "XML-RPC client/server") 5 5 (category web) 6 (needs base64 http-client ssax sxpath)6 (needs base64 http-client intarweb ssax sxpath) 7 7 (test-depends test) ; numbers 8 8 (doc-from-wiki)
Note: See TracChangeset
for help on using the changeset viewer.