ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 05:48:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

inferior: Keep the store bridge connected.

Browse source 
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

131
guix/inferior.scm
View file

@ -25,6 +25,7 @@ (define-module (guix inferior)
#: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 @@ (define-module (guix inferior)
&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 @@ (define-module (guix inferior)
#: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 @@ (define-module (guix inferior)
;; 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 @@ (define-record-type <inferior>
(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,24 +134,56 @@ (define (write-inferior inferior port)
(set-record-type-printer! <inferior> write-inferior) (set-record-type-printer! <inferior> write-inferior)
(define* (inferior-pipe directory command error-port) (define (open-bidirectional-pipe command . args)
"Return an input/output pipe on the Guix instance in DIRECTORY. This runs "Open a bidirectional pipe to COMMAND invoked with ARGS and return it, as a
'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if regular file port (socket).
it's an old Guix."
(let ((pipe (with-error-to-port error-port 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 () (lambda ()
(open-pipe* OPEN_BOTH #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 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) (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
"guile"
"-L" (string-append directory "/share/guile/site/" "-L" (string-append directory "/share/guile/site/"
(effective-version)) (effective-version))
"-C" (string-append directory "/share/guile/site/" "-C" (string-append directory "/share/guile/site/"
@ -168,7 +196,7 @@ (define* (inferior-pipe directory command error-port)
(primitive-load ,(search-path %load-path (primitive-load ,(search-path %load-path
"guix/repl.scm")) "guix/repl.scm"))
((@ (guix repl) machine-repl)))))))) ((@ (guix repl) machine-repl))))))))
pipe))) (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 @@ (define* (port->inferior pipe #:optional (close close-port))
(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 @@ (define* (open-inferior directory
(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 @@ (define (close-inferior inferior)
;; 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 @@ (define (inferior-package-provenance package)
'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 @@ (define (proxy client backend) ;adapted from (guix ssh)
(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 @@ (define (open-store-bridge! inferior)
;; 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) (chmod directory #o700)
(let ((name (string-append directory "/inferior")) (let ((name (string-append directory "/inferior"))
(socket (socket AF_UNIX SOCK_STREAM 0))) (socket (socket AF_UNIX SOCK_STREAM 0)))
(bind socket AF_UNIX name) (bind socket AF_UNIX name)
(listen socket 2) (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) (define (ensure-store-bridge! inferior)
"Ensure INFERIOR has a connected bridge." "Ensure INFERIOR has a connected bridge."
@ -575,22 +621,19 @@ (define (inferior-eval-with-store inferior store code)
(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 @@ (define (inferior-eval-with-store inferior store code)
`(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)