ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

swh: ‘vault-fetch’ follows redirects.

Browse source 
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
This commit is contained in:
Ludovic Courtès 2024-01-25 22:40:48 +01:00
parent 5bd5bb5f6c
commit 1610a632d4
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 41 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
guix/swh.scm
View file

@ -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
(let-values (((port length)
(http-get/follow (swh-url (vault-reply-fetch-url reply))
#:verify-certificate?
(%verify-swh-certificate?))))
(if (= (response-code response) 200)
port
(begin ;shouldn't happen
(close-port port)
#f))))
port))
('failed
;; Upon failure, we're supposed to try again.
(format log-port "SWH vault: failure: ~a~%"