From 00a5a07bb2af8b46169944ba772ad46d4e6e9172 Mon Sep 17 00:00:00 2001
From: Philip McGrath <philip@philipmcgrath.com>
Date: Wed, 18 May 2022 14:10:53 -0400
Subject: http-client: Accept '#:headers' in 'http-fetched/cached'.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

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

* guix/http-client.scm (http-fetch/cached): Add '#:headers' argument.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
 guix/http-client.scm | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

(limited to 'guix')

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 cache-time
         (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 headers
                      (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
-- 
cgit v1.2.3