diff options
| -rw-r--r-- | build-aux/build-self.scm | 90 |
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 |