* [bug#32837] [PATCH 4/5] Add (guix status) and use it for pretty colored output.
2018-09-25 15:32 ` [bug#32837] [PATCH 1/5] progress: 'progress-reporter-report!' takes any number of arguments Ludovic Courtès
2018-09-25 15:32 ` [bug#32837] [PATCH 2/5] substitute: Progress port really closes underlying port Ludovic Courtès
2018-09-25 15:32 ` [bug#32837] [PATCH 3/5] progress: Add 'display-download-progress' Ludovic Courtès
@ 2018-09-25 15:32 ` Ludovic Courtès
2018-09-25 15:32 ` [bug#32837] [PATCH 5/5] perform-download: Optionally report a "download-progress" trace Ludovic Courtès
2018-09-26 7:58 ` [bug#32837] [PATCH 1/5] progress: 'progress-reporter-report!' takes any number of arguments Danny Milosavljevic
4 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2018-09-25 15:32 UTC (permalink / raw)
To: 32837; +Cc: Ricardo Wurmus
* guix/progress.scm (progress-reporter/trace): New procedure.
* guix/scripts/build.scm (set-build-options-from-command-line): Pass
#:print-extended-build-trace?.
(%default-options): Add 'print-extended-build-trace?'.
(guix-build): Parameterize CURRENT-TERMINAL-COLUMNS. Use
'build-status-updater'.
* guix/scripts/environment.scm (%default-options): Add
'print-extended-build-trace?'.
(guix-environment): Wrap body in 'with-status-report'.
* guix/scripts/pack.scm (%default-options): Add 'print-build-trace?' and
'print-extended-build-trace?'.
(guix-pack): Wrap body in 'with-status-report'.
* guix/scripts/package.scm (%default-options, guix-package): Likewise.
* guix/scripts/system.scm (%default-options, guix-system): Likewise.
* guix/scripts/substitute.scm (progress-report-port): Don't call STOP
when TOTAL is zero.
(process-substitution): Add #:print-build-trace? and honor it.
(guix-substitute)[print-build-trace?]: New variable.
Pass #:print-build-trace? to 'process-substitution'.
* guix/status.scm: New file.
* guix/store.scm (set-build-options): Add #:print-extended-build-trace?;
pass it into PAIRS.
* guix/ui.scm (build-output-port): Remove.
(colorize-string): Export.
* po/guix/POTFILES.in: Add guix/status.scm.
* tests/status.scm: New file.
* Makefile.am (SCM_TESTS): Add it.
---
.dir-locals.el | 1 +
Makefile.am | 2 +
guix/progress.scm | 30 +-
guix/scripts/build.scm | 15 +-
guix/scripts/environment.scm | 110 +++----
guix/scripts/pack.scm | 140 ++++-----
guix/scripts/package.scm | 24 +-
guix/scripts/perform-download.scm | 1 +
guix/scripts/substitute.scm | 42 ++-
guix/scripts/system.scm | 11 +-
guix/status.scm | 463 ++++++++++++++++++++++++++++++
guix/store.scm | 14 +-
guix/ui.scm | 108 +------
po/guix/POTFILES.in | 1 +
tests/status.scm | 115 ++++++++
15 files changed, 820 insertions(+), 257 deletions(-)
create mode 100644 guix/status.scm
create mode 100644 tests/status.scm
diff --git a/.dir-locals.el b/.dir-locals.el
index eb99a5bcc..793117c0a 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -59,6 +59,7 @@
(eval . (put 'emacs-substitute-variables 'scheme-indent-function 1))
(eval . (put 'with-derivation-narinfo 'scheme-indent-function 1))
(eval . (put 'with-derivation-substitute 'scheme-indent-function 2))
+ (eval . (put 'with-status-report 'scheme-indent-function 1))
(eval . (put 'mlambda 'scheme-indent-function 1))
(eval . (put 'mlambdaq 'scheme-indent-function 1))
diff --git a/Makefile.am b/Makefile.am
index 5c8639d66..7fd29b90a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -131,6 +131,7 @@ MODULES = \
guix/svn-download.scm \
guix/i18n.scm \
guix/ui.scm \
+ guix/status.scm \
guix/build/android-ndk-build-system.scm \
guix/build/ant-build-system.scm \
guix/build/download.scm \
@@ -340,6 +341,7 @@ SCM_TESTS = \
tests/glob.scm \
tests/grafts.scm \
tests/ui.scm \
+ tests/status.scm \
tests/records.scm \
tests/upstream.scm \
tests/combinators.scm \
diff --git a/guix/progress.scm b/guix/progress.scm
index d4ebb3299..27610091c 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -38,8 +38,11 @@
progress-reporter/silent
progress-reporter/file
progress-reporter/bar
+ progress-reporter/trace
display-download-progress
+ erase-current-line
+ progress-bar
byte-count->string
current-terminal-columns
@@ -279,6 +282,31 @@ tasks is performed. Write PREFIX at the beginning of the line."
(newline port))
(force-output port)))))
+(define* (progress-reporter/trace file url size
+ #:optional (log-port (current-output-port)))
+ "Like 'progress-reporter/file', but instead of returning human-readable
+progress reports, write \"build trace\" lines to be processed elsewhere."
+ (define (report-progress transferred)
+ (define message
+ (format #f "@ download-progress ~a ~a ~a ~a~%"
+ file url (or size "-") transferred))
+
+ (display message log-port) ;should be atomic
+ (flush-output-port log-port))
+
+ (progress-reporter
+ (start (lambda ()
+ (display (format #f "@ download-started ~a ~a ~a~%"
+ file url (or size "-"))
+ log-port)))
+ (report report-progress)
+ (stop (lambda ()
+ (display (format #f "@ download-succeeded ~a ~a ~a~%"
+ file url
+ (or (and=> (stat file #f) stat:size)
+ size))
+ log-port)))))
+
;; TODO: replace '(@ (guix build utils) dump-port))'.
(define* (dump-port* in out
#:key (buffer-size 16384)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 3fa3c2c20..5a6ba62bc 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -45,6 +45,9 @@
#:use-module (srfi srfi-37)
#:autoload (gnu packages) (specification->package %package-module-path)
#:autoload (guix download) (download-to-store)
+ #:use-module (guix status)
+ #:use-module ((guix progress) #:select (current-terminal-columns))
+ #:use-module ((guix build syscalls) #:select (terminal-columns))
#:export (%standard-build-options
set-build-options-from-command-line
set-build-options-from-command-line*
@@ -390,6 +393,8 @@ options handled by 'set-build-options-from-command-line', and listed in
#:max-silent-time (assoc-ref opts 'max-silent-time)
#:timeout (assoc-ref opts 'timeout)
#:print-build-trace (assoc-ref opts 'print-build-trace?)
+ #:print-extended-build-trace?
+ (assoc-ref opts 'print-extended-build-trace?)
#:verbosity (assoc-ref opts 'verbosity)))
(define set-build-options-from-command-line*
@@ -499,6 +504,7 @@ options handled by 'set-build-options-from-command-line', and listed in
(substitutes? . #t)
(build-hook? . #t)
(print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
(verbosity . 0)))
(define (show-help)
@@ -733,9 +739,12 @@ needed."
;; Set the build options before we do anything else.
(set-build-options-from-command-line store opts)
- (parameterize ((current-build-output-port (if quiet?
- (%make-void-port "w")
- (build-output-port #:verbose? #t))))
+ (parameterize ((current-terminal-columns (terminal-columns))
+ (current-build-output-port
+ (if quiet?
+ (%make-void-port "w")
+ (build-event-output-port
+ (build-status-updater print-build-event)))))
(let* ((mode (assoc-ref opts 'build-mode))
(drv (options->derivations store opts))
(urls (map (cut string-append <> "/log")
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 1c04800e4..9fc7edcd3 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -21,6 +21,7 @@
(define-module (guix scripts environment)
#:use-module (guix ui)
#:use-module (guix store)
+ #:use-module (guix status)
#:use-module (guix grafts)
#:use-module (guix derivations)
#:use-module (guix packages)
@@ -173,6 +174,8 @@ COMMAND or an interactive shell in that environment.\n"))
(substitutes? . #t)
(build-hook? . #t)
(graft? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
(verbosity . 0)))
(define (tag-package-arg opts arg)
@@ -661,59 +664,60 @@ message if any test fails."
(leave (G_ "'--user' cannot be used without '--container'~%")))
(with-store store
- (set-build-options-from-command-line store opts)
+ (with-status-report print-build-event
+ (set-build-options-from-command-line store opts)
- ;; Use the bootstrap Guile when requested.
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%guile-for-build
- (package-derivation
- store
- (if bootstrap?
- %bootstrap-guile
- (canonical-package guile-2.2)))))
- (run-with-store store
- ;; Containers need a Bourne shell at /bin/sh.
- (mlet* %store-monad ((bash (environment-bash container?
- bootstrap?
- system))
- (prof-drv (manifest->derivation
- manifest system bootstrap?))
- (profile -> (derivation->output-path prof-drv))
- (gc-root -> (assoc-ref opts 'gc-root)))
+ ;; Use the bootstrap Guile when requested.
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build
+ (package-derivation
+ store
+ (if bootstrap?
+ %bootstrap-guile
+ (canonical-package guile-2.2)))))
+ (run-with-store store
+ ;; Containers need a Bourne shell at /bin/sh.
+ (mlet* %store-monad ((bash (environment-bash container?
+ bootstrap?
+ system))
+ (prof-drv (manifest->derivation
+ manifest system bootstrap?))
+ (profile -> (derivation->output-path prof-drv))
+ (gc-root -> (assoc-ref opts 'gc-root)))
- ;; First build the inputs. This is necessary even for
- ;; --search-paths. Additionally, we might need to build bash for
- ;; a container.
- (mbegin %store-monad
- (build-environment (if (derivation? bash)
- (list prof-drv bash)
- (list prof-drv))
- opts)
- (mwhen gc-root
- (register-gc-root profile gc-root))
+ ;; First build the inputs. This is necessary even for
+ ;; --search-paths. Additionally, we might need to build bash for
+ ;; a container.
+ (mbegin %store-monad
+ (build-environment (if (derivation? bash)
+ (list prof-drv bash)
+ (list prof-drv))
+ opts)
+ (mwhen gc-root
+ (register-gc-root profile gc-root))
- (cond
- ((assoc-ref opts 'dry-run?)
- (return #t))
- ((assoc-ref opts 'search-paths)
- (show-search-paths profile manifest #:pure? pure?)
- (return #t))
- (container?
- (let ((bash-binary
- (if bootstrap?
- bash
- (string-append (derivation->output-path bash)
- "/bin/sh"))))
- (launch-environment/container #:command command
- #:bash bash-binary
- #:user user
- #:user-mappings mappings
- #:profile profile
- #:manifest manifest
- #:link-profile? link-prof?
- #:network? network?)))
- (else
- (return
- (exit/status
- (launch-environment/fork command profile manifest
- #:pure? pure?)))))))))))))
+ (cond
+ ((assoc-ref opts 'dry-run?)
+ (return #t))
+ ((assoc-ref opts 'search-paths)
+ (show-search-paths profile manifest #:pure? pure?)
+ (return #t))
+ (container?
+ (let ((bash-binary
+ (if bootstrap?
+ bash
+ (string-append (derivation->output-path bash)
+ "/bin/sh"))))
+ (launch-environment/container #:command command
+ #:bash bash-binary
+ #:user user
+ #:user-mappings mappings
+ #:profile profile
+ #:manifest manifest
+ #:link-profile? link-prof?
+ #:network? network?)))
+ (else
+ (return
+ (exit/status
+ (launch-environment/fork command profile manifest
+ #:pure? pure?))))))))))))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 1916f3b9d..163f5b1dc 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -25,6 +25,7 @@
#:use-module (guix gexp)
#:use-module (guix utils)
#:use-module (guix store)
+ #:use-module (guix status)
#:use-module (guix grafts)
#:use-module (guix monads)
#:use-module (guix modules)
@@ -538,6 +539,8 @@ please email '~a'~%")
(substitutes? . #t)
(build-hook? . #t)
(graft? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
(verbosity . 0)
(symlinks . ())
(compressor . ,(first %compressors))))
@@ -684,72 +687,73 @@ Create a bundle of PACKAGE.\n"))
(with-error-handling
(with-store store
- ;; Set the build options before we do anything else.
- (set-build-options-from-command-line store opts)
+ (with-status-report print-build-event
+ ;; Set the build options before we do anything else.
+ (set-build-options-from-command-line store opts)
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%guile-for-build (package-derivation
- store
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (canonical-package guile-2.2))
- (assoc-ref opts 'system)
- #:graft? (assoc-ref opts 'graft?))))
- (let* ((dry-run? (assoc-ref opts 'dry-run?))
- (relocatable? (assoc-ref opts 'relocatable?))
- (manifest (let ((manifest (manifest-from-args store opts)))
- ;; Note: We cannot honor '--bootstrap' here because
- ;; 'glibc-bootstrap' lacks 'libc.a'.
- (if relocatable?
- (map-manifest-entries wrapped-package manifest)
- manifest)))
- (pack-format (assoc-ref opts 'format))
- (name (string-append (symbol->string pack-format)
- "-pack"))
- (target (assoc-ref opts 'target))
- (bootstrap? (assoc-ref opts 'bootstrap?))
- (compressor (if bootstrap?
- bootstrap-xz
- (assoc-ref opts 'compressor)))
- (archiver (if (equal? pack-format 'squashfs)
- squashfs-tools-next
- (if bootstrap?
- %bootstrap-coreutils&co
- tar)))
- (symlinks (assoc-ref opts 'symlinks))
- (build-image (match (assq-ref %formats pack-format)
- ((? procedure? proc) proc)
- (#f
- (leave (G_ "~a: unknown pack format~%")
- pack-format))))
- (localstatedir? (assoc-ref opts 'localstatedir?)))
- (run-with-store store
- (mlet* %store-monad ((profile (profile-derivation
- manifest
- #:relative-symlinks? relocatable?
- #:hooks (if bootstrap?
- '()
- %default-profile-hooks)
- #:locales? (not bootstrap?)
- #:target target))
- (drv (build-image name profile
- #:target
- target
- #:compressor
- compressor
- #:symlinks
- symlinks
- #:localstatedir?
- localstatedir?
- #:archiver
- archiver)))
- (mbegin %store-monad
- (show-what-to-build* (list drv)
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:dry-run? dry-run?)
- (munless dry-run?
- (built-derivations (list drv))
- (return (format #t "~a~%"
- (derivation->output-path drv))))))
- #:system (assoc-ref opts 'system)))))))
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build (package-derivation
+ store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (canonical-package guile-2.2))
+ (assoc-ref opts 'system)
+ #:graft? (assoc-ref opts 'graft?))))
+ (let* ((dry-run? (assoc-ref opts 'dry-run?))
+ (relocatable? (assoc-ref opts 'relocatable?))
+ (manifest (let ((manifest (manifest-from-args store opts)))
+ ;; Note: We cannot honor '--bootstrap' here because
+ ;; 'glibc-bootstrap' lacks 'libc.a'.
+ (if relocatable?
+ (map-manifest-entries wrapped-package manifest)
+ manifest)))
+ (pack-format (assoc-ref opts 'format))
+ (name (string-append (symbol->string pack-format)
+ "-pack"))
+ (target (assoc-ref opts 'target))
+ (bootstrap? (assoc-ref opts 'bootstrap?))
+ (compressor (if bootstrap?
+ bootstrap-xz
+ (assoc-ref opts 'compressor)))
+ (archiver (if (equal? pack-format 'squashfs)
+ squashfs-tools-next
+ (if bootstrap?
+ %bootstrap-coreutils&co
+ tar)))
+ (symlinks (assoc-ref opts 'symlinks))
+ (build-image (match (assq-ref %formats pack-format)
+ ((? procedure? proc) proc)
+ (#f
+ (leave (G_ "~a: unknown pack format~%")
+ pack-format))))
+ (localstatedir? (assoc-ref opts 'localstatedir?)))
+ (run-with-store store
+ (mlet* %store-monad ((profile (profile-derivation
+ manifest
+ #:relative-symlinks? relocatable?
+ #:hooks (if bootstrap?
+ '()
+ %default-profile-hooks)
+ #:locales? (not bootstrap?)
+ #:target target))
+ (drv (build-image name profile
+ #:target
+ target
+ #:compressor
+ compressor
+ #:symlinks
+ symlinks
+ #:localstatedir?
+ localstatedir?
+ #:archiver
+ archiver)))
+ (mbegin %store-monad
+ (show-what-to-build* (list drv)
+ #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run? dry-run?)
+ (munless dry-run?
+ (built-derivations (list drv))
+ (return (format #t "~a~%"
+ (derivation->output-path drv))))))
+ #:system (assoc-ref opts 'system))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 73cbccba3..93a77915f 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -24,6 +24,7 @@
(define-module (guix scripts package)
#:use-module (guix ui)
+ #:use-module (guix status)
#:use-module (guix store)
#:use-module (guix grafts)
#:use-module (guix derivations)
@@ -330,7 +331,8 @@ ENTRIES, a list of manifest entries, in the context of PROFILE."
(graft? . #t)
(substitutes? . #t)
(build-hook? . #t)
- (print-build-trace? . #t)))
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)))
(define (show-help)
(display (G_ "Usage: guix package [OPTION]...
@@ -941,14 +943,12 @@ processed, #f otherwise."
(or (process-query opts)
(parameterize ((%store (open-connection))
(%graft? (assoc-ref opts 'graft?)))
- (set-build-options-from-command-line (%store) opts)
-
- (parameterize ((%guile-for-build
- (package-derivation
- (%store)
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (canonical-package guile-2.2))))
- (current-build-output-port
- (build-output-port #:verbose? verbose?)))
- (process-actions (%store) opts))))))
+ (with-status-report print-build-event/quiet
+ (set-build-options-from-command-line (%store) opts)
+ (parameterize ((%guile-for-build
+ (package-derivation
+ (%store)
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (canonical-package guile-2.2)))))
+ (process-actions (%store) opts)))))))
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 18e2fc92f..9f6ecc00d 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -48,6 +48,7 @@ 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")
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 50c6a2206..eb8222401 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -837,7 +837,16 @@ REPORTER, which should be a <progress-reporter> object."
(make-custom-binary-input-port "progress-port-proc"
read! #f #f
(lambda ()
- (stop)
+ ;; XXX: Kludge! When used through
+ ;; 'decompressed-port', this port ends
+ ;; up being closed twice: once in a
+ ;; child process early on, and at the
+ ;; end in the parent process. Ignore
+ ;; the early close so we don't output
+ ;; a spurious "download-succeeded"
+ ;; trace.
+ (unless (zero? total)
+ (stop))
(close-port port)))))))
(define-syntax with-networking
@@ -930,7 +939,7 @@ authorized substitutes."
(error "unknown `--query' command" wtf))))
(define* (process-substitution store-item destination
- #:key cache-urls acl)
+ #:key cache-urls acl print-build-trace?)
"Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
DESTINATION as a nar file. Verify the substitute against ACL."
(let* ((narinfo (lookup-narinfo cache-urls store-item
@@ -943,8 +952,10 @@ DESTINATION as a nar file. Verify the substitute against ACL."
;; Tell the daemon what the expected hash of the Nar itself is.
(format #t "~a~%" (narinfo-hash narinfo))
- (format (current-error-port)
- (G_ "Downloading ~a...~%") (uri->string uri))
+ (unless print-build-trace?
+ (format (current-error-port)
+ (G_ "Downloading ~a...~%") (uri->string uri)))
+
(let*-values (((raw download-size)
;; Note that Hydra currently generates Nars on the fly
;; and doesn't specify a Content-Length, so
@@ -955,10 +966,15 @@ DESTINATION as a nar file. Verify the substitute against ACL."
(dl-size (or download-size
(and (equal? comp "none")
(narinfo-size narinfo))))
- (reporter (progress-reporter/file
- (uri->string uri) dl-size
- (current-error-port)
- #:abbreviation nar-uri-abbreviation)))
+ (reporter (if print-build-trace?
+ (progress-reporter/trace
+ destination
+ (uri->string uri) dl-size
+ (current-error-port))
+ (progress-reporter/file
+ (uri->string uri) dl-size
+ (current-error-port)
+ #:abbreviation nar-uri-abbreviation))))
(progress-report-port reporter raw)))
((input pids)
;; NOTE: This 'progress' port of current process will be
@@ -1058,6 +1074,13 @@ default value."
(define (guix-substitute . args)
"Implement the build daemon's substituter protocol."
+ (define print-build-trace?
+ (match (or (find-daemon-option "untrusted-print-extended-build-trace")
+ (find-daemon-option "print-extended-build-trace"))
+ (#f #f)
+ ((= string->number number) (> number 0))
+ (_ #f)))
+
(mkdir-p %narinfo-cache-directory)
(maybe-remove-expired-cache-entries %narinfo-cache-directory
cached-narinfo-files
@@ -1111,7 +1134,8 @@ default value."
(parameterize ((current-terminal-columns (client-terminal-columns)))
(process-substitution store-path destination
#:cache-urls (substitute-urls)
- #:acl (current-acl))))
+ #:acl (current-acl)
+ #:print-build-trace? print-build-trace?)))
((or ("-V") ("--version"))
(show-version-and-exit "guix substitute"))
(("--help")
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 69bd05b51..5d003c88f 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -23,6 +23,7 @@
(define-module (guix scripts system)
#:use-module (guix config)
#:use-module (guix ui)
+ #:use-module (guix status)
#:use-module (guix store)
#:autoload (guix store database) (register-path)
#:use-module (guix grafts)
@@ -1072,6 +1073,8 @@ Some ACTIONS support additional ARGS.\n"))
`((system . ,(%current-system))
(substitutes? . #t)
(build-hook? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
(graft? . #t)
(verbosity . 0)
(file-system-type . "ext4")
@@ -1246,9 +1249,11 @@ argument list and OPTS is the option alist."
parse-sub-command))
(args (option-arguments opts))
(command (assoc-ref opts 'action)))
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (current-terminal-columns (terminal-columns)))
- (process-command command args opts)))))
+ (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (with-status-report (if (memq command '(init reconfigure))
+ print-build-event/quiet
+ print-build-event)
+ (process-command command args opts))))))
;;; Local Variables:
;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)
diff --git a/guix/status.scm b/guix/status.scm
new file mode 100644
index 000000000..60727892f
--- /dev/null
+++ b/guix/status.scm
@@ -0,0 +1,463 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix status)
+ #:use-module (guix records)
+ #:use-module (guix i18n)
+ #:use-module ((guix ui) #:select (colorize-string))
+ #:use-module (guix progress)
+ #:autoload (guix build syscalls) (terminal-columns)
+ #:use-module ((guix store)
+ #:select (current-build-output-port log-file))
+ #:use-module (guix derivations)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
+ #:use-module ((system foreign)
+ #:select (bytevector->pointer pointer->bytevector))
+ #:export (build-event-output-port
+ compute-status
+
+ build-status
+ build-status?
+ build-status-building
+ build-status-downloading
+ build-status-builds-completed
+ build-status-downloads-completed
+
+ download?
+ download
+ download-item
+ download-uri
+ download-size
+ download-start
+ download-end
+ download-transferred
+
+ build-status-updater
+ print-build-event
+ print-build-event/quiet
+ print-build-status
+
+ with-status-report))
+
+;;; Commentary:
+;;;
+;;; This module provides facilities to track the status of ongoing builds and
+;;; downloads in a given session, as well as tools to report about the current
+;;; status to user interfaces. It does so by analyzing the output of
+;;; 'current-build-output-port'. The build status is maintained in a
+;;; <build-status> record.
+;;;
+;;; Code:
+
+\f
+;;;
+;;; Build status tracking.
+;;;
+
+;; Builds and substitutions performed by the daemon.
+(define-record-type* <build-status> build-status make-build-status
+ build-status?
+ (building build-status-building ;list of drv
+ (default '()))
+ (downloading build-status-downloading ;list of <download>
+ (default '()))
+ (builds-completed build-status-builds-completed ;list of drv
+ (default '()))
+ (downloads-completed build-status-downloads-completed ;list of store items
+ (default '())))
+
+;; On-going or completed downloads. Downloads can be stem from substitutes
+;; and from "builtin:download" fixed-output derivations.
+(define-record-type <download>
+ (%download item uri size start end transferred)
+ download?
+ (item download-item) ;store item
+ (uri download-uri) ;string | #f
+ (size download-size) ;integer | #f
+ (start download-start) ;<time>
+ (end download-end) ;#f | <time>
+ (transferred download-transferred)) ;integer
+
+(define* (download item uri
+ #:key size
+ (start (current-time time-monotonic)) end
+ (transferred 0))
+ "Return a new download."
+ (%download item uri size start end transferred))
+
+(define (matching-download item)
+ "Return a predicate that matches downloads of ITEM."
+ (lambda (download)
+ (string=? item (download-item download))))
+
+(define* (compute-status event status
+ #:key (current-time current-time))
+ "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...),
+compute a new status based on STATUS."
+ (match event
+ (('build-started drv _ ...)
+ (build-status
+ (inherit status)
+ (building (cons drv (build-status-building status)))))
+ (((or 'build-succeeded 'build-failed) drv _ ...)
+ (build-status
+ (inherit status)
+ (building (delete drv (build-status-building status)))
+ (builds-completed (cons drv (build-status-builds-completed status)))))
+
+ ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because
+ ;; they're not as informative as 'download-started' and
+ ;; 'download-succeeded'.
+
+ (('download-started item uri (= string->number size))
+ ;; This is presumably a fixed-output derivation so move it from
+ ;; 'building' to 'downloading'. XXX: This doesn't work in 'check' mode
+ ;; because ITEM is different from DRV's output.
+ (build-status
+ (inherit status)
+ (building (remove (lambda (drv)
+ (equal? (false-if-exception
+ (derivation->output-path
+ (read-derivation-from-file drv)))
+ item))
+ (build-status-building status)))
+ (downloading (cons (download item uri #:size size
+ #:start (current-time time-monotonic))
+ (build-status-downloading status)))))
+ (('download-succeeded item uri (= string->number size))
+ (let ((current (find (matching-download item)
+ (build-status-downloading status))))
+ (build-status
+ (inherit status)
+ (downloading (delq current (build-status-downloading status)))
+ (downloads-completed
+ (cons (download item uri
+ #:size size
+ #:start (download-start current)
+ #:transferred size
+ #:end (current-time time-monotonic))
+ (build-status-downloads-completed status))))))
+ (('substituter-succeeded item _ ...)
+ (match (find (matching-download item)
+ (build-status-downloading status))
+ (#f
+ ;; Presumably we already got a 'download-succeeded' event for ITEM,
+ ;; everything is fine.
+ status)
+ (current
+ ;; Maybe the build process didn't emit a 'download-succeeded' event
+ ;; for ITEM, so remove CURRENT from the queue now.
+ (build-status
+ (inherit status)
+ (downloading (delq current (build-status-downloading status)))
+ (downloads-completed
+ (cons (download item (download-uri current)
+ #:size (download-size current)
+ #:start (download-start current)
+ #:transferred (download-size current)
+ #:end (current-time time-monotonic))
+ (build-status-downloads-completed status)))))))
+ (('download-progress item uri
+ (= string->number size)
+ (= string->number transferred))
+ (let ((downloads (remove (matching-download item)
+ (build-status-downloading status)))
+ (current (find (matching-download item)
+ (build-status-downloading status))))
+ (build-status
+ (inherit status)
+ (downloading (cons (download item uri
+ #:size size
+ #:start
+ (or (and current
+ (download-start current))
+ (current-time time-monotonic))
+ #:transferred transferred)
+ downloads)))))
+ (_
+ status)))
+
+(define (simultaneous-jobs status)
+ "Return the number of on-going builds and downloads for STATUS."
+ (+ (length (build-status-building status))
+ (length (build-status-downloading status))))
+
+(define spin!
+ (let ((steps (circular-list "\\" "|" "/" "-")))
+ (lambda (port)
+ "Display a spinner on PORT."
+ (match steps
+ ((first . rest)
+ (set! steps rest)
+ (display "\r\x1b[K" port)
+ (display first port)
+ (force-output port))))))
+
+(define (color-output? port)
+ "Return true if we should write colored output to PORT."
+ (and (not (getenv "INSIDE_EMACS"))
+ (not (getenv "NO_COLOR"))
+ (isatty? port)))
+
+(define-syntax color-rules
+ (syntax-rules ()
+ "Return a procedure that colorizes the string it is passed according to
+the given rules. Each rule has the form:
+
+ (REGEXP COLOR1 COLOR2 ...)
+
+where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
+on."
+ ((_ (regexp colors ...) rest ...)
+ (let ((next (color-rules rest ...))
+ (rx (make-regexp regexp)))
+ (lambda (str)
+ (if (string-index str #\nul)
+ str
+ (match (regexp-exec rx str)
+ (#f (next str))
+ (m (let loop ((n 1)
+ (c '(colors ...))
+ (result '()))
+ (match c
+ (()
+ (string-concatenate-reverse result))
+ ((first . tail)
+ (loop (+ n 1) tail
+ (cons (colorize-string (match:substring m n)
+ first)
+ result)))))))))))
+ ((_)
+ (lambda (str)
+ str))))
+
+(define colorize-log-line
+ ;; Take a string and return a possibly colorized string according to the
+ ;; rules below.
+ (color-rules
+ ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)"
+ GREEN BOLD GREEN RESET GREEN BLUE)
+ ("^(phase)(.*)(failed after)(.*)(seconds)(.*)"
+ RED BLUE RED BLUE RED BLUE)
+ ("^(.*)(error|fail|failed|FAIL|FAILED)([[:blank:]]*)(:)(.*)"
+ RESET RED BOLD BOLD BOLD)
+ ("^(.*)(warning)([[:blank:]]*)(:)(.*)"
+ RESET ORANGE BOLD BOLD BOLD)))
+
+(define* (print-build-event event old-status status
+ #:optional (port (current-error-port))
+ #:key
+ (colorize? (color-output? port))
+ (print-log? #t))
+ "Print information about EVENT and STATUS to PORT. When COLORIZE? is true,
+produce colorful output. When PRINT-LOG? is true, display the build log in
+addition to build events."
+ (define info
+ (if colorize?
+ (cut colorize-string <> 'BOLD)
+ identity))
+
+ (define success
+ (if colorize?
+ (cut colorize-string <> 'GREEN 'BOLD)
+ identity))
+
+ (define failure
+ (if colorize?
+ (cut colorize-string <> 'RED 'BOLD)
+ identity))
+
+ (define print-log-line
+ (if print-log?
+ (if colorize?
+ (lambda (line)
+ (display (colorize-log-line line) port))
+ (cut display <> port))
+ (lambda (line)
+ (spin! port))))
+
+ (display "\r" port) ;erase the spinner
+ (match event
+ (('build-started drv . _)
+ (format port (info (G_ "building ~a...")) drv)
+ (newline port))
+ (('build-succeeded drv . _)
+ (format port (success (G_ "successfully built ~a")) drv)
+ (newline port)
+ (match (build-status-building status)
+ (() #t)
+ (ongoing ;when max-jobs > 1
+ (format port
+ (N_ "The following build is still in progress:~%~{ ~a~%~}~%"
+ "The following builds are still in progress:~%~{ ~a~%~}~%"
+ (length ongoing))
+ ongoing))))
+ (('build-failed drv . _)
+ (format port (failure (G_ "build of ~a failed")) drv)
+ (newline port)
+ (format port (info (G_ "View build log at '~a'.~%"))
+ (log-file #f drv)))
+ (('substituter-started item _ ...)
+ (when print-log?
+ (format port (info (G_ "substituting ~a...")) item)
+ (newline port)))
+ (('download-started item uri _ ...)
+ (format port (info (G_ "downloading from ~a...")) uri)
+ (newline port))
+ (('download-progress item uri
+ (= string->number size)
+ (= string->number transferred))
+ ;; Print a progress bar, but only if there's only one on-going
+ ;; job--otherwise the output would be intermingled.
+ (when (= 1 (simultaneous-jobs status))
+ (match (find (matching-download item)
+ (build-status-downloading status))
+ (#f #f) ;shouldn't happen!
+ (download
+ (display-download-progress (basename uri) size
+ #:start-time
+ (download-start download)
+ #:transferred transferred)))))
+ (('substituter-succeeded item _ ...)
+ ;; If there are no jobs running, we already reported download completion
+ ;; sot there's nothing left to do.
+ (unless (zero? (simultaneous-jobs status))
+ (format port (success (G_ "substitution of ~a complete")) item)
+ (newline port)))
+ (('substituter-failed item _ ...)
+ (format port (failure (G_ "substitution of ~a failed")) item)
+ (newline port))
+ (('build-log line)
+ ;; The daemon prefixes early messages coming with 'guix substitute' with
+ ;; "substitute:". These are useful ("updating substitutes from URL"), so
+ ;; let them through.
+ (if (string-prefix? "substitute: " line)
+ (begin
+ (format port line)
+ (force-output port))
+ (print-log-line line)))
+ (_
+ event)))
+
+(define* (print-build-event/quiet event old-status status
+ #:optional
+ (port (current-error-port))
+ #:key
+ (colorize? (color-output? port)))
+ (print-build-event event old-status status port
+ #:colorize? colorize?
+ #:print-log? #f))
+
+(define* (build-status-updater #:optional (on-change (const #t)))
+ "Return a procedure that can be passed to 'build-event-output-port'. That
+procedure computes the new build status upon each even and call ON-CHANGE:
+
+ (ON-CHANGE event status new-status)
+
+ON-CHANGE can display the build status, build events, etc."
+ (lambda (event status)
+ (let ((new (compute-status event status)))
+ (on-change event status new)
+ new)))
+
+\f
+;;;
+;;; Build port.
+;;;
+
+(define %newline
+ (char-set #\return #\newline))
+
+(define* (build-event-output-port proc #:optional (seed (build-status)))
+ "Return an output port for use as 'current-build-output-port' that calls
+PROC with its current state value, initialized with SEED, on every build
+event. Build events passed to PROC are tuples corresponding to the \"build
+traces\" produced by the daemon:
+
+ (build-started \"/gnu/store/...-foo.drv\" ...)
+ (substituter-started \"/gnu/store/...-foo\" ...)
+
+and so on.
+
+The second return value is a thunk to retrieve the current state."
+ (define %fragments
+ ;; Line fragments received so far.
+ '())
+
+ (define %state
+ ;; Current state for PROC.
+ seed)
+
+ (define (process-line line)
+ (if (string-prefix? "@ " line)
+ (match (string-tokenize (string-drop line 2))
+ (((= string->symbol event-name) args ...)
+ (set! %state
+ (proc (cons event-name args)
+ %state))))
+ (set! %state (proc (list 'build-log line)
+ %state))))
+
+ (define (bytevector-range bv offset count)
+ (let ((ptr (bytevector->pointer bv offset)))
+ (pointer->bytevector ptr count)))
+
+ (define (write! bv offset count)
+ (let loop ((str (utf8->string (bytevector-range bv offset count))))
+ (match (string-index str %newline)
+ ((? integer? cr)
+ (let ((tail (string-take str (+ 1 cr))))
+ (process-line (string-concatenate-reverse
+ (cons tail %fragments)))
+ (set! %fragments '())
+ (loop (string-drop str (+ 1 cr)))))
+ (#f
+ (unless (string-null? str)
+ (set! %fragments (cons str %fragments)))
+ count))))
+
+ (define port
+ (make-custom-binary-output-port "filtering-input-port"
+ write!
+ #f #f
+ #f))
+
+ ;; The build port actually receives Unicode strings.
+ (set-port-encoding! port "UTF-8")
+ (setvbuf port (cond-expand (guile-2.2 'line) (else _IOLBF)))
+
+ (values port (lambda () %state)))
+
+(define (call-with-status-report on-event thunk)
+ (parameterize ((current-terminal-columns (terminal-columns))
+ (current-build-output-port
+ (build-event-output-port (build-status-updater on-event))))
+ (thunk)))
+
+(define-syntax-rule (with-status-report on-event exp ...)
+ "Set up build status reporting to the user using the ON-EVENT procedure;
+evaluate EXP... in that context."
+ (call-with-status-report on-event (lambda () exp ...)))
diff --git a/guix/store.scm b/guix/store.scm
index af7f6980c..3e9835d83 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -682,6 +682,13 @@ encoding conversion errors."
(build-verbosity 0)
(log-type 0)
(print-build-trace #t)
+
+ ;; When true, provide machine-readable "build
+ ;; traces" for use by (guix status). Old clients
+ ;; are unable to make sense, which is why it's
+ ;; disabled by default.
+ print-extended-build-trace?
+
build-cores
(use-substitutes? #t)
@@ -725,7 +732,12 @@ encoding conversion errors."
(when (>= (nix-server-minor-version server) 10)
(send (boolean use-substitutes?)))
(when (>= (nix-server-minor-version server) 12)
- (let ((pairs `(,@(if timeout
+ (let ((pairs `(;; This option is honored by 'guix substitute' et al.
+ ,@(if print-build-trace
+ `(("print-extended-build-trace"
+ . ,(if print-extended-build-trace? "1" "0")))
+ '())
+ ,@(if timeout
`(("build-timeout" . ,(number->string timeout)))
'())
,@(if max-silent-time
diff --git a/guix/ui.scm b/guix/ui.scm
index 1bbd37c25..96f403acf 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -119,7 +119,7 @@
warning
info
guix-main
- build-output-port))
+ colorize-string))
;;; Commentary:
;;;
@@ -1676,110 +1676,4 @@ be reset such that subsequent output will not have any colors in effect."
str
(color 'RESET)))
-(define* (build-output-port #:key
- (colorize? #t)
- verbose?
- (port (current-error-port)))
- "Return a soft port that processes build output. By default it colorizes
-phase announcements and replaces any other output with a spinner."
- (define spun? #f)
- (define spin!
- (let ((steps (circular-list "\\" "|" "/" "-")))
- (lambda ()
- (match steps
- ((first . rest)
- (set! steps rest)
- (set! spun? #t) ; remember to erase spinner
- first)))))
-
- (define use-color?
- (and colorize?
- (not (or (getenv "NO_COLOR")
- (getenv "INSIDE_EMACS")
- (not (isatty? port))))))
-
- (define handle-string
- (let* ((proc (if use-color?
- colorize-string
- (lambda (s . _) s)))
- (rules `(("^(@ build-started) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Building " 'BLUE 'BOLD)
- (match:substring m 2) "\n")))
- ("^(@ build-failed) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Build failed: " 'RED 'BOLD)
- (match:substring m 2) "\n")))
- ("^(@ build-succeeded) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Built " 'GREEN 'BOLD)
- (match:substring m 2) "\n")))
- ("^(@ substituter-started) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Substituting " 'BLUE 'BOLD)
- (match:substring m 2) "\n")))
- ("^(@ substituter-failed) (.*) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Substituter failed: " 'RED 'BOLD)
- (match:substring m 2) "\n"
- (match:substring m 3) ": "
- (match:substring m 4) "\n")))
- ("^(@ substituter-succeeded) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Substituted " 'GREEN 'BOLD)
- (match:substring m 2) "\n")))
- ("^(starting phase )(.*)"
- BLUE GREEN)
- ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)"
- GREEN BLUE GREEN BLUE GREEN BLUE)
- ("^(phase)(.*)(failed after)(.*)(seconds)(.*)"
- RED BLUE RED BLUE RED BLUE))))
- (lambda (str)
- (let ((processed
- (any (match-lambda
- ((pattern #:transform transform)
- (and=> (string-match pattern str)
- transform))
- ((pattern . colors)
- (and=> (string-match pattern str)
- (lambda (m)
- (let ((substrings
- (map (cut match:substring m <>)
- (iota (- (match:count m) 1) 1))))
- (string-join (map proc substrings colors) ""))))))
- rules)))
- (when spun?
- (display (string #\backspace) port))
- (if processed
- (begin
- (display processed port)
- (set! spun? #f))
- ;; Print unprocessed line, or replace with spinner
- (display (if verbose? str (spin!)) port))))))
- (make-soft-port
- (vector
- ;; procedure accepting one character for output
- (cut write <> port)
- ;; procedure accepting a string for output
- handle-string
- ;; thunk for flushing output
- (lambda () (force-output port))
- ;; thunk for getting one character
- (const #t)
- ;; thunk for closing port (not by garbage collection)
- (lambda () (close port)))
- "w"))
-
;;; ui.scm ends here
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 2762ea078..df2cf12de 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -37,6 +37,7 @@ guix/scripts/container.scm
guix/scripts/container/exec.scm
guix/upstream.scm
guix/ui.scm
+guix/status.scm
guix/http-client.scm
guix/nar.scm
guix/channels.scm
diff --git a/tests/status.scm b/tests/status.scm
new file mode 100644
index 000000000..04dedb702
--- /dev/null
+++ b/tests/status.scm
@@ -0,0 +1,115 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-status)
+ #:use-module (guix status)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-64))
+
+(test-begin "status")
+
+(test-equal "compute-status, no-op"
+ (build-status)
+ (let-values (((port get-status)
+ (build-event-output-port compute-status)))
+ (display "foo\nbar\n\baz\n" port)
+ (get-status)))
+
+(test-equal "compute-status, builds + substitutes"
+ (list (build-status
+ (building '("foo.drv"))
+ (downloading (list (download "bar" "http://example.org/bar"
+ #:size 500
+ #:start 'now))))
+ (build-status
+ (building '("foo.drv"))
+ (downloading (list (download "bar" "http://example.org/bar"
+ #:size 500
+ #:transferred 42
+ #:start 'now))))
+ (build-status
+ (builds-completed '("foo.drv"))
+ (downloads-completed (list (download "bar" "http://example.org/bar"
+ #:size 500
+ #:transferred 500
+ #:start 'now
+ #:end 'now)))))
+ (let-values (((port get-status)
+ (build-event-output-port (lambda (event status)
+ (compute-status event status
+ #:current-time
+ (const 'now))))))
+ (display "@ build-started foo.drv\n" port)
+ (display "@ substituter-started bar\n" port)
+ (display "@ download-started bar http://example.org/bar 500\n" port)
+ (display "various\nthings\nget\nwritten\n" port)
+ (let ((first (get-status)))
+ (display "@ download-progress bar http://example.org/bar 500 42\n"
+ port)
+ (let ((second (get-status)))
+ (display "@ download-progress bar http://example.org/bar 500 84\n"
+ port)
+ (display "@ build-succeeded foo.drv\n" port)
+ (display "@ download-succeeded bar http://example.org/bar 500\n" port)
+ (display "Almost done!\n" port)
+ (display "@ substituter-succeeded bar\n" port)
+ (list first second (get-status))))))
+
+(test-equal "compute-status, missing events"
+ (list (build-status
+ (building '("foo.drv"))
+ (downloading (list (download "baz" "http://example.org/baz"
+ #:size 500
+ #:transferred 42
+ #:start 'now)
+ (download "bar" "http://example.org/bar"
+ #:size 999
+ #:transferred 0
+ #:start 'now))))
+ (build-status
+ (builds-completed '("foo.drv"))
+ (downloads-completed (list (download "baz" "http://example.org/baz"
+ #:size 500
+ #:transferred 500
+ #:start 'now
+ #:end 'now)
+ (download "bar" "http://example.org/bar"
+ #:size 999
+ #:transferred 999
+ #:start 'now
+ #:end 'now)))))
+ ;; Below we omit 'substituter-started' events and the like.
+ (let-values (((port get-status)
+ (build-event-output-port (lambda (event status)
+ (compute-status event status
+ #:current-time
+ (const 'now))))))
+ (display "@ build-started foo.drv\n" port)
+ (display "@ download-started bar http://example.org/bar 999\n" port)
+ (display "various\nthings\nget\nwritten\n" port)
+ (display "@ download-progress baz http://example.org/baz 500 42\n"
+ port)
+ (let ((first (get-status)))
+ (display "@ build-succeeded foo.drv\n" port)
+ (display "@ download-succeeded bar http://example.org/bar 999\n" port)
+ (display "Almost done!\n" port)
+ (display "@ substituter-succeeded baz\n" port)
+ (list first (get-status)))))
+
+(test-end "status")
--
2.19.0
^ permalink raw reply related [flat|nested] 12+ messages in thread* [bug#32837] [PATCH 5/5] perform-download: Optionally report a "download-progress" trace.
2018-09-25 15:32 ` [bug#32837] [PATCH 1/5] progress: 'progress-reporter-report!' takes any number of arguments Ludovic Courtès
` (2 preceding siblings ...)
2018-09-25 15:32 ` [bug#32837] [PATCH 4/5] Add (guix status) and use it for pretty colored output Ludovic Courtès
@ 2018-09-25 15:32 ` Ludovic Courtès
2018-09-26 7:58 ` [bug#32837] [PATCH 1/5] progress: 'progress-reporter-report!' takes any number of arguments Danny Milosavljevic
4 siblings, 0 replies; 12+ messages in thread
From: Ludovic Courtès @ 2018-09-25 15:32 UTC (permalink / raw)
To: 32837; +Cc: Ricardo Wurmus
* 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.
---
guix/build/download.scm | 31 +++++++++++++++++++++----------
guix/scripts/perform-download.scm | 18 +++++++++++++-----
nix/libstore/builtins.cc | 5 ++++-
3 files changed, 38 insertions(+), 16 deletions(-)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 315a3554e..54163849a 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))))
+ #: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)
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 9f6ecc00d..df787a994 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 a5ebb4773..1f52511c8 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. */
--
2.19.0
^ permalink raw reply related [flat|nested] 12+ messages in thread