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.

1 files changed, 73 insertions, 10 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