summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2018-10-05 19:15:39 +0200
committerMarius Bakke <mbakke@fastmail.com>2018-10-05 19:15:39 +0200
commitcf6db76d2af2f287f12928df160447ab4165b3e5 (patch)
tree49a1309c0e04c00090ab106f7ae3495a6da328c1 /guix
parente65b2181e8b436278e3dd0b405602a400fbd0a75 (diff)
parenta6798218bea0d6b2df598042d1ced29f74bb4250 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/haskell.scm32
-rw-r--r--guix/build/download.scm33
-rw-r--r--guix/build/haskell-build-system.scm12
-rw-r--r--guix/build/lisp-utils.scm7
-rw-r--r--guix/import/stackage.scm11
-rw-r--r--guix/progress.scm110
-rw-r--r--guix/scripts/build.scm13
-rw-r--r--guix/scripts/environment.scm116
-rw-r--r--guix/scripts/pack.scm142
-rw-r--r--guix/scripts/package.scm25
-rw-r--r--guix/scripts/perform-download.scm17
-rw-r--r--guix/scripts/pull.scm66
-rwxr-xr-xguix/scripts/substitute.scm42
-rw-r--r--guix/scripts/system.scm36
-rw-r--r--guix/status.scm501
-rw-r--r--guix/store.scm81
-rw-r--r--guix/ui.scm122
17 files changed, 971 insertions, 395 deletions
diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm
index 1cb734631c..1ec11c71d8 100644
--- a/guix/build-system/haskell.scm
+++ b/guix/build-system/haskell.scm
@@ -21,6 +21,7 @@
#:use-module (guix utils)
#:use-module (guix packages)
#:use-module (guix derivations)
+ #:use-module (guix download)
#:use-module (guix search-paths)
#:use-module (guix build-system)
#:use-module (guix build-system gnu)
@@ -48,14 +49,35 @@
(let ((haskell (resolve-interface '(gnu packages haskell))))
(module-ref haskell 'ghc)))
+(define (source-url->revision-url url revision)
+ "Convert URL (a Hackage source URL) to the URL for the Cabal file at
+version REVISION."
+ (let* ((last-slash (string-rindex url #\/))
+ (next-slash (string-rindex url #\/ 0 last-slash)))
+ (string-append (substring url 0 next-slash)
+ (substring url last-slash (- (string-length url)
+ (string-length ".tar.gz")))
+ "/revision/" revision ".cabal")))
+
(define* (lower name
#:key source inputs native-inputs outputs system target
(haskell (default-haskell))
+ cabal-revision
#:allow-other-keys
#:rest arguments)
"Return a bag for NAME."
(define private-keywords
- '(#:target #:haskell #:inputs #:native-inputs))
+ '(#:target #:haskell #:cabal-revision #:inputs #:native-inputs))
+
+ (define (cabal-revision->origin cabal-revision)
+ (match cabal-revision
+ ((revision hash)
+ (origin
+ (method url-fetch)
+ (uri (source-url->revision-url (origin-uri source) revision))
+ (sha256 (base32 hash))
+ (file-name (string-append name "-" revision ".cabal"))))
+ (#f #f)))
(and (not target) ;XXX: no cross-compilation
(bag
@@ -64,6 +86,9 @@
(host-inputs `(,@(if source
`(("source" ,source))
'())
+ ,@(match (cabal-revision->origin cabal-revision)
+ (#f '())
+ (revision `(("cabal-revision" ,revision))))
,@inputs
;; Keep the standard inputs of 'gnu-build-system'.
@@ -103,6 +128,11 @@ provides a 'Setup.hs' file as its build system."
source)
(source
source))
+ #:cabal-revision ,(match (assoc-ref inputs
+ "cabal-revision")
+ (((? derivation? revision))
+ (derivation->output-path revision))
+ (revision revision))
#:configure-flags ,configure-flags
#:haddock-flags ,haddock-flags
#:system ,system
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 315a3554ec..54163849a2 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -115,7 +115,7 @@ and 'guix publish', something like
(string-drop path 33)
path)))
-(define* (ftp-fetch uri file #:key timeout)
+(define* (ftp-fetch uri file #:key timeout print-build-trace?)
"Fetch data from URI and write it to FILE. Return FILE on success. Bail
out if the connection could not be established in less than TIMEOUT seconds."
(let* ((conn (match (and=> (uri-userinfo uri)
@@ -136,12 +136,17 @@ out if the connection could not be established in less than TIMEOUT seconds."
(lambda (out)
(dump-port* in out
#:buffer-size %http-receive-buffer-size
- #:reporter (progress-reporter/file
- (uri-abbreviation uri) size))))
-
- (ftp-close conn))
- (newline)
- file)
+ #:reporter
+ (if print-build-trace?
+ (progress-reporter/trace
+ file (uri->string uri) size)
+ (progress-reporter/file
+ (uri-abbreviation uri) size)))))
+
+ (ftp-close conn)
+ (unless print-build-trace?
+ (newline))
+ file))
;; Autoload GnuTLS so that this module can be used even when GnuTLS is
;; not available. At compile time, this yields "possibly unbound
@@ -723,7 +728,8 @@ Return a list of URIs."
#:key
(timeout 10) (verify-certificate? #t)
(mirrors '()) (content-addressed-mirrors '())
- (hashes '()))
+ (hashes '())
+ print-build-trace?)
"Fetch FILE from URL; URL may be either a single string, or a list of
string denoting alternate URLs for FILE. Return #f on failure, and FILE
on success.
@@ -759,13 +765,18 @@ otherwise simply ignore them."
(lambda (output)
(dump-port* port output
#:buffer-size %http-receive-buffer-size
- #:reporter (progress-reporter/file
- (uri-abbreviation uri) size))
+ #:reporter (if print-build-trace?
+ (progress-reporter/trace
+ file (uri->string uri) size)
+ (progress-reporter/file
+ (uri-abbreviation uri) size)))
(newline)))
file)))
((ftp)
(false-if-exception* (ftp-fetch uri file
- #:timeout timeout)))
+ #:timeout timeout
+ #:print-build-trace?
+ print-build-trace?)))
(else
(format #t "skipping URI with unsupported scheme: ~s~%"
uri)
diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
index 5a72d22842..72714a29ad 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -28,6 +28,7 @@
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
+ #:use-module (ice-9 ftw)
#:export (%standard-phases
haskell-build))
@@ -266,8 +267,19 @@ given Haskell package."
(run-setuphs "haddock" haddock-flags))
#t)
+(define* (patch-cabal-file #:key cabal-revision #:allow-other-keys)
+ (when cabal-revision
+ ;; Cabal requires there to be a single file with the suffix ".cabal".
+ (match (scandir "." (cut string-suffix? ".cabal" <>))
+ ((original)
+ (format #t "replacing ~s with ~s~%" original cabal-revision)
+ (copy-file cabal-revision original))
+ (_ (error "Could not find a Cabal file to patch."))))
+ #t)
+
(define %standard-phases
(modify-phases gnu:%standard-phases
+ (add-after 'unpack 'patch-cabal-file patch-cabal-file)
(delete 'bootstrap)
(add-before 'configure 'setup-compiler setup-compiler)
(add-before 'install 'haddock haddock)
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 6470cfec97..97bc6197a3 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -84,11 +84,12 @@
(define (normalize-dependency dependency)
"Normalize the name of DEPENDENCY. Handles dependency definitions of the
dependency-def form described by
-<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>."
+<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>.
+Assume that any symbols in DEPENDENCY will be in upper-case."
(match dependency
- ((':version name rest ...)
+ ((':VERSION name rest ...)
`(:version ,(normalize-string name) ,@rest))
- ((':feature feature-specification dependency-specification)
+ ((':FEATURE feature-specification dependency-specification)
`(:feature
,feature-specification
,(normalize-dependency dependency-specification)))
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index afd5d997ae..1c1e73a723 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -43,15 +43,12 @@
(define (lts-info-ghc-version lts-info)
"Retruns the version of the GHC compiler contained in LTS-INFO."
- (match lts-info
- ((("snapshot" ("ghc" . version) _ _) _) version)
- (_ #f)))
+ (and=> (assoc-ref lts-info "snapshot")
+ (cut assoc-ref <> "ghc")))
(define (lts-info-packages lts-info)
- "Returns the alist of packages contained in LTS-INFO."
- (match lts-info
- ((("packages" pkg ...) . _) pkg)
- (_ '())))
+ "Retruns the alist of packages contained in LTS-INFO."
+ (or (assoc-ref lts-info "packages") '()))
(define (leave-with-message fmt . args)
(raise (condition (&message (message (apply format #f fmt args))))))
diff --git a/guix/progress.scm b/guix/progress.scm
index 53aea1c56d..f846944952 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -38,7 +38,11 @@
progress-reporter/silent
progress-reporter/file
progress-reporter/bar
+ progress-reporter/trace
+ display-download-progress
+ erase-current-line
+ progress-bar
byte-count->string
current-terminal-columns
@@ -183,6 +187,46 @@ width of the bar is BAR-WIDTH."
move the cursor to the beginning of the line."
(display "\r\x1b[K" port))
+(define* (display-download-progress file size
+ #:key
+ start-time (transferred 0)
+ (log-port (current-error-port)))
+ "Write the progress report to LOG-PORT. Use START-TIME (a SRFI-19 time
+object) and TRANSFERRED (a total number of bytes) to determine the
+throughput."
+ (define elapsed
+ (duration->seconds
+ (time-difference (current-time time-monotonic) start-time)))
+ (if (number? size)
+ (let* ((% (* 100.0 (/ transferred size)))
+ (throughput (/ transferred elapsed))
+ (left (format #f " ~a ~a" file
+ (byte-count->string size)))
+ (right (format #f "~a/s ~a ~a~6,1f%"
+ (byte-count->string throughput)
+ (seconds->string elapsed)
+ (progress-bar %) %)))
+ (erase-current-line log-port)
+ (display (string-pad-middle left right
+ (current-terminal-columns))
+ log-port)
+ (force-output log-port))
+ (let* ((throughput (/ transferred elapsed))
+ (left (format #f " ~a" file))
+ (right (format #f "~a/s ~a | ~a transferred"
+ (byte-count->string throughput)
+ (seconds->string elapsed)
+ (byte-count->string transferred))))
+ (erase-current-line log-port)
+ (display (string-pad-middle left right
+ (current-terminal-columns))
+ 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))
@@ -192,44 +236,16 @@ ABBREVIATION used to shorten FILE for display."
(let ((start-time (current-time time-monotonic))
(transferred 0))
(define (render)
- "Write the progress report to LOG-PORT."
- (define elapsed
- (duration->seconds
- (time-difference (current-time time-monotonic) start-time)))
- (if (number? size)
- (let* ((% (* 100.0 (/ transferred size)))
- (throughput (/ transferred elapsed))
- (left (format #f " ~a ~a"
- (abbreviation file)
- (byte-count->string size)))
- (right (format #f "~a/s ~a ~a~6,1f%"
- (byte-count->string throughput)
- (seconds->string elapsed)
- (progress-bar %) %)))
- (erase-current-line log-port)
- (display (string-pad-middle left right
- (current-terminal-columns))
- log-port)
- (force-output log-port))
- (let* ((throughput (/ transferred elapsed))
- (left (format #f " ~a"
- (abbreviation file)))
- (right (format #f "~a/s ~a | ~a transferred"
- (byte-count->string throughput)
- (seconds->string elapsed)
- (byte-count->string transferred))))
- (erase-current-line log-port)
- (display (string-pad-middle left right
- (current-terminal-columns))
- log-port)
- (force-output log-port))))
+ (display-download-progress (abbreviation file) size
+ #:start-time start-time
+ #:transferred transferred
+ #:log-port log-port))
(progress-reporter
(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))))
@@ -269,6 +285,32 @@ tasks is performed. Write PREFIX at the beginning of the line."
(newline port))
(force-output port)))))
+(define* (progress-reporter/trace file url size
+ #:optional (log-port (current-output-port)))
+ "Like 'progress-reporter/file', but instead of returning human-readable
+progress reports, write \"build trace\" lines to be processed elsewhere."
+ (define (report-progress transferred)
+ (define message
+ (format #f "@ download-progress ~a ~a ~a ~a~%"
+ file url (or size "-") transferred))
+
+ (display message log-port) ;should be atomic
+ (flush-output-port log-port))
+
+ (progress-reporter
+ (start (lambda ()
+ (display (format #f "@ download-started ~a ~a ~a~%"
+ file url (or size "-"))
+ log-port)))
+ (report (rate-limited report-progress %progress-interval))
+ (stop (lambda ()
+ (let ((size (or (and=> (stat file #f) stat:size)
+ size)))
+ (report-progress size)
+ (display (format #f "@ download-succeeded ~a ~a ~a~%"
+ file url size)
+ log-port))))))
+
;; TODO: replace '(@ (guix build utils) dump-port))'.
(define* (dump-port* in out
#:key (buffer-size 16384)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 9d38610633..5a6ba62bc3 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -45,6 +45,9 @@
#:use-module (srfi srfi-37)
#:autoload (gnu packages) (specification->package %package-module-path)
#:autoload (guix download) (download-to-store)
+ #:use-module (guix status)
+ #:use-module ((guix progress) #:select (current-terminal-columns))
+ #:use-module ((guix build syscalls) #:select (terminal-columns))
#:export (%standard-build-options
set-build-options-from-command-line
set-build-options-from-command-line*
@@ -390,6 +393,8 @@ options handled by 'set-build-options-from-command-line', and listed in
#:max-silent-time (assoc-ref opts 'max-silent-time)
#:timeout (assoc-ref opts 'timeout)
#:print-build-trace (assoc-ref opts 'print-build-trace?)
+ #:print-extended-build-trace?
+ (assoc-ref opts 'print-extended-build-trace?)
#:verbosity (assoc-ref opts 'verbosity)))
(define set-build-options-from-command-line*
@@ -499,6 +504,7 @@ options handled by 'set-build-options-from-command-line', and listed in
(substitutes? . #t)
(build-hook? . #t)
(print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
(verbosity . 0)))
(define (show-help)
@@ -733,11 +739,12 @@ needed."
;; Set the build options before we do anything else.
(set-build-options-from-command-line store opts)
- (parameterize ((current-build-output-port
+ (parameterize ((current-terminal-columns (terminal-columns))
+ (current-build-output-port
(if quiet?
(%make-void-port "w")
- (build-output-port #:verbose? #t
- #:port (duplicate-port (current-error-port) "w")))))
+ (build-event-output-port
+ (build-status-updater print-build-event)))))
(let* ((mode (assoc-ref opts 'build-mode))
(drv (options->derivations store opts))
(urls (map (cut string-append <> "/log")
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 1c04800e42..9fc7edcd36 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -21,6 +21,7 @@
(define-module (guix scripts environment)
#:use-module (guix ui)
#:use-module (guix store)
+ #:use-module (guix status)
#:use-module (guix grafts)
#:use-module (guix derivations)
#:use-module (guix packages)
@@ -173,6 +174,8 @@ COMMAND or an interactive shell in that environment.\n"))
(substitutes? . #t)
(build-hook? . #t)
(graft? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
(verbosity . 0)))
(define (tag-package-arg opts arg)
@@ -661,59 +664,60 @@ message if any test fails."
(leave (G_ "'--user' cannot be used without '--container'~%")))
(with-store store
- (set-build-options-from-command-line store opts)
-
- ;; Use the bootstrap Guile when requested.
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%guile-for-build
- (package-derivation
- store
- (if bootstrap?
- %bootstrap-guile
- (canonical-package guile-2.2)))))
- (run-with-store store
- ;; Containers need a Bourne shell at /bin/sh.
- (mlet* %store-monad ((bash (environment-bash container?
- bootstrap?
- system))
- (prof-drv (manifest->derivation
- manifest system bootstrap?))
- (profile -> (derivation->output-path prof-drv))
- (gc-root -> (assoc-ref opts 'gc-root)))
-
- ;; First build the inputs. This is necessary even for
- ;; --search-paths. Additionally, we might need to build bash for
- ;; a container.
- (mbegin %store-monad
- (build-environment (if (derivation? bash)
- (list prof-drv bash)
- (list prof-drv))
- opts)
- (mwhen gc-root
- (register-gc-root profile gc-root))
-
- (cond
- ((assoc-ref opts 'dry-run?)
- (return #t))
- ((assoc-ref opts 'search-paths)
- (show-search-paths profile manifest #:pure? pure?)
- (return #t))
- (container?
- (let ((bash-binary
- (if bootstrap?
- bash
- (string-append (derivation->output-path bash)
- "/bin/sh"))))
- (launch-environment/container #:command command
- #:bash bash-binary
- #:user user
- #:user-mappings mappings
- #:profile profile
- #:manifest manifest
- #:link-profile? link-prof?
- #:network? network?)))
- (else
- (return
- (exit/status
- (launch-environment/fork command profile manifest
- #:pure? pure?)))))))))))))
+ (with-status-report print-build-event
+ (set-build-options-from-command-line store opts)
+
+ ;; Use the bootstrap Guile when requested.
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build
+ (package-derivation
+ store
+ (if bootstrap?
+ %bootstrap-guile
+ (canonical-package guile-2.2)))))
+ (run-with-store store
+ ;; Containers need a Bourne shell at /bin/sh.
+ (mlet* %store-monad ((bash (environment-bash container?
+ bootstrap?
+ system))
+ (prof-drv (manifest->derivation
+ manifest system bootstrap?))
+ (profile -> (derivation->output-path prof-drv))
+ (gc-root -> (assoc-ref opts 'gc-root)))
+
+ ;; First build the inputs. This is necessary even for
+ ;; --search-paths. Additionally, we might need to build bash for
+ ;; a container.
+ (mbegin %store-monad
+ (build-environment (if (derivation? bash)
+ (list prof-drv bash)
+ (list prof-drv))
+ opts)
+ (mwhen gc-root
+ (register-gc-root profile gc-root))
+
+ (cond
+ ((assoc-ref opts 'dry-run?)
+ (return #t))
+ ((assoc-ref opts 'search-paths)
+ (show-search-paths profile manifest #:pure? pure?)
+ (return #t))
+ (container?
+ (let ((bash-binary
+ (if bootstrap?
+ bash
+ (string-append (derivation->output-path bash)
+ "/bin/sh"))))
+ (launch-environment/container #:command command
+ #:bash bash-binary
+ #:user user
+ #:user-mappings mappings
+ #:profile profile
+ #:manifest manifest
+ #:link-profile? link-prof?
+ #:network? network?)))
+ (else
+ (return
+ (exit/status
+ (launch-environment/fork command profile manifest
+ #:pure? pure?))))))))))))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 1916f3b9d7..163f5b1dc1 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -25,6 +25,7 @@
#:use-module (guix gexp)
#:use-module (guix utils)
#:use-module (guix store)
+ #:use-module (guix status)
#:use-module (guix grafts)
#:use-module (guix monads)
#:use-module (guix modules)
@@ -538,6 +539,8 @@ please email '~a'~%")
(substitutes? . #t)
(build-hook? . #t)
(graft? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
(verbosity . 0)
(symlinks . ())
(compressor . ,(first %compressors))))
@@ -684,72 +687,73 @@ Create a bundle of PACKAGE.\n"))
(with-error-handling
(with-store store
- ;; Set the build options before we do anything else.
- (set-build-options-from-command-line store opts)
-
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%guile-for-build (package-derivation
- store
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (canonical-package guile-2.2))
- (assoc-ref opts 'system)
- #:graft? (assoc-ref opts 'graft?))))
- (let* ((dry-run? (assoc-ref opts 'dry-run?))
- (relocatable? (assoc-ref opts 'relocatable?))
- (manifest (let ((manifest (manifest-from-args store opts)))
- ;; Note: We cannot honor '--bootstrap' here because
- ;; 'glibc-bootstrap' lacks 'libc.a'.
- (if relocatable?
- (map-manifest-entries wrapped-package manifest)
- manifest)))
- (pack-format (assoc-ref opts 'format))
- (name (string-append (symbol->string pack-format)
- "-pack"))
- (target (assoc-ref opts 'target))
- (bootstrap? (assoc-ref opts 'bootstrap?))
- (compressor (if bootstrap?
- bootstrap-xz
- (assoc-ref opts 'compressor)))
- (archiver (if (equal? pack-format 'squashfs)
- squashfs-tools-next
- (if bootstrap?
- %bootstrap-coreutils&co
- tar)))
- (symlinks (assoc-ref opts 'symlinks))
- (build-image (match (assq-ref %formats pack-format)
- ((? procedure? proc) proc)
- (#f
- (leave (G_ "~a: unknown pack format~%")
- pack-format))))
- (localstatedir? (assoc-ref opts 'localstatedir?)))
- (run-with-store store
- (mlet* %store-monad ((profile (profile-derivation
- manifest
- #:relative-symlinks? relocatable?
- #:hooks (if bootstrap?
- '()
- %default-profile-hooks)
- #:locales? (not bootstrap?)
- #:target target))
- (drv (build-image name profile
- #:target
- target
- #:compressor
- compressor
- #:symlinks
- symlinks
- #:localstatedir?
- localstatedir?
- #:archiver
- archiver)))
- (mbegin %store-monad
- (show-what-to-build* (list drv)
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:dry-run? dry-run?)
- (munless dry-run?
- (built-derivations (list drv))
- (return (format #t "~a~%"
- (derivation->output-path drv))))))
- #:system (assoc-ref opts 'system)))))))
+ (with-status-report print-build-event
+ ;; Set the build options before we do anything else.
+ (set-build-options-from-command-line store opts)
+
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build (package-derivation
+ store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (canonical-package guile-2.2))
+ (assoc-ref opts 'system)
+ #:graft? (assoc-ref opts 'graft?))))
+ (let* ((dry-run? (assoc-ref opts 'dry-run?))
+ (relocatable? (assoc-ref opts 'relocatable?))
+ (manifest (let ((manifest (manifest-from-args store opts)))
+ ;; Note: We cannot honor '--bootstrap' here because
+ ;; 'glibc-bootstrap' lacks 'libc.a'.
+ (if relocatable?
+ (map-manifest-entries wrapped-package manifest)
+ manifest)))
+ (pack-format (assoc-ref opts 'format))
+ (name (string-append (symbol->string pack-format)
+ "-pack"))
+ (target (assoc-ref opts 'target))
+ (bootstrap? (assoc-ref opts 'bootstrap?))
+ (compressor (if bootstrap?
+ bootstrap-xz
+ (assoc-ref opts 'compressor)))
+ (archiver (if (equal? pack-format 'squashfs)
+ squashfs-tools-next
+ (if bootstrap?
+ %bootstrap-coreutils&co
+ tar)))
+ (symlinks (assoc-ref opts 'symlinks))
+ (build-image (match (assq-ref %formats pack-format)
+ ((? procedure? proc) proc)
+ (#f
+ (leave (G_ "~a: unknown pack format~%")
+ pack-format))))
+ (localstatedir? (assoc-ref opts 'localstatedir?)))
+ (run-with-store store
+ (mlet* %store-monad ((profile (profile-derivation
+ manifest
+ #:relative-symlinks? relocatable?
+ #:hooks (if bootstrap?
+ '()
+ %default-profile-hooks)
+ #:locales? (not bootstrap?)
+ #:target target))
+ (drv (build-image name profile
+ #:target
+ target
+ #:compressor
+ compressor
+ #:symlinks
+ symlinks
+ #:localstatedir?
+ localstatedir?
+ #:archiver
+ archiver)))
+ (mbegin %store-monad
+ (show-what-to-build* (list drv)
+ #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run? dry-run?)
+ (munless dry-run?
+ (built-derivations (list drv))
+ (return (format #t "~a~%"
+ (derivation->output-path drv))))))
+ #:system (assoc-ref opts 'system))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index c3ed2ac935..93a77915fe 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -24,6 +24,7 @@
(define-module (guix scripts package)
#:use-module (guix ui)
+ #:use-module (guix status)
#:use-module (guix store)
#:use-module (guix grafts)
#:use-module (guix derivations)
@@ -330,7 +331,8 @@ ENTRIES, a list of manifest entries, in the context of PROFILE."
(graft? . #t)
(substitutes? . #t)
(build-hook? . #t)
- (print-build-trace? . #t)))
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)))
(define (show-help)
(display (G_ "Usage: guix package [OPTION]...
@@ -941,15 +943,12 @@ processed, #f otherwise."
(or (process-query opts)
(parameterize ((%store (open-connection))
(%graft? (assoc-ref opts 'graft?)))
- (set-build-options-from-command-line (%store) opts)
-
- (parameterize ((%guile-for-build
- (package-derivation
- (%store)
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (canonical-package guile-2.2))))
- (current-build-output-port
- (build-output-port #:verbose? verbose?
- #:port (duplicate-port (current-error-port) "w"))))
- (process-actions (%store) opts))))))
+ (with-status-report print-build-event/quiet
+ (set-build-options-from-command-line (%store) opts)
+ (parameterize ((%guile-for-build
+ (package-derivation
+ (%store)
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (canonical-package guile-2.2)))))
+ (process-actions (%store) opts)))))))
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 18e2fc92f2..df787a9940 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -41,7 +41,8 @@
(module-use! module (resolve-interface '(guix base32)))
module))
-(define* (perform-download drv #:optional output)
+(define* (perform-download drv #:optional output
+ #:key print-build-trace?)
"Perform the download described by DRV, a fixed-output derivation, to
OUTPUT.
@@ -67,6 +68,7 @@ actual output is different from that when we're doing a 'bmCheck' or
;; We're invoked by the daemon, which gives us write access to OUTPUT.
(when (url-fetch url output
+ #:print-build-trace? print-build-trace?
#:mirrors (if mirrors
(call-with-input-file mirrors read)
'())
@@ -98,6 +100,11 @@ allows us to sidestep bootstrapping problems, such downloading the source code
of GnuTLS over HTTPS, before we have built GnuTLS. See
<http://bugs.gnu.org/22774>."
+ (define print-build-trace?
+ (match (getenv "_NIX_OPTIONS")
+ (#f #f)
+ (str (string-contains str "print-extended-build-trace=1"))))
+
;; This program must be invoked by guix-daemon under an unprivileged UID to
;; prevent things downloading from 'file:///etc/shadow' or arbitrary code
;; execution via the content-addressed mirror procedures. (That means we
@@ -107,10 +114,12 @@ of GnuTLS over HTTPS, before we have built GnuTLS. See
(((? derivation-path? drv) (? store-path? output))
(assert-low-privileges)
(perform-download (read-derivation-from-file drv)
- output))
+ output
+ #:print-build-trace? print-build-trace?))
(((? derivation-path? drv)) ;backward compatibility
(assert-low-privileges)
- (perform-download (read-derivation-from-file drv)))
+ (perform-download (read-derivation-from-file drv)
+ #:print-build-trace? print-build-trace?))
(("--version")
(show-version-and-exit))
(x
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 39aebb18e2..803f7cf142 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -20,6 +20,7 @@
(define-module (guix scripts pull)
#:use-module (guix ui)
#:use-module (guix utils)
+ #:use-module (guix status)
#:use-module (guix scripts)
#:use-module (guix store)
#:use-module (guix config)
@@ -61,6 +62,8 @@
`((system . ,(%current-system))
(substitutes? . #t)
(build-hook? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
(graft? . #t)
(verbosity . 0)))
@@ -447,36 +450,37 @@ Use '~/.config/guix/channels.scm' instead."))
#t) ;XXX: not very useful
(else
(with-store store
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%repository-cache-directory cache))
- (set-build-options-from-command-line store opts)
- (honor-x509-certificates store)
-
- (let ((instances (latest-channel-instances store channels)))
- (format (current-error-port)
- (N_ "Building from this channel:~%"
- "Building from these channels:~%"
- (length instances)))
- (for-each (lambda (instance)
- (let ((channel
- (channel-instance-channel instance)))
- (format (current-error-port)
- " ~10a~a\t~a~%"
- (channel-name channel)
- (channel-url channel)
- (string-take
- (channel-instance-commit instance)
- 7))))
- instances)
- (parameterize ((%guile-for-build
- (package-derivation
- store
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (canonical-package guile-2.2)))))
- (run-with-store store
- (build-and-install instances profile
- #:verbose?
- (assoc-ref opts 'verbose?)))))))))))))
+ (with-status-report print-build-event
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%repository-cache-directory cache))
+ (set-build-options-from-command-line store opts)
+ (honor-x509-certificates store)
+
+ (let ((instances (latest-channel-instances store channels)))
+ (format (current-error-port)
+ (N_ "Building from this channel:~%"
+ "Building from these channels:~%"
+ (length instances)))
+ (for-each (lambda (instance)
+ (let ((channel
+ (channel-instance-channel instance)))
+ (format (current-error-port)
+ " ~10a~a\t~a~%"
+ (channel-name channel)
+ (channel-url channel)
+ (string-take
+ (channel-instance-commit instance)
+ 7))))
+ instances)
+ (parameterize ((%guile-for-build
+ (package-derivation
+ store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (canonical-package guile-2.2)))))
+ (run-with-store store
+ (build-and-install instances profile
+ #:verbose?
+ (assoc-ref opts 'verbose?))))))))))))))
;;; pull.scm ends here
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 50c6a22064..eb82224016 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -837,7 +837,16 @@ REPORTER, which should be a <progress-reporter> object."
(make-custom-binary-input-port "progress-port-proc"
read! #f #f
(lambda ()
- (stop)
+ ;; XXX: Kludge! When used through
+ ;; 'decompressed-port', this port ends
+ ;; up being closed twice: once in a
+ ;; child process early on, and at the
+ ;; end in the parent process. Ignore
+ ;; the early close so we don't output
+ ;; a spurious "download-succeeded"
+ ;; trace.
+ (unless (zero? total)
+ (stop))
(close-port port)))))))
(define-syntax with-networking
@@ -930,7 +939,7 @@ authorized substitutes."
(error "unknown `--query' command" wtf))))
(define* (process-substitution store-item destination
- #:key cache-urls acl)
+ #:key cache-urls acl print-build-trace?)
"Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
DESTINATION as a nar file. Verify the substitute against ACL."
(let* ((narinfo (lookup-narinfo cache-urls store-item
@@ -943,8 +952,10 @@ DESTINATION as a nar file. Verify the substitute against ACL."
;; Tell the daemon what the expected hash of the Nar itself is.
(format #t "~a~%" (narinfo-hash narinfo))
- (format (current-error-port)
- (G_ "Downloading ~a...~%") (uri->string uri))
+ (unless print-build-trace?
+ (format (current-error-port)
+ (G_ "Downloading ~a...~%") (uri->string uri)))
+
(let*-values (((raw download-size)
;; Note that Hydra currently generates Nars on the fly
;; and doesn't specify a Content-Length, so
@@ -955,10 +966,15 @@ DESTINATION as a nar file. Verify the substitute against ACL."
(dl-size (or download-size
(and (equal? comp "none")
(narinfo-size narinfo))))
- (reporter (progress-reporter/file
- (uri->string uri) dl-size
- (current-error-port)
- #:abbreviation nar-uri-abbreviation)))
+ (reporter (if print-build-trace?
+ (progress-reporter/trace
+ destination
+ (uri->string uri) dl-size
+ (current-error-port))
+ (progress-reporter/file
+ (uri->string uri) dl-size
+ (current-error-port)
+ #:abbreviation nar-uri-abbreviation))))
(progress-report-port reporter raw)))
((input pids)
;; NOTE: This 'progress' port of current process will be
@@ -1058,6 +1074,13 @@ default value."
(define (guix-substitute . args)
"Implement the build daemon's substituter protocol."
+ (define print-build-trace?
+ (match (or (find-daemon-option "untrusted-print-extended-build-trace")
+ (find-daemon-option "print-extended-build-trace"))
+ (#f #f)
+ ((= string->number number) (> number 0))
+ (_ #f)))
+
(mkdir-p %narinfo-cache-directory)
(maybe-remove-expired-cache-entries %narinfo-cache-directory
cached-narinfo-files
@@ -1111,7 +1134,8 @@ default value."
(parameterize ((current-terminal-columns (client-terminal-columns)))
(process-substitution store-path destination
#:cache-urls (substitute-urls)
- #:acl (current-acl))))
+ #:acl (current-acl)
+ #:print-build-trace? print-build-trace?)))
((or ("-V") ("--version"))
(show-version-and-exit "guix substitute"))
(("--help")
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 69bd05b516..f9d6b9e5b6 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -23,6 +23,7 @@
(define-module (guix scripts system)
#:use-module (guix config)
#:use-module (guix ui)
+ #:use-module (guix status)
#:use-module (guix store)
#:autoload (guix store database) (register-path)
#:use-module (guix grafts)
@@ -310,9 +311,9 @@ names of services to load (upgrade), and the list of names of services to
unload."
(match (current-services)
((services ...)
- (let-values (((to-unload to-load)
+ (let-values (((to-unload to-restart)
(shepherd-service-upgrade services new-services)))
- (mproc to-load
+ (mproc to-restart
(map (compose first live-service-provision)
to-unload))))
(#f
@@ -335,25 +336,32 @@ bring the system down."
;; Arrange to simply emit a warning if the service upgrade fails.
(with-shepherd-error-handling
(call-with-service-upgrade-info new-services
- (lambda (to-load to-unload)
+ (lambda (to-restart to-unload)
(for-each (lambda (unload)
(info (G_ "unloading service '~a'...~%") unload)
(unload-service unload))
to-unload)
(with-monad %store-monad
- (munless (null? to-load)
- (let ((to-load-names (map shepherd-service-canonical-name to-load))
- (to-start (filter shepherd-service-auto-start? to-load)))
- (info (G_ "loading new services:~{ ~a~}...~%") to-load-names)
+ (munless (null? new-services)
+ (let ((new-service-names (map shepherd-service-canonical-name new-services))
+ (to-restart-names (map shepherd-service-canonical-name to-restart))
+ (to-start (filter shepherd-service-auto-start? new-services)))
+ (info (G_ "loading new services:~{ ~a~}...~%") new-service-names)
+ (unless (null? to-restart-names)
+ ;; Listing TO-RESTART-NAMES in the message below wouldn't help
+ ;; because many essential services cannot be meaningfully
+ ;; restarted. See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>.
+ (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop,
+upgrade, and restart each service that was not automatically restarted.\n")))
(mlet %store-monad ((files (mapm %store-monad
(compose lower-object
shepherd-service-file)
- to-load)))
+ new-services)))
;; Here we assume that FILES are exactly those that were computed
;; as part of the derivation that built OS, which is normally the
;; case.
- (load-services (map derivation->output-path files))
+ (load-services/safe (map derivation->output-path files))
(for-each start-service
(map shepherd-service-canonical-name to-start))
@@ -1072,6 +1080,8 @@ Some ACTIONS support additional ARGS.\n"))
`((system . ,(%current-system))
(substitutes? . #t)
(build-hook? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
(graft? . #t)
(verbosity . 0)
(file-system-type . "ext4")
@@ -1246,9 +1256,11 @@ argument list and OPTS is the option alist."
parse-sub-command))
(args (option-arguments opts))
(command (assoc-ref opts 'action)))
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (current-terminal-columns (terminal-columns)))
- (process-command command args opts)))))
+ (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (with-status-report (if (memq command '(init reconfigure))
+ print-build-event/quiet
+ print-build-event)
+ (process-command command args opts))))))
;;; Local Variables:
;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)
diff --git a/guix/status.scm b/guix/status.scm
new file mode 100644
index 0000000000..c6956066fd
--- /dev/null
+++ b/guix/status.scm
@@ -0,0 +1,501 @@
+;;; 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)
+ #: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 MAGENTA 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)
+ (match (derivation-log-file drv)
+ (#f
+ (format port (failure (G_ "Could not find build log for '~a'."))
+ drv))
+ (log
+ (format port (info (G_ "View build log at '~a'.")) log)))
+ (newline port))
+ (('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)
+ ;; TODO: Better distinguish daemon messages and build log lines.
+ (cond ((string-prefix? "substitute: " line)
+ ;; The daemon prefixes early messages coming with 'guix
+ ;; substitute' with "substitute:". These are useful ("updating
+ ;; substitutes from URL"), so let them through.
+ (format port line)
+ (force-output port))
+ ((string-prefix? "waiting for locks" line)
+ ;; This is when a derivation is already being built and we're just
+ ;; waiting for the build to complete.
+ (display (info (string-trim-right line)) port)
+ (newline))
+ (else
+ (print-log-line line))))
+ (_
+ event)))
+
+(define* (print-build-event/quiet event old-status status
+ #:optional
+ (port (current-error-port))
+ #:key
+ (colorize? (color-output? port)))
+ (print-build-event event old-status status port
+ #:colorize? colorize?
+ #:print-log? #f))
+
+(define* (build-status-updater #:optional (on-change (const #t)))
+ "Return a procedure that can be passed to 'build-event-output-port'. That
+procedure computes the new build status upon each event and calls ON-CHANGE:
+
+ (ON-CHANGE event status new-status)
+
+ON-CHANGE can display the build status, build events, etc."
+ (lambda (event status)
+ (let ((new (compute-status event status)))
+ (on-change event status new)
+ new)))
+
+
+;;;
+;;; Build port.
+;;;
+
+(define %newline
+ (char-set #\return #\newline))
+
+(define* (build-event-output-port proc #:optional (seed (build-status)))
+ "Return an output port for use as 'current-build-output-port' that calls
+PROC with its current state value, initialized with SEED, on every build
+event. Build events passed to PROC are tuples corresponding to the \"build
+traces\" produced by the daemon:
+
+ (build-started \"/gnu/store/...-foo.drv\" ...)
+ (substituter-started \"/gnu/store/...-foo\" ...)
+
+and so on.
+
+The second return value is a thunk to retrieve the current state."
+ (define %fragments
+ ;; Line fragments received so far.
+ '())
+
+ (define %state
+ ;; Current state for PROC.
+ seed)
+
+ (define (process-line line)
+ (if (string-prefix? "@ " line)
+ (match (string-tokenize (string-drop line 2))
+ (((= string->symbol event-name) args ...)
+ (set! %state
+ (proc (cons event-name args)
+ %state))))
+ (set! %state (proc (list 'build-log line)
+ %state))))
+
+ (define (bytevector-range bv offset count)
+ (let ((ptr (bytevector->pointer bv offset)))
+ (pointer->bytevector ptr count)))
+
+ (define (write! bv offset count)
+ (let loop ((str (utf8->string (bytevector-range bv offset count))))
+ (match (string-index str %newline)
+ ((? integer? cr)
+ (let ((tail (string-take str (+ 1 cr))))
+ (process-line (string-concatenate-reverse
+ (cons tail %fragments)))
+ (set! %fragments '())
+ (loop (string-drop str (+ 1 cr)))))
+ (#f
+ (unless (string-null? str)
+ (set! %fragments (cons str %fragments)))
+ count))))
+
+ (define port
+ (make-custom-binary-output-port "filtering-input-port"
+ write!
+ #f #f
+ #f))
+
+ ;; The build port actually receives Unicode strings.
+ (set-port-encoding! port "UTF-8")
+ (setvbuf port (cond-expand (guile-2.2 'line) (else _IOLBF)))
+
+ (values port (lambda () %state)))
+
+(define (call-with-status-report on-event thunk)
+ (parameterize ((current-terminal-columns (terminal-columns))
+ (current-build-output-port
+ (build-event-output-port (build-status-updater on-event))))
+ (thunk)))
+
+(define-syntax-rule (with-status-report on-event exp ...)
+ "Set up build status reporting to the user using the ON-EVENT procedure;
+evaluate EXP... in that context."
+ (call-with-status-report on-event (lambda () exp ...)))
diff --git a/guix/store.scm b/guix/store.scm
index f88cdefe87..8b35fc8d7a 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -50,9 +50,11 @@
%default-substitute-urls
nix-server?
+ nix-server-version
nix-server-major-version
nix-server-minor-version
nix-server-socket
+ current-store-protocol-version ;for internal use
&nix-error nix-error?
&nix-connection-error nix-connection-error?
@@ -150,9 +152,10 @@
store-path-package-name
store-path-hash-part
direct-store-path
+ derivation-log-file
log-file))
-(define %protocol-version #x161)
+(define %protocol-version #x162)
(define %worker-magic-1 #x6e697863) ; "nixc"
(define %worker-magic-2 #x6478696f) ; "dxio"
@@ -161,6 +164,8 @@
(logand magic #xff00))
(define (protocol-minor magic)
(logand magic #x00ff))
+(define (protocol-version major minor)
+ (logior major minor))
(define-syntax define-enumerate-type
(syntax-rules ()
@@ -540,6 +545,11 @@ connection. Use with care."
(make-hash-table 100)
(make-hash-table 100))))
+(define (nix-server-version store)
+ "Return the protocol version of STORE as an integer."
+ (protocol-version (nix-server-major-version store)
+ (nix-server-minor-version store)))
+
(define (write-buffered-output server)
"Flush SERVER's output port."
(force-output (nix-server-output-port server))
@@ -556,10 +566,20 @@ automatically close the store when the dynamic extent of EXP is left."
(dynamic-wind
(const #f)
(lambda ()
- exp ...)
+ (parameterize ((current-store-protocol-version
+ (nix-server-version store)))
+ exp) ...)
(lambda ()
(false-if-exception (close-connection store))))))
+(define current-store-protocol-version
+ ;; Protocol version of the store currently used. XXX: This is a hack to
+ ;; communicate the protocol version to the build output port. It's a hack
+ ;; because it could be inaccurrate, for instance if there's code that
+ ;; manipulates several store connections at once; it works well for the
+ ;; purposes of (guix status) though.
+ (make-parameter #f))
+
(define current-build-output-port
;; The port where build output is sent.
(make-parameter (current-error-port)))
@@ -682,6 +702,13 @@ encoding conversion errors."
(build-verbosity 0)
(log-type 0)
(print-build-trace #t)
+
+ ;; When true, provide machine-readable "build
+ ;; traces" for use by (guix status). Old clients
+ ;; are unable to make sense, which is why it's
+ ;; disabled by default.
+ print-extended-build-trace?
+
build-cores
(use-substitutes? #t)
@@ -725,7 +752,12 @@ encoding conversion errors."
(when (>= (nix-server-minor-version server) 10)
(send (boolean use-substitutes?)))
(when (>= (nix-server-minor-version server) 12)
- (let ((pairs `(,@(if timeout
+ (let ((pairs `(;; This option is honored by 'guix substitute' et al.
+ ,@(if print-build-trace
+ `(("print-extended-build-trace"
+ . ,(if print-extended-build-trace? "1" "0")))
+ '())
+ ,@(if timeout
`(("build-timeout" . ,(number->string timeout)))
'())
,@(if max-silent-time
@@ -1064,13 +1096,15 @@ an arbitrary directory layout in the store without creating a derivation."
outputs, and return when the worker is done building them. Elements of THINGS
that are not derivations can only be substituted and not built locally.
Return #t on success."
- (if (>= (nix-server-minor-version store) 15)
- (build store things mode)
- (if (= mode (build-mode normal))
- (build/old store things)
- (raise (condition (&nix-protocol-error
- (message "unsupported build mode")
- (status 1)))))))))
+ (parameterize ((current-store-protocol-version
+ (nix-server-version store)))
+ (if (>= (nix-server-minor-version store) 15)
+ (build store things mode)
+ (if (= mode (build-mode normal))
+ (build/old store things)
+ (raise (condition (&nix-protocol-error
+ (message "unsupported build mode")
+ (status 1))))))))))
(define-operation (add-temp-root (store-path path))
"Make PATH a temporary root for the duration of the current session.
@@ -1673,21 +1707,26 @@ syntactically valid store path."
(and (string-every %nix-base32-charset hash)
hash))))))
+(define (derivation-log-file drv)
+ "Return the build log file for DRV, a derivation file name, or #f if it
+could not be found."
+ (let* ((base (basename drv))
+ (log (string-append (dirname %state-directory) ; XXX
+ "/log/guix/drvs/"
+ (string-take base 2) "/"
+ (string-drop base 2)))
+ (log.gz (string-append log ".gz"))
+ (log.bz2 (string-append log ".bz2")))
+ (cond ((file-exists? log.gz) log.gz)
+ ((file-exists? log.bz2) log.bz2)
+ ((file-exists? log) log)
+ (else #f))))
+
(define (log-file store file)
"Return the build log file for FILE, or #f if none could be found. FILE
must be an absolute store file name, or a derivation file name."
(cond ((derivation-path? file)
- (let* ((base (basename file))
- (log (string-append (dirname %state-directory) ; XXX
- "/log/guix/drvs/"
- (string-take base 2) "/"
- (string-drop base 2)))
- (log.gz (string-append log ".gz"))
- (log.bz2 (string-append log ".bz2")))
- (cond ((file-exists? log.gz) log.gz)
- ((file-exists? log.bz2) log.bz2)
- ((file-exists? log) log)
- (else #f))))
+ (derivation-log-file file))
(else
(match (valid-derivers store file)
((derivers ...)
diff --git a/guix/ui.scm b/guix/ui.scm
index c55ae7e2f8..96f403acf5 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -119,7 +119,7 @@
warning
info
guix-main
- build-output-port))
+ colorize-string))
;;; Commentary:
;;;
@@ -1676,124 +1676,4 @@ be reset such that subsequent output will not have any colors in effect."
str
(color 'RESET)))
-(define* (build-output-port #:key
- (colorize? #t)
- verbose?
- (port (current-error-port)))
- "Return a soft port that processes build output. By default it colorizes
-phase announcements and replaces any other output with a spinner."
- (define spun? #f)
- (define spin!
- (let ((steps (circular-list "\\" "|" "/" "-")))
- (lambda ()
- (match steps
- ((first . rest)
- (set! steps rest)
- (set! spun? #t) ; remember to erase spinner
- first)))))
-
- (define use-color?
- (and colorize?
- (not (or (getenv "NO_COLOR")
- (getenv "INSIDE_EMACS")
- (not (isatty? port))))))
-
- (define handle-string
- (let* ((proc (if use-color?
- colorize-string
- (lambda (s . _) s)))
- (rules `(("^(@ build-started) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Building " 'BLUE 'BOLD)
- (match:substring m 2) "\n")))
- ,(if verbose?
- ;; Err on the side of caution: show everything, even
- ;; if it might be redundant.
- `("^(@ build-failed)(.+)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Build failed: " 'RED 'BOLD)
- (match:substring m 2))))
- ;; Show only that the build failed.
- `("^(@ build-failed)(.+) -.*"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Build failed: " 'RED 'BOLD)
- (match:substring m 2)
- "\n"))))
- ;; NOTE: this line contains "\n" characters.
- ("^(sha256 hash mismatch for output path)(.*)"
- RED BLACK)
- ("^(@ build-succeeded) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Built " 'GREEN 'BOLD)
- (match:substring m 2) "\n")))
- ("^(@ substituter-started) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Substituting " 'BLUE 'BOLD)
- (match:substring m 2) "\n")))
- ("^(@ substituter-failed) (.*) (.*) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Substituter failed: " 'RED 'BOLD)
- (match:substring m 2) "\n"
- (match:substring m 3) ": "
- (match:substring m 4) "\n")))
- ("^(@ substituter-succeeded) (.*)"
- #:transform
- ,(lambda (m)
- (string-append
- (proc "Substituted " 'GREEN 'BOLD)
- (match:substring m 2) "\n")))
- ("^(starting phase )(.*)"
- BLUE GREEN)
- ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)"
- GREEN BLUE GREEN BLUE GREEN BLUE)
- ("^(phase)(.*)(failed after)(.*)(seconds)(.*)"
- RED BLUE RED BLUE RED BLUE))))
- (lambda (str)
- (let ((processed
- (any (match-lambda
- ((pattern #:transform transform)
- (and=> (string-match pattern str)
- transform))
- ((pattern . colors)
- (and=> (string-match pattern str)
- (lambda (m)
- (let ((substrings
- (map (cut match:substring m <>)
- (iota (- (match:count m) 1) 1))))
- (string-join (map proc substrings colors) ""))))))
- rules)))
- (when spun?
- (display (string #\backspace) port))
- (if processed
- (begin
- (display processed port)
- (set! spun? #f))
- ;; Print unprocessed line, or replace with spinner
- (display (if verbose? str (spin!)) port))))))
- (make-soft-port
- (vector
- ;; procedure accepting one character for output
- (cut write <> port)
- ;; procedure accepting a string for output
- handle-string
- ;; thunk for flushing output
- (lambda () (force-output port))
- ;; thunk for getting one character
- (const #t)
- ;; thunk for closing port (not by garbage collection)
- (lambda () (close port)))
- "w"))
-
;;; ui.scm ends here