diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | guix/progress.scm | 38 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 13 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 116 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 142 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 25 | ||||
| -rw-r--r-- | guix/scripts/perform-download.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 66 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 42 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 11 | ||||
| -rw-r--r-- | guix/status.scm | 493 | ||||
| -rw-r--r-- | guix/store.scm | 53 | ||||
| -rw-r--r-- | guix/ui.scm | 122 | ||||
| -rw-r--r-- | nix/libstore/build.cc | 27 | ||||
| -rw-r--r-- | nix/libstore/worker-protocol.hh | 2 | ||||
| -rw-r--r-- | po/guix/POTFILES.in | 1 | ||||
| -rw-r--r-- | tests/status.scm | 115 |
18 files changed, 939 insertions, 331 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index eb99a5bcc1..793117c0ae 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 5c8639d665..7fd29b90a8 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 d4ebb32991..3b9ff408cd 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 @@ -220,6 +223,10 @@ throughput." log-port) (force-output log-port)))) +(define %progress-interval + ;; Default interval between subsequent outputs for rate-limited displays. + (make-time time-monotonic 200000000 0)) + (define* (progress-reporter/file file size #:optional (log-port (current-output-port)) #:key (abbreviation basename)) @@ -238,8 +245,7 @@ ABBREVIATION used to shorten FILE for display." (start render) ;; Report the progress every 300ms or longer. (report - (let ((rate-limited-render - (rate-limited render (make-time time-monotonic 300000000 0)))) + (let ((rate-limited-render (rate-limited render %progress-interval))) (lambda (value) (set! transferred value) (rate-limited-render)))) @@ -279,6 +285,32 @@ 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 (rate-limited report-progress %progress-interval)) + (stop (lambda () + (report-progress size) + (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 9d38610633..5a6ba62bc3 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,11 +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 + (parameterize ((current-terminal-columns (terminal-columns)) + (current-build-output-port (if quiet? (%make-void-port "w") - (build-output-port #:verbose? #t - #:port (duplicate-port (current-error-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 1c04800e42..9fc7edcd36 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) - - ;; 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)) - - (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?))))))))))))) + (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))) + + ;; 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?)))))))))))))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 1916f3b9d7..163f5b1dc1 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) - - (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))))))) + (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)))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index c3ed2ac935..93a77915fe 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,15 +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? - #:port (duplicate-port (current-error-port) "w")))) - (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 18e2fc92f2..9f6ecc00d2 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/pull.scm b/guix/scripts/pull.scm index 39aebb18e2..803f7cf142 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -20,6 +20,7 @@ (define-module (guix scripts pull) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix status) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix config) @@ -61,6 +62,8 @@ `((system . ,(%current-system)) (substitutes? . #t) (build-hook? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) (graft? . #t) (verbosity . 0))) @@ -447,36 +450,37 @@ Use '~/.config/guix/channels.scm' instead.")) #t) ;XXX: not very useful (else (with-store store - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%repository-cache-directory cache)) - (set-build-options-from-command-line store opts) - (honor-x509-certificates store) - - (let ((instances (latest-channel-instances store channels))) - (format (current-error-port) - (N_ "Building from this channel:~%" - "Building from these channels:~%" - (length instances))) - (for-each (lambda (instance) - (let ((channel - (channel-instance-channel instance))) - (format (current-error-port) - " ~10a~a\t~a~%" - (channel-name channel) - (channel-url channel) - (string-take - (channel-instance-commit instance) - 7)))) - instances) - (parameterize ((%guile-for-build - (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (run-with-store store - (build-and-install instances profile - #:verbose? - (assoc-ref opts 'verbose?))))))))))))) + (with-status-report print-build-event + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%repository-cache-directory cache)) + (set-build-options-from-command-line store opts) + (honor-x509-certificates store) + + (let ((instances (latest-channel-instances store channels))) + (format (current-error-port) + (N_ "Building from this channel:~%" + "Building from these channels:~%" + (length instances))) + (for-each (lambda (instance) + (let ((channel + (channel-instance-channel instance))) + (format (current-error-port) + " ~10a~a\t~a~%" + (channel-name channel) + (channel-url channel) + (string-take + (channel-instance-commit instance) + 7)))) + instances) + (parameterize ((%guile-for-build + (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (run-with-store store + (build-and-install instances profile + #:verbose? + (assoc-ref opts 'verbose?)))))))))))))) ;;; pull.scm ends here diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 50c6a22064..eb82224016 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 1e7620f147..f9d6b9e5b6 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) @@ -1079,6 +1080,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") @@ -1253,9 +1256,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 0000000000..94d4748af5 --- /dev/null +++ b/guix/status.scm @@ -0,0 +1,493 @@ +;;; 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 build download) + #:select (nar-uri-abbreviation)) + #:use-module ((guix store) + #:select (current-build-output-port + current-store-protocol-version + 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: + + +;;; +;;; 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)))) + + +;;; +;;; Rendering. +;;; + +(define (extended-build-trace-supported?) + "Return true if the currently used store is known to support \"extended +build traces\" such as \"@ download-progress\" traces." + ;; Support for extended build traces was added in protocol version #x162. + (and (current-store-protocol-version) + (>= (current-store-protocol-version) #x162))) + +(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 (or print-log? (not (extended-build-trace-supported?))) + (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 + ;; XXX: It would be nice to memoize the abbreviation. + (let ((uri (if (string-contains uri "/nar/") + (nar-uri-abbreviation uri) + (basename uri)))) + (display-download-progress uri size + #:start-time + (download-start download) + #:transferred transferred)))))) + (('substituter-succeeded item _ ...) + ;; If there are no jobs running, we already reported download completion + ;; so there's nothing left to do. + (unless (and (zero? (simultaneous-jobs status)) + (extended-build-trace-supported?)) + (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)) + (('hash-mismatch item algo expected actual _ ...) + ;; TRANSLATORS: The final string looks like "sha256 hash mismatch for + ;; /gnu/store/…-sth:", where "sha256" is the hash algorithm. + (format port (failure (G_ "~a hash mismatch for ~a:")) algo item) + (newline port) + (format port (info (G_ "\ + expected hash: ~a + actual hash: ~a~%")) + expected actual)) + (('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 event and calls 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))) + + +;;; +;;; 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 f88cdefe87..7785a53aa1 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -50,9 +50,11 @@ %default-substitute-urls nix-server? + nix-server-version nix-server-major-version nix-server-minor-version nix-server-socket + current-store-protocol-version ;for internal use &nix-error nix-error? &nix-connection-error nix-connection-error? @@ -152,7 +154,7 @@ direct-store-path log-file)) -(define %protocol-version #x161) +(define %protocol-version #x162) (define %worker-magic-1 #x6e697863) ; "nixc" (define %worker-magic-2 #x6478696f) ; "dxio" @@ -161,6 +163,8 @@ (logand magic #xff00)) (define (protocol-minor magic) (logand magic #x00ff)) +(define (protocol-version major minor) + (logior major minor)) (define-syntax define-enumerate-type (syntax-rules () @@ -540,6 +544,11 @@ connection. Use with care." (make-hash-table 100) (make-hash-table 100)))) +(define (nix-server-version store) + "Return the protocol version of STORE as an integer." + (protocol-version (nix-server-major-version store) + (nix-server-minor-version store))) + (define (write-buffered-output server) "Flush SERVER's output port." (force-output (nix-server-output-port server)) @@ -556,10 +565,20 @@ automatically close the store when the dynamic extent of EXP is left." (dynamic-wind (const #f) (lambda () - exp ...) + (parameterize ((current-store-protocol-version + (nix-server-version store))) + exp) ...) (lambda () (false-if-exception (close-connection store)))))) +(define current-store-protocol-version + ;; Protocol version of the store currently used. XXX: This is a hack to + ;; communicate the protocol version to the build output port. It's a hack + ;; because it could be inaccurrate, for instance if there's code that + ;; manipulates several store connections at once; it works well for the + ;; purposes of (guix status) though. + (make-parameter #f)) + (define current-build-output-port ;; The port where build output is sent. (make-parameter (current-error-port))) @@ -682,6 +701,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 +751,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 @@ -1064,13 +1095,15 @@ an arbitrary directory layout in the store without creating a derivation." outputs, and return when the worker is done building them. Elements of THINGS that are not derivations can only be substituted and not built locally. Return #t on success." - (if (>= (nix-server-minor-version store) 15) - (build store things mode) - (if (= mode (build-mode normal)) - (build/old store things) - (raise (condition (&nix-protocol-error - (message "unsupported build mode") - (status 1))))))))) + (parameterize ((current-store-protocol-version + (nix-server-version store))) + (if (>= (nix-server-minor-version store) 15) + (build store things mode) + (if (= mode (build-mode normal)) + (build/old store things) + (raise (condition (&nix-protocol-error + (message "unsupported build mode") + (status 1)))))))))) (define-operation (add-temp-root (store-path path)) "Make PATH a temporary root for the duration of the current session. diff --git a/guix/ui.scm b/guix/ui.scm index c55ae7e2f8..96f403acf5 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -119,7 +119,7 @@ warning info guix-main - build-output-port)) + colorize-string)) ;;; Commentary: ;;; @@ -1676,124 +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"))) - ,(if verbose? - ;; Err on the side of caution: show everything, even - ;; if it might be redundant. - `("^(@ build-failed)(.+)" - #:transform - ,(lambda (m) - (string-append - (proc "Build failed: " 'RED 'BOLD) - (match:substring m 2)))) - ;; Show only that the build failed. - `("^(@ build-failed)(.+) -.*" - #:transform - ,(lambda (m) - (string-append - (proc "Build failed: " 'RED 'BOLD) - (match:substring m 2) - "\n")))) - ;; NOTE: this line contains "\n" characters. - ("^(sha256 hash mismatch for output path)(.*)" - RED BLACK) - ("^(@ 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/nix/libstore/build.cc b/nix/libstore/build.cc index c7f32494d0..b2c319f00b 100644 --- a/nix/libstore/build.cc +++ b/nix/libstore/build.cc @@ -2466,13 +2466,13 @@ void DerivationGoal::registerOutputs() /* Check the hash. */ Hash h2 = recursive ? hashPath(ht, actualPath).first : hashFile(ht, actualPath); - if (h != h2) - throw BuildError( - format("%1% hash mismatch for output path `%2%'\n" - " expected: %3%\n" - " actual: %4%") - % i->second.hashAlgo % path - % printHash16or32(h) % printHash16or32(h2)); + if (h != h2) { + if (settings.printBuildTrace) + printMsg(lvlError, format("@ hash-mismatch %1% %2% %3% %4%") + % path % i->second.hashAlgo + % printHash16or32(h) % printHash16or32(h2)); + throw BuildError(format("hash mismatch for store item '%1%'") % path); + } } /* Get rid of all weird permissions. This also checks that @@ -3157,11 +3157,14 @@ void SubstitutionGoal::finished() throw Error(format("unknown hash algorithm in `%1%'") % expectedHashStr); Hash expectedHash = parseHash16or32(hashType, string(expectedHashStr, n + 1)); Hash actualHash = hashType == htSHA256 ? hash.first : hashPath(hashType, destPath).first; - if (expectedHash != actualHash) - throw SubstError(format("hash mismatch in downloaded path `%1%'\n" - " expected: %2%\n" - " actual: %3%") - % storePath % printHash(expectedHash) % printHash(actualHash)); + if (expectedHash != actualHash) { + if (settings.printBuildTrace) + printMsg(lvlError, format("@ hash-mismatch %1% %2% %3% %4%") + % storePath % "sha256" + % printHash16or32(expectedHash) + % printHash16or32(actualHash)); + throw SubstError(format("hash mismatch for substituted item `%1%'") % storePath); + } } } catch (SubstError & e) { diff --git a/nix/libstore/worker-protocol.hh b/nix/libstore/worker-protocol.hh index efe9eadf23..103d60a8c2 100644 --- a/nix/libstore/worker-protocol.hh +++ b/nix/libstore/worker-protocol.hh @@ -6,7 +6,7 @@ namespace nix { #define WORKER_MAGIC_1 0x6e697863 #define WORKER_MAGIC_2 0x6478696f -#define PROTOCOL_VERSION 0x161 +#define PROTOCOL_VERSION 0x162 #define GET_PROTOCOL_MAJOR(x) ((x) & 0xff00) #define GET_PROTOCOL_MINOR(x) ((x) & 0x00ff) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 2762ea078a..df2cf12de2 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 0000000000..04dedb702c --- /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") |