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.
This commit is contained in:
Ludovic Courtès
parent
4056ba3645
commit
1c10c2751a
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue