kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases 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))
#:use-module ((guix utils)
#:select (%current-system
call-with-temporary-directory
version>? version-prefix?
cache-directory))
#:use-module ((guix store)
@ -36,6 +35,8 @@
&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)
@ -112,14 +113,21 @@
;; Inferior Guix process.
(define-record-type <inferior>
(inferior pid socket close version packages table)
(inferior pid socket close version packages table
bridge-file-name bridge-socket)
inferior?
(pid inferior-pid)
(socket inferior-socket)
(close inferior-close-socket) ;procedure
(version inferior-version) ;REPL protocol version
(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)
(match inferior
@ -172,7 +180,8 @@ inferior."
(('repl-version 0 rest ...)
(letrec ((result (inferior 'pipe pipe close (cons 0 rest)
(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.
(match rest
@ -205,7 +214,13 @@ equivalent. Return #f if the inferior could not be launched."
(define (close-inferior inferior)
"Close 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.
(define-record-type <inferior-object>
@ -524,67 +539,84 @@ input/output ports.)"
(unless (port-closed? client)
(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)
"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."
;; Create a named socket in /tmp and 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).
(call-with-temporary-directory
(lambda (directory)
(chmod directory #o700)
(let* ((name (string-append directory "/inferior"))
(socket (socket AF_UNIX SOCK_STREAM 0))
(major (store-connection-major-version store))
(minor (store-connection-minor-version store))
(proto (logior major minor)))
(bind socket AF_UNIX name)
(listen socket 1024)
(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 ,name)
(let* ((major (store-connection-major-version store))
(minor (store-connection-minor-version store))
(proto (logior major minor)))
(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)
(open-connection))))
(dynamic-wind
(const #t)
(lambda ()
;; Serialize '&store-protocol-error' conditions. The
;; exception serialization mechanism that
;; 'read-repl-response' expects is unsuitable for SRFI-35
;; error conditions, hence this special case.
(guard (c ((error? c)
`(store-protocol-error ,(error-message c))))
`(result ,(proc store))))
(lambda ()
(close-connection store)
(close-port socket)))))
inferior)
(match (accept socket)
((client . address)
(proxy client (store-connection-socket store))))
(close-port socket)
;; '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)
(open-connection))))
(dynamic-wind
(const #t)
(lambda ()
;; Serialize '&store-protocol-error' conditions. The
;; exception serialization mechanism that
;; 'read-repl-response' expects is unsuitable for SRFI-35
;; error conditions, hence this special case.
(guard (c ((error? c)
`(store-protocol-error ,(error-message c))))
`(result ,(proc store))))
(lambda ()
(close-connection store)
(close-port socket)))))
inferior)
(match (accept (inferior-bridge-socket inferior))
((client . address)
(proxy client (store-connection-socket store))))
(match (read-inferior-response inferior)
(('store-protocol-error message)
(raise (condition
(&store-protocol-error (message message)
(status 1)))))
(('result result)
result))))))
(match (read-inferior-response inferior)
(('store-protocol-error message)
(raise (condition
(&store-protocol-error (message message)
(status 1)))))
(('result result)
result))))
(define* (inferior-package-derivation store package
#:optional