mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
inferior: Create the store proxy listening socket only once.
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
parent
19371a4dc3
commit
10aad72110
1 changed files with 93 additions and 61 deletions
|
|
@ -25,7 +25,6 @@ (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)
|
||||
|
|
@ -36,6 +35,8 @@ (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)
|
||||
|
|
@ -112,14 +113,21 @@ (define-module (guix inferior)
|
|||
|
||||
;; 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 @@ (define* (port->inferior pipe #:optional (close close-port))
|
|||
(('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 @@ (define pipe
|
|||
(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 @@ (define (proxy client backend) ;adapted from (guix ssh)
|
|||
(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
|
||||
|
|
|
|||
Loading…
Reference in a new issue