download: Use Disarchive as a last resort.

* guix/download.scm (%disarchive-mirrors): New variable.
(%disarchive-mirror-file): New variable.
(built-in-download): Add 'disarchive-mirrors' keyword argument and
pass its value along to the 'builtin:download' derivation.
(url-fetch): Pass '%disarchive-mirror-file' to 'built-in-download'.
* guix/scripts/perform-download.scm (perform-download): Read
Disarchive mirrors from the environment and pass them to
'url-fetch'.
* guix/build/download.scm (disarchive-fetch/any): New procedure.
(url-fetch): Add 'disarchive-mirrors' keyword argument, use it to
make a list of URIs, and use the new procedure to fetch the file if
all other methods fail.

3 files changed, 95 insertions, 14 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index a22d4064ca..5431d7c682 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2021 Timothy Sample <samplet@ngyro.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -34,6 +35,8 @@
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:autoload   (ice-9 ftw) (scandir)
+  #:autoload   (guix base16) (bytevector->base16-string)
+  #:autoload   (guix swh) (swh-download-directory)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:export (open-socket-for-uri
@@ -626,10 +629,53 @@ Return a list of URIs."
     (else
      (list uri))))
 
+(define* (disarchive-fetch/any uris file
+                               #:key (timeout 10) (verify-certificate? #t))
+  "Fetch a Disarchive specification from any of URIS, assemble it,
+and write the output to FILE."
+  (define (fetch-specification uris)
+    (any (lambda (uri)
+           (false-if-exception*
+            (let-values (((port size) (http-fetch uri
+                                                  #:verify-certificate?
+                                                  verify-certificate?
+                                                  #:timeout timeout)))
+              (let ((specification (read port)))
+                (close-port port)
+                specification))))
+         uris))
+
+  (define (resolve addresses output)
+    (any (match-lambda
+           (('swhid swhid)
+            (match (string-split swhid #\:)
+              (("swh" "1" "dir" id)
+               (format #t "Downloading from Software Heritage...~%" file)
+               (false-if-exception*
+                (swh-download-directory id output)))
+              (_ #f)))
+           (_ #f))
+         addresses))
+
+  (format #t "Trying to use Disarchive to assemble ~a...~%" file)
+  (match (and=> (resolve-module '(disarchive) #:ensure #f)
+                (lambda (disarchive)
+                  (cons (module-ref disarchive '%disarchive-log-port)
+                        (module-ref disarchive 'disarchive-assemble))))
+    (#f
+     (format #t "could not load Disarchive~%"))
+    ((%disarchive-log-port . disarchive-assemble)
+     (match (fetch-specification uris)
+       (#f
+        (format #t "could not find its Disarchive specification~%"))
+       (spec (parameterize ((%disarchive-log-port (current-output-port)))
+               (disarchive-assemble spec file #:resolver resolve)))))))
+
 (define* (url-fetch url file
                     #:key
                     (timeout 10) (verify-certificate? #t)
                     (mirrors '()) (content-addressed-mirrors '())
+                    (disarchive-mirrors '())
                     (hashes '())
                     print-build-trace?)
   "Fetch FILE from URL; URL may be either a single string, or a list of
@@ -693,6 +739,18 @@ otherwise simply ignore them."
                               hashes))
                 content-addressed-mirrors))
 
+  (define disarchive-uris
+    (append-map (match-lambda
+                  ((? string? mirror)
+                   (map (match-lambda
+                          ((hash-algo . hash)
+                           (string->uri
+                            (string-append mirror
+                                           (symbol->string hash-algo) "/"
+                                           (bytevector->base16-string hash)))))
+                        hashes)))
+                disarchive-mirrors))
+
   ;; Make this unbuffered so 'progress-report/file' works as expected.  'line
   ;; means '\n', not '\r', so it's not appropriate here.
   (setvbuf (current-output-port) 'none)
@@ -705,15 +763,20 @@ otherwise simply ignore them."
        (or (fetch uri file)
            (try tail)))
       (()
-       (format (current-error-port) "failed to download ~s from ~s~%"
-               file url)
-
-       ;; Remove FILE in case we made an incomplete download, for example due
-       ;; to ENOSPC.
-       (catch 'system-error
-         (lambda ()
-           (delete-file file))
-         (const #f))
-       #f))))
+       ;; If we are looking for a software archive, one last thing we
+       ;; can try is to use Disarchive to assemble it.
+       (or (disarchive-fetch/any disarchive-uris file
+                                 #:verify-certificate? verify-certificate?
+                                 #:timeout timeout)
+           (begin
+             (format (current-error-port) "failed to download ~s from ~s~%"
+                     file url)
+             ;; Remove FILE in case we made an incomplete download, for
+             ;; example due to ENOSPC.
+             (catch 'system-error
+               (lambda ()
+                 (delete-file file))
+               (const #f))
+             #f))))))
 
 ;;; download.scm ends here
diff --git a/guix/download.scm b/guix/download.scm
index 30f69c0325..72094e7318 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -406,12 +406,19 @@
   (plain-file "content-addressed-mirrors"
               (object->string %content-addressed-mirrors)))
 
+(define %disarchive-mirrors
+  '("https://disarchive.ngyro.com/"))
+
+(define %disarchive-mirror-file
+  (plain-file "disarchive-mirrors" (object->string %disarchive-mirrors)))
+
 (define built-in-builders*
   (store-lift built-in-builders))
 
 (define* (built-in-download file-name url
                             #:key system hash-algo hash
                             mirrors content-addressed-mirrors
+                            disarchive-mirrors
                             executable?
                             (guile 'unused))
   "Download FILE-NAME from URL using the built-in 'download' builder.  When
@@ -422,13 +429,16 @@ explicitly depend on Guile, GnuTLS, etc.  Instead, the daemon performs the
 download by itself using its own dependencies."
   (mlet %store-monad ((mirrors (lower-object mirrors))
                       (content-addressed-mirrors
-                       (lower-object content-addressed-mirrors)))
+                       (lower-object content-addressed-mirrors))
+                      (disarchive-mirrors (lower-object disarchive-mirrors)))
     (raw-derivation file-name "builtin:download" '()
                     #:system system
                     #:hash-algo hash-algo
                     #:hash hash
                     #:recursive? executable?
-                    #:sources (list mirrors content-addressed-mirrors)
+                    #:sources (list mirrors
+                                    content-addressed-mirrors
+                                    disarchive-mirrors)
 
                     ;; Honor the user's proxy and locale settings.
                     #:leaked-env-vars '("http_proxy" "https_proxy"
@@ -439,6 +449,7 @@ download by itself using its own dependencies."
                                  ("mirrors" . ,mirrors)
                                  ("content-addressed-mirrors"
                                   . ,content-addressed-mirrors)
+                                 ("disarchive-mirrors" . ,disarchive-mirrors)
                                  ,@(if executable?
                                        '(("executable" . "1"))
                                        '()))
@@ -492,7 +503,9 @@ name in the store."
                              #:executable? executable?
                              #:mirrors %mirror-file
                              #:content-addressed-mirrors
-                             %content-addressed-mirror-file)))))
+                             %content-addressed-mirror-file
+                             #:disarchive-mirrors
+                             %disarchive-mirror-file)))))
 
 (define* (url-fetch/executable url hash-algo hash
                                #:optional name
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 8d409092ba..6889bcef79 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -54,7 +54,8 @@ actual output is different from that when we're doing a 'bmCheck' or
                        (output* "out")
                        (executable "executable")
                        (mirrors "mirrors")
-                       (content-addressed-mirrors "content-addressed-mirrors"))
+                       (content-addressed-mirrors "content-addressed-mirrors")
+                       (disarchive-mirrors "disarchive-mirrors"))
     (unless url
       (leave (G_ "~a: missing URL~%") (derivation-file-name drv)))
 
@@ -79,6 +80,10 @@ actual output is different from that when we're doing a 'bmCheck' or
                              (lambda (port)
                                (eval (read port) %user-module)))
                            '())
+                       #:disarchive-mirrors
+                       (if disarchive-mirrors
+                           (call-with-input-file disarchive-mirrors read)
+                           '())
                        #:hashes `((,algo . ,hash))
 
                        ;; Since DRV's output hash is known, X.509 certificate