02/04: download: Fall back to web.archive.org as a very last resort.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 5871639bb1544171310fa5c4da7196eeea2c8089
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Sep 22 12:27:41 2021 +0200

    download: Fall back to web.archive.org as a very last resort.
    
    Suggested by Florian Pelz <pelzflorian@pelzflorian.de>.
    
    * 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 c8ddadf..1ed6230 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -678,6 +678,18 @@ and write the output to FILE."
                (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 @@ otherwise simply ignore them."
 
   (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)