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

@@ -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)

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)

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))))

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]...

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)))
 

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")

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
+                                   (derivation-path->output-path drv))
-                                    (read-derivation-from-file 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,13 +393,20 @@ addition to build events."
   expected hash: ~a
   actual hash:   ~a~%"))
              expected actual))
-    (('build-log line)
+    (('build-log pid line)
-     ;; TODO: Better distinguish daemon messages and build log lines.
+     (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.
-            (format port line)
+                (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
@@ -398,7 +414,7 @@ addition to build events."
                 (display (info (string-trim-right line)) port)
                 (newline))
                (else
-            (print-log-line line))))
+                (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,32 +502,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-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)
+    (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))))
+                      %state)))))
-        (set! %state (proc (list 'build-log line)
+          (else
-                           %state))))
+           (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))))
+    (if %build-output-pid
-      (match (string-index str %newline)
+        (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 (string-take str (+ 1 cr))))
+           (let* ((tail (maybe-utf8->string
-           (process-line (string-concatenate-reverse
+                         (bytevector-range bv offset (- cr -1 offset))))
-                          (cons tail %fragments)))
+                  (line (string-concatenate-reverse
+                         (cons tail %fragments))))
+             (process-line line)
              (set! %fragments '())
-           (loop (string-drop str (+ 1 cr)))))
+             (- cr -1 offset)))
           (#f
-         (unless (string-null? str)
+           (unless (zero? count)
-           (set! %fragments (cons str %fragments)))
+             (let ((str (maybe-utf8->string
+                         (bytevector-range bv offset count))))
+               (set! %fragments (cons str %fragments))))
            count))))
 
   (define port

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: <20>lambda: λ\n"))
+  '((build-log #f "garbage: <20>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")