me
/
guix
Archived
1
0
Fork 0
Code

inferior: Keep the store bridge connected. 

Previously, each 'inferior-eval-with-store' would lead the inferior to
connect to the named socket the parent is listening to.  With this
change, the connection is established once for all and reused
afterwards.

* guix/inferior.scm (<inferior>)[bridge-file-name]: Remove.
(open-bidirectional-pipe): New procedure.
(inferior-pipe): Use it instead of 'open-pipe*' and return two values.
(port->inferior): Adjust call to 'inferior'.
(open-inferior): Adjust to 'inferior-pipe' changes.
(close-inferior): Remove 'inferior-bridge-file-name' handling.
(open-store-bridge!): Switch back to 'call-with-temporary-directory'.
Define '%bridge-socket' in the inferior, connected to the caller.
(proxy): Change first argument to be an inferior.  Add 'reponse-port'
and call to 'drain-input'.  Pass 'reponse-port' to 'select' and use it
as a loop termination clause.
(inferior-eval-with-store): Remove 'socket' and 'connect' calls from the
inferior code, and use '%bridge-socket' instead.
Ludovic Courtès 2022-01-27 00:20:12 +01:00
parent 10aad72110
commit bd86bbd300
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 104 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

167
guix/inferior.scm
View File

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