TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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.
This commit is contained in:
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))
#: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")))
(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)
(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)))
(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)