From: "Ludovic Courtès" <ludo@gnu.org>
To: 68741@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludo@gnu.org>,
"Christopher Baines" <guix@cbaines.net>,
"Josselin Poiret" <dev@jpoiret.xyz>,
"Ludovic Courtès" <ludo@gnu.org>,
"Mathieu Othacehe" <othacehe@gnu.org>,
"Ricardo Wurmus" <rekado@elephly.net>,
"Simon Tournier" <zimon.toutoune@gmail.com>,
"Tobias Geerinckx-Rice" <me@tobias.gr>
Subject: [bug#68741] [PATCH 1/6] swh: ‘vault-fetch’ follows redirects.
Date: Fri, 26 Jan 2024 18:25:01 +0100 [thread overview]
Message-ID: <8d1ecdcbef60d2643f1aad455e9a2525e6c9d78a.1706287537.git.ludo@gnu.org> (raw)
In-Reply-To: <cover.1706287537.git.ludo@gnu.org>
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.
* guix/swh.scm (http-get/follow): New procedure.
(vault-fetch): Use it instead of ‘http-get*’.
Change-Id: Id6b9585a9ce6699a2274b99c9a6d4edda1018b02
---
guix/swh.scm | 52 +++++++++++++++++++++++++++++++++++++++++-----------
1 file 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 @@ (define* (request-cooking id #:optional kind #:key (archive-type 'flat))
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 @@ (define* (vault-fetch id
(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~%"
--
2.41.0
next prev parent reply other threads:[~2024-01-26 17:26 UTC|newest]
Thread overview: 9+ messages / expand[flat|nested] mbox.gz Atom feed top
2024-01-26 17:16 [bug#68741] [PATCH 0/6] Content-addressed downloads from Software Heritage Ludovic Courtès
2024-01-26 17:25 ` Ludovic Courtès [this message]
2024-01-26 17:25 ` [bug#68741] [PATCH 2/6] swh: Add bindings for the “ExtID” API Ludovic Courtès
2024-01-26 17:25 ` [bug#68741] [PATCH 3/6] swh: Add ‘swh-download-directory-by-nar-hash’ Ludovic Courtès
2024-01-26 17:25 ` [bug#68741] [PATCH 4/6] lint: archival: Check with ‘lookup-directory-by-nar-hash’ Ludovic Courtès
2024-01-26 17:25 ` [bug#68741] [PATCH 5/6] git-download: Download from SWH by nar hash when possible Ludovic Courtès
2024-01-26 17:25 ` [bug#68741] [PATCH 6/6] swh: Fix docstring of ‘lookup-directory’ Ludovic Courtès
2024-01-26 17:25 ` [bug#68741] [PATCH 0/6] Content-addressed downloads from Software Heritage Ludovic Courtès
2024-02-12 11:23 ` bug#68741: " Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=8d1ecdcbef60d2643f1aad455e9a2525e6c9d78a.1706287537.git.ludo@gnu.org \
--to=ludo@gnu.org \
--cc=68741@debbugs.gnu.org \
--cc=dev@jpoiret.xyz \
--cc=guix@cbaines.net \
--cc=me@tobias.gr \
--cc=othacehe@gnu.org \
--cc=rekado@elephly.net \
--cc=zimon.toutoune@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.