diff options
| -rw-r--r-- | guix/build/download.scm | 83 | ||||
| -rw-r--r-- | guix/download.scm | 19 | ||||
| -rw-r--r-- | guix/scripts/perform-download.scm | 7 |
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 |