ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
* 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.
This commit is contained in:
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 '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))

2
Makefile.am
View file

@ -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 \

38
guix/progress.scm
View file

@ -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 @@ (define-module (guix progress)
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 @@ (define elapsed
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 @@ (define (render)
(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 @@ (define (report-progress)
(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)

13
guix/scripts/build.scm
View file

@ -45,6 +45,9 @@ (define-module (guix scripts build)
#: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 @@ (define (set-build-options-from-command-line store opts)
#: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 @@ (define %default-options
(substitutes? . #t)
(build-hook? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(verbosity . 0)))
(define (show-help)
@ -733,11 +739,12 @@ (define quiet?
;; 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")

110
guix/scripts/environment.scm
View file

@ -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 @@ (define %default-options
(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 @@ (define (guix-environment . args)
(leave (G_ "'--user' cannot be used without '--container'~%")))
(with-store store
(set-build-options-from-command-line store opts)
(with-status-report print-build-event
(set-build-options-from-command-line store opts)
;; Use the bootstrap Guile when requested.
(parameterize ((%graft? (assoc-ref opts 'graft?))
(%guile-for-build
(package-derivation
store
(if bootstrap?
%bootstrap-guile
(canonical-package guile-2.2)))))
(run-with-store store
;; Containers need a Bourne shell at /bin/sh.
(mlet* %store-monad ((bash (environment-bash container?
bootstrap?
system))
(prof-drv (manifest->derivation
manifest system bootstrap?))
(profile -> (derivation->output-path prof-drv))
(gc-root -> (assoc-ref opts 'gc-root)))
;; Use the bootstrap Guile when requested.
(parameterize ((%graft? (assoc-ref opts 'graft?))
(%guile-for-build
(package-derivation
store
(if bootstrap?
%bootstrap-guile
(canonical-package guile-2.2)))))
(run-with-store store
;; Containers need a Bourne shell at /bin/sh.
(mlet* %store-monad ((bash (environment-bash container?
bootstrap?
system))
(prof-drv (manifest->derivation
manifest system bootstrap?))
(profile -> (derivation->output-path prof-drv))
(gc-root -> (assoc-ref opts 'gc-root)))
;; First build the inputs. This is necessary even for
;; --search-paths. Additionally, we might need to build bash for
;; a container.
(mbegin %store-monad
(build-environment (if (derivation? bash)
(list prof-drv bash)
(list prof-drv))
opts)
(mwhen gc-root
(register-gc-root profile gc-root))
;; First build the inputs. This is necessary even for
;; --search-paths. Additionally, we might need to build bash for
;; a container.
(mbegin %store-monad
(build-environment (if (derivation? bash)
(list prof-drv bash)
(list prof-drv))
opts)
(mwhen gc-root
(register-gc-root profile gc-root))
(cond
((assoc-ref opts 'dry-run?)
(return #t))
((assoc-ref opts 'search-paths)
(show-search-paths profile manifest #:pure? pure?)
(return #t))
(container?
(let ((bash-binary
(if bootstrap?
bash
(string-append (derivation->output-path bash)
"/bin/sh"))))
(launch-environment/container #:command command
#:bash bash-binary
#:user user
#:user-mappings mappings
#:profile profile
#:manifest manifest
#:link-profile? link-prof?
#:network? network?)))
(else
(return
(exit/status
(launch-environment/fork command profile manifest
#:pure? pure?)))))))))))))
(cond
((assoc-ref opts 'dry-run?)
(return #t))
((assoc-ref opts 'search-paths)
(show-search-paths profile manifest #:pure? pure?)
(return #t))
(container?
(let ((bash-binary
(if bootstrap?
bash
(string-append (derivation->output-path bash)
"/bin/sh"))))
(launch-environment/container #:command command
#:bash bash-binary
#:user user
#:user-mappings mappings
#:profile profile
#:manifest manifest
#:link-profile? link-prof?
#:network? network?)))
(else
(return
(exit/status
(launch-environment/fork command profile manifest
#:pure? pure?))))))))))))))

140
guix/scripts/pack.scm
View file

@ -25,6 +25,7 @@ (define-module (guix scripts pack)
#: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 @@ (define %default-options
(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 @@ (define (manifest-from-args store opts)
(with-error-handling
(with-store store
;; Set the build options before we do anything else.
(set-build-options-from-command-line store opts)
(with-status-report print-build-event
;; Set the build options before we do anything else.
(set-build-options-from-command-line store opts)
(parameterize ((%graft? (assoc-ref opts 'graft?))
(%guile-for-build (package-derivation
store
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
(canonical-package guile-2.2))
(assoc-ref opts 'system)
#:graft? (assoc-ref opts 'graft?))))
(let* ((dry-run? (assoc-ref opts 'dry-run?))
(relocatable? (assoc-ref opts 'relocatable?))
(manifest (let ((manifest (manifest-from-args store opts)))
;; Note: We cannot honor '--bootstrap' here because
;; 'glibc-bootstrap' lacks 'libc.a'.
(if relocatable?
(map-manifest-entries wrapped-package manifest)
manifest)))
(pack-format (assoc-ref opts 'format))
(name (string-append (symbol->string pack-format)
"-pack"))
(target (assoc-ref opts 'target))
(bootstrap? (assoc-ref opts 'bootstrap?))
(compressor (if bootstrap?
bootstrap-xz
(assoc-ref opts 'compressor)))
(archiver (if (equal? pack-format 'squashfs)
squashfs-tools-next
(if bootstrap?
%bootstrap-coreutils&co
tar)))
(symlinks (assoc-ref opts 'symlinks))
(build-image (match (assq-ref %formats pack-format)
((? procedure? proc) proc)
(#f
(leave (G_ "~a: unknown pack format~%")
pack-format))))
(localstatedir? (assoc-ref opts 'localstatedir?)))
(run-with-store store
(mlet* %store-monad ((profile (profile-derivation
manifest
#:relative-symlinks? relocatable?
#:hooks (if bootstrap?
'()
%default-profile-hooks)
#:locales? (not bootstrap?)
#:target target))
(drv (build-image name profile
#:target
target
#:compressor
compressor
#:symlinks
symlinks
#:localstatedir?
localstatedir?
#:archiver
archiver)))
(mbegin %store-monad
(show-what-to-build* (list drv)
#:use-substitutes?
(assoc-ref opts 'substitutes?)
#:dry-run? dry-run?)
(munless dry-run?
(built-derivations (list drv))
(return (format #t "~a~%"
(derivation->output-path drv))))))
#:system (assoc-ref opts 'system)))))))
(parameterize ((%graft? (assoc-ref opts 'graft?))
(%guile-for-build (package-derivation
store
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
(canonical-package guile-2.2))
(assoc-ref opts 'system)
#:graft? (assoc-ref opts 'graft?))))
(let* ((dry-run? (assoc-ref opts 'dry-run?))
(relocatable? (assoc-ref opts 'relocatable?))
(manifest (let ((manifest (manifest-from-args store opts)))
;; Note: We cannot honor '--bootstrap' here because
;; 'glibc-bootstrap' lacks 'libc.a'.
(if relocatable?
(map-manifest-entries wrapped-package manifest)
manifest)))
(pack-format (assoc-ref opts 'format))
(name (string-append (symbol->string pack-format)
"-pack"))
(target (assoc-ref opts 'target))
(bootstrap? (assoc-ref opts 'bootstrap?))
(compressor (if bootstrap?
bootstrap-xz
(assoc-ref opts 'compressor)))
(archiver (if (equal? pack-format 'squashfs)
squashfs-tools-next
(if bootstrap?
%bootstrap-coreutils&co
tar)))
(symlinks (assoc-ref opts 'symlinks))
(build-image (match (assq-ref %formats pack-format)
((? procedure? proc) proc)
(#f
(leave (G_ "~a: unknown pack format~%")
pack-format))))
(localstatedir? (assoc-ref opts 'localstatedir?)))
(run-with-store store
(mlet* %store-monad ((profile (profile-derivation
manifest
#:relative-symlinks? relocatable?
#:hooks (if bootstrap?
'()
%default-profile-hooks)
#:locales? (not bootstrap?)
#:target target))
(drv (build-image name profile
#:target
target
#:compressor
compressor
#:symlinks
symlinks
#:localstatedir?
localstatedir?
#:archiver
archiver)))
(mbegin %store-monad
(show-what-to-build* (list drv)
#:use-substitutes?
(assoc-ref opts 'substitutes?)
#:dry-run? dry-run?)
(munless dry-run?
(built-derivations (list drv))
(return (format #t "~a~%"
(derivation->output-path drv))))))
#:system (assoc-ref opts 'system))))))))

25
guix/scripts/package.scm
View file

@ -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 @@ (define %default-options
(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 @@ (define verbose?
(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)))))))

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

@ -48,6 +48,7 @@ (define* (perform-download drv #:optional 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")

64
guix/scripts/pull.scm
View file

@ -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 @@ (define %default-options
`((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 @@ (define (guix-pull . args)
#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)
(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?)))))))))))))
(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

42
guix/scripts/substitute.scm
View file

@ -837,7 +837,16 @@ (define (progress-report-port reporter port)
(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 @@ (define (valid? obj)
(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 @@ (define* (process-substitution store-item destination
;; 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 @@ (define* (process-substitution store-item destination
(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 @@ (define (validate-uri uri)
(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 @@ (define (guix-substitute . args)
(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")

11
guix/scripts/system.scm
View file

@ -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 @@ (define %default-options
`((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 @@ (define (fail)
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)

493
guix/status.scm Normal file
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 @@ (define-module (guix store)
%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 @@ (define-module (guix store)
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 @@ (define (protocol-major magic)
(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 @@ (define* (port->connection port
(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 @@ (define-syntax-rule (with-store store exp ...)
(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 @@ (define* (set-build-options server
(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 @@ (define socket
(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 @@ (define build-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.
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.

122
guix/ui.scm
View file

@ -119,7 +119,7 @@ (define-module (guix ui)
warning
info
guix-main
build-output-port))
colorize-string))
;;; Commentary:
;;;
@ -1676,124 +1676,4 @@ (define (colorize-string str . color-list)
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

27
nix/libstore/build.cc
View file

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

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

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

1
po/guix/POTFILES.in
View file

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

115
tests/status.scm Normal file
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")