From: "Ludovic Courtès" <ludo@gnu.org>
To: 33515@debbugs.gnu.org
Subject: [bug#33515] [PATCH 1/5] inferior: Add 'inferior-eval-with-store'.
Date: Mon, 26 Nov 2018 17:45:20 +0100 [thread overview]
Message-ID: <20181126164524.17680-1-ludo@gnu.org> (raw)
In-Reply-To: <20181126163757.17399-1-ludo@gnu.org>
* guix/inferior.scm (inferior-eval-with-store): New procedure, with code
formerly in 'inferior-package-derivation'.
(inferior-package-derivation): Rewrite in terms of
'inferior-eval-with-store'.
* tests/inferior.scm ("inferior-eval-with-store"): New test.
---
guix/inferior.scm | 70 ++++++++++++++++++++++++++++------------------
tests/inferior.scm | 9 ++++++
2 files changed, 52 insertions(+), 27 deletions(-)
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 1dbb9e1699..ccc1c27cb2 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -56,6 +56,7 @@
open-inferior
close-inferior
inferior-eval
+ inferior-eval-with-store
inferior-object?
inferior-packages
@@ -402,55 +403,70 @@ input/output ports.)"
(unless (port-closed? client)
(loop))))))
-(define* (inferior-package-derivation store package
- #:optional
- (system (%current-system))
- #:key target)
- "Return the derivation for PACKAGE, an inferior package, built for SYSTEM
-and cross-built for TARGET if TARGET is true. The inferior corresponding to
-PACKAGE must be live."
- ;; Create a named socket in /tmp and let the inferior of PACKAGE 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.
+(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.
(call-with-temporary-directory
(lambda (directory)
(chmod directory #o700)
(let* ((name (string-append directory "/inferior"))
(socket (socket AF_UNIX SOCK_STREAM 0))
- (inferior (inferior-package-inferior package))
(major (nix-server-major-version store))
(minor (nix-server-minor-version store))
(proto (logior major minor)))
(bind socket AF_UNIX name)
(listen socket 1024)
(send-inferior-request
- `(let ((socket (socket AF_UNIX SOCK_STREAM 0)))
+ `(let ((proc ,code)
+ (socket (socket AF_UNIX SOCK_STREAM 0)))
(connect socket AF_UNIX ,name)
;; '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)))
- (package (hashv-ref %package-table
- ,(inferior-package-id package)))
- (drv ,(if target
- `(package-cross-derivation store package
- ,target
- ,system)
- `(package-derivation store package
- ,system))))
- (close-connection store)
- (close-port socket)
- (derivation-file-name drv)))
+ (let ((store (if (defined? 'port->connection)
+ (port->connection socket #:version ,proto)
+ (open-connection))))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (proc store))
+ (lambda ()
+ (close-connection store)
+ (close-port socket)))))
inferior)
(match (accept socket)
((client . address)
(proxy client (nix-server-socket store))))
(close-port socket)
- (read-derivation-from-file (read-inferior-response inferior))))))
+ (read-inferior-response inferior)))))
+
+(define* (inferior-package-derivation store package
+ #:optional
+ (system (%current-system))
+ #:key target)
+ "Return the derivation for PACKAGE, an inferior package, built for SYSTEM
+and cross-built for TARGET if TARGET is true. The inferior corresponding to
+PACKAGE must be live."
+ (define proc
+ `(lambda (store)
+ (let* ((package (hashv-ref %package-table
+ ,(inferior-package-id package)))
+ (drv ,(if target
+ `(package-cross-derivation store package
+ ,target
+ ,system)
+ `(package-derivation store package
+ ,system))))
+ (derivation-file-name drv))))
+
+ (and=> (inferior-eval-with-store (inferior-package-inferior package) store
+ proc)
+ read-derivation-from-file))
(define inferior-package->derivation
(store-lift inferior-package-derivation))
diff --git a/tests/inferior.scm b/tests/inferior.scm
index d1d5c00a77..d5a894ca8f 100644
--- a/tests/inferior.scm
+++ b/tests/inferior.scm
@@ -157,6 +157,15 @@
(close-inferior inferior)
result))
+(test-equal "inferior-eval-with-store"
+ (add-text-to-store %store "foo" "Hello, world!")
+ (let* ((inferior (open-inferior %top-builddir
+ #:command "scripts/guix")))
+ (inferior-eval-with-store inferior %store
+ '(lambda (store)
+ (add-text-to-store store "foo"
+ "Hello, world!")))))
+
(test-equal "inferior-package-derivation"
(map derivation-file-name
(list (package-derivation %store %bootstrap-guile "x86_64-linux")
--
2.19.1
next prev parent reply other threads:[~2018-11-26 16:46 UTC|newest]
Thread overview: 11+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-11-26 16:37 [bug#33515] [PATCH 0/5] Cuirass/Hydra: evaluate jobs in an inferior Ludovic Courtès
2018-11-26 16:45 ` Ludovic Courtès [this message]
2018-11-26 16:45 ` [bug#33515] [PATCH 2/5] hydra: Move job definitions to (gnu ci) Ludovic Courtès
2018-11-26 16:45 ` [bug#33515] [PATCH 3/5] hydra: evaluate: Add the checkout to the store Ludovic Courtès
2018-11-26 16:45 ` [bug#33515] [PATCH 4/5] channels: Add 'checkout->channel-instance' Ludovic Courtès
2018-11-26 16:45 ` [bug#33515] [PATCH 5/5] hydra: Compute jobs in an inferior Ludovic Courtès
2018-11-28 9:51 ` [bug#33515] [PATCH 0/5] Cuirass/Hydra: evaluate " Ludovic Courtès
2018-12-27 17:27 ` Ludovic Courtès
2018-12-28 4:21 ` Mark H Weaver
2018-12-28 23:19 ` Ludovic Courtès
2019-01-06 20:44 ` bug#33515: " Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20181126164524.17680-1-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=33515@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.