me
/
guix
Archived
1
0
Fork 0

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.
master
Ludovic Courtès 2021-03-30 16:07:26 +02:00
parent 4056ba3645
commit 1c10c2751a
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 65 additions and 25 deletions

View File

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