diff -Nrc xml-rpc.orig/xml-rpc-client.scm xml-rpc/xml-rpc-client.scm
*** xml-rpc.orig/xml-rpc-client.scm	Wed Dec  8 18:59:54 2004
--- xml-rpc/xml-rpc-client.scm	Thu Dec 15 00:16:31 2005
***************
*** 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)] ) ) ) )