From 5871639bb1544171310fa5c4da7196eeea2c8089 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 22 Sep 2021 12:27:41 +0200 Subject: [PATCH] download: Fall back to web.archive.org as a very last resort. Suggested by Florian Pelz . * guix/build/download.scm (internet-archive-uri): New procedure. (url-fetch): Append it to the list of URIs after CONTENT-ADDRESSED-URIS. --- guix/build/download.scm | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/guix/build/download.scm b/guix/build/download.scm index c8ddadfdd4..1ed623034b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -678,6 +678,18 @@ (define (resolve addresses output) (false-if-exception* (disarchive-assemble spec file #:resolver resolve)))))))) +(define (internet-archive-uri uri) + "Return a URI corresponding to an Internet Archive backup of URI, or #f if +URI does not denote a Web URI." + (and (memq (uri-scheme uri) '(http https)) + (let* ((now (time-utc->date (current-time time-utc))) + (date (date->string now "~Y~m~d~H~M~S"))) + ;; Note: the date in the URL can be anything and web.archive.org + ;; automatically redirects to the closest date. + (build-uri 'https #:host "web.archive.org" + #:path (string-append "/web/" date "/" + (uri->string uri)))))) + (define* (url-fetch url file #:key (timeout 10) (verify-certificate? #t) @@ -769,7 +781,12 @@ (define disarchive-uris (setvbuf (current-error-port) 'line) - (let try ((uri (append uri content-addressed-uris))) + (let try ((uri (append uri content-addressed-uris + (match uri + ((first . _) + (or (and=> (internet-archive-uri first) list) + '())) + (() '()))))) (match uri ((uri tail ...) (or (fetch uri file)