Index: http-client.scm =================================================================== --- http-client.scm (revision 34324) +++ http-client.scm (working copy) @@ -43,7 +43,8 @@ basic-authenticator digest-authenticator determine-username/password determine-proxy determine-proxy-from-environment determine-proxy-username/password - server-connector default-server-connector) + server-connector default-server-connector + prepare-request default-prepare-request) (import chicken scheme lolevel) (use srfi-1 srfi-13 srfi-18 srfi-69 @@ -333,12 +334,10 @@ (when (> (read-string! (string-length buf) buf port) 0) (loop #f))))))) -(define (add-headers req) +(define (default-prepare-request req) (let* ((uri (request-uri req)) (cookies (get-cookies-for-uri (request-uri req))) (h `(,@(if (not (null? cookies)) `((cookie . ,cookies)) '()) - (host ,(cons (uri-host uri) (and (not (uri-default-port? uri)) - (uri-port uri)))) ,@(if (and (client-software) (not (null? (client-software)))) `((user-agent ,(client-software))) '())))) @@ -345,6 +344,8 @@ (update-request req headers: (headers h (request-headers req))))) +(define prepare-request (make-parameter default-prepare-request)) + (define (http-client-error loc msg args specific . rest) (raise (make-composite-condition (make-property-condition 'exn 'location loc 'message msg 'arguments args) @@ -587,8 +588,15 @@ (let* ((uri (request-uri req)) (con (ensure-connection! uri))) (condition-case - (let* ((req (add-headers (update-request - req port: (http-connection-outport con)))) + (let* ((req ((prepare-request) + (update-request + req + headers: (headers + `((host ,(cons (uri-host uri) + (and (not (uri-default-port? uri)) + (uri-port uri))))) + (request-headers req)) + port: (http-connection-outport con)))) ;; No outgoing URIs should ever contain credentials or fragments (req-uri (update-uri uri fragment: #f username: #f password: #f)) ;; RFC1945, 5.1.2: "The absoluteURI form is only allowed