me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2021-09-22 12:27:41 +02:00
parent 09289d0d2b
commit 5871639bb1
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 18 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
guix/build/download.scm
View File

@ -678,6 +678,18 @@ and write the output to FILE."
(false-if-exception* (false-if-exception*
(disarchive-assemble spec file #:resolver resolve)))))))) (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 (define* (url-fetch url file
#:key #:key
(timeout 10) (verify-certificate? #t) (timeout 10) (verify-certificate? #t)
@ -769,7 +781,12 @@ otherwise simply ignore them."
(setvbuf (current-error-port) 'line) (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 (match uri
((uri tail ...) ((uri tail ...)
(or (fetch uri file) (or (fetch uri file)