fix: ignore invalid Guix progress updates

Reject nonsensical download-progress values before updating status or rendering progress. This keeps malformed trace fragments from producing invalid progress math while preserving the previous behavior for ordinary malformed non-numeric events.\n\nCover both status reduction and quiet event rendering with overrun progress tests.

(cherry picked from commit d240c0dc76)

.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 [`']([^']+)'"))
@@ -271,18 +280,25 @@ compute a new status based on STATUS."
                                    #: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))))))
+     (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))
     (_
@@ -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
@@ -704,13 +723,22 @@ found."
           ((memv (bytevector-u8-ref bv offset) numbers) offset)
           (else (loop (+ 1 offset) (- count 1))))))
 
+(define (line-delimiter? chr)
+  ;; Either '\n' or '\r' delimits a record in the daemon's trace stream:
+  ;; '\n' terminates ordinary trace events and log lines, '\r' is used by
+  ;; 'guix substitute' to redraw in-line progress.
+  (or (char=? chr #\newline)
+      (char=? chr #\return)))
+
 (define (split-lines str)
-  "Split STR into lines in a way that preserves newline characters."
+  "Split STR into lines, treating '\\n' and '\\r' as record delimiters and
+preserving the delimiter in each resulting line.  Trailing input without a
+delimiter is returned as the final element."
   (let loop ((str str)
              (result '()))
     (if (string-null? str)
         (reverse result)
-        (match (string-index str #\newline)
+        (match (string-index str line-delimiter?)
           (#f
            (loop "" (cons str result)))
           (index
@@ -744,6 +772,13 @@ The second return value is a thunk to retrieve the current state."
   (define %build-output '())
   (define %build-output-left #f)
 
+  ;; Hash table mapping PID -> partial-line string carried over from a
+  ;; previous "@ build-log" frame.  A single trace record can span
+  ;; consecutive frames when the daemon's read() of the child's pipe falls
+  ;; between bytes of the record; without per-PID carry-over the fragments
+  ;; would each be parsed as a separate (malformed) event.
+  (define %build-output-fragments (make-hash-table))
+
   (define (process-line line)
     (cond ((string-prefix? "@ " line)
            ;; Note: Drop the trailing \n, and use 'string-split' to preserve
@@ -765,7 +800,11 @@ The second return value is a thunk to retrieve the current state."
 
   (define (process-build-output pid output)
     ;; Transform OUTPUT in 'build-log' events or download events as generated
-    ;; by extended build traces.
+    ;; by extended build traces.  OUTPUT is the payload of a single
+    ;; "@ build-log PID LENGTH" frame; the daemon may have split a single
+    ;; record across consecutive frames, so combine OUTPUT with any partial
+    ;; line carried over for PID and re-buffer whatever trails the last
+    ;; delimiter.
     (define (line->event line)
       (match (and (string-prefix? "@ " line)
                   (string-tokenize (string-drop line 2)))
@@ -777,9 +816,32 @@ The second return value is a thunk to retrieve the current state."
         (_
          `(build-log ,pid ,line))))
 
-    (let* ((lines  (split-lines output))
-           (events (map line->event lines)))
-      (set! %state (fold proc %state events))))
+    (define (handle-trailing-partial partial)
+      ;; A trailing fragment without a terminator: hold it back only if it
+      ;; looks like the head of a pending trace record ('@ ' prefix), so a
+      ;; record split across frames reassembles into a single event.  Free-
+      ;; form log fragments are flushed eagerly to preserve the streamy feel
+      ;; of build output and to match prior per-frame semantics.
+      (cond
+       ((string-null? partial)
+        (hash-remove! %build-output-fragments pid))
+       ((string-prefix? "@ " partial)
+        (hash-set! %build-output-fragments pid partial))
+       (else
+        (hash-remove! %build-output-fragments pid)
+        (set! %state (proc `(build-log ,pid ,partial) %state)))))
+
+    (let* ((prev     (hash-ref %build-output-fragments pid ""))
+           (combined (if (string-null? prev) output (string-append prev output))))
+      (match (string-rindex combined line-delimiter?)
+        (#f
+         (handle-trailing-partial combined))
+        (last
+         (let* ((complete (string-take combined (+ last 1)))
+                (partial  (string-drop combined (+ last 1)))
+                (events   (map line->event (split-lines complete))))
+           (set! %state (fold proc %state events))
+           (handle-trailing-partial partial))))))
 
   (define (bytevector-range bv offset count)
     (let ((ptr (bytevector->pointer bv offset)))

guix/ui.scm

@@ -866,6 +866,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)
@@ -1024,9 +1041,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

@@ -3719,6 +3719,19 @@ private:
        substituter.  */
     string status;
 
+    /* Wrap DATA with the '@ build-log PID LENGTH\n' framing used by
+       'multiplexedBuildOutput' and write it to the daemon's standard error,
+       or write DATA raw when multiplexing is disabled.  Used for the
+       substituter's stderr, which carries '@ download-*' progress traces. */
+    void writeFramedToStderr(const string & data);
+
+    /* Drain any bytes currently pending on the substituter's stderr and
+       forward them, framed, to the daemon's standard error.  Called before
+       waking the goal in reaction to a status reply on builderOut, so that
+       trailing progress traces reach the client before goal-emitted events
+       such as '@ substituter-succeeded'. */
+    void drainFromAgent();
+
     void tryNext();
 
 public:
@@ -4041,11 +4054,66 @@ void SubstitutionGoal::finished()
 }
 
 
+void SubstitutionGoal::writeFramedToStderr(const string & data)
+{
+    if (data.empty()) return;
+
+    if (settings.multiplexedBuildOutput) {
+	/* Wrap the chunk in an '@ build-log PID LENGTH\n<payload>' frame, the
+	   same framing 'DerivationGoal' uses for builder output.  This keeps
+	   progress traces of one substituter attributable on the client side
+	   and prevents them from being interleaved at byte granularity with
+	   unrelated daemon output. */
+	string prefix = "@ build-log "
+	    + std::to_string(substituter->pid)
+	    + " " + std::to_string(data.size()) + "\n";
+	writeToStderr(prefix + data);
+    } else {
+	writeToStderr(data);
+    }
+}
+
+
+void SubstitutionGoal::drainFromAgent()
+{
+    if (verbosity < settings.buildVerbosity || !substituter) return;
+
+    int fd = substituter->fromAgent.readSide;
+
+    while (true) {
+	fd_set readable;
+	FD_ZERO(&readable);
+	FD_SET(fd, &readable);
+
+	struct timeval timeout;
+	timeout.tv_sec = 0;
+	timeout.tv_usec = 0;
+
+	int ready = select(fd + 1, &readable, 0, 0, &timeout);
+	if (ready == -1) {
+	    if (errno == EINTR) continue;
+	    throw SysError("polling substituter stderr");
+	}
+	if (ready == 0 || !FD_ISSET(fd, &readable)) return;
+
+	unsigned char buffer[4096];
+	ssize_t rd = read(fd, buffer, sizeof(buffer));
+	if (rd == -1) {
+	    if (errno == EINTR) continue;
+	    throw SysError("reading substituter stderr");
+	}
+	if (rd == 0) return;
+
+	writeFramedToStderr(string((char *) buffer, rd));
+    }
+}
+
+
 void SubstitutionGoal::handleChildOutput(int fd, const string & data)
 {
-    if (verbosity >= settings.buildVerbosity
-	&& fd == substituter->fromAgent.readSide) {
-	writeToStderr(data);
+    if (fd == substituter->fromAgent.readSide
+	&& verbosity >= settings.buildVerbosity) {
+	writeFramedToStderr(data);
 	/* Don't write substitution output to a log file for now.  We
 	   probably should, though. */
     }
@@ -4053,6 +4121,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");
@@ -4061,13 +4131,22 @@ 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) {
+	    /* Drain any trailing progress traces that the substituter wrote on
+	       'fromAgent' before its status reply, so they reach the client
+	       ahead of the '@ substituter-succeeded' the goal will emit once
+	       the wake-up advances its state machine. */
+	    drainFromAgent();
+	    worker.wakeUp(shared_from_this());
+	}
     }
 }
 
@@ -4363,7 +4442,31 @@ void Worker::waitForInput()
 
     time_t after = time(0);
 
-    /* Process all available file descriptors. */
+    /* Process all available file descriptors.
+
+       A goal's handleChildOutput may opportunistically drain another
+       descriptor that the original select() already marked ready (the
+       substituter status path does this to preserve trace ordering).  Probe
+       readiness again before each read so the worker does not block on a
+       descriptor that has been consumed in this same dispatch cycle. */
+    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("rechecking 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
@@ -4381,7 +4484,7 @@ void Worker::waitForInput()
 
         set<int> fds2(j->second.fds);
         for (auto& k : fds2) {
-            if (FD_ISSET(k, &fds)) {
+            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,60 @@
       (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 "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 '()))
@@ -179,7 +236,7 @@
                                                            ("bar.drv" "bar")))))))
     (display "@ build-started foo.drv - x86_64-linux  121\n" port)
     (display "@ build-started bar.drv - armhf-linux bar.log 144\n" port)
-    (display "@ build-log 121 6\nHello!" port)
+    (display "@ build-log 121 6\nHello\n" port)
     (display "@ build-log 144 50
 @ download-started bar http://example.org/bar 999\n" port)
     (let ((first (get-status)))
@@ -193,6 +250,116 @@
         (display "@ build-succeeded bar.drv\n" port)
         (list first second (get-status))))))
 
+(define (frame pid payload)
+  ;; Build an '@ build-log PID LENGTH\\n<payload>' frame for use in tests.
+  (string-append "@ build-log " (number->string pid) " "
+                 (number->string (string-length payload))
+                 "\n" payload))
+
+(test-equal "compute-status, substituter trace inside @ build-log frame"
+  ;; The daemon now wraps substituter stderr in '@ build-log PID LENGTH'
+  ;; frames.  A download trace delivered through such a frame must drive
+  ;; status as if it had arrived on the top-level stream.
+  (build-status
+   (downloading (list (download "bar" "http://example.org/bar"
+                                #:size 999
+                                #:transferred 250
+                                #:start 'now))))
+  (let ((port get-status
+              (build-event-output-port (lambda (event status)
+                                         (compute-status event status
+                                                         #:current-time
+                                                         (const 'now))))))
+    (display (frame 7 "@ download-started bar http://example.org/bar 999\n")
+             port)
+    (display (frame 7 "@ download-progress bar http://example.org/bar 999 250\n")
+             port)
+    (get-status)))
+
+(test-equal "compute-status, trace record split across frames for same PID"
+  ;; A single trace record may straddle two consecutive '@ build-log' frames
+  ;; for the same PID when the daemon's read() of the substituter pipe falls
+  ;; mid-record.  The parser must reassemble it instead of treating each
+  ;; fragment as its own event.
+  (build-status
+   (downloading (list (download "bar" "http://example.org/bar"
+                                #:size 999
+                                #:transferred 500
+                                #:start 'now))))
+  (let* ((port get-status
+               (build-event-output-port (lambda (event status)
+                                          (compute-status event status
+                                                          #:current-time
+                                                          (const 'now)))))
+         (record "@ download-progress bar http://example.org/bar 999 500\n")
+         (mid    (quotient (string-length record) 2))
+         (head   (substring record 0 mid))
+         (tail   (substring record mid)))
+    (display (frame 7 "@ download-started bar http://example.org/bar 999\n")
+             port)
+    (display (frame 7 head) port)
+    (display (frame 7 tail) port)
+    (get-status)))
+
+(test-equal "compute-status, CR-delimited progress inside a frame"
+  ;; 'guix substitute' redraws in-line progress with '\\r' between updates;
+  ;; CRs inside a framed payload must be treated as record delimiters.
+  (build-status
+   (downloading (list (download "bar" "http://example.org/bar"
+                                #:size 999
+                                #:transferred 600
+                                #:start 'now))))
+  (let ((port get-status
+              (build-event-output-port (lambda (event status)
+                                         (compute-status event status
+                                                         #:current-time
+                                                         (const 'now))))))
+    (display (frame 7 "@ download-started bar http://example.org/bar 999\n")
+             port)
+    (display (frame 7
+                    (string-append
+                     "@ download-progress bar http://example.org/bar 999 200\r"
+                     "@ download-progress bar http://example.org/bar 999 400\r"
+                     "@ download-progress bar http://example.org/bar 999 600\n"))
+             port)
+    (get-status)))
+
+(test-equal "compute-status, partial lines do not cross PID boundaries"
+  ;; Two substituter processes have separate per-PID buffers; a partial
+  ;; record from PID 7 must not be glued to PID 8's frame.  Both downloads
+  ;; must reach their final progress; 'one' completes last and therefore
+  ;; sits at the head of the most-recently-updated list.
+  (build-status
+   (downloading (list (download "one" "http://example.org/one"
+                                #:size 100
+                                #:transferred 50
+                                #:start 'now)
+                      (download "two" "http://example.org/two"
+                                #:size 200
+                                #:transferred 100
+                                #:start 'now))))
+  (let* ((port get-status
+               (build-event-output-port (lambda (event status)
+                                          (compute-status event status
+                                                          #:current-time
+                                                          (const 'now)))))
+         (one    "@ download-progress one http://example.org/one 100 50\n")
+         (mid    (quotient (string-length one) 2))
+         (one-head (substring one 0 mid))
+         (one-tail (substring one mid)))
+    (display (frame 7 "@ download-started one http://example.org/one 100\n")
+             port)
+    (display (frame 8 "@ download-started two http://example.org/two 200\n")
+             port)
+    ;; Partial record on PID 7.
+    (display (frame 7 one-head) port)
+    ;; A complete record on PID 8 that must not pick up PID 7's tail.
+    (display (frame 8 "@ download-progress two http://example.org/two 200 100\n")
+             port)
+    ;; Now finish PID 7's record.
+    (display (frame 7 one-tail) port)
+    (get-status)))
+
 (test-equal "compute-status, build completion"
   (list (build-status
          (building (list (build "foo.drv" "x86_64-linux" #:id 121))))
@@ -211,16 +378,16 @@
                                                          #:current-time
                                                          (const 'now))))))
     (display "@ build-started foo.drv - x86_64-linux  121\n" port)
-    (display "@ build-log 121 6\nHello!" port)
+    (display "@ build-log 121 6\nHello\n" port)
     (let ((first (get-status)))
       (display "@ build-log 121 20\n[ 0/100] building X\n" port)
-      (display "@ build-log 121 6\nHello!" port)
+      (display "@ build-log 121 6\nHello\n" port)
       (let ((second (get-status)))
         (display "@ build-log 121 20\n[50/100] building Y\n" port)
-        (display "@ build-log 121 6\nHello!" port)
+        (display "@ build-log 121 6\nHello\n" port)
         (let ((third (get-status)))
           (display "@ build-log 121 21\n[100/100] building Z\n" port)
-          (display "@ build-log 121 6\nHello!" port)
+          (display "@ build-log 121 6\nHello\n" port)
           (display "@ build-succeeded foo.drv\n" port)
           (list first second third (get-status)))))))