summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2018-10-17 20:47:11 +0200
committerMarius Bakke <mbakke@fastmail.com>2018-10-17 20:47:11 +0200
commitd02bb02f7d833ad371c53c346b6cb77f01377cf4 (patch)
tree9506f04a7fde2f3b264ba1d2a9012085e1f72b72 /guix
parentfb3ff265cd8c6b4c6160f94240dc8932097e637b (diff)
parentacce0a474c1493ab18912bc46285248e4ccb0314 (diff)
downloadguix-patches-d02bb02f7d833ad371c53c346b6cb77f01377cf4.tar
guix-patches-d02bb02f7d833ad371c53c346b6cb77f01377cf4.tar.gz
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/import/json.scm3
-rw-r--r--guix/profiles.scm87
-rw-r--r--guix/scripts.scm4
-rw-r--r--guix/scripts/build.scm9
-rw-r--r--guix/scripts/describe.scm2
-rw-r--r--guix/scripts/environment.scm1
-rw-r--r--guix/scripts/import/cran.scm2
-rw-r--r--guix/scripts/pack.scm1
-rw-r--r--guix/scripts/package.scm43
-rw-r--r--guix/scripts/pull.scm69
-rw-r--r--guix/scripts/system.scm1
-rw-r--r--guix/self.scm9
-rw-r--r--guix/status.scm194
-rw-r--r--guix/store.scm15
14 files changed, 319 insertions, 121 deletions
diff --git a/guix/import/json.scm b/guix/import/json.scm
index 4f96a513df..81ea5e7b31 100644
--- a/guix/import/json.scm
+++ b/guix/import/json.scm
@@ -47,4 +47,5 @@ the query."
(define (json-fetch-alist url)
"Return an alist representation of the JSON resource URL, or #f if URL
returns 403 or 404."
- (hash-table->alist (json-fetch url)))
+ (and=> (json-fetch url)
+ hash-table->alist))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 669ebe04e5..89e92ea2ba 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -28,7 +28,8 @@
#:use-module ((guix config) #:select (%state-directory))
#:use-module ((guix utils) #:hide (package-name->name+version))
#:use-module ((guix build utils)
- #:select (package-name->name+version))
+ #:select (package-name->name+version mkdir-p))
+ #:use-module (guix i18n)
#:use-module (guix records)
#:use-module (guix packages)
#:use-module (guix derivations)
@@ -127,6 +128,7 @@
%user-profile-directory
%profile-directory
%current-profile
+ ensure-profile-directory
canonicalize-profile
user-friendly-profile))
@@ -1249,7 +1251,7 @@ the entries in MANIFEST."
(define config.scm
(scheme-file "config.scm"
#~(begin
- (define-module (guix config)
+ (define-module #$'(guix config) ;placate Geiser
#:export (%libz))
(define %libz
@@ -1610,28 +1612,73 @@ because the NUMBER is zero.)"
;; coexist with Nix profiles.
(string-append %profile-directory "/guix-profile"))
-(define (canonicalize-profile profile)
- "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise
-return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if
-'-p' was omitted." ; see <http://bugs.gnu.org/17939>
+(define (ensure-profile-directory)
+ "Attempt to create /…/profiles/per-user/$USER if needed."
+ (let ((s (stat %profile-directory #f)))
+ (unless (and s (eq? 'directory (stat:type s)))
+ (catch 'system-error
+ (lambda ()
+ (mkdir-p %profile-directory))
+ (lambda args
+ ;; Often, we cannot create %PROFILE-DIRECTORY because its
+ ;; parent directory is root-owned and we're running
+ ;; unprivileged.
+ (raise (condition
+ (&message
+ (message
+ (format #f
+ (G_ "while creating directory `~a': ~a")
+ %profile-directory
+ (strerror (system-error-errno args)))))
+ (&fix-hint
+ (hint
+ (format #f (G_ "Please create the @file{~a} directory, \
+with you as the owner.")
+ %profile-directory))))))))
+
+ ;; Bail out if it's not owned by the user.
+ (unless (or (not s) (= (stat:uid s) (getuid)))
+ (raise (condition
+ (&message
+ (message
+ (format #f (G_ "directory `~a' is not owned by you")
+ %profile-directory)))
+ (&fix-hint
+ (hint
+ (format #f (G_ "Please change the owner of @file{~a} \
+to user ~s.")
+ %profile-directory (or (getenv "USER")
+ (getenv "LOGNAME")
+ (getuid))))))))))
- ;; Trim trailing slashes so that the basename comparison below works as
- ;; intended.
+(define (canonicalize-profile profile)
+ "If PROFILE points to a profile in %PROFILE-DIRECTORY, return that.
+Otherwise return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile'
+as if '-p' was omitted." ; see <http://bugs.gnu.org/17939>
+ ;; Trim trailing slashes so 'readlink' can do its job.
(let ((profile (string-trim-right profile #\/)))
- (if (and %user-profile-directory
- (string=? (canonicalize-path (dirname profile))
- (dirname %user-profile-directory))
- (string=? (basename profile) (basename %user-profile-directory)))
- %current-profile
- profile)))
+ (catch 'system-error
+ (lambda ()
+ (let ((target (readlink profile)))
+ (if (string=? (dirname target) %profile-directory)
+ target
+ profile)))
+ (const profile))))
+
+(define %known-shorthand-profiles
+ ;; Known shorthand forms for profiles that the user manipulates.
+ (list (string-append (config-directory #:ensure? #f) "/current")
+ %user-profile-directory))
(define (user-friendly-profile profile)
- "Return either ~/.guix-profile if that's what PROFILE refers to, directly or
-indirectly, or PROFILE."
- (if (and %user-profile-directory
- (false-if-exception
- (string=? (readlink %user-profile-directory) profile)))
- %user-profile-directory
+ "Return either ~/.guix-profile or ~/.config/guix/current if that's what
+PROFILE refers to, directly or indirectly, or PROFILE."
+ (or (find (lambda (shorthand)
+ (and shorthand
+ (let ((target (false-if-exception
+ (readlink shorthand))))
+ (and target (string=? target profile)))))
+ %known-shorthand-profiles)
profile))
;;; profiles.scm ends here
diff --git a/guix/scripts.scm b/guix/scripts.scm
index 4cbbbeb96f..98751bc812 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -26,6 +26,7 @@
#:use-module (guix monads)
#:use-module (guix packages)
#:use-module (guix derivations)
+ #:use-module ((guix profiles) #:select (%profile-directory))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-37)
@@ -169,8 +170,7 @@ Show what and how will/would be built."
(define age
(match (false-if-not-found
- (lstat (string-append (config-directory #:ensure? #f)
- "/current")))
+ (lstat (string-append %profile-directory "/current-guix")))
(#f #f)
(stat (- (time-second (current-time time-utc))
(stat:mtime stat)))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 5a6ba62bc3..13978abb77 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -395,6 +395,8 @@ options handled by 'set-build-options-from-command-line', and listed in
#:print-build-trace (assoc-ref opts 'print-build-trace?)
#:print-extended-build-trace?
(assoc-ref opts 'print-extended-build-trace?)
+ #:multiplexed-build-output?
+ (assoc-ref opts 'multiplexed-build-output?)
#:verbosity (assoc-ref opts 'verbosity)))
(define set-build-options-from-command-line*
@@ -505,6 +507,7 @@ options handled by 'set-build-options-from-command-line', and listed in
(build-hook? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
(verbosity . 0)))
(define (show-help)
@@ -623,7 +626,7 @@ must be one of 'package', 'all', or 'transitive'~%")
"Read the arguments from OPTS and return a list of high-level objects to
build---packages, gexps, derivations, and so on."
(define (validate-type x)
- (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x))
+ (unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x))
(leave (G_ "~s: not something we can build~%") x)))
(define (ensure-list x)
@@ -700,6 +703,10 @@ package '~a' has no source~%")
(set-guile-for-build (default-guile))
(proc))
#:system system)))
+ ((? file-like? obj)
+ (list (run-with-store store
+ (lower-object obj system
+ #:target (assoc-ref opts 'target)))))
((? gexp? gexp)
(list (run-with-store store
(mbegin %store-monad
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index c1a20fe26c..e59502076c 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -158,4 +158,4 @@ in the format specified by FMT."
(#f
(display-checkout-info format))
(profile
- (display-profile-info profile format))))))
+ (display-profile-info (canonicalize-profile profile) format))))))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 9fc7edcd36..5965e3426e 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -176,6 +176,7 @@ COMMAND or an interactive shell in that environment.\n"))
(graft? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
(verbosity . 0)))
(define (tag-package-arg opts arg)
diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm
index 30ae6d4342..794fb710cd 100644
--- a/guix/scripts/import/cran.scm
+++ b/guix/scripts/import/cran.scm
@@ -47,6 +47,8 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
+ -r, --recursive import packages recursively"))
+ (display (G_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 163f5b1dc1..fb3c50521d 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -541,6 +541,7 @@ please email '~a'~%")
(graft? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
(verbosity . 0)
(symlinks . ())
(compressor . ,(first %compressors))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 93a77915fe..5d146b8427 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -68,50 +68,14 @@
(define (ensure-default-profile)
"Ensure the default profile symlink and directory exist and are writable."
-
- (define (rtfm)
- (format (current-error-port)
- (G_ "Try \"info '(guix) Invoking guix package'\" for \
-more information.~%"))
- (exit 1))
+ (ensure-profile-directory)
;; Create ~/.guix-profile if it doesn't exist yet.
(when (and %user-profile-directory
%current-profile
(not (false-if-exception
(lstat %user-profile-directory))))
- (symlink %current-profile %user-profile-directory))
-
- (let ((s (stat %profile-directory #f)))
- ;; Attempt to create /…/profiles/per-user/$USER if needed.
- (unless (and s (eq? 'directory (stat:type s)))
- (catch 'system-error
- (lambda ()
- (mkdir-p %profile-directory))
- (lambda args
- ;; Often, we cannot create %PROFILE-DIRECTORY because its
- ;; parent directory is root-owned and we're running
- ;; unprivileged.
- (format (current-error-port)
- (G_ "error: while creating directory `~a': ~a~%")
- %profile-directory
- (strerror (system-error-errno args)))
- (format (current-error-port)
- (G_ "Please create the `~a' directory, with you as the owner.~%")
- %profile-directory)
- (rtfm))))
-
- ;; Bail out if it's not owned by the user.
- (unless (or (not s) (= (stat:uid s) (getuid)))
- (format (current-error-port)
- (G_ "error: directory `~a' is not owned by you~%")
- %profile-directory)
- (format (current-error-port)
- (G_ "Please change the owner of `~a' to user ~s.~%")
- %profile-directory (or (getenv "USER")
- (getenv "LOGNAME")
- (getuid)))
- (rtfm))))
+ (symlink %current-profile %user-profile-directory)))
(define (delete-generations store profile generations)
"Delete GENERATIONS from PROFILE.
@@ -332,7 +296,8 @@ ENTRIES, a list of manifest entries, in the context of PROFILE."
(substitutes? . #t)
(build-hook? . #t)
(print-build-trace? . #t)
- (print-extended-build-trace? . #t)))
+ (print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)))
(define (show-help)
(display (G_ "Usage: guix package [OPTION]...
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 803f7cf142..188237aa90 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -64,6 +64,7 @@
(build-hook? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
(graft? . #t)
(verbosity . 0)))
@@ -227,6 +228,60 @@ Download and deploy the latest version of Guix.\n"))
;;;
+;;; Profile.
+;;;
+
+(define %current-profile
+ ;; The "real" profile under /var/guix.
+ (string-append %profile-directory "/current-guix"))
+
+(define %user-profile-directory
+ ;; The user-friendly name of %CURRENT-PROFILE.
+ (string-append (config-directory #:ensure? #f) "/current"))
+
+(define (migrate-generations profile directory)
+ "Migrate the generations of PROFILE to DIRECTORY."
+ (format (current-error-port)
+ (G_ "Migrating profile generations to '~a'...~%")
+ %profile-directory)
+ (let ((current (generation-number profile)))
+ (for-each (lambda (generation)
+ (let ((source (generation-file-name profile generation))
+ (target (string-append directory "/current-guix-"
+ (number->string generation)
+ "-link")))
+ ;; Note: Don't use 'rename-file' as SOURCE and TARGET might
+ ;; live on different file systems.
+ (symlink (readlink source) target)
+ (delete-file source)))
+ (profile-generations profile))
+ (symlink (string-append "current-guix-"
+ (number->string current) "-link")
+ (string-append directory "/current-guix"))))
+
+(define (ensure-default-profile)
+ (ensure-profile-directory)
+
+ ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks. Move
+ ;; them to %PROFILE-DIRECTORY.
+ (unless (string=? %profile-directory
+ (dirname (canonicalize-profile %user-profile-directory)))
+ (migrate-generations %user-profile-directory %profile-directory))
+
+ ;; Make sure ~/.config/guix/current points to /var/guix/profiles/….
+ (let ((link %user-profile-directory))
+ (unless (equal? (false-if-exception (readlink link))
+ %current-profile)
+ (catch 'system-error
+ (lambda ()
+ (false-if-exception (delete-file link))
+ (symlink %current-profile link))
+ (lambda args
+ (leave (G_ "while creating symlink '~a': ~a~%")
+ link (strerror (system-error-errno args))))))))
+
+
+;;;
;;; Queries.
;;;
@@ -341,11 +396,8 @@ and ALIST2 differ, display HEADING upfront."
(display-new/upgraded-packages (package-alist gen1)
(package-alist gen2)))
-(define (process-query opts)
- "Process any query specified by OPTS."
- (define profile
- (string-append (config-directory) "/current"))
-
+(define (process-query opts profile)
+ "Process any query on PROFILE specified by OPTS."
(match (assoc-ref opts 'query)
(('list-generations pattern)
(define (list-generations profile numbers)
@@ -441,11 +493,10 @@ Use '~/.config/guix/channels.scm' instead."))
(list %default-options)))
(cache (string-append (cache-directory) "/pull"))
(channels (channel-list opts))
- (profile (or (assoc-ref opts 'profile)
- (string-append (config-directory) "/current"))))
-
+ (profile (or (assoc-ref opts 'profile) %current-profile)))
+ (ensure-default-profile)
(cond ((assoc-ref opts 'query)
- (process-query opts))
+ (process-query opts profile))
((assoc-ref opts 'dry-run?)
#t) ;XXX: not very useful
(else
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index f9d6b9e5b6..f9af38b7c5 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1082,6 +1082,7 @@ Some ACTIONS support additional ARGS.\n"))
(build-hook? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
(graft? . #t)
(verbosity . 0)
(file-system-type . "ext4")
diff --git a/guix/self.scm b/guix/self.scm
index 733c4a2cc9..3e29c9a42a 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -904,7 +904,11 @@ is not supported."
version))
(define guile
- (guile-for-build guile-version))
+ ;; When PULL-VERSION >= 1, produce a self-contained Guix and use Guile 2.2
+ ;; unconditionally.
+ (guile-for-build (if (>= pull-version 1)
+ "2.2"
+ guile-version)))
(mbegin %store-monad
(set-guile-for-build guile)
@@ -913,7 +917,8 @@ is not supported."
#:name (string-append "guix-"
(shorten version))
#:pull-version pull-version
- #:guile-version guile-version
+ #:guile-version (if (>= pull-version 1)
+ "2.2" guile-version)
#:guile-for-build guile)))
(if guix
(lower-object guix)
diff --git a/guix/status.scm b/guix/status.scm
index c6956066fd..ffa9d9e93c 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -34,6 +34,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 binary-ports)
+ #:autoload (ice-9 rdelim) (read-string)
#:use-module (rnrs bytevectors)
#:use-module ((system foreign)
#:select (bytevector->pointer pointer->bytevector))
@@ -115,7 +116,10 @@
(string=? item (download-item download))))
(define* (compute-status event status
- #:key (current-time current-time))
+ #:key
+ (current-time current-time)
+ (derivation-path->output-path
+ derivation-path->output-path))
"Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...),
compute a new status based on STATUS."
(match event
@@ -141,8 +145,7 @@ compute a new status based on STATUS."
(inherit status)
(building (remove (lambda (drv)
(equal? (false-if-exception
- (derivation->output-path
- (read-derivation-from-file drv)))
+ (derivation-path->output-path drv))
item))
(build-status-building status)))
(downloading (cons (download item uri #:size size
@@ -218,6 +221,12 @@ build traces\" such as \"@ download-progress\" traces."
(and (current-store-protocol-version)
(>= (current-store-protocol-version) #x162)))
+(define (multiplexed-output-supported?)
+ "Return true if the daemon supports \"multiplexed output\"--i.e., \"@
+build-log\" traces."
+ (and (current-store-protocol-version)
+ (>= (current-store-protocol-version) #x163)))
+
(define spin!
(let ((steps (circular-list "\\" "|" "/" "-")))
(lambda (port)
@@ -312,14 +321,16 @@ addition to build events."
(lambda (line)
(spin! port))))
- (display "\r" port) ;erase the spinner
+ (unless print-log?
+ (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)
+ (when (or print-log? (not (extended-build-trace-supported?)))
+ (format port (success (G_ "successfully built ~a")) drv)
+ (newline port))
(match (build-status-building status)
(() #t)
(ongoing ;when max-jobs > 1
@@ -382,21 +393,28 @@ addition to build events."
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))))
+ (('build-log pid line)
+ (if (multiplexed-output-supported?)
+ (if (not pid)
+ (begin
+ ;; LINE comes from the daemon, not from builders. Let it
+ ;; through.
+ (display line port)
+ (force-output port))
+ (print-log-line line))
+ (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.
+ (display line port)
+ (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)))
@@ -426,8 +444,43 @@ ON-CHANGE can display the build status, build events, etc."
;;; Build port.
;;;
-(define %newline
- (char-set #\return #\newline))
+(define (maybe-utf8->string bv)
+ "Attempt to decode BV as UTF-8 string and return it. Gracefully handle the
+case where BV does not contain only valid UTF-8."
+ (catch 'decoding-error
+ (lambda ()
+ (utf8->string bv))
+ (lambda _
+ ;; This is the sledgehammer but it's the only safe way we have to
+ ;; properly handle this. It's expensive but it's rarely needed.
+ (let ((port (open-bytevector-input-port bv)))
+ (set-port-encoding! port "UTF-8")
+ (set-port-conversion-strategy! port 'substitute)
+ (let ((str (read-string port)))
+ (close-port port)
+ str)))))
+
+(define (bytevector-index bv number offset count)
+ "Search for NUMBER in BV starting from OFFSET and reading up to COUNT bytes;
+return the offset where NUMBER first occurs or #f if it could not be found."
+ (let loop ((offset offset)
+ (count count))
+ (cond ((zero? count) #f)
+ ((= (bytevector-u8-ref bv offset) number) offset)
+ (else (loop (+ 1 offset) (- count 1))))))
+
+(define (split-lines str)
+ "Split STR into lines in a way that preserves newline characters."
+ (let loop ((str str)
+ (result '()))
+ (if (string-null? str)
+ (reverse result)
+ (match (string-index str #\newline)
+ (#f
+ (loop "" (cons str result)))
+ (index
+ (loop (string-drop str (+ index 1))
+ (cons (string-take str (+ index 1)) result)))))))
(define* (build-event-output-port proc #:optional (seed (build-status)))
"Return an output port for use as 'current-build-output-port' that calls
@@ -449,33 +502,83 @@ The second return value is a thunk to retrieve the current state."
;; Current state for PROC.
seed)
+ ;; When true, this represents the current state while reading a
+ ;; "@ build-log" trace: the current builder PID, the previously-read
+ ;; bytevectors, and the number of bytes that remain to be read.
+ (define %build-output-pid #f)
+ (define %build-output '())
+ (define %build-output-left #f)
+
(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))))
+ (cond ((string-prefix? "@ " line)
+ (match (string-tokenize (string-drop line 2))
+ (("build-log" (= string->number pid) (= string->number len))
+ (set! %build-output-pid pid)
+ (set! %build-output '())
+ (set! %build-output-left len))
+ (((= string->symbol event-name) args ...)
+ (set! %state
+ (proc (cons event-name args)
+ %state)))))
+ (else
+ (set! %state (proc (list 'build-log #f line)
+ %state)))))
+
+ (define (process-build-output pid output)
+ ;; Transform OUTPUT in 'build-log' events or download events as generated
+ ;; by extended build traces.
+ (define (line->event line)
+ (match (and (string-prefix? "@ " line)
+ (string-tokenize (string-drop line 2)))
+ ((type . args)
+ (if (or (string-prefix? "download-" type)
+ (string=? "build-remote" type))
+ (cons (string->symbol type) args)
+ `(build-log ,pid ,line)))
+ (_
+ `(build-log ,pid ,line))))
+
+ (let* ((lines (split-lines output))
+ (events (map line->event lines)))
+ (set! %state (fold proc %state events))))
(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))))
+ (if %build-output-pid
+ (let ((keep (min count %build-output-left)))
+ (set! %build-output
+ (let ((bv* (make-bytevector keep)))
+ (bytevector-copy! bv offset bv* 0 keep)
+ (cons bv* %build-output)))
+ (set! %build-output-left
+ (- %build-output-left keep))
+
+ (when (zero? %build-output-left)
+ (process-build-output %build-output-pid
+ (string-concatenate-reverse
+ (map maybe-utf8->string %build-output))) ;XXX
+ (set! %build-output '())
+ (set! %build-output-pid #f))
+ keep)
+ (match (bytevector-index bv (char->integer #\newline)
+ offset count)
+ ((? integer? cr)
+ (let* ((tail (maybe-utf8->string
+ (bytevector-range bv offset (- cr -1 offset))))
+ (line (string-concatenate-reverse
+ (cons tail %fragments))))
+ (process-line line)
+ (set! %fragments '())
+ (- cr -1 offset)))
+ (#f
+ (unless (zero? count)
+ (let ((str (maybe-utf8->string
+ (bytevector-range bv offset count))))
+ (set! %fragments (cons str %fragments))))
+ count))))
(define port
(make-custom-binary-output-port "filtering-input-port"
@@ -485,8 +588,9 @@ The second return value is a thunk to retrieve the current state."
;; The build port actually receives Unicode strings.
(set-port-encoding! port "UTF-8")
- (setvbuf port (cond-expand (guile-2.2 'line) (else _IOLBF)))
-
+ (cond-expand
+ ((and guile-2 (not guile-2.2)) #t)
+ (else (setvbuf port 'line)))
(values port (lambda () %state)))
(define (call-with-status-report on-event thunk)
diff --git a/guix/store.scm b/guix/store.scm
index 8b35fc8d7a..b1bdbf3813 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -155,7 +155,7 @@
derivation-log-file
log-file))
-(define %protocol-version #x162)
+(define %protocol-version #x163)
(define %worker-magic-1 #x6e697863) ; "nixc"
(define %worker-magic-2 #x6478696f) ; "dxio"
@@ -709,6 +709,15 @@ encoding conversion errors."
;; disabled by default.
print-extended-build-trace?
+ ;; When true, the daemon prefixes builder output
+ ;; with "@ build-log" traces so we can
+ ;; distinguish it from daemon output, and we can
+ ;; distinguish each builder's output
+ ;; (PRINT-BUILD-TRACE must be true as well.) The
+ ;; latter is particularly useful when
+ ;; MAX-BUILD-JOBS > 1.
+ multiplexed-build-output?
+
build-cores
(use-substitutes? #t)
@@ -757,6 +766,10 @@ encoding conversion errors."
`(("print-extended-build-trace"
. ,(if print-extended-build-trace? "1" "0")))
'())
+ ,@(if multiplexed-build-output?
+ `(("multiplexed-build-output"
+ . ,(if multiplexed-build-output? "true" "false")))
+ '())
,@(if timeout
`(("build-timeout" . ,(number->string timeout)))
'())