diff options
Diffstat (limited to 'guix/inferior.scm')
| -rw-r--r-- | guix/inferior.scm | 169 |
1 files changed, 105 insertions, 64 deletions
diff --git a/guix/inferior.scm b/guix/inferior.scm index a997c3ead4..1c19527b8f 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -25,6 +25,7 @@ #:select (source-properties->location)) #:use-module ((guix utils) #:select (%current-system + call-with-temporary-directory version>? version-prefix? cache-directory)) #:use-module ((guix store) @@ -35,8 +36,6 @@ &store-protocol-error)) #:use-module ((guix derivations) #:select (read-derivation-from-file)) - #:use-module ((guix build syscalls) - #:select (mkdtemp!)) #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix profiles) @@ -56,7 +55,6 @@ #:use-module (srfi srfi-71) #:autoload (ice-9 ftw) (scandir) #:use-module (ice-9 match) - #:use-module (ice-9 popen) #:use-module (ice-9 vlist) #:use-module (ice-9 binary-ports) #:use-module ((rnrs bytevectors) #:select (string->utf8)) @@ -114,7 +112,7 @@ ;; Inferior Guix process. (define-record-type <inferior> (inferior pid socket close version packages table - bridge-file-name bridge-socket) + bridge-socket) inferior? (pid inferior-pid) (socket inferior-socket) @@ -124,8 +122,6 @@ (table inferior-package-table) ;promise of vhash ;; Bridging with a store. - (bridge-file-name inferior-bridge-file-name ;#f | string - set-inferior-bridge-file-name!) (bridge-socket inferior-bridge-socket ;#f | port set-inferior-bridge-socket!)) @@ -138,37 +134,69 @@ (set-record-type-printer! <inferior> write-inferior) +(define (open-bidirectional-pipe command . args) + "Open a bidirectional pipe to COMMAND invoked with ARGS and return it, as a +regular file port (socket). + +This is equivalent to (open-pipe* OPEN_BOTH ...) except that the result is a +regular file port that can be passed to 'select' ('open-pipe*' returns a +custom binary port)." + (match (socketpair AF_UNIX SOCK_STREAM 0) + ((parent . child) + (match (primitive-fork) + (0 + (dynamic-wind + (lambda () + #t) + (lambda () + (close-port parent) + (close-fdes 0) + (close-fdes 1) + (dup2 (fileno child) 0) + (dup2 (fileno child) 1) + ;; Mimic 'open-pipe*'. + (unless (file-port? (current-error-port)) + (close-fdes 2) + (dup2 (open-fdes "/dev/null" O_WRONLY) 2)) + (apply execlp command command args)) + (lambda () + (primitive-_exit 127)))) + (pid + (close-port child) + (values parent pid)))))) + (define* (inferior-pipe directory command error-port) - "Return an input/output pipe on the Guix instance in DIRECTORY. This runs -'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if -it's an old Guix." - (let ((pipe (with-error-to-port error-port - (lambda () - (open-pipe* OPEN_BOTH - (string-append directory "/" command) - "repl" "-t" "machine"))))) + "Return two values: an input/output pipe on the Guix instance in DIRECTORY +and its PID. This runs 'DIRECTORY/COMMAND repl' if it exists, or falls back +to some other method if it's an old Guix." + (let ((pipe pid (with-error-to-port error-port + (lambda () + (open-bidirectional-pipe + (string-append directory "/" command) + "repl" "-t" "machine"))))) (if (eof-object? (peek-char pipe)) (begin - (close-pipe pipe) + (close-port pipe) ;; Older versions of Guix didn't have a 'guix repl' command, so ;; emulate it. (with-error-to-port error-port (lambda () - (open-pipe* OPEN_BOTH "guile" - "-L" (string-append directory "/share/guile/site/" - (effective-version)) - "-C" (string-append directory "/share/guile/site/" - (effective-version)) - "-C" (string-append directory "/lib/guile/" - (effective-version) "/site-ccache") - "-c" - (object->string - `(begin - (primitive-load ,(search-path %load-path - "guix/repl.scm")) - ((@ (guix repl) machine-repl)))))))) - pipe))) + (open-bidirectional-pipe + "guile" + "-L" (string-append directory "/share/guile/site/" + (effective-version)) + "-C" (string-append directory "/share/guile/site/" + (effective-version)) + "-C" (string-append directory "/lib/guile/" + (effective-version) "/site-ccache") + "-c" + (object->string + `(begin + (primitive-load ,(search-path %load-path + "guix/repl.scm")) + ((@ (guix repl) machine-repl)))))))) + (values pipe pid)))) (define* (port->inferior pipe #:optional (close close-port)) "Given PIPE, an input/output port, return an inferior that talks over PIPE. @@ -181,7 +209,7 @@ inferior." (letrec ((result (inferior 'pipe pipe close (cons 0 rest) (delay (%inferior-packages result)) (delay (%inferior-package-table result)) - #f #f))) + #f))) ;; For protocol (0 1) and later, send the protocol version we support. (match rest @@ -206,10 +234,11 @@ inferior." (error-port (%make-void-port "w"))) "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or equivalent. Return #f if the inferior could not be launched." - (define pipe - (inferior-pipe directory command error-port)) - - (port->inferior pipe close-pipe)) + (let ((pipe pid (inferior-pipe directory command error-port))) + (port->inferior pipe + (lambda (port) + (close-port port) + (waitpid pid))))) (define (close-inferior inferior) "Close INFERIOR." @@ -218,9 +247,7 @@ equivalent. Return #f if the inferior could not be launched." ;; Close and delete the store bridge, if any. (when (inferior-bridge-socket inferior) - (close-port (inferior-bridge-socket inferior)) - (delete-file (inferior-bridge-file-name inferior)) - (rmdir (dirname (inferior-bridge-file-name inferior)))))) + (close-port (inferior-bridge-socket inferior))))) ;; Non-self-quoting object of the inferior. (define-record-type <inferior-object> @@ -512,22 +539,32 @@ is similar to the sexp returned by 'package-provenance' for regular packages." 'package-provenance)))) (or provenance (const #f))))) -(define (proxy client backend) ;adapted from (guix ssh) - "Proxy communication between CLIENT and BACKEND until CLIENT closes the -connection, at which point CLIENT is closed (both CLIENT and BACKEND must be -input/output ports.)" +(define (proxy inferior store) ;adapted from (guix ssh) + "Proxy communication between INFERIOR and STORE, until the connection to +STORE is closed or INFERIOR has data available for input (a REPL response)." + (define client + (inferior-bridge-socket inferior)) + (define backend + (store-connection-socket store)) + (define response-port + (inferior-socket inferior)) + ;; Use buffered ports so that 'get-bytevector-some' returns up to the ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>. (setvbuf client 'block 65536) (setvbuf backend 'block 65536) + ;; RESPONSE-PORT may typically contain a leftover newline that 'read' didn't + ;; consume. Drain it so that 'select' doesn't immediately stop. + (drain-input response-port) + (let loop () - (match (select (list client backend) '() '()) + (match (select (list client backend response-port) '() '()) ((reads () ()) (when (memq client reads) (match (get-bytevector-some client) ((? eof-object?) - (close-port client)) + #t) (bv (put-bytevector backend bv) (force-output backend)))) @@ -536,7 +573,8 @@ input/output ports.)" (bv (put-bytevector client bv) (force-output client)))) - (unless (port-closed? client) + (unless (or (port-closed? client) + (memq response-port reads)) (loop)))))) (define (open-store-bridge! inferior) @@ -547,17 +585,25 @@ process." ;; its store. This ensures the inferior uses the same store, with the same ;; options, the same per-session GC roots, etc. ;; FIXME: This strategy doesn't work for remote inferiors (SSH). - (define directory - (mkdtemp! (string-append (or (getenv "TMPDIR") "/tmp") - "/guix-inferior.XXXXXX"))) - - (chmod directory #o700) - (let ((name (string-append directory "/inferior")) - (socket (socket AF_UNIX SOCK_STREAM 0))) - (bind socket AF_UNIX name) - (listen socket 2) - (set-inferior-bridge-file-name! inferior name) - (set-inferior-bridge-socket! inferior socket))) + (call-with-temporary-directory + (lambda (directory) + (chmod directory #o700) + (let ((name (string-append directory "/inferior")) + (socket (socket AF_UNIX SOCK_STREAM 0))) + (bind socket AF_UNIX name) + (listen socket 2) + + (send-inferior-request + `(define %bridge-socket + (let ((socket (socket AF_UNIX SOCK_STREAM 0))) + (connect socket AF_UNIX ,name) + socket)) + inferior) + (match (accept socket) + ((client . address) + (close-port socket) + (set-inferior-bridge-socket! inferior client))) + (read-inferior-response inferior))))) (define (ensure-store-bridge! inferior) "Ensure INFERIOR has a connected bridge." @@ -575,22 +621,19 @@ thus be the code of a one-argument procedure that accepts a store." (ensure-store-bridge! inferior) (send-inferior-request `(let ((proc ,code) - (socket (socket AF_UNIX SOCK_STREAM 0)) (error? (if (defined? 'store-protocol-error?) store-protocol-error? nix-protocol-error?)) (error-message (if (defined? 'store-protocol-error-message) store-protocol-error-message nix-protocol-error-message))) - (connect socket AF_UNIX - ,(inferior-bridge-file-name inferior)) ;; 'port->connection' appeared in June 2018 and we can hardly ;; emulate it on older versions. Thus fall back to ;; 'open-connection', at the risk of talking to the wrong daemon or ;; having our build result reclaimed (XXX). (let ((store (if (defined? 'port->connection) - (port->connection socket #:version ,proto) + (port->connection %bridge-socket #:version ,proto) (open-connection)))) (dynamic-wind (const #t) @@ -603,12 +646,10 @@ thus be the code of a one-argument procedure that accepts a store." `(store-protocol-error ,(error-message c)))) `(result ,(proc store)))) (lambda () - (close-connection store) - (close-port socket))))) + (unless (defined? 'port->connection) + (close-port store)))))) inferior) - (match (accept (inferior-bridge-socket inferior)) - ((client . address) - (proxy client (store-connection-socket store)))) + (proxy inferior store) (match (read-inferior-response inferior) (('store-protocol-error message) |