diff options
Diffstat (limited to 'guix/build/download.scm')
| -rw-r--r-- | guix/build/download.scm | 83 |
1 files changed, 10 insertions, 73 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index 5431d7c682..a22d4064ca 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -2,7 +2,6 @@ ;;; 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. ;;; @@ -35,8 +34,6 @@ #: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 @@ -629,53 +626,10 @@ 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 @@ -739,18 +693,6 @@ 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) @@ -763,20 +705,15 @@ otherwise simply ignore them." (or (fetch uri file) (try tail))) (() - ;; 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)))))) + (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 |