http-client: prepare-request 2 added by caolanm on Tue Aug 22 15:30:10 2017

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