me/guix
Archived
1
0
Fork 0
Code Activity

inferior: Create the store proxy listening socket only once.

Browse source 
Previously, each 'inferior-eval-with-store' call would have the calling
process create a temporary directory with a listening socket in there.
Now that listening socket is created once and reused in subsequent
calls.

* guix/inferior.scm (<inferior>)[bridge-file-name, bridge-socket]: New
fields.
(port->inferior): Adjust accordingly.
(close-inferior): Close 'inferior-bridge-socket' and delete
'inferior-bridge-file-name' if set.
(open-store-bridge!, ensure-store-bridge!): New procedures.
(inferior-eval-with-store): Use them.
This commit is contained in:
Ludovic Courtès 2022-01-26 23:10:51 +01:00
parent 19371a4dc3
commit 10aad72110
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 93 additions and 61 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

154
guix/inferior.scm
View file

@ -25,7 +25,6 @@
#: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)
@ -36,6 +35,8 @@
&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)
@ -112,14 +113,21 @@
;; 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)
inferior? inferior?
(pid inferior-pid) (pid inferior-pid)
(socket inferior-socket) (socket inferior-socket)
(close inferior-close-socket) ;procedure (close inferior-close-socket) ;procedure
(version inferior-version) ;REPL protocol version (version inferior-version) ;REPL protocol version
(packages inferior-package-promise) ;promise of inferior packages (packages inferior-package-promise) ;promise of inferior packages
(table inferior-package-table)) ;promise of vhash (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!))
(define (write-inferior inferior port) (define (write-inferior inferior port)
(match inferior (match inferior
@ -172,7 +180,8 @@ inferior."
(('repl-version 0 rest ...) (('repl-version 0 rest ...)
(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)))
;; 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
@ -205,7 +214,13 @@ equivalent. Return #f if the inferior could not be launched."
(define (close-inferior inferior) (define (close-inferior inferior)
"Close INFERIOR." "Close INFERIOR."
(let ((close (inferior-close-socket inferior))) (let ((close (inferior-close-socket inferior)))
(close (inferior-socket inferior)))) (close (inferior-socket 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))))))
;; Non-self-quoting object of the inferior. ;; Non-self-quoting object of the inferior.
(define-record-type <inferior-object> (define-record-type <inferior-object>
@ -524,67 +539,84 @@ input/output ports.)"
(unless (port-closed? client) (unless (port-closed? client)
(loop)))))) (loop))))))
(define (open-store-bridge! inferior)
"Open a \"store bridge\" for INFERIOR--a named socket in /tmp that will be
used to proxy store RPCs from the inferior to the store of the calling
process."
;; Create a named socket in /tmp to let INFERIOR connect to it and use it as
;; 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)))
(define (ensure-store-bridge! inferior)
"Ensure INFERIOR has a connected bridge."
(or (inferior-bridge-socket inferior)
(begin
(open-store-bridge! inferior)
(inferior-bridge-socket inferior))))
(define (inferior-eval-with-store inferior store code) (define (inferior-eval-with-store inferior store code)
"Evaluate CODE in INFERIOR, passing it STORE as its argument. CODE must "Evaluate CODE in INFERIOR, passing it STORE as its argument. CODE must
thus be the code of a one-argument procedure that accepts a store." thus be the code of a one-argument procedure that accepts a store."
;; Create a named socket in /tmp and let INFERIOR connect to it and use it (let* ((major (store-connection-major-version store))
;; as its store. This ensures the inferior uses the same store, with the (minor (store-connection-minor-version store))
;; same options, the same per-session GC roots, etc. (proto (logior major minor)))
;; FIXME: This strategy doesn't work for remote inferiors (SSH). (ensure-store-bridge! inferior)
(call-with-temporary-directory (send-inferior-request
(lambda (directory) `(let ((proc ,code)
(chmod directory #o700) (socket (socket AF_UNIX SOCK_STREAM 0))
(let* ((name (string-append directory "/inferior")) (error? (if (defined? 'store-protocol-error?)
(socket (socket AF_UNIX SOCK_STREAM 0)) store-protocol-error?
(major (store-connection-major-version store)) nix-protocol-error?))
(minor (store-connection-minor-version store)) (error-message (if (defined? 'store-protocol-error-message)
(proto (logior major minor))) store-protocol-error-message
(bind socket AF_UNIX name) nix-protocol-error-message)))
(listen socket 1024) (connect socket AF_UNIX
(send-inferior-request ,(inferior-bridge-file-name inferior))
`(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 ,name)
;; '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 socket #:version ,proto)
(open-connection)))) (open-connection))))
(dynamic-wind (dynamic-wind
(const #t) (const #t)
(lambda () (lambda ()
;; Serialize '&store-protocol-error' conditions. The ;; Serialize '&store-protocol-error' conditions. The
;; exception serialization mechanism that ;; exception serialization mechanism that
;; 'read-repl-response' expects is unsuitable for SRFI-35 ;; 'read-repl-response' expects is unsuitable for SRFI-35
;; error conditions, hence this special case. ;; error conditions, hence this special case.
(guard (c ((error? c) (guard (c ((error? c)
`(store-protocol-error ,(error-message c)))) `(store-protocol-error ,(error-message c))))
`(result ,(proc store)))) `(result ,(proc store))))
(lambda () (lambda ()
(close-connection store) (close-connection store)
(close-port socket))))) (close-port socket)))))
inferior) inferior)
(match (accept socket) (match (accept (inferior-bridge-socket inferior))
((client . address) ((client . address)
(proxy client (store-connection-socket store)))) (proxy client (store-connection-socket store))))
(close-port socket)
(match (read-inferior-response inferior) (match (read-inferior-response inferior)
(('store-protocol-error message) (('store-protocol-error message)
(raise (condition (raise (condition
(&store-protocol-error (message message) (&store-protocol-error (message message)
(status 1))))) (status 1)))))
(('result result) (('result result)
result)))))) result))))
(define* (inferior-package-derivation store package (define* (inferior-package-derivation store package
#:optional #:optional