From fe17037b387c6eca0c45f0526d2761e982a192bb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Oct 2018 09:53:02 +0200 Subject: status: Gracefully handle invalid UTF-8 in build logs. * guix/status.scm (maybe-utf8->string): New procedure. (build-event-output-port): Use it in lieu of 'utf8->string'. * tests/status.scm ("build-output-port, UTF-8") ("current-build-output-port, UTF-8 + garbage"): New tests. --- tests/status.scm | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/status.scm b/tests/status.scm index 04dedb702c..486ad04dd2 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -20,7 +20,9 @@ #:use-module (guix status) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports)) (test-begin "status") @@ -112,4 +114,22 @@ (display "@ substituter-succeeded baz\n" port) (list first (get-status))))) +(test-equal "build-output-port, UTF-8" + '((build-log "lambda is λ!\n")) + (let-values (((port get-status) (build-event-output-port cons '())) + ((bv) (string->utf8 "lambda is λ!\n"))) + (put-bytevector port bv) + (force-output port) + (get-status))) + +(test-equal "current-build-output-port, UTF-8 + garbage" + ;; What about a mixture of UTF-8 + garbage? + '((build-log "garbage: �lambda: λ\n")) + (let-values (((port get-status) (build-event-output-port cons '()))) + (display "garbage: " port) + (put-bytevector port #vu8(128)) + (put-bytevector port (string->utf8 "lambda: λ\n")) + (force-output port) + (get-status))) + (test-end "status") -- cgit v1.2.3 From b33e191c86b7638517ea838b63a54d031a033554 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Oct 2018 18:52:37 +0200 Subject: guix build: '-f' accepts file-like objects. * guix/scripts/build.scm (options->things-to-build)[validate-type]: Check for 'file-like?'. (options->derivations): Accept 'file-like?'. * tests/guix-build.sh: Add a test with 'computed-file'. * doc/guix.texi (Additional Build Options): Mention file-like objects. --- doc/guix.texi | 5 ++--- guix/scripts/build.scm | 6 +++++- tests/guix-build.sh | 4 ++++ 3 files changed, 11 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 3c116fc0be..9b37270a83 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6365,9 +6365,8 @@ retrieved using the @option{--log-file} option. @item --file=@var{file} @itemx -f @var{file} - -Build the package or derivation that the code within @var{file} -evaluates to. +Build the package, derivation, or other file-like object that the code within +@var{file} evaluates to (@pxref{G-Expressions, file-like objects}). As an example, @var{file} might contain a package definition like this (@pxref{Defining Packages}): diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 5a6ba62bc3..f3aa5512d5 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -623,7 +623,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 +700,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/tests/guix-build.sh b/tests/guix-build.sh index 92e7299321..7842ce87c6 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -221,6 +221,10 @@ guix build -e "(begin guix build -e '#~(mkdir #$output)' -d guix build -e '#~(mkdir #$output)' -d | grep 'gexp\.drv' +# Same with a file-like object. +guix build -e '(computed-file "foo" #~(mkdir #$output))' -d +guix build -e '(computed-file "foo" #~(mkdir #$output))' -d | grep 'foo\.drv' + # Building from a package file. cat > "$module_dir/package.scm"< Date: Mon, 15 Oct 2018 22:40:35 +0200 Subject: daemon: Support multiplexed build output. This allows clients to tell whether output comes from the daemon or, if it comes from a builder, from which builder it comes. The latter is particularly useful when MAX-BUILD-JOBS > 1. * nix/libstore/build.cc (DerivationGoal::tryBuildHook) (DerivationGoal::startBuilder): Print the child's PID in "@ build-started" traces. (DerivationGoal::handleChildOutput): Define 'prefix', pass it to 'writeToStderr'. * nix/libstore/globals.cc (Settings:Settings): Initialize 'multiplexedBuildOutput'. (Settings::update): Likewise. * nix/libstore/globals.hh (Settings)[multiplexedBuildOutput]: New field. Update 'printBuildTrace' documentation. * nix/libstore/worker-protocol.hh (PROTOCOL_VERSION): Bump to 0.163. * nix/nix-daemon/nix-daemon.cc (performOp) : Special-case "multiplexed-build-output" and remove "use-ssh-substituter". * guix/store.scm (set-build-options): Add #:multiplexed-build-output? and honor it. (%protocol-version): Bump to #x163. * tests/store.scm ("multiplexed-build-output"): New test. fixlet --- guix/store.scm | 15 +++++++++- nix/libstore/build.cc | 25 ++++++++++++---- nix/libstore/globals.cc | 2 ++ nix/libstore/globals.hh | 9 +++++- nix/libstore/worker-protocol.hh | 2 +- nix/nix-daemon/nix-daemon.cc | 2 +- tests/store.scm | 63 +++++++++++++++++++++++++++++++++++++++++ 7 files changed, 108 insertions(+), 10 deletions(-) (limited to 'tests') 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))) '()) diff --git a/nix/libstore/build.cc b/nix/libstore/build.cc index b2c319f00b..d7b8b0f0ca 100644 --- a/nix/libstore/build.cc +++ b/nix/libstore/build.cc @@ -1652,8 +1652,8 @@ HookReply DerivationGoal::tryBuildHook() worker.childStarted(shared_from_this(), hook->pid, fds, false, false); if (settings.printBuildTrace) - printMsg(lvlError, format("@ build-started %1% - %2% %3%") - % drvPath % drv.platform % logFile); + printMsg(lvlError, format("@ build-started %1% - %2% %3% %4%") + % drvPath % drv.platform % logFile % hook->pid); return rpAccept; } @@ -2038,8 +2038,8 @@ void DerivationGoal::startBuilder() if (!msg.empty()) throw Error(msg); if (settings.printBuildTrace) { - printMsg(lvlError, format("@ build-started %1% - %2% %3%") - % drvPath % drv.platform % logFile); + printMsg(lvlError, format("@ build-started %1% - %2% %3% %4%") + % drvPath % drv.platform % logFile % pid); } } @@ -2736,6 +2736,19 @@ void DerivationGoal::deleteTmpDir(bool force) void DerivationGoal::handleChildOutput(int fd, const string & data) { + string prefix; + + if (settings.multiplexedBuildOutput) { + /* Print a prefix that allows clients to determine whether a message + comes from the daemon or from a build process, and in the latter + case, which build process it comes from. The PID here matches the + one given in "@ build-started" traces; it's shorter that the + derivation file name, hence this choice. */ + prefix = "@ build-log " + + std::to_string(pid < 0 ? hook->pid : pid) + + " " + std::to_string(data.size()) + "\n"; + } + if ((hook && fd == hook->builderOut.readSide) || (!hook && fd == builderOut.readSide)) { @@ -2748,7 +2761,7 @@ void DerivationGoal::handleChildOutput(int fd, const string & data) return; } if (verbosity >= settings.buildVerbosity) - writeToStderr(data); + writeToStderr(prefix + data); if (gzLogFile) { if (data.size() > 0) { @@ -2767,7 +2780,7 @@ void DerivationGoal::handleChildOutput(int fd, const string & data) } if (hook && fd == hook->fromHook.readSide) - writeToStderr(data); + writeToStderr(prefix + data); } diff --git a/nix/libstore/globals.cc b/nix/libstore/globals.cc index 94c2e516f8..4b5b485e65 100644 --- a/nix/libstore/globals.cc +++ b/nix/libstore/globals.cc @@ -36,6 +36,7 @@ Settings::Settings() buildTimeout = 0; useBuildHook = true; printBuildTrace = false; + multiplexedBuildOutput = false; reservedSize = 8 * 1024 * 1024; fsyncMetadata = true; useSQLiteWAL = true; @@ -120,6 +121,7 @@ void Settings::update() _get(maxBuildJobs, "build-max-jobs"); _get(buildCores, "build-cores"); _get(thisSystem, "system"); + _get(multiplexedBuildOutput, "multiplexed-build-output"); _get(maxSilentTime, "build-max-silent-time"); _get(buildTimeout, "build-timeout"); _get(reservedSize, "gc-reserved-space"); diff --git a/nix/libstore/globals.hh b/nix/libstore/globals.hh index 4c142e6933..a6935c3337 100644 --- a/nix/libstore/globals.hh +++ b/nix/libstore/globals.hh @@ -127,7 +127,7 @@ struct Settings { a fixed format to allow its progress to be monitored. Each line starts with a "@". The following are defined: - @ build-started + @ build-started @ build-failed @ build-succeeded @ substituter-started @@ -139,6 +139,13 @@ struct Settings { builders. */ bool printBuildTrace; + /* When true, 'buildDerivations' prefixes lines coming from builders so + that clients know exactly which line comes from which builder, and + which line comes from the daemon itself. The prefix for data coming + from builders is "log:PID:LEN:DATA" where PID uniquely identifies the + builder (PID is given in "build-started" traces.) */ + bool multiplexedBuildOutput; + /* Amount of reserved space for the garbage collector (/nix/var/nix/db/reserved). */ off_t reservedSize; diff --git a/nix/libstore/worker-protocol.hh b/nix/libstore/worker-protocol.hh index 103d60a8c2..ea67b10a5b 100644 --- a/nix/libstore/worker-protocol.hh +++ b/nix/libstore/worker-protocol.hh @@ -6,7 +6,7 @@ namespace nix { #define WORKER_MAGIC_1 0x6e697863 #define WORKER_MAGIC_2 0x6478696f -#define PROTOCOL_VERSION 0x162 +#define PROTOCOL_VERSION 0x163 #define GET_PROTOCOL_MAJOR(x) ((x) & 0xff00) #define GET_PROTOCOL_MINOR(x) ((x) & 0x00ff) diff --git a/nix/nix-daemon/nix-daemon.cc b/nix/nix-daemon/nix-daemon.cc index 782e4acfc5..2939422172 100644 --- a/nix/nix-daemon/nix-daemon.cc +++ b/nix/nix-daemon/nix-daemon.cc @@ -594,7 +594,7 @@ static void performOp(bool trusted, unsigned int clientVersion, if (name == "build-timeout" || name == "build-max-silent-time" || name == "build-max-jobs" || name == "build-cores" || name == "build-repeat" - || name == "use-ssh-substituter") + || name == "multiplexed-build-output") settings.set(name, value); else settings.set(trusted ? name : "untrusted-" + name, value); diff --git a/tests/store.scm b/tests/store.scm index 2858369706..3ff526cdcf 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -31,6 +31,7 @@ #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (web uri) @@ -1021,4 +1022,66 @@ (call-with-input-file (derivation->output-path drv2) read)))))) +(test-equal "multiplexed-build-output" + '("Hello from first." "Hello from second.") + (with-store store + (let* ((build (add-text-to-store store "build.sh" + "echo Hello from $NAME.; echo > $out")) + (bash (add-to-store store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (drv1 (derivation store "one" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("NAME" . "first") + ("x" . ,(random-text))))) + (drv2 (derivation store "two" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("NAME" . "second") + ("x" . ,(random-text)))))) + (set-build-options store + #:print-build-trace #t + #:multiplexed-build-output? #t + #:max-build-jobs 10) + (let ((port (open-output-string))) + ;; Send the build log to PORT. + (parameterize ((current-build-output-port port)) + (build-derivations store (list drv1 drv2))) + + ;; Retrieve the build log; make sure it contains valid "@ build-log" + ;; traces that allow us to retrieve each builder's output (we assume + ;; there's exactly one "build-output" trace for each builder, which is + ;; reasonable.) + (let* ((log (get-output-string port)) + (started (fold-matches + (make-regexp "@ build-started ([^ ]+) - ([^ ]+) ([^ ]+) ([0-9]+)") + log '() cons)) + (done (fold-matches + (make-regexp "@ build-succeeded (.*) - (.*) (.*) (.*)") + log '() cons)) + (output (fold-matches + (make-regexp "@ build-log ([[:digit:]]+) ([[:digit:]]+)\n([A-Za-z .*]+)\n") + log '() cons)) + (drv-pid (lambda (name) + (lambda (m) + (let ((drv (match:substring m 1)) + (pid (string->number + (match:substring m 4)))) + (and (string-suffix? name drv) pid))))) + (pid-log (lambda (pid) + (lambda (m) + (let ((n (string->number + (match:substring m 1))) + (len (string->number + (match:substring m 2))) + (str (match:substring m 3))) + (and (= pid n) + (= (string-length str) (- len 1)) + str))))) + (pid1 (any (drv-pid "one.drv") started)) + (pid2 (any (drv-pid "two.drv") started))) + (list (any (pid-log pid1) output) + (any (pid-log pid2) output))))))) + (test-end "store") -- cgit v1.2.3 From f9a8fce10f2d99efec7cb1dd0f6c5f0df9d1b2df Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 15 Oct 2018 23:06:55 +0200 Subject: status: Build upon multiplexed build output. This allows for more accurate status tracking and parsing of extended build traces. * guix/status.scm (multiplexed-output-supported?): New procedure. (print-build-event): Don't print \r when PRINT-LOG? is true. Adjust 'build-log' handling for when 'multiplexed-output-supported?' returns true. (bytevector-index, split-lines): New procedures. (build-event-output-port)[%build-output-pid, %build-output] [%build-output-left]: New variables. [process-line]: Handle "@ build-output" traces. [process-build-output]: New procedure. [write!]: Add case for when %BUILD-OUTPUT-PID is true. Use 'bytevector-index' rather than 'string-index'. (compute-status): Add #:derivation-path->output-path. Use it. * tests/status.scm ("compute-status, multiplexed build output"): New test. ("build-output-port, UTF-8") ("current-build-output-port, UTF-8 + garbage"): Adjust to new 'build-log' output. * guix/scripts/build.scm (set-build-options-from-command-line): Pass #:multiplexed-build-output?. (%default-options): Add 'multiplexed-build-output?'. * guix/scripts/environment.scm (%default-options): Likewise. * guix/scripts/pack.scm (%default-options): Likewise. * guix/scripts/package.scm (%default-options): Likewise. * guix/scripts/pull.scm (%default-options): Likewise. * guix/scripts/system.scm (%default-options): Likewise. --- guix/scripts/build.scm | 3 + guix/scripts/environment.scm | 1 + guix/scripts/pack.scm | 1 + guix/scripts/package.scm | 3 +- guix/scripts/pull.scm | 1 + guix/scripts/system.scm | 1 + guix/status.scm | 169 ++++++++++++++++++++++++++++++++----------- tests/status.scm | 51 ++++++++++++- 8 files changed, 184 insertions(+), 46 deletions(-) (limited to 'tests') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index f3aa5512d5..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) 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/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 e588ff81ed..5d146b8427 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -296,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 d3fd624228..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))) 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/status.scm b/guix/status.scm index d8d761dc23..8e05d4eb76 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -116,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 @@ -142,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 @@ -219,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) @@ -313,7 +321,8 @@ 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) @@ -384,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))) @@ -428,9 +444,6 @@ 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." @@ -447,6 +460,28 @@ case where BV does not contain only valid UTF-8." (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 PROC with its current state value, initialized with SEED, on every build @@ -467,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 (maybe-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" diff --git a/tests/status.scm b/tests/status.scm index 486ad04dd2..3b74946673 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -22,7 +22,8 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports)) + #:use-module (rnrs io ports) + #:use-module (ice-9 match)) (test-begin "status") @@ -115,7 +116,7 @@ (list first (get-status))))) (test-equal "build-output-port, UTF-8" - '((build-log "lambda is λ!\n")) + '((build-log #f "lambda is λ!\n")) (let-values (((port get-status) (build-event-output-port cons '())) ((bv) (string->utf8 "lambda is λ!\n"))) (put-bytevector port bv) @@ -124,7 +125,7 @@ (test-equal "current-build-output-port, UTF-8 + garbage" ;; What about a mixture of UTF-8 + garbage? - '((build-log "garbage: �lambda: λ\n")) + '((build-log #f "garbage: �lambda: λ\n")) (let-values (((port get-status) (build-event-output-port cons '()))) (display "garbage: " port) (put-bytevector port #vu8(128)) @@ -132,4 +133,48 @@ (force-output port) (get-status))) +(test-equal "compute-status, multiplexed build output" + (list (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 999 + #:start 'now)))) + (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 42 + #:start 'now)))) + (build-status + ;; XXX: Should "bar.drv" be present twice? + (builds-completed '("bar.drv" "foo.drv")) + (downloads-completed (list (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 999 + #:start 'now + #:end 'now))))) + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now) + #:derivation-path->output-path + (match-lambda + ("bar.drv" "bar"))))))) + (display "@ build-started foo.drv 121\n" port) + (display "@ build-started bar.drv 144\n" port) + (display "@ build-log 121 6\nHello!" port) + (display "@ build-log 144 50 +@ download-started bar http://example.org/bar 999\n" port) + (let ((first (get-status))) + (display "@ build-log 121 30\n@ build-started FAKE!.drv 555\n") + (display "@ build-log 144 54 +@ download-progress bar http://example.org/bar 999 42\n" + port) + (let ((second (get-status))) + (display "@ download-succeeded bar http://example.org/bar 999\n" port) + (display "@ build-succeeded foo.drv\n" port) + (display "@ build-succeeded bar.drv\n" port) + (list first second (get-status)))))) + (test-end "status") -- cgit v1.2.3 From 278f86a43f1561b1c064ce88da012db414ec7efc Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Wed, 10 Oct 2018 16:42:02 -0500 Subject: ui: Fix port-buffering with guile@2.0. * guix/status.scm (build-event-output-port)[guile@2.0]: Do not call 'setvbuf' on custom binary port. * tests/status.scm (current-build-output-port, UTF-8 + garbage)[guile@2.0]: Use "?" in place of REPLACEMENT CHARACTER. --- guix/status.scm | 5 +++-- tests/status.scm | 5 ++++- 2 files changed, 7 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/status.scm b/guix/status.scm index 8e05d4eb76..ffa9d9e93c 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -588,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/tests/status.scm b/tests/status.scm index 3b74946673..99abb41c8b 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -125,7 +125,10 @@ (test-equal "current-build-output-port, UTF-8 + garbage" ;; What about a mixture of UTF-8 + garbage? - '((build-log #f "garbage: �lambda: λ\n")) + (let ((replacement (cond-expand + ((and guile-2 (not guile-2.2)) "?") + (else "�")))) + `((build-log #f ,(string-append "garbage: " replacement "lambda: λ\n")))) (let-values (((port get-status) (build-event-output-port cons '()))) (display "garbage: " port) (put-bytevector port #vu8(128)) -- cgit v1.2.3