me
/
guix
Archived
1
0
Fork 0
Code

Add (guix status) and use it for pretty colored output. 

* guix/progress.scm (progress-reporter/trace): New procedure.
(%progress-interval): New variable.
(progress-reporter/file): Use it.
* 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/pull.scm (%default-options, guix-pull): 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.
(%protocol-version): Bump.
(protocol-version, nix-server-version): New procedures.
(current-store-protocol-version): New variable.
(with-store, build-things): Parameterize it.
* 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.
* nix/libstore/worker-protocol.hh (PROTOCOL_VERSION): Bump to 0x162.
* nix/libstore/build.cc (DerivationGoal::registerOutputs)
(SubstitutionGoal::finished): Print a "@ hash-mismatch" trace before
throwing.
master
Ludovic Courtès 2017-01-18 23:21:29 +01:00
parent fe65b559a6
commit dc0f74e5fc
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
18 changed files with 934 additions and 326 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.dir-locals.el
View File

@ -59,6 +59,7 @@
(eval . (put 'emacs-substitute-variables 'scheme-indent-function 1)) (eval . (put 'emacs-substitute-variables 'scheme-indent-function 1))
(eval . (put 'with-derivation-narinfo '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-derivation-substitute 'scheme-indent-function 2))
(eval . (put 'with-status-report 'scheme-indent-function 1))
(eval . (put 'mlambda 'scheme-indent-function 1)) (eval . (put 'mlambda 'scheme-indent-function 1))
(eval . (put 'mlambdaq 'scheme-indent-function 1)) (eval . (put 'mlambdaq 'scheme-indent-function 1))

2
Makefile.am
View File

@ -131,6 +131,7 @@ MODULES = \
guix/svn-download.scm \ guix/svn-download.scm \
guix/i18n.scm \ guix/i18n.scm \
guix/ui.scm \ guix/ui.scm \
guix/status.scm \
guix/build/android-ndk-build-system.scm \ guix/build/android-ndk-build-system.scm \
guix/build/ant-build-system.scm \ guix/build/ant-build-system.scm \
guix/build/download.scm \ guix/build/download.scm \
@ -340,6 +341,7 @@ SCM_TESTS = \
tests/glob.scm \ tests/glob.scm \
tests/grafts.scm \ tests/grafts.scm \
tests/ui.scm \ tests/ui.scm \
tests/status.scm \
tests/records.scm \ tests/records.scm \
tests/upstream.scm \ tests/upstream.scm \
tests/combinators.scm \ tests/combinators.scm \

38
guix/progress.scm
View File

@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2015 Steve Sprang <scs@stevesprang.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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -38,8 +38,11 @@
progress-reporter/silent progress-reporter/silent
progress-reporter/file progress-reporter/file
progress-reporter/bar progress-reporter/bar
progress-reporter/trace
display-download-progress display-download-progress
erase-current-line
progress-bar
byte-count->string byte-count->string
current-terminal-columns current-terminal-columns
@ -220,6 +223,10 @@ throughput."
log-port) log-port)
(force-output 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 (define* (progress-reporter/file file size
#:optional (log-port (current-output-port)) #:optional (log-port (current-output-port))
#:key (abbreviation basename)) #:key (abbreviation basename))
@ -238,8 +245,7 @@ ABBREVIATION used to shorten FILE for display."
(start render) (start render)
;; Report the progress every 300ms or longer. ;; Report the progress every 300ms or longer.
(report (report
(let ((rate-limited-render (let ((rate-limited-render (rate-limited render %progress-interval)))
(rate-limited render (make-time time-monotonic 300000000 0))))
(lambda (value) (lambda (value)
(set! transferred value) (set! transferred value)
(rate-limited-render)))) (rate-limited-render))))
@ -279,6 +285,32 @@ tasks is performed. Write PREFIX at the beginning of the line."
(newline port)) (newline port))
(force-output 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))'. ;; TODO: replace '(@ (guix build utils) dump-port))'.
(define* (dump-port* in out (define* (dump-port* in out
#:key (buffer-size 16384) #:key (buffer-size 16384)

13
guix/scripts/build.scm
View File

@ -45,6 +45,9 @@
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:autoload (gnu packages) (specification->package %package-module-path) #:autoload (gnu packages) (specification->package %package-module-path)
#:autoload (guix download) (download-to-store) #: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 #:export (%standard-build-options
set-build-options-from-command-line set-build-options-from-command-line
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) #:max-silent-time (assoc-ref opts 'max-silent-time)
#:timeout (assoc-ref opts 'timeout) #:timeout (assoc-ref opts 'timeout)
#:print-build-trace (assoc-ref opts 'print-build-trace?) #: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))) #:verbosity (assoc-ref opts 'verbosity)))
(define set-build-options-from-command-line* (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) (substitutes? . #t)
(build-hook? . #t) (build-hook? . #t)
(print-build-trace? . #t) (print-build-trace? . #t)
(print-extended-build-trace? . #t)
(verbosity . 0))) (verbosity . 0)))
(define (show-help) (define (show-help)
@ -733,11 +739,12 @@ needed."
;; Set the build options before we do anything else. ;; Set the build options before we do anything else.
(set-build-options-from-command-line store opts) (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? (if quiet?
(%make-void-port "w") (%make-void-port "w")
(build-output-port #:verbose? #t (build-event-output-port
#:port (duplicate-port (current-error-port) "w"))))) (build-status-updater print-build-event)))))
(let* ((mode (assoc-ref opts 'build-mode)) (let* ((mode (assoc-ref opts 'build-mode))
(drv (options->derivations store opts)) (drv (options->derivations store opts))
(urls (map (cut string-append <> "/log") (urls (map (cut string-append <> "/log")

110
guix/scripts/environment.scm
View File

@ -21,6 +21,7 @@
(define-module (guix scripts environment) (define-module (guix scripts environment)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix status)
#:use-module (guix grafts) #:use-module (guix grafts)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages) #:use-module (guix packages)
@ -173,6 +174,8 @@ COMMAND or an interactive shell in that environment.\n"))
(substitutes? . #t) (substitutes? . #t)
(build-hook? . #t) (build-hook? . #t)
(graft? . #t) (graft? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(verbosity . 0))) (verbosity . 0)))
(define (tag-package-arg opts arg) (define (tag-package-arg opts arg)
@ -661,59 +664,60 @@ message if any test fails."
(leave (G_ "'--user' cannot be used without '--container'~%"))) (leave (G_ "'--user' cannot be used without '--container'~%")))
(with-store store (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. ;; Use the bootstrap Guile when requested.
(parameterize ((%graft? (assoc-ref opts 'graft?)) (parameterize ((%graft? (assoc-ref opts 'graft?))
(%guile-for-build (%guile-for-build
(package-derivation (package-derivation
store store
(if bootstrap? (if bootstrap?
%bootstrap-guile %bootstrap-guile
(canonical-package guile-2.2))))) (canonical-package guile-2.2)))))
(run-with-store store (run-with-store store
;; Containers need a Bourne shell at /bin/sh. ;; Containers need a Bourne shell at /bin/sh.
(mlet* %store-monad ((bash (environment-bash container? (mlet* %store-monad ((bash (environment-bash container?
bootstrap? bootstrap?
system)) system))
(prof-drv (manifest->derivation (prof-drv (manifest->derivation
manifest system bootstrap?)) manifest system bootstrap?))
(profile -> (derivation->output-path prof-drv)) (profile -> (derivation->output-path prof-drv))
(gc-root -> (assoc-ref opts 'gc-root))) (gc-root -> (assoc-ref opts 'gc-root)))
;; First build the inputs. This is necessary even for ;; First build the inputs. This is necessary even for
;; --search-paths. Additionally, we might need to build bash for ;; --search-paths. Additionally, we might need to build bash for
;; a container. ;; a container.
(mbegin %store-monad (mbegin %store-monad
(build-environment (if (derivation? bash) (build-environment (if (derivation? bash)
(list prof-drv bash) (list prof-drv bash)
(list prof-drv)) (list prof-drv))
opts) opts)
(mwhen gc-root (mwhen gc-root
(register-gc-root profile gc-root)) (register-gc-root profile gc-root))
(cond (cond
((assoc-ref opts 'dry-run?) ((assoc-ref opts 'dry-run?)
(return #t)) (return #t))
((assoc-ref opts 'search-paths) ((assoc-ref opts 'search-paths)
(show-search-paths profile manifest #:pure? pure?) (show-search-paths profile manifest #:pure? pure?)
(return #t)) (return #t))
(container? (container?
(let ((bash-binary (let ((bash-binary
(if bootstrap? (if bootstrap?
bash bash
(string-append (derivation->output-path bash) (string-append (derivation->output-path bash)
"/bin/sh")))) "/bin/sh"))))
(launch-environment/container #:command command (launch-environment/container #:command command
#:bash bash-binary #:bash bash-binary
#:user user #:user user
#:user-mappings mappings #:user-mappings mappings
#:profile profile #:profile profile
#:manifest manifest #:manifest manifest
#:link-profile? link-prof? #:link-profile? link-prof?
#:network? network?))) #:network? network?)))
(else (else
(return (return
(exit/status (exit/status
(launch-environment/fork command profile manifest (launch-environment/fork command profile manifest
#:pure? pure?))))))))))))) #:pure? pure?))))))))))))))

140
guix/scripts/pack.scm
View File

@ -25,6 +25,7 @@
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix status)
#:use-module (guix grafts) #:use-module (guix grafts)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix modules) #:use-module (guix modules)
@ -538,6 +539,8 @@ please email '~a'~%")
(substitutes? . #t) (substitutes? . #t)
(build-hook? . #t) (build-hook? . #t)
(graft? . #t) (graft? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(verbosity . 0) (verbosity . 0)
(symlinks . ()) (symlinks . ())
(compressor . ,(first %compressors)))) (compressor . ,(first %compressors))))
@ -684,72 +687,73 @@ Create a bundle of PACKAGE.\n"))
(with-error-handling (with-error-handling
(with-store store (with-store store
;; Set the build options before we do anything else. (with-status-report print-build-event
(set-build-options-from-command-line store opts) ;; Set the build options before we do anything else.
(set-build-options-from-command-line store opts)
(parameterize ((%graft? (assoc-ref opts 'graft?)) (parameterize ((%graft? (assoc-ref opts 'graft?))
(%guile-for-build (package-derivation (%guile-for-build (package-derivation
store store
(if (assoc-ref opts 'bootstrap?) (if (assoc-ref opts 'bootstrap?)
%bootstrap-guile %bootstrap-guile
(canonical-package guile-2.2)) (canonical-package guile-2.2))
(assoc-ref opts 'system) (assoc-ref opts 'system)
#:graft? (assoc-ref opts 'graft?)))) #:graft? (assoc-ref opts 'graft?))))
(let* ((dry-run? (assoc-ref opts 'dry-run?)) (let* ((dry-run? (assoc-ref opts 'dry-run?))
(relocatable? (assoc-ref opts 'relocatable?)) (relocatable? (assoc-ref opts 'relocatable?))
(manifest (let ((manifest (manifest-from-args store opts))) (manifest (let ((manifest (manifest-from-args store opts)))
;; Note: We cannot honor '--bootstrap' here because ;; Note: We cannot honor '--bootstrap' here because
;; 'glibc-bootstrap' lacks 'libc.a'. ;; 'glibc-bootstrap' lacks 'libc.a'.
(if relocatable? (if relocatable?
(map-manifest-entries wrapped-package manifest) (map-manifest-entries wrapped-package manifest)
manifest))) manifest)))
(pack-format (assoc-ref opts 'format)) (pack-format (assoc-ref opts 'format))
(name (string-append (symbol->string pack-format) (name (string-append (symbol->string pack-format)
"-pack")) "-pack"))
(target (assoc-ref opts 'target)) (target (assoc-ref opts 'target))
(bootstrap? (assoc-ref opts 'bootstrap?)) (bootstrap? (assoc-ref opts 'bootstrap?))
(compressor (if bootstrap? (compressor (if bootstrap?
bootstrap-xz bootstrap-xz
(assoc-ref opts 'compressor))) (assoc-ref opts 'compressor)))
(archiver (if (equal? pack-format 'squashfs) (archiver (if (equal? pack-format 'squashfs)
squashfs-tools-next squashfs-tools-next
(if bootstrap? (if bootstrap?
%bootstrap-coreutils&co %bootstrap-coreutils&co
tar))) tar)))
(symlinks (assoc-ref opts 'symlinks)) (symlinks (assoc-ref opts 'symlinks))
(build-image (match (assq-ref %formats pack-format) (build-image (match (assq-ref %formats pack-format)
((? procedure? proc) proc) ((? procedure? proc) proc)
(#f (#f
(leave (G_ "~a: unknown pack format~%") (leave (G_ "~a: unknown pack format~%")
pack-format)))) pack-format))))
(localstatedir? (assoc-ref opts 'localstatedir?))) (localstatedir? (assoc-ref opts 'localstatedir?)))
(run-with-store store (run-with-store store
(mlet* %store-monad ((profile (profile-derivation (mlet* %store-monad ((profile (profile-derivation
manifest manifest
#:relative-symlinks? relocatable? #:relative-symlinks? relocatable?
#:hooks (if bootstrap? #:hooks (if bootstrap?
'() '()
%default-profile-hooks) %default-profile-hooks)
#:locales? (not bootstrap?) #:locales? (not bootstrap?)
#:target target)) #:target target))
(drv (build-image name profile (drv (build-image name profile
#:target #:target
target target
#:compressor #:compressor
compressor compressor
#:symlinks #:symlinks
symlinks symlinks
#:localstatedir? #:localstatedir?
localstatedir? localstatedir?
#:archiver #:archiver
archiver))) archiver)))
(mbegin %store-monad (mbegin %store-monad
(show-what-to-build* (list drv) (show-what-to-build* (list drv)
#:use-substitutes? #:use-substitutes?
(assoc-ref opts 'substitutes?) (assoc-ref opts 'substitutes?)
#:dry-run? dry-run?) #:dry-run? dry-run?)
(munless dry-run? (munless dry-run?
(built-derivations (list drv)) (built-derivations (list drv))
(return (format #t "~a~%" (return (format #t "~a~%"
(derivation->output-path drv)))))) (derivation->output-path drv))))))
#:system (assoc-ref opts 'system))))))) #:system (assoc-ref opts 'system))))))))

25
guix/scripts/package.scm
View File

@ -24,6 +24,7 @@
(define-module (guix scripts package) (define-module (guix scripts package)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix status)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix grafts) #:use-module (guix grafts)
#:use-module (guix derivations) #:use-module (guix derivations)
@ -330,7 +331,8 @@ ENTRIES, a list of manifest entries, in the context of PROFILE."
(graft? . #t) (graft? . #t)
(substitutes? . #t) (substitutes? . #t)
(build-hook? . #t) (build-hook? . #t)
(print-build-trace? . #t))) (print-build-trace? . #t)
(print-extended-build-trace? . #t)))
(define (show-help) (define (show-help)
(display (G_ "Usage: guix package [OPTION]... (display (G_ "Usage: guix package [OPTION]...
@ -941,15 +943,12 @@ processed, #f otherwise."
(or (process-query opts) (or (process-query opts)
(parameterize ((%store (open-connection)) (parameterize ((%store (open-connection))
(%graft? (assoc-ref opts 'graft?))) (%graft? (assoc-ref opts 'graft?)))
(set-build-options-from-command-line (%store) opts) (with-status-report print-build-event/quiet
(set-build-options-from-command-line (%store) opts)
(parameterize ((%guile-for-build (parameterize ((%guile-for-build
(package-derivation (package-derivation
(%store) (%store)
(if (assoc-ref opts 'bootstrap?) (if (assoc-ref opts 'bootstrap?)
%bootstrap-guile %bootstrap-guile
(canonical-package guile-2.2)))) (canonical-package guile-2.2)))))
(current-build-output-port (process-actions (%store) opts)))))))
(build-output-port #:verbose? verbose?
#:port (duplicate-port (current-error-port) "w"))))
(process-actions (%store) opts))))))

1
guix/scripts/perform-download.scm
View File

@ -48,6 +48,7 @@ OUTPUT.
Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the 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 actual output is different from that when we're doing a 'bmCheck' or
'bmRepair' build." 'bmRepair' build."
;; TODO: Use 'trace-progress-proc' when possible.
(derivation-let drv ((url "url") (derivation-let drv ((url "url")
(output* "out") (output* "out")
(executable "executable") (executable "executable")

64
guix/scripts/pull.scm
View File

@ -20,6 +20,7 @@
(define-module (guix scripts pull) (define-module (guix scripts pull)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix status)
#:use-module (guix scripts) #:use-module (guix scripts)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix config) #:use-module (guix config)
@ -61,6 +62,8 @@
`((system . ,(%current-system)) `((system . ,(%current-system))
(substitutes? . #t) (substitutes? . #t)
(build-hook? . #t) (build-hook? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(graft? . #t) (graft? . #t)
(verbosity . 0))) (verbosity . 0)))
@ -447,36 +450,37 @@ Use '~/.config/guix/channels.scm' instead."))
#t) ;XXX: not very useful #t) ;XXX: not very useful
(else (else
(with-store store (with-store store
(parameterize ((%graft? (assoc-ref opts 'graft?)) (with-status-report print-build-event
(%repository-cache-directory cache)) (parameterize ((%graft? (assoc-ref opts 'graft?))
(set-build-options-from-command-line store opts) (%repository-cache-directory cache))
(honor-x509-certificates store) (set-build-options-from-command-line store opts)
(honor-x509-certificates store)
(let ((instances (latest-channel-instances store channels))) (let ((instances (latest-channel-instances store channels)))
(format (current-error-port) (format (current-error-port)
(N_ "Building from this channel:~%" (N_ "Building from this channel:~%"
"Building from these channels:~%" "Building from these channels:~%"
(length instances))) (length instances)))
(for-each (lambda (instance) (for-each (lambda (instance)
(let ((channel (let ((channel
(channel-instance-channel instance))) (channel-instance-channel instance)))
(format (current-error-port) (format (current-error-port)
" ~10a~a\t~a~%" " ~10a~a\t~a~%"
(channel-name channel) (channel-name channel)
(channel-url channel) (channel-url channel)
(string-take (string-take
(channel-instance-commit instance) (channel-instance-commit instance)
7)))) 7))))
instances) instances)
(parameterize ((%guile-for-build (parameterize ((%guile-for-build
(package-derivation (package-derivation
store store
(if (assoc-ref opts 'bootstrap?) (if (assoc-ref opts 'bootstrap?)
%bootstrap-guile %bootstrap-guile
(canonical-package guile-2.2))))) (canonical-package guile-2.2)))))
(run-with-store store (run-with-store store
(build-and-install instances profile (build-and-install instances profile
#:verbose? #:verbose?
(assoc-ref opts 'verbose?))))))))))))) (assoc-ref opts 'verbose?))))))))))))))
;;; pull.scm ends here ;;; pull.scm ends here

42
guix/scripts/substitute.scm
View File

@ -837,7 +837,16 @@ REPORTER, which should be a <progress-reporter> object."
(make-custom-binary-input-port "progress-port-proc" (make-custom-binary-input-port "progress-port-proc"
read! #f #f read! #f #f
(lambda () (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))))))) (close-port port)))))))
(define-syntax with-networking (define-syntax with-networking
@ -930,7 +939,7 @@ authorized substitutes."
(error "unknown `--query' command" wtf)))) (error "unknown `--query' command" wtf))))
(define* (process-substitution store-item destination (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 "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
DESTINATION as a nar file. Verify the substitute against ACL." DESTINATION as a nar file. Verify the substitute against ACL."
(let* ((narinfo (lookup-narinfo cache-urls store-item (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. ;; Tell the daemon what the expected hash of the Nar itself is.
(format #t "~a~%" (narinfo-hash narinfo)) (format #t "~a~%" (narinfo-hash narinfo))
(format (current-error-port) (unless print-build-trace?
(G_ "Downloading ~a...~%") (uri->string uri)) (format (current-error-port)
(G_ "Downloading ~a...~%") (uri->string uri)))
(let*-values (((raw download-size) (let*-values (((raw download-size)
;; Note that Hydra currently generates Nars on the fly ;; Note that Hydra currently generates Nars on the fly
;; and doesn't specify a Content-Length, so ;; 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 (dl-size (or download-size
(and (equal? comp "none") (and (equal? comp "none")
(narinfo-size narinfo)))) (narinfo-size narinfo))))
(reporter (progress-reporter/file (reporter (if print-build-trace?
(uri->string uri) dl-size (progress-reporter/trace
(current-error-port) destination
#:abbreviation nar-uri-abbreviation))) (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))) (progress-report-port reporter raw)))
((input pids) ((input pids)
;; NOTE: This 'progress' port of current process will be ;; NOTE: This 'progress' port of current process will be
@ -1058,6 +1074,13 @@ default value."
(define (guix-substitute . args) (define (guix-substitute . args)
"Implement the build daemon's substituter protocol." "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) (mkdir-p %narinfo-cache-directory)
(maybe-remove-expired-cache-entries %narinfo-cache-directory (maybe-remove-expired-cache-entries %narinfo-cache-directory
cached-narinfo-files cached-narinfo-files
@ -1111,7 +1134,8 @@ default value."
(parameterize ((current-terminal-columns (client-terminal-columns))) (parameterize ((current-terminal-columns (client-terminal-columns)))
(process-substitution store-path destination (process-substitution store-path destination
#:cache-urls (substitute-urls) #:cache-urls (substitute-urls)
#:acl (current-acl)))) #:acl (current-acl)
#:print-build-trace? print-build-trace?)))
((or ("-V") ("--version")) ((or ("-V") ("--version"))
(show-version-and-exit "guix substitute")) (show-version-and-exit "guix substitute"))
(("--help") (("--help")

11
guix/scripts/system.scm
View File

@ -23,6 +23,7 @@
(define-module (guix scripts system) (define-module (guix scripts system)
#:use-module (guix config) #:use-module (guix config)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (guix status)
#:use-module (guix store) #:use-module (guix store)
#:autoload (guix store database) (register-path) #:autoload (guix store database) (register-path)
#:use-module (guix grafts) #:use-module (guix grafts)
@ -1079,6 +1080,8 @@ Some ACTIONS support additional ARGS.\n"))
`((system . ,(%current-system)) `((system . ,(%current-system))
(substitutes? . #t) (substitutes? . #t)
(build-hook? . #t) (build-hook? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(graft? . #t) (graft? . #t)
(verbosity . 0) (verbosity . 0)
(file-system-type . "ext4") (file-system-type . "ext4")
@ -1253,9 +1256,11 @@ argument list and OPTS is the option alist."
parse-sub-command)) parse-sub-command))
(args (option-arguments opts)) (args (option-arguments opts))
(command (assoc-ref opts 'action))) (command (assoc-ref opts 'action)))
(parameterize ((%graft? (assoc-ref opts 'graft?)) (parameterize ((%graft? (assoc-ref opts 'graft?)))
(current-terminal-columns (terminal-columns))) (with-status-report (if (memq command '(init reconfigure))
(process-command command args opts))))) print-build-event/quiet
print-build-event)
(process-command command args opts))))))
;;; Local Variables: ;;; Local Variables:
;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1) ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)

493
guix/status.scm 100644
View File

@ -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 ...)))

53
guix/store.scm
View File

@ -50,9 +50,11 @@
%default-substitute-urls %default-substitute-urls
nix-server? nix-server?
nix-server-version
nix-server-major-version nix-server-major-version
nix-server-minor-version nix-server-minor-version
nix-server-socket nix-server-socket
current-store-protocol-version ;for internal use
&nix-error nix-error? &nix-error nix-error?
&nix-connection-error nix-connection-error? &nix-connection-error nix-connection-error?
@ -152,7 +154,7 @@
direct-store-path direct-store-path
log-file)) log-file))
(define %protocol-version #x161) (define %protocol-version #x162)
(define %worker-magic-1 #x6e697863) ; "nixc" (define %worker-magic-1 #x6e697863) ; "nixc"
(define %worker-magic-2 #x6478696f) ; "dxio" (define %worker-magic-2 #x6478696f) ; "dxio"
@ -161,6 +163,8 @@
(logand magic #xff00)) (logand magic #xff00))
(define (protocol-minor magic) (define (protocol-minor magic)
(logand magic #x00ff)) (logand magic #x00ff))
(define (protocol-version major minor)
(logior major minor))
(define-syntax define-enumerate-type (define-syntax define-enumerate-type
(syntax-rules () (syntax-rules ()
@ -540,6 +544,11 @@ connection. Use with care."
(make-hash-table 100) (make-hash-table 100)
(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) (define (write-buffered-output server)
"Flush SERVER's output port." "Flush SERVER's output port."
(force-output (nix-server-output-port server)) (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 (dynamic-wind
(const #f) (const #f)
(lambda () (lambda ()
exp ...) (parameterize ((current-store-protocol-version
(nix-server-version store)))
exp) ...)
(lambda () (lambda ()
(false-if-exception (close-connection store)))))) (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 (define current-build-output-port
;; The port where build output is sent. ;; The port where build output is sent.
(make-parameter (current-error-port))) (make-parameter (current-error-port)))
@ -682,6 +701,13 @@ encoding conversion errors."
(build-verbosity 0) (build-verbosity 0)
(log-type 0) (log-type 0)
(print-build-trace #t) (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 build-cores
(use-substitutes? #t) (use-substitutes? #t)
@ -725,7 +751,12 @@ encoding conversion errors."
(when (>= (nix-server-minor-version server) 10) (when (>= (nix-server-minor-version server) 10)
(send (boolean use-substitutes?))) (send (boolean use-substitutes?)))
(when (>= (nix-server-minor-version server) 12) (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))) `(("build-timeout" . ,(number->string timeout)))
'()) '())
,@(if max-silent-time ,@(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 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. that are not derivations can only be substituted and not built locally.
Return #t on success." Return #t on success."
(if (>= (nix-server-minor-version store) 15) (parameterize ((current-store-protocol-version
(build store things mode) (nix-server-version store)))
(if (= mode (build-mode normal)) (if (>= (nix-server-minor-version store) 15)
(build/old store things) (build store things mode)
(raise (condition (&nix-protocol-error (if (= mode (build-mode normal))
(message "unsupported build mode") (build/old store things)
(status 1))))))))) (raise (condition (&nix-protocol-error
(message "unsupported build mode")
(status 1))))))))))
(define-operation (add-temp-root (store-path path)) (define-operation (add-temp-root (store-path path))
"Make PATH a temporary root for the duration of the current session. "Make PATH a temporary root for the duration of the current session.

122
guix/ui.scm
View File

@ -119,7 +119,7 @@
warning warning
info info
guix-main guix-main
build-output-port)) colorize-string))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -1676,124 +1676,4 @@ be reset such that subsequent output will not have any colors in effect."
str str
(color 'RESET))) (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 ;;; ui.scm ends here

27
nix/libstore/build.cc
View File

@ -2466,13 +2466,13 @@ void DerivationGoal::registerOutputs()
/* Check the hash. */ /* Check the hash. */
Hash h2 = recursive ? hashPath(ht, actualPath).first : hashFile(ht, actualPath); Hash h2 = recursive ? hashPath(ht, actualPath).first : hashFile(ht, actualPath);
if (h != h2) if (h != h2) {
throw BuildError( if (settings.printBuildTrace)
format("%1% hash mismatch for output path `%2%'\n" printMsg(lvlError, format("@ hash-mismatch %1% %2% %3% %4%")
" expected: %3%\n" % path % i->second.hashAlgo
" actual: %4%") % printHash16or32(h) % printHash16or32(h2));
% i->second.hashAlgo % path throw BuildError(format("hash mismatch for store item '%1%'") % path);
% printHash16or32(h) % printHash16or32(h2)); }
} }
/* Get rid of all weird permissions. This also checks that /* 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); throw Error(format("unknown hash algorithm in `%1%'") % expectedHashStr);
Hash expectedHash = parseHash16or32(hashType, string(expectedHashStr, n + 1)); Hash expectedHash = parseHash16or32(hashType, string(expectedHashStr, n + 1));
Hash actualHash = hashType == htSHA256 ? hash.first : hashPath(hashType, destPath).first; Hash actualHash = hashType == htSHA256 ? hash.first : hashPath(hashType, destPath).first;
if (expectedHash != actualHash) if (expectedHash != actualHash) {
throw SubstError(format("hash mismatch in downloaded path `%1%'\n" if (settings.printBuildTrace)
" expected: %2%\n" printMsg(lvlError, format("@ hash-mismatch %1% %2% %3% %4%")
" actual: %3%") % storePath % "sha256"
% storePath % printHash(expectedHash) % printHash(actualHash)); % printHash16or32(expectedHash)
% printHash16or32(actualHash));
throw SubstError(format("hash mismatch for substituted item `%1%'") % storePath);
}
} }
} catch (SubstError & e) { } catch (SubstError & e) {

2
nix/libstore/worker-protocol.hh
View File

@ -6,7 +6,7 @@ namespace nix {
#define WORKER_MAGIC_1 0x6e697863 #define WORKER_MAGIC_1 0x6e697863
#define WORKER_MAGIC_2 0x6478696f #define WORKER_MAGIC_2 0x6478696f
#define PROTOCOL_VERSION 0x161 #define PROTOCOL_VERSION 0x162
#define GET_PROTOCOL_MAJOR(x) ((x) & 0xff00) #define GET_PROTOCOL_MAJOR(x) ((x) & 0xff00)
#define GET_PROTOCOL_MINOR(x) ((x) & 0x00ff) #define GET_PROTOCOL_MINOR(x) ((x) & 0x00ff)

1
po/guix/POTFILES.in
View File

@ -37,6 +37,7 @@ guix/scripts/container.scm
guix/scripts/container/exec.scm guix/scripts/container/exec.scm
guix/upstream.scm guix/upstream.scm
guix/ui.scm guix/ui.scm
guix/status.scm
guix/http-client.scm guix/http-client.scm
guix/nar.scm guix/nar.scm
guix/channels.scm guix/channels.scm

115
tests/status.scm 100644
View File

@ -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")