[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#48007: [PATCH 2/4] inferior: Keep the store bridge connected.
|
From: |
Ludovic Courtès |
|
Subject: |
bug#48007: [PATCH 2/4] inferior: Keep the store bridge connected. |
|
Date: |
Thu, 27 Jan 2022 09:47:41 +0100 |
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.
---
guix/inferior.scm | 167 +++++++++++++++++++++++++++++-----------------
1 file changed, 104 insertions(+), 63 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 @@ (define-module (guix inferior)
#: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 @@ (define-module (guix inferior)
&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 @@ (define-module (guix inferior)
#: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 @@ (define-module (guix inferior)
;; 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 @@ (define-record-type <inferior>
(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 @@ (define (write-inferior inferior port)
(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 @@ (define* (port->inferior pipe #:optional (close close-port))
(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 @@ (define* (open-inferior directory
(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 @@ (define (close-inferior inferior)
;; 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 @@ (define (inferior-package-provenance package)
'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 @@ (define (proxy client backend) ;adapted
from (guix ssh)
(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 @@ (define (open-store-bridge! inferior)
;; 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 @@ (define (inferior-eval-with-store inferior store code)
(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 @@ (define (inferior-eval-with-store inferior store code)
`(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)
--
2.34.0