diff options
author | Ludovic Courtès <ludo@gnu.org> | 2024-01-25 22:40:48 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2024-02-12 12:03:52 +0100 |
commit | 1610a632d4b3097282d18af27ff3e9e178d7dfcb (patch) | |
tree | 1115d91f41dca71d3644818c3c431f97f64154a6 /guix | |
parent | 5bd5bb5f6ca822f76599ca6d1959f4c42d4bc222 (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')
-rw-r--r-- | guix/swh.scm | 52 |
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~%" |