From patchwork Mon Nov 26 16:45:20 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 318 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id B04FB16826; Mon, 26 Nov 2018 16:46:21 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-6.9 required=5.0 tests=BAYES_00,RCVD_IN_DNSWL_HI autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [IPv6:2001:4830:134:3::11]) by mira.cbaines.net (Postfix) with ESMTPS id 3A1971681B for ; Mon, 26 Nov 2018 16:46:21 +0000 (GMT) Received: from localhost ([::1]:37606 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gRK1c-0003fF-DY for patchwork@mira.cbaines.net; Mon, 26 Nov 2018 11:46:20 -0500 Received: from eggs.gnu.org ([2001:4830:134:3::10]:42397) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gRK1O-0003Vy-Gf for guix-patches@gnu.org; Mon, 26 Nov 2018 11:46:07 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gRK1K-0007Gh-MH for guix-patches@gnu.org; Mon, 26 Nov 2018 11:46:06 -0500 Received: from debbugs.gnu.org ([208.118.235.43]:45796) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1gRK1K-0007FQ-8f for guix-patches@gnu.org; Mon, 26 Nov 2018 11:46:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1gRK1K-0002ZI-66 for guix-patches@gnu.org; Mon, 26 Nov 2018 11:46:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#33515] [PATCH 1/5] inferior: Add 'inferior-eval-with-store'. References: <20181126163757.17399-1-ludo@gnu.org> In-Reply-To: <20181126163757.17399-1-ludo@gnu.org> Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Mon, 26 Nov 2018 16:46:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 33515 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 33515@debbugs.gnu.org Received: via spool by 33515-submit@debbugs.gnu.org id=B33515.15432507499185 (code B ref 33515); Mon, 26 Nov 2018 16:46:02 +0000 Received: (at 33515) by debbugs.gnu.org; 26 Nov 2018 16:45:49 +0000 Received: from localhost ([127.0.0.1]:50047 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gRK16-0002NY-Va for submit@debbugs.gnu.org; Mon, 26 Nov 2018 11:45:49 -0500 Received: from eggs.gnu.org ([208.118.235.92]:60903) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gRK12-0002Et-Sw for 33515@debbugs.gnu.org; Mon, 26 Nov 2018 11:45:45 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gRK0w-00075X-K1 for 33515@debbugs.gnu.org; Mon, 26 Nov 2018 11:45:39 -0500 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:51258) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gRK0t-000748-3Q; Mon, 26 Nov 2018 11:45:35 -0500 Received: from [2001:660:6102:320:e120:2c8f:8909:cdfe] (port=51762 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1gRK0s-00051o-QP; Mon, 26 Nov 2018 11:45:35 -0500 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Mon, 26 Nov 2018 17:45:20 +0100 Message-Id: <20181126164524.17680-1-ludo@gnu.org> X-Mailer: git-send-email 2.19.1 MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * 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")