diff options
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/download.scm | 83 |
1 files changed, 73 insertions, 10 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index a22d4064ca..ce31038b05 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 ~a 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 |