aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/build/download.scm33
-rw-r--r--guix/scripts/perform-download.scm18
-rw-r--r--nix/libstore/builtins.cc5
3 files changed, 39 insertions, 17 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 315a3554ec..54163849a2 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -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))))
-
- (ftp-close conn))
- (newline)
- file)
+ #:reporter
+ (if print-build-trace?
+ (progress-reporter/trace
+ file (uri->string uri) size)
+ (progress-reporter/file
+ (uri-abbreviation uri) size)))))
+
+ (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)
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 9f6ecc00d2..df787a9940 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -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
diff --git a/nix/libstore/builtins.cc b/nix/libstore/builtins.cc
index a5ebb47737..1f52511c80 100644
--- a/nix/libstore/builtins.cc
+++ b/nix/libstore/builtins.cc
@@ -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. */