[bug#55030] [PATCH v2 06/34] http-client: Accept '#:headers' in 'http-fetched/cached'.

[Philip McGrath]

Callers can supply alternative headers as with 'http-fetch'.

* guix/http-client.scm (http-fetch/cached): Add '#:headers' argument.
---
 guix/http-client.scm | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/guix/http-client.scm b/guix/http-client.scm
index a367c41afa..699f5dfd57 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -296,6 +296,7 @@ (define (cache-file-for-uri uri)
                                   #f #f base64url-alphabet))))
 
 (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
+                            (headers '((user-agent . "GNU Guile")))
                             (write-cache dump-port)
                             (cache-miss (const #t))
                             (log-port (current-error-port))
@@ -307,6 +308,9 @@ (define* (http-fetch/cached uri #:key (ttl 
(%http-cache-ttl)) text?
 the data to cache.  Call CACHE-MISS with URI just before fetching data from
 URI.
 
+HEADERS is an alist of extra HTTP headers, to which cache-related headers are
+added automatically as appropriate.
+
 TIMEOUT specifies the timeout in seconds for connection establishment.
 
 Write information about redirects to LOG-PORT."
@@ -316,12 +320,12 @@ (define* (http-fetch/cached uri #:key (ttl 
(%http-cache-ttl)) text?
         (and cache-port
              (stat:mtime (stat cache-port))))
 
-      (define headers
-        `((user-agent . "GNU Guile")
-          ,@(if cache-time
-                `((if-modified-since
-                   . ,(time-utc->date (make-time time-utc 0 cache-time))))
-                '())))
+      (define extended-headers
+        (if cache-time
+            `((if-modified-since
+               . ,(time-utc->date (make-time time-utc 0 cache-time)))
+              ,@headers)
+            headers))
 
       ;; Update the cache and return an input port.
       (guard (c ((http-get-error? c)
@@ -332,7 +336,8 @@ (define* (http-fetch/cached uri #:key (ttl 
(%http-cache-ttl)) text?
                      (raise c))))
         (let ((port (http-fetch uri #:text? text?
                                 #:log-port log-port
-                                #:headers headers #:timeout timeout)))
+                                #:headers extended-headers
+                                #:timeout timeout)))
           (cache-miss uri)
           (mkdir-p (dirname file))
           (when cache-port
-- 
2.32.0