me
/
guix
Archived
1
0
Fork 0
Code

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
build-aux/build-self.scm
View File

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