summaryrefslogtreecommitdiff
path: root/guix/swh.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2024-01-25 22:40:48 +0100
committerLudovic Courtès <ludo@gnu.org>2024-02-12 12:03:52 +0100
commit1610a632d4b3097282d18af27ff3e9e178d7dfcb (patch)
tree1115d91f41dca71d3644818c3c431f97f64154a6 /guix/swh.scm
parent5bd5bb5f6ca822f76599ca6d1959f4c42d4bc222 (diff)
swh: ‘vault-fetch’ follows redirects.
Today, URLs like https://archive.softwareheritage.org/api/1/vault/flat/swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153/raw/ redirect to https://swhvaultstorage.blob.core.windows.net/…. This change fixes ‘vault-fetch’ to follow these. Fixes <https://issues.guix.gnu.org/69058>. * guix/swh.scm (http-get/follow): New procedure. (vault-fetch): Use it instead of ‘http-get*’. Change-Id: Id6b9585a9ce6699a2274b99c9a6d4edda1018b02
Diffstat (limited to 'guix/swh.scm')
-rw-r--r--guix/swh.scm52
1 files changed, 41 insertions, 11 deletions
diff --git a/guix/swh.scm b/guix/swh.scm
index c7c1c873a2..4e71bdb045 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2021, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
@@ -583,6 +583,41 @@ directory identifier is deprecated."
json->vault-reply
http-post*))
+(define* (http-get/follow url
+ #:key
+ (verify-certificate? (%verify-swh-certificate?)))
+ "Like 'http-get' but follow redirects (HTTP 30x). On success, return two
+values: an input port to read the response body and its 'Content-Length'. On
+failure return #f and #f."
+ (define uri
+ (if (string? url) (string->uri url) url))
+
+ (let loop ((uri uri))
+ (define (resolve-uri-reference target)
+ (if (and (uri-scheme target) (uri-host target))
+ target
+ (build-uri (uri-scheme uri) #:host (uri-host uri)
+ #:port (uri-port uri)
+ #:path (uri-path target))))
+
+ (let*-values (((response port)
+ (http-get* uri #:streaming? #t
+ #:verify-certificate? verify-certificate?))
+ ((code)
+ (response-code response)))
+ (case code
+ ((200)
+ (values port (response-content-length response)))
+ ((301 ; moved permanently
+ 302 ; found (redirection)
+ 303 ; see other
+ 307 ; temporary redirection
+ 308) ; permanent redirection
+ (close-port port)
+ (loop (resolve-uri-reference (response-location response))))
+ (else
+ (values #f #f))))))
+
(define* (vault-fetch id
#:optional kind
#:key
@@ -604,16 +639,11 @@ for a tarball containing a bare Git repository corresponding to a revision."
(match (vault-reply-status reply)
('done
;; Fetch the bundle.
- (let-values (((response port)
- (http-get* (swh-url (vault-reply-fetch-url reply))
- #:streaming? #t
- #:verify-certificate?
- (%verify-swh-certificate?))))
- (if (= (response-code response) 200)
- port
- (begin ;shouldn't happen
- (close-port port)
- #f))))
+ (let-values (((port length)
+ (http-get/follow (swh-url (vault-reply-fetch-url reply))
+ #:verify-certificate?
+ (%verify-swh-certificate?))))
+ port))
('failed
;; Upon failure, we're supposed to try again.
(format log-port "SWH vault: failure: ~a~%"