[bug#32980] [PATCH 0/2] Multiplexed build output from the daemon

[bug#32980] [PATCH 0/2] Multiplexed build output from the daemon

[Ludovic Courtès]

Hello Guix!

This patch set is partly a response to the problem Ricardo raised at:

  https://lists.gnu.org/archive/html/guix-devel/2018-09/msg00322.html

and partly a natural followup to the addition of (guix status):

  https://issues.guix.info/issue/32837

So far the daemon would send all its output (messages it writes as well as
messages any of its build processes writes) directly as a single stream
to its clients.  This had several shortcomings:

  1. Clients could not distinguish messages coming from the daemon (such
     as build traces or ‘guix substitute’ messages) from messages coming
     from build processes.  (Notably build processes could “forge” build
     traces such as “@ build-started”.)

  2. When max-jobs > 1, clients would receive intermingled output from all
     the build processes without any way to disentangle it.

  3. Build traces written by the daemon were expected to start on a new
     line but a builder could write output not terminated by a newline
     (e.g., “checking for …” messages from ./configure) and consequently
     build traces would not start on a new line and would go unnoticed
     by (guix status) and co.

With this change clients can optionally ask for “multiplexed build
output”.  When it’s enabled, build output is prefixed by a special
trace, like this:

  @ build-output 1234 21
  checking for fcntl...

where 1234 is the PID of the build process speaking and 21 is the number
of bytes in the following build output fragment.  The PID is first given
in the corresponding “@ build-started” trace.

On the client side, (guix status) is adjusted to produce events like:

  (build-log #f MESSAGE)

for a message coming from the daemon, and:

  (build-log PID MESSAGE)

for a message coming from PID.

The downside of the protocol is that it creates quite some overhead.  For
example, when extracting a tarball, we see things like:

  read(13, "gmlo\0\0\0\0", 8)             = 8
  read(13, "5\0\0\0\0\0\0\0", 8)          = 8
  read(13, "@ build-output 25935 29\ncoreutils-8.29/m4/fseterr.m4\n", 53) = 53
  read(13, "\0\0\0", 3)                   = 3

That is, a 29-byte message with a 24-byte header (plus the
8 + 8 + 3 = 19 bytes of the underlying protocol; see ‘process-stderr’.)

Another option would be to incorporate multiplexing in the lower-level
binary protocol.  However, the client side would need potentially bigger
changes: the single ‘current-build-output-port’ sink would no longer
be a good match.

Thoughts?

Ludo’.

Ludovic Courtès (2):
  daemon: Support multiplexed build output.
  status: Build upon multiplexed build output.

 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                 | 165 ++++++++++++++++++++++++--------
 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/status.scm                |  47 ++++++++-
 tests/store.scm                 |  63 ++++++++++++
 15 files changed, 289 insertions(+), 51 deletions(-)

-- 
2.19.0

[bug#32980] [PATCH 1/2] daemon: Support multiplexed build output.

[Ludovic Courtès]

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) <wopSetOptions>: 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(-)

diff --git a/guix/store.scm b/guix/store.scm
index 8b35fc8d7..00e975ae2 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-output" 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 b2c319f00..e50bd8585 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-output "
+	    + 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 94c2e516f..4b5b485e6 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 4c142e693..a6935c333 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 <drvpath> <outpath> <system> <logfile>
+       @ build-started <drvpath> <outpath> <system> <logfile> <pid>
        @ build-failed <drvpath> <outpath> <exitcode> <error text>
        @ build-succeeded <drvpath> <outpath>
        @ substituter-started <outpath> <substituter>
@@ -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 103d60a8c..ea67b10a5 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 782e4acfc..293942217 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 285836970..fad286cd6 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 valid "@ build-output" 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-output ([[: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")
-- 
2.19.0

[bug#32980] [PATCH 2/2] status: Build upon multiplexed build output.

[Ludovic Courtès]

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.
* 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              | 165 ++++++++++++++++++++++++++---------
 tests/status.scm             |  47 +++++++++-
 8 files changed, 181 insertions(+), 41 deletions(-)

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 5a6ba62bc..ebdaaaa05 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 9fc7edcd3..5965e3426 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 163f5b1dc..fb3c50521 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 93a77915f..d8cffacd7 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -332,7 +332,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 803f7cf14..0eb94a10f 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 f9d6b9e5b..f9af38b7c 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 c6956066f..428d51e0f 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -115,7 +115,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 +144,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 +220,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-output\" traces."
+  (and (current-store-protocol-version)
+       (>= (current-store-protocol-version) #x163)))
+
 (define spin!
   (let ((steps (circular-list "\\" "|" "/" "-")))
     (lambda (port)
@@ -312,7 +320,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)
@@ -382,21 +391,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)))
 
@@ -429,6 +445,28 @@ ON-CHANGE can display the build status, build events, etc."
 (define %newline
   (char-set #\return #\newline))
 
+(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
@@ -449,33 +487,82 @@ 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-output" 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-output" (= 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 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 (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 (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 04dedb702..9d051dc86 100644
--- a/tests/status.scm
+++ b/tests/status.scm
@@ -20,7 +20,8 @@
   #: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 (ice-9 match))
 
 (test-begin "status")
 
@@ -112,4 +113,48 @@
       (display "@ substituter-succeeded baz\n" port)
       (list first (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-output 121 6\nHello!" port)
+    (display "@ build-output 144 50
+@ download-started bar http://example.org/bar 999\n" port)
+    (let ((first (get-status)))
+      (display "@ build-output 121 30\n@ build-started FAKE!.drv 555\n")
+      (display "@ build-output 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")
-- 
2.19.0

bug#32980: [PATCH 0/2] Multiplexed build output from the daemon

[Ludovic Courtès]

Hello,

Ludovic Courtès <ludo@gnu.org> skribis:

> The downside of the protocol is that it creates quite some overhead.  For
> example, when extracting a tarball, we see things like:
>
>   read(13, "gmlo\0\0\0\0", 8)             = 8
>   read(13, "5\0\0\0\0\0\0\0", 8)          = 8
>   read(13, "@ build-output 25935 29\ncoreutils-8.29/m4/fseterr.m4\n", 53) = 53
>   read(13, "\0\0\0", 3)                   = 3
>
> That is, a 29-byte message with a 24-byte header (plus the
> 8 + 8 + 3 = 19 bytes of the underlying protocol; see ‘process-stderr’.)

I timed “guix build -S binutils --check”, which includes the output of
“tar xvf” followed by “tar cvf”, and the timing difference is not
noticeable (of course the peak of CPU activity is caused by xz.)

Anyway I went ahead and pushed this as
f9a8fce10f2d99efec7cb1dd0f6c5f0df9d1b2df.

I changed “@ build-output” to “@ build-log”, and also adjusted
tests/status.scm since new tests had been added to that file in the
meantime.

Ludo’.