ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 22:08:16 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
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.
This commit is contained in:
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 @@ (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)