hi again,
On Fri, Sep 09, 2005 at 01:37:34PM +0200, Hans Bulfone wrote:
> i have attached a patch that fixes both, i hope you like it :)
> it works for me but i've not tested it thoroughly.
i've extended the patch to provide support for http basic
authentication on the client side.
regards,
hans.
diff -Nrc xml-rpc.orig/xml-rpc-client.scm xml-rpc/xml-rpc-client.scm
*** xml-rpc.orig/xml-rpc-client.scm 2004-12-08 18:59:54.000000000 +0100
--- xml-rpc/xml-rpc-client.scm 2005-09-09 14:47:47.843111216 +0200
***************
*** 5,10 ****
--- 5,11 ----
(require 'ssax-utils)
(require 'xml-rpc-utils)
(require 'url)
+ (require 'base64)
(declare
(uses extras)
***************
*** 19,25 ****
(sprintf "Chicken ~A, XML-RPC ~A" (chicken-version) version) )
(define (xml-rpc:server host . more)
! (define (decode-arguments host port path)
(let* ((endpoint-url (url host))
(endpoint-scheme (url-scheme endpoint-url))
(host-is-url (if endpoint-scheme
--- 20,26 ----
(sprintf "Chicken ~A, XML-RPC ~A" (chicken-version) version) )
(define (xml-rpc:server host . more)
! (define (decode-arguments host port path user pass)
(let* ((endpoint-url (url host))
(endpoint-scheme (url-scheme endpoint-url))
(host-is-url (if endpoint-scheme
***************
*** 31,40 ****
(values
(url-host endpoint-url)
(or (url-port endpoint-url) 80)
! (string-append "/" (or (url-path endpoint-url) "")))
! (values host port path))))
! (let-optionals more ([port 80] [path "/RPC2"])
! (let-values (((host port path) (decode-arguments host port path)))
(lambda (name)
(lambda args
(let ([payload (create-payload name args)])
--- 32,43 ----
(values
(url-host endpoint-url)
(or (url-port endpoint-url) 80)
! (string-append "/" (or (url-path endpoint-url) ""))
! (url-user endpoint-url)
! (url-password endpoint-url))
! (values host port path user pass))))
! (let-optionals more ([port 80] [path "/RPC2"] [user #f] [pass #f])
! (let-values (((host port path user pass) (decode-arguments host port path
user pass)))
(lambda (name)
(lambda args
(let ([payload (create-payload name args)])
***************
*** 43,51 ****
(http:make-request
'post
(sprintf "~A:~A~A" host port path)
! `(("content-type" . "text/xml")
! ("content-length" . ,(number->string
(string-length payload)))
! ("user-agent" . ,xml-rpc:version) )
payload
'http/1.0) ) ] )
(let ([x (parameterize ([case-sensitive #t])
--- 46,62 ----
(http:make-request
'post
(sprintf "~A:~A~A" host port path)
! (append
! `(("content-type" . "text/xml")
! ("content-length" . ,(number->string
(string-length payload)))
! ("user-agent" . ,xml-rpc:version) )
! (if (and user pass)
! `(("authorization" . ,(string-append
! "Basic "
! (base64:encode
! (string-append
! user ":" pass)))))
! '()))
payload
'http/1.0) ) ] )
(let ([x (parameterize ([case-sensitive #t])
***************
*** 78,87 ****
(apply values (map xml-rpc:unmarshall-value x)) ]
[`(fault
(value
! (struct
! (member (name "faultCode") (value (int ,code)))
! (member (name "faultString") (value (string ,str))) ) ) )
! (xml-rpc:error (string->number code) (sprintf "XML-RPC fault
response (code ~A): ~A" code str)) ]
[r (bad r r0)] ) ]
[r (bad r r0)] ) ) ]
[r (bad r r0)] ) ) ) )
--- 89,105 ----
(apply values (map xml-rpc:unmarshall-value x)) ]
[`(fault
(value
! ,('struct members ...)))
! (let loop ((code #f) (msg #f) (members members))
! (if (null? members)
! (xml-rpc:error (and code (string->number code))
! (sprintf "XML-RPC fault response (code
~A): ~A" code msg))
! (match (car members)
! [`(member (name "faultCode") (value ,((or 'int 'i4)
code)))
! (loop code msg (cdr members))]
! [`(member (name "faultString") (value (string ,msg)))
! (loop code msg (cdr members))]
! [r (bad r r0)])))]
[r (bad r r0)] ) ]
[r (bad r r0)] ) ) ]
[r (bad r r0)] ) ) ) )
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
