build-self: Forward sub-process build output to (current-build-output-port).

Fixes <https://bugs.gnu.org/41930>.

* build-aux/build-self.scm (build-program): Add extra 'build-output'
parameter.  Interpret it as a socket name and connect to it; use it as
the CURRENT-BUILD-OUTPUT-PORT.
(proxy): New procedure.
(build): Open a named socket.  Accept connections and call 'proxy' on it.

1 files changed, 65 insertions, 25 deletions

diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index dd845d1596..3e057ca5d2 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -336,7 +336,8 @@ interface (FFI) of Guile.")
                             (loop (cdr spin)))))
 
                       (match (command-line)
-                        ((_ source system version protocol-version)
+                        ((_ source system version protocol-version
+                            build-output)
                          ;; The current input port normally wraps a file
                          ;; descriptor connected to the daemon, or it is
                          ;; connected to /dev/null.  In the former case, reuse
@@ -349,16 +350,22 @@ interface (FFI) of Guile.")
                                                               (current-input-port)
                                                               "w+0")
                                                              #:version proto)
-                                           (open-connection))))
+                                           (open-connection)))
+                                (sock  (socket AF_UNIX SOCK_STREAM 0)))
                            (call-with-new-thread
                             (lambda ()
                               (spin system)))
 
+                           ;; Connect to BUILD-OUTPUT and send it the raw
+                           ;; build output.
+                           (connect sock AF_UNIX build-output)
+
                            (display
                             (and=>
                              ;; Silence autoload warnings and the likes.
                              (parameterize ((current-warning-port
-                                             (%make-void-port "w")))
+                                             (%make-void-port "w"))
+                                            (current-build-output-port sock))
                                (run-with-store store
                                  (guix-derivation source version
                                                   #$guile-version
@@ -370,6 +377,20 @@ interface (FFI) of Guile.")
                              derivation-file-name))))))
                   #:module-path (list source))))
 
+(define (proxy input output)
+  "Dump the contents of INPUT to OUTPUT until EOF is reached on INPUT."
+  (setvbuf input 'block 16384)
+  (let loop ()
+    (match (select (list input) '() '())
+      ((() () ())
+       (loop))
+      (((_) () ())
+       ;; Read from INPUT as much as can be read without blocking.
+       (let ((bv (get-bytevector-some input)))
+         (unless (eof-object? bv)
+           (put-bytevector output bv)
+           (loop)))))))
+
 (define (call-with-clean-environment thunk)
   (let ((env (environ)))
     (dynamic-wind
@@ -426,7 +447,14 @@ files."
       ;; way, we know 'open-pipe*' will not close it on 'exec'.  If PORT is
       ;; not a file port (e.g., it's an SSH channel), then the subprocess's
       ;; stdin will actually be /dev/null.
-      (let* ((pipe   (with-input-from-port port
+      (let* ((sock   (socket AF_UNIX SOCK_STREAM 0))
+             (node   (let ((file (string-append (or (getenv "TMPDIR") "/tmp")
+                                                "/guix-build-output-"
+                                                (number->string (getpid)))))
+                       (bind sock AF_UNIX file)
+                       (listen sock 1)
+                       file))
+             (pipe   (with-input-from-port port
                        (lambda ()
                          ;; Make sure BUILD is not influenced by
                          ;; $GUILE_LOAD_PATH & co.
@@ -442,30 +470,42 @@ files."
                                       (if (file-port? port)
                                           (number->string
                                            (logior major minor))
-                                          "none"))))))
-             (str    (get-string-all pipe))
-             (status (close-pipe pipe)))
-        (match str
-          ((? eof-object?)
-           (error "build program failed" (list build status)))
-          ((? derivation-path? drv)
-           (mbegin %store-monad
-             (return (newline (current-error-port)))
-             ((store-lift add-temp-root) drv)
-             (return (read-derivation-from-file drv))))
-          ("#f"
-           ;; Unsupported PULL-VERSION.
-           (return #f))
-          ((? string? str)
-           (raise (condition
-                   (&message
-                    (message (format #f "You found a bug: the program '~a'
+                                          "none")
+                                      node))))))
+        ;; Wait for a connection on SOCK and proxy build output so it can be
+        ;; processed according to the settings currently in effect (build
+        ;; traces, verbosity level, and so on).
+        (match (accept sock)
+          ((port . _)
+           (close-port sock)
+           (delete-file node)
+           (proxy port (current-build-output-port))))
+
+        ;; Now that the build output connection was closed, read the result, a
+        ;; derivation file name, from PIPE.
+        (let ((str    (get-string-all pipe))
+              (status (close-pipe pipe)))
+          (match str
+            ((? eof-object?)
+             (error "build program failed" (list build status)))
+            ((? derivation-path? drv)
+             (mbegin %store-monad
+               (return (newline (current-error-port)))
+               ((store-lift add-temp-root) drv)
+               (return (read-derivation-from-file drv))))
+            ("#f"
+             ;; Unsupported PULL-VERSION.
+             (return #f))
+            ((? string? str)
+             (raise (condition
+                     (&message
+                      (message (format #f "You found a bug: the program '~a'
 failed to compute the derivation for Guix (version: ~s; system: ~s;
 host version: ~s; pull-version: ~s).
 Please report it by email to <~a>.~%"
-                                     (derivation->output-path build)
-                                     version system %guix-version pull-version
-                                     %guix-bug-report-address)))))))))))
+                                       (derivation->output-path build)
+                                       version system %guix-version pull-version
+                                       %guix-bug-report-address))))))))))))
 
 ;; This file is loaded by 'guix pull'; return it the build procedure.
 build