fix: preserve substituter trace ordering

Drain pending substituter stderr before waking a substitution goal after the fd 4 status reply. This avoids daemon-side substituter-succeeded traces overtaking the child's final download progress trace on the client status stream.

Recheck descriptor readiness before reads because draining one descriptor can consume readiness observed by the worker's earlier select call.

.guix-authorizations

@@ -120,6 +120,8 @@
    (name "sharlatan"))
   ("F494 72F4 7A59 00D5 C235  F212 89F9 6D48 08F3 59C7"
    (name "snape"))
+  ("6688 9153 C51C 4613 A493  A525 2F0D FD14 EF99 DAC3"
+   (name "steffen"))
   ("6580 7361 3BFC C5C7 E2E4  5D45 DC51 8FC8 7F97 16AA"
    (name "vagrantc"))
   (;; primary: "C955 CC5D C048 7FB1 7966  40A9 199A F6A3 67E9 4ABB"

guix/progress.scm

@@ -23,6 +23,8 @@
   #:use-module (guix records)
   #:autoload   (guix build syscalls) (terminal-string-width)
   #:use-module (srfi srfi-19)
+  #:use-module (ice-9 ports)
+  #:use-module (ice-9 rw)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 format)
@@ -269,6 +271,50 @@ ANSI escape codes."
   ;; Default interval between subsequent outputs for rate-limited displays.
   (make-time time-duration 200000000 0))
 
+(define %maximum-atomic-trace-line-length
+  ;; POSIX guarantees writes to a pipe are atomic up to PIPE_BUF bytes.  POSIX
+  ;; requires PIPE_BUF to be at least 512 bytes; Linux uses 4096 bytes.  Guix
+  ;; trace lines are normally far smaller than this.
+  4096)
+
+(define (port-file-descriptor port)
+  "Return PORT's file descriptor, or #f if PORT is not backed by one."
+  (catch #t
+    (lambda ()
+      (fileno port))
+    (lambda _
+      #f)))
+
+(define (write-string/direct file-descriptor str)
+  "Write STR directly to FILE-DESCRIPTOR."
+  (let ((len (string-length str)))
+    (let loop ((start 0))
+      (when (< start len)
+        (let ((written (write-string/partial str file-descriptor start len)))
+          (if (zero? written)
+              (error "short trace write" str)
+              (loop (+ start written))))))))
+
+(define (write-trace-line str port)
+  "Write trace line STR to PORT.
+
+For file ports, bypass Guile's ordinary port buffering so STR is emitted as one
+kernel write in the common case.  This prevents Guix build trace lines from
+being combined with adjacent human-readable output in the daemon log stream."
+  (match (and (<= (string-length str) %maximum-atomic-trace-line-length)
+              (port-file-descriptor port))
+    (#f
+     (display str port)
+     (force-output port))
+    (file-descriptor
+     (catch #t
+       (lambda ()
+         (force-output port)
+         (write-string/direct file-descriptor str))
+       (lambda _
+         (display str port)
+         (force-output port))))))
+
 (define* (progress-reporter/file file size
                                  #:optional (log-port (current-output-port))
                                  #:key (abbreviation basename))
@@ -344,15 +390,14 @@ progress reports, write \"build trace\" lines to be processed elsewhere."
       (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))
+    (write-trace-line message log-port))
 
   (progress-reporter
    (start (lambda ()
             (set! total 0)
-            (display (format #f "@ download-started ~a ~a ~a~%"
-                             file url (or size "-"))
-                     log-port)))
+            (write-trace-line (format #f "@ download-started ~a ~a ~a~%"
+                                      file url (or size "-"))
+                              log-port)))
    (report (let ((report (rate-limited report-progress %progress-interval)))
              (lambda (transferred)
                (set! total transferred)
@@ -360,9 +405,9 @@ progress reports, write \"build trace\" lines to be processed elsewhere."
    (stop (lambda ()
            (let ((size (or size total)))
              (report-progress size)
-             (display (format #f "@ download-succeeded ~a ~a ~a~%"
-                              file url size)
-                      log-port))))))
+             (write-trace-line (format #f "@ download-succeeded ~a ~a ~a~%"
+                                       file url size)
+                               log-port))))))
 
 ;; TODO: replace '(@ (guix build utils) dump-port))'.
 (define* (dump-port* in out
@@ -425,4 +470,3 @@ the underlying connection."
                                           (stop))
                                         (when close?
                                           (close-port port))))))))
-

guix/status.scm

@@ -150,6 +150,15 @@
   (lambda (download)
     (string=? item (download-item download))))
 
+(define (valid-progress-values? size transferred)
+  "Return true when SIZE and TRANSFERRED form a sensible progress update."
+  (and (real? size)
+       (real? transferred)
+       (not (negative? size))
+       (not (negative? transferred))
+       (or (zero? size)
+           (<= transferred size))))
+
 (define %phase-start-rx
   ;; Match the "starting phase" message emitted by 'gnu-build-system'.
   (make-regexp "^starting phase [`']([^']+)'"))
@@ -255,7 +264,7 @@ compute a new status based on STATUS."
     ;; they're not as informative as 'download-started' and
     ;; 'download-succeeded'.
 
-    (('download-started item uri (= string->number size))
+    (('download-started item uri (= string->number (? 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.
@@ -270,19 +279,26 @@ compute a new status based on 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))))))
+    (('download-succeeded item uri (= string->number (? number? size)))
+     (match (find (matching-download item)
+                  (build-status-downloading status))
+       (#f
+        ;; Download traces can arrive without a tracked 'download-started'
+        ;; event due to trace ordering or spurious duplicate completion
+        ;; events.  Ignore the completion trace instead of crashing while
+        ;; trying to read fields from #f.
+        status)
+       (current
+        (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))
@@ -304,22 +320,24 @@ compute a new status based on STATUS."
                           #: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)))))
+                         (= string->number (? number? size))
+                         (= string->number (? number? transferred)))
+     (if (valid-progress-values? size 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))
     (('build-log (? integer? pid) line)
      (update-build status pid line))
     (_
@@ -571,8 +589,8 @@ The channels you are pulling from are: ~a.")
        (format port (info (G_ "downloading from ~a ...")) uri)
        (newline port)))
     (('download-progress item uri
-                         (= string->number size)
-                         (= string->number transferred))
+                         (= string->number (? number? size))
+                         (= string->number (? 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))
@@ -581,14 +599,15 @@ The channels you are pulling from are: ~a.")
          (#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
-                                       #:tty? tty?
-                                       #:start-time
-                                       (download-start download)
-                                       #:transferred transferred))))))
+          (when (valid-progress-values? size transferred)
+            (let ((uri (if (string-contains uri "/nar/")
+                           (nar-uri-abbreviation uri)
+                           (basename uri))))
+              (display-download-progress uri size
+                                         #:tty? tty?
+                                         #:start-time
+                                         (download-start download)
+                                         #:transferred transferred)))))))
     (('substituter-succeeded item _ ...)
      (when (extended-build-trace-supported?)
        ;; If there are no jobs running, we already reported download completion
@@ -705,12 +724,18 @@ found."
           (else (loop (+ 1 offset) (- count 1))))))
 
 (define (split-lines str)
-  "Split STR into lines in a way that preserves newline characters."
+  "Split STR into lines in a way that preserves newline characters.
+Treat carriage returns as line delimiters as well: progress traces emitted by
+'guix substitute' can use them, and a multiplexed build-log payload may contain
+several such traces."
   (let loop ((str str)
              (result '()))
     (if (string-null? str)
         (reverse result)
-        (match (string-index str #\newline)
+        (match (string-index str
+                             (lambda (chr)
+                               (or (char=? chr #\newline)
+                                   (char=? chr #\return))))
           (#f
            (loop "" (cons str result)))
           (index

guix/ui.scm

@@ -757,6 +757,23 @@ evaluating the tests and bodies of CLAUSES."
     (lambda () exp ...)
     #:unwind? #f))
 
+(define (system-error-message proc format-string format-args rest)
+  "Format a Guile 'system-error' payload, falling back to raw fields.
+
+Some low-level callers can raise malformed 'system-error' payloads.  Avoid
+masking the original failure with a second exception from the error reporter."
+  (catch #t
+    (lambda ()
+      (apply format #f format-string format-args))
+    (lambda (key . args)
+      (format #f
+              "unprintable system-error payload: proc=~s format=~s args=~s rest=~s formatter-error=~s"
+              proc
+              format-string
+              format-args
+              rest
+              (cons key args)))))
+
 (define (call-with-error-handling thunk)
   "Call THUNK within a user-friendly error handler."
   (define (port-filename* port)
@@ -915,9 +932,12 @@ directories:~{ ~a~}~%")
              (((exception-predicate &exception-with-kind-and-args) c)
               (if (eq? 'system-error (exception-kind c)) ;EPIPE & co.
                   (match (exception-args c)
-                    ((proc format-string format-args . _)
+                    ((proc format-string format-args . rest)
                      (leave (G_ "~a: ~a~%") proc
-                            (apply format #f format-string format-args))))
+                            (system-error-message proc
+                                                  format-string
+                                                  format-args
+                                                  rest))))
                   (raise c)))
 
              ((message-condition? c)

nix/libstore/build.cc

@@ -3698,6 +3698,9 @@ private:
        substituter.  */
     string status;
 
+    /* Drain currently pending substituter stderr. */
+    void drainSubstituterOutput();
+
     void tryNext();
 
 public:
@@ -4032,6 +4035,8 @@ void SubstitutionGoal::handleChildOutput(int fd, const string & data)
     if (fd == substituter->builderOut.readSide) {
 	/* DATA may consist of several lines.  Process them one by one.  */
 	string input = data;
+	bool gotStatus = false;
+
 	while (!input.empty()) {
 	    /* Process up to the first newline.  */
 	    size_t end = input.find_first_of("\n");
@@ -4040,13 +4045,18 @@ void SubstitutionGoal::handleChildOutput(int fd, const string & data)
 	    /* Update the goal's state accordingly.  */
 	    if (status == "") {
 		status = trimmed;
-		worker.wakeUp(shared_from_this());
+		gotStatus = true;
 	    } else {
 		printMsg(lvlError, std::format("unexpected substituter message '{}'", input));
 	    }
 
 	    input = (end != string::npos) ? input.substr(end + 1) : "";
 	}
+
+	if (gotStatus) {
+	    drainSubstituterOutput();
+	    worker.wakeUp(shared_from_this());
+	}
     }
 }
 
@@ -4057,6 +4067,40 @@ void SubstitutionGoal::handleEOF(int fd)
 }
 
 
+void SubstitutionGoal::drainSubstituterOutput()
+{
+    if (!(verbosity >= settings.buildVerbosity) || !substituter) return;
+
+    while (true) {
+	fd_set fds;
+	FD_ZERO(&fds);
+	FD_SET(substituter->fromAgent.readSide, &fds);
+
+	struct timeval timeout;
+	timeout.tv_sec = 0;
+	timeout.tv_usec = 0;
+
+	int ready = select(substituter->fromAgent.readSide + 1, &fds, 0, 0, &timeout);
+	if (ready == -1) {
+	    if (errno == EINTR) continue;
+	    throw SysError("waiting for substituter stderr");
+	}
+	if (ready == 0 || !FD_ISSET(substituter->fromAgent.readSide, &fds))
+	    return;
+
+	unsigned char buffer[4096];
+	ssize_t rd = read(substituter->fromAgent.readSide, buffer, sizeof(buffer));
+	if (rd == -1) {
+	    if (errno == EINTR) continue;
+	    throw SysError("reading from substituter stderr");
+	}
+	if (rd == 0) return;
+
+	writeToStderr(string((char *) buffer, rd));
+    }
+}
+
+
 
 //////////////////////////////////////////////////////////////////////
 
@@ -4343,6 +4387,25 @@ void Worker::waitForInput()
     time_t after = time(0);
 
     /* Process all available file descriptors. */
+    auto stillReadable = [](int fd) {
+	while (true) {
+	    fd_set probe;
+	    FD_ZERO(&probe);
+	    FD_SET(fd, &probe);
+
+	    struct timeval timeout;
+	    timeout.tv_sec = 0;
+	    timeout.tv_usec = 0;
+
+	    int ready = select(fd + 1, &probe, 0, 0, &timeout);
+	    if (ready == -1) {
+		if (errno == EINTR) continue;
+		throw SysError("checking child output readiness");
+	    }
+
+	    return ready > 0 && FD_ISSET(fd, &probe);
+	}
+    };
 
     /* Since goals may be canceled from inside the loop below (causing
        them go be erased from the `children' map), we have to be
@@ -4360,7 +4423,10 @@ void Worker::waitForInput()
 
         set<int> fds2(j->second.fds);
         for (auto& k : fds2) {
-            if (FD_ISSET(k, &fds)) {
+            /* A goal may drain another descriptor that was marked by
+               the original select() call.  Recheck before read() so
+               the worker does not block on stale readiness. */
+            if (FD_ISSET(k, &fds) && stillReadable(k)) {
                 unsigned char buffer[4096];
                 ssize_t rd = read(k, buffer, sizeof(buffer));
                 if (rd == -1) {

tests/status.scm

@@ -18,6 +18,9 @@
 
 (define-module (test-status)
   #:use-module (guix status)
+  #:use-module (guix progress)
+  #:use-module ((guix build utils)
+                #:select (call-with-temporary-output-file))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
   #:use-module (srfi srfi-71)
@@ -116,6 +119,74 @@
       (display "@ substituter-succeeded baz\n" port)
       (list first (get-status)))))
 
+(test-equal "compute-status, stray download-succeeded"
+  (build-status)
+  (let ((port get-status
+              (build-event-output-port (lambda (event status)
+                                         (compute-status event status
+                                                         #:current-time
+                                                         (const 'now))))))
+    (display "@ download-succeeded bar http://example.org/bar 999\n" port)
+    (get-status)))
+
+(test-equal "compute-status, malformed download-progress"
+  (build-status
+   (downloading (list (download "bar" "http://example.org/bar"
+                                #:size 999
+                                #:start 'now))))
+  (let ((port get-status
+              (build-event-output-port (lambda (event status)
+                                         (compute-status event status
+                                                         #:current-time
+                                                         (const 'now))))))
+    (display "@ download-started bar http://example.org/bar 999\n" port)
+    (display "@ download-progress bar http://example.org/bar 999 nope\n" port)
+    (get-status)))
+
+(test-equal "progress-reporter/trace, complete trace lines"
+  (string-append "@ download-started bar http://example.org/bar 999\n"
+                 "@ download-progress bar http://example.org/bar 999 42\n"
+                 "@ download-progress bar http://example.org/bar 999 999\n"
+                 "@ download-succeeded bar http://example.org/bar 999\n")
+  (call-with-temporary-output-file
+   (lambda (file port)
+     (let ((reporter (progress-reporter/trace "bar" "http://example.org/bar"
+                                              999 port)))
+       (start-progress-reporter! reporter)
+       (progress-reporter-report! reporter 42)
+       (stop-progress-reporter! reporter)
+       (force-output port)
+       (call-with-input-file file get-string-all)))))
+
+(test-equal "compute-status, overrun download-progress"
+  (build-status
+   (downloading (list (download "bar" "http://example.org/bar"
+                                #:size 999
+                                #:start 'now))))
+  (let ((port get-status
+              (build-event-output-port (lambda (event status)
+                                         (compute-status event status
+                                                         #:current-time
+                                                         (const 'now))))))
+    (display "@ download-started bar http://example.org/bar 999\n" port)
+    (display "@ download-progress bar htt@ 999 1000\n" port)
+    (get-status)))
+
+(test-assert "print-build-event, overrun download-progress"
+  (let ((output (open-output-string)))
+    (call-with-values
+        (lambda ()
+          (build-event-output-port
+           (build-status-updater
+            (lambda (event old-status status)
+              (print-build-event/quiet event old-status status output
+                                       #:colorize? #f)))))
+      (lambda (port get-status)
+        (display "@ download-started bar http://example.org/bar 999\n" port)
+        (display "@ download-progress bar htt@ 999 1000\n" port)
+        (force-output port)
+        (build-status? (get-status))))))
+
 (test-equal "build-output-port, UTF-8"
   '((build-log #f "lambda is λ!\n"))
   (let ((port get-status (build-event-output-port cons '()))
@@ -149,6 +220,19 @@
     (force-output port)
     (get-status)))
 
+(test-equal "build-output-port, multiplexed CR-delimited traces"
+  '((download-started "bar" "http://example.org/bar" "999")
+    (build-log 121 "@ substituter-succeeded bar\n"))
+  (let* ((port get-status (build-event-output-port cons '()))
+         (payload (string->utf8
+                   "@ download-started bar http://example.org/bar 999\r@ substituter-succeeded bar\n")))
+    (display (format #f "@ build-log 121 ~a\n"
+                     (bytevector-length payload))
+             port)
+    (put-bytevector port payload)
+    (force-output port)
+    (reverse (get-status))))
+
 (test-equal "compute-status, multiplexed build output"
   (list (build-status
          (building (list (build "foo.drv" "x86_64-linux" #:id 121)))