perform-download: Optionally report a "download-progress" trace.
* guix/scripts/perform-download.scm (perform-download): Add #:print-build-trace? and pass it to 'url-fetch'. (guix-perform-download): Define 'print-build-trace?' and pass it to 'perform-download'. * guix/build/download.scm (ftp-fetch): Add #:print-build-trace? and honor it. (url-fetch): Likewise. * nix/libstore/builtins.cc (builtinDownload): Set _NIX_OPTIONS environment variable.
This commit is contained in:
Ludovic Courtès
parent
dc0f74e5fc
commit
240a9c69a6
|
|
@ -115,7 +115,7 @@ and 'guix publish', something like
|
|||
(string-drop path 33)
|
||||
path)))
|
||||
|
||||
(define* (ftp-fetch uri file #:key timeout)
|
||||
(define* (ftp-fetch uri file #:key timeout print-build-trace?)
|
||||
"Fetch data from URI and write it to FILE. Return FILE on success. Bail
|
||||
out if the connection could not be established in less than TIMEOUT seconds."
|
||||
(let* ((conn (match (and=> (uri-userinfo uri)
|
||||
|
|
@ -136,12 +136,17 @@ out if the connection could not be established in less than TIMEOUT seconds."
|
|||
(lambda (out)
|
||||
(dump-port* in out
|
||||
#:buffer-size %http-receive-buffer-size
|
||||
#:reporter (progress-reporter/file
|
||||
(uri-abbreviation uri) size))))
|
||||
#:reporter
|
||||
(if print-build-trace?
|
||||
(progress-reporter/trace
|
||||
file (uri->string uri) size)
|
||||
(progress-reporter/file
|
||||
(uri-abbreviation uri) size)))))
|
||||
|
||||
(ftp-close conn))
|
||||
(newline)
|
||||
file)
|
||||
(ftp-close conn)
|
||||
(unless print-build-trace?
|
||||
(newline))
|
||||
file))
|
||||
|
||||
;; Autoload GnuTLS so that this module can be used even when GnuTLS is
|
||||
;; not available. At compile time, this yields "possibly unbound
|
||||
|
|
@ -723,7 +728,8 @@ Return a list of URIs."
|
|||
#:key
|
||||
(timeout 10) (verify-certificate? #t)
|
||||
(mirrors '()) (content-addressed-mirrors '())
|
||||
(hashes '()))
|
||||
(hashes '())
|
||||
print-build-trace?)
|
||||
"Fetch FILE from URL; URL may be either a single string, or a list of
|
||||
string denoting alternate URLs for FILE. Return #f on failure, and FILE
|
||||
on success.
|
||||
|
|
@ -759,13 +765,18 @@ otherwise simply ignore them."
|
|||
(lambda (output)
|
||||
(dump-port* port output
|
||||
#:buffer-size %http-receive-buffer-size
|
||||
#:reporter (progress-reporter/file
|
||||
(uri-abbreviation uri) size))
|
||||
#:reporter (if print-build-trace?
|
||||
(progress-reporter/trace
|
||||
file (uri->string uri) size)
|
||||
(progress-reporter/file
|
||||
(uri-abbreviation uri) size)))
|
||||
(newline)))
|
||||
file)))
|
||||
((ftp)
|
||||
(false-if-exception* (ftp-fetch uri file
|
||||
#:timeout timeout)))
|
||||
#:timeout timeout
|
||||
#:print-build-trace?
|
||||
print-build-trace?)))
|
||||
(else
|
||||
(format #t "skipping URI with unsupported scheme: ~s~%"
|
||||
uri)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -41,14 +41,14 @@
|
|||
(module-use! module (resolve-interface '(guix base32)))
|
||||
module))
|
||||
|
||||
(define* (perform-download drv #:optional output)
|
||||
(define* (perform-download drv #:optional output
|
||||
#:key print-build-trace?)
|
||||
"Perform the download described by DRV, a fixed-output derivation, to
|
||||
OUTPUT.
|
||||
|
||||
Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the
|
||||
actual output is different from that when we're doing a 'bmCheck' or
|
||||
'bmRepair' build."
|
||||
;; TODO: Use 'trace-progress-proc' when possible.
|
||||
(derivation-let drv ((url "url")
|
||||
(output* "out")
|
||||
(executable "executable")
|
||||
|
|
@ -68,6 +68,7 @@ actual output is different from that when we're doing a 'bmCheck' or
|
|||
|
||||
;; We're invoked by the daemon, which gives us write access to OUTPUT.
|
||||
(when (url-fetch url output
|
||||
#:print-build-trace? print-build-trace?
|
||||
#:mirrors (if mirrors
|
||||
(call-with-input-file mirrors read)
|
||||
'())
|
||||
|
|
@ -99,6 +100,11 @@ allows us to sidestep bootstrapping problems, such downloading the source code
|
|||
of GnuTLS over HTTPS, before we have built GnuTLS. See
|
||||
<http://bugs.gnu.org/22774>."
|
||||
|
||||
(define print-build-trace?
|
||||
(match (getenv "_NIX_OPTIONS")
|
||||
(#f #f)
|
||||
(str (string-contains str "print-extended-build-trace=1"))))
|
||||
|
||||
;; This program must be invoked by guix-daemon under an unprivileged UID to
|
||||
;; prevent things downloading from 'file:///etc/shadow' or arbitrary code
|
||||
;; execution via the content-addressed mirror procedures. (That means we
|
||||
|
|
@ -108,10 +114,12 @@ of GnuTLS over HTTPS, before we have built GnuTLS. See
|
|||
(((? derivation-path? drv) (? store-path? output))
|
||||
(assert-low-privileges)
|
||||
(perform-download (read-derivation-from-file drv)
|
||||
output))
|
||||
output
|
||||
#:print-build-trace? print-build-trace?))
|
||||
(((? derivation-path? drv)) ;backward compatibility
|
||||
(assert-low-privileges)
|
||||
(perform-download (read-derivation-from-file drv)))
|
||||
(perform-download (read-derivation-from-file drv)
|
||||
#:print-build-trace? print-build-trace?))
|
||||
(("--version")
|
||||
(show-version-and-exit))
|
||||
(x
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
/* GNU Guix --- Functional package management for GNU
|
||||
Copyright (C) 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
Copyright (C) 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
|
||||
|
||||
This file is part of GNU Guix.
|
||||
|
||||
|
|
@ -47,6 +47,9 @@ static void builtinDownload(const Derivation &drv,
|
|||
content-addressed mirrors) works correctly. */
|
||||
setenv("NIX_STORE", settings.nixStore.c_str(), 1);
|
||||
|
||||
/* Tell it about options such as "print-extended-build-trace". */
|
||||
setenv("_NIX_OPTIONS", settings.pack().c_str(), 1);
|
||||
|
||||
/* XXX: Hack our way to use the 'download' script from 'LIBEXECDIR/guix'
|
||||
or just 'LIBEXECDIR', depending on whether we're running uninstalled or
|
||||
not. */
|
||||
|
|
|
|||
Loading…
Reference in New Issue