bug#50568: Missing source code

[Ludovic Courtès]

Hi Florian,

"pelzflorian (Florian Pelz)" <pelzflorian@pelzflorian.de> skribis:

> On Tue, Sep 14, 2021 at 10:38:55AM +0200, Ludovic Courtès wrote:
>> Hi,
>> 
>> Maxime Devos <maximedevos@telenet.be> skribis:
>> 
>> > The Wayback Machine has some copies of software at 
>> > https://www.atromatic.net:
>> 
>> Thanks, they’re now all in store on berlin.
>> 
>> It’s kinda ironic that it’s the Wayback Machine that’s saving us here…
>> I wonder if there’s a way to construct generic web.archive.org URLs that
>> we could use as a fallback in (guix build download)?
>
> AFAIK Just replace the date in
>
> On Mon, Sep 13, 2021 at 03:49:05PM +0200, Maxime Devos wrote:
>> https://web.archive.org/web/20161204140455/https://www.astromatic.net/download/stuff/stuff-1.26.0.tar.gz
>
> by the current time.

Oh nice, that seems to work:

--8<---------------cut here---------------start------------->8---
$ guix download 
https://web.archive.org/web/20210911171400/https://www.astromatic.net/download/stuff/stuff-1.26.0.tar.gz

Starting download of /tmp/guix-file.QXTq4V
>From 
>https://web.archive.org/web/20210911171400/https://www.astromatic.net/download/stuff/stuff-1.26.0.tar.gz...
following redirection to 
`https://web.archive.org/web/20161204140455/http://www.astromatic.net/download/stuff/stuff-1.26.0.tar.gz'...
 …6.0.tar.gz                                                                    
    200KiB/s 00:20 | 3.9MiB transferred
/gnu/store/l3r5j8r4f6fh6bxa9va3681n3bclxpdq-stuff-1.26.0.tar.gz
1syibi3b86z9pikhicvkkmgxm916j732fdiw0agw0lq6z13fdcjm
--8<---------------cut here---------------end--------------->8---

How ’bout the attached patch?  Works for me.

Thanks,
Ludo’.

diff --git a/guix/build/download.scm b/guix/build/download.scm
index c8ddadfdd4..140e42afec 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,9 @@ 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
+                   (or (and=> (internet-archive-uri (first uri)) list)
+                       '()))))
     (match uri
       ((uri tail ...)
        (or (fetch uri file)