From patchwork Mon Jun 10 21:41:27 2019 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: 14282 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 CE1F717064; Mon, 10 Jun 2019 22:42:30 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 3C44D1704B for ; Mon, 10 Jun 2019 22:42:30 +0100 (BST) Received: from localhost ([::1]:49910 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1haS3g-0003jP-MP for patchwork@mira.cbaines.net; Mon, 10 Jun 2019 17:42:29 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:35131) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1haS3I-0003QC-4l for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1haS3F-0001Jd-RG for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:44039) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1haS3F-0001JX-NI for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:01 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1haS3F-0006Jf-KY for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36162] [PATCH 1/4] gexp: Add 'lower-gexp' and express 'gexp->derivation' in terms of it. References: <20190610210853.5709-1-ludo@gnu.org> In-Reply-To: <20190610210853.5709-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, 10 Jun 2019 21:42:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36162 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 36162@debbugs.gnu.org Received: via spool by 36162-submit@debbugs.gnu.org id=B36162.156020291124237 (code B ref 36162); Mon, 10 Jun 2019 21:42:01 +0000 Received: (at 36162) by debbugs.gnu.org; 10 Jun 2019 21:41:51 +0000 Received: from localhost ([127.0.0.1]:57575 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1haS34-0006Ih-GH for submit@debbugs.gnu.org; Mon, 10 Jun 2019 17:41:51 -0400 Received: from eggs.gnu.org ([209.51.188.92]:54430) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1haS2z-0006IN-Ua for 36162@debbugs.gnu.org; Mon, 10 Jun 2019 17:41:46 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:60151) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1haS2u-00015F-Kn; Mon, 10 Jun 2019 17:41:40 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=33892 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1haS2s-0001fJ-5h; Mon, 10 Jun 2019 17:41:40 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Mon, 10 Jun 2019 23:41:27 +0200 Message-Id: <20190610214130.19378-1-ludo@gnu.org> X-Mailer: git-send-email 2.21.0 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: 209.51.188.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/gexp.scm (gexp-input-thing, gexp-input-output) (gexp-input-native?): Export. (lower-inputs): Return records instead of tuples. (lower-reference-graphs): Adjust accordingly. (): New record type. (lower-gexp, gexp-input->tuple): New procedure. (gexp->derivation)[%modules]: Remove. [requested-graft?]: New variable. [add-modules]: New procedure. Rewrite in terms of 'lower-gexp'. (gexp-inputs): Add TODO comment. * tests/gexp.scm ("lower-gexp"): New test. --- guix/gexp.scm | 238 +++++++++++++++++++++++++++++++++++++------------ tests/gexp.scm | 37 ++++++++ 2 files changed, 216 insertions(+), 59 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index 4f2adba90a..38f64db7f1 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -39,6 +39,9 @@ gexp-input gexp-input? + gexp-input-thing + gexp-input-output + gexp-input-native? local-file local-file? @@ -78,6 +81,14 @@ load-path-expression gexp-modules + lower-gexp + lowered-gexp? + lowered-gexp-sexp + lowered-gexp-inputs + lowered-gexp-guile + lowered-gexp-load-path + lowered-gexp-load-compiled-path + gexp->derivation gexp->file gexp->script @@ -566,15 +577,20 @@ list." "Turn any package from INPUTS into a derivation for SYSTEM; return the corresponding input list as a monadic value. When TARGET is true, use it as the cross-compilation target triplet." + (define (store-item? obj) + (and (string? obj) (store-path? obj))) + (with-monad %store-monad (mapm %store-monad (match-lambda (((? struct? thing) sub-drv ...) (mlet %store-monad ((drv (lower-object thing system #:target target))) - (return `(,drv ,@sub-drv)))) + (return (apply gexp-input drv sub-drv)))) + (((? store-item? item)) + (return (gexp-input item))) (input - (return input))) + (return (gexp-input input)))) inputs))) (define* (lower-reference-graphs graphs #:key system target) @@ -586,7 +602,9 @@ corresponding derivation." (mlet %store-monad ((inputs (lower-inputs inputs #:system system #:target target))) - (return (map cons file-names inputs)))))) + (return (map (lambda (file input) + (cons file (gexp-input->tuple input))) + file-names inputs)))))) (define* (lower-references lst #:key system target) "Based on LST, a list of output names and packages, return a list of output @@ -618,6 +636,128 @@ names and file names suitable for the #:allowed-references argument to (lambda (system) ((force proc) system)))) +;; Representation of a gexp instantiated for a given target and system. +(define-record-type + (lowered-gexp sexp inputs guile load-path load-compiled-path) + lowered-gexp? + (sexp lowered-gexp-sexp) ;sexp + (inputs lowered-gexp-inputs) ;list of + (guile lowered-gexp-guile) ; | #f + (load-path lowered-gexp-load-path) ;list of store items + (load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items + +(define* (lower-gexp exp + #:key + (module-path %load-path) + (system (%current-system)) + (target 'current) + (graft? (%graft?)) + (guile-for-build (%guile-for-build)) + (effective-version "2.2") + + deprecation-warnings + (pre-load-modules? #t)) ;transitional + "Lower EXP, a gexp, instantiating it for SYSTEM and TARGET. Return a + ready to be used. + +Lowered gexps are an intermediate representation that's useful for +applications that deal with gexps outside in a way that is disconnected from +derivations--e.g., code evaluated for its side effects." + (define %modules + (delete-duplicates (gexp-modules exp))) + + (define (search-path modules extensions suffix) + (append (match modules + ((? derivation? drv) + (list (derivation->output-path drv))) + (#f + '()) + ((? store-path? item) + (list item))) + (map (lambda (extension) + (string-append (match extension + ((? derivation? drv) + (derivation->output-path drv)) + ((? store-path? item) + item)) + suffix)) + extensions))) + + (mlet* %store-monad ( ;; The following binding forces '%current-system' and + ;; '%current-target-system' to be looked up at >>= + ;; time. + (graft? (set-grafting graft?)) + + (system -> (or system (%current-system))) + (target -> (if (eq? target 'current) + (%current-target-system) + target)) + (guile (if guile-for-build + (return guile-for-build) + (default-guile-derivation system))) + (normals (lower-inputs (gexp-inputs exp) + #:system system + #:target target)) + (natives (lower-inputs (gexp-native-inputs exp) + #:system system + #:target #f)) + (inputs -> (append normals natives)) + (sexp (gexp->sexp exp + #:system system + #:target target)) + (extensions -> (gexp-extensions exp)) + (exts (mapm %store-monad + (lambda (obj) + (lower-object obj system)) + extensions)) + (modules (if (pair? %modules) + (imported-modules %modules + #:system system + #:module-path module-path) + (return #f))) + (compiled (if (pair? %modules) + (compiled-modules %modules + #:system system + #:module-path module-path + #:extensions extensions + #:guile guile-for-build + #:pre-load-modules? + pre-load-modules? + #:deprecation-warnings + deprecation-warnings) + (return #f)))) + (define load-path + (search-path modules exts + (string-append "/share/guile/site/" effective-version))) + + (define load-compiled-path + (search-path compiled exts + (string-append "/lib/guile/" effective-version + "/site-ccache"))) + + (mbegin %store-monad + (set-grafting graft?) ;restore the initial setting + (return (lowered-gexp sexp + `(,@(if modules + (list (gexp-input modules)) + '()) + ,@(if compiled + (list (gexp-input compiled)) + '()) + ,@(map gexp-input exts) + ,@inputs) + guile-for-build + load-path + load-compiled-path))))) + +(define (gexp-input->tuple input) + "Given INPUT, a record, return the corresponding input tuple +suitable for the 'derivation' procedure." + (match (gexp-input-output input) + ("out" `(,(gexp-input-thing input))) + (output `(,(gexp-input-thing input) + ,(gexp-input-output input))))) + (define* (gexp->derivation name exp #:key system (target 'current) @@ -682,10 +822,8 @@ DEPRECATION-WARNINGS determines whether to show deprecation warnings while compiling modules. It can be #f, #t, or 'detailed. The other arguments are as for 'derivation'." - (define %modules - (delete-duplicates - (append modules (gexp-modules exp)))) (define outputs (gexp-outputs exp)) + (define requested-graft? graft?) (define (graphs-file-names graphs) ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. @@ -699,11 +837,13 @@ The other arguments are as for 'derivation'." (cons file-name thing))) graphs)) - (define (extension-flags extension) - `("-L" ,(string-append (derivation->output-path extension) - "/share/guile/site/" effective-version) - "-C" ,(string-append (derivation->output-path extension) - "/lib/guile/" effective-version "/site-ccache"))) + (define (add-modules exp modules) + (if (null? modules) + exp + (make-gexp (gexp-references exp) + (append modules (gexp-self-modules exp)) + (gexp-self-extensions exp) + (gexp-proc exp)))) (mlet* %store-monad ( ;; The following binding forces '%current-system' and ;; '%current-target-system' to be looked up at >>= @@ -714,40 +854,21 @@ The other arguments are as for 'derivation'." (target -> (if (eq? target 'current) (%current-target-system) target)) - (normals (lower-inputs (gexp-inputs exp) - #:system system - #:target target)) - (natives (lower-inputs (gexp-native-inputs exp) - #:system system - #:target #f)) - (inputs -> (append normals natives)) - (sexp (gexp->sexp exp - #:system system - #:target target)) - (builder (text-file script-name - (object->string sexp))) - (extensions -> (gexp-extensions exp)) - (exts (mapm %store-monad - (lambda (obj) - (lower-object obj system)) - extensions)) - (modules (if (pair? %modules) - (imported-modules %modules - #:system system - #:module-path module-path - #:guile guile-for-build) - (return #f))) - (compiled (if (pair? %modules) - (compiled-modules %modules - #:system system - #:module-path module-path - #:extensions extensions - #:guile guile-for-build - #:pre-load-modules? - pre-load-modules? - #:deprecation-warnings - deprecation-warnings) - (return #f))) + (exp -> (add-modules exp modules)) + (lowered (lower-gexp exp + #:module-path module-path + #:system system + #:target target + #:graft? requested-graft? + #:guile-for-build + guile-for-build + #:effective-version + effective-version + #:deprecation-warnings + deprecation-warnings + #:pre-load-modules? + pre-load-modules?)) + (graphs (if references-graphs (lower-reference-graphs references-graphs #:system system @@ -763,32 +884,30 @@ The other arguments are as for 'derivation'." #:system system #:target target) (return #f))) - (guile (if guile-for-build - (return guile-for-build) - (default-guile-derivation system)))) + (guile -> (lowered-gexp-guile lowered)) + (builder (text-file script-name + (object->string + (lowered-gexp-sexp lowered))))) (mbegin %store-monad (set-grafting graft?) ;restore the initial setting (raw-derivation name (string-append (derivation->output-path guile) "/bin/guile") `("--no-auto-compile" - ,@(if (pair? %modules) - `("-L" ,(if (derivation? modules) - (derivation->output-path modules) - modules) - "-C" ,(derivation->output-path compiled)) - '()) - ,@(append-map extension-flags exts) + ,@(append-map (lambda (directory) + `("-L" ,directory)) + (lowered-gexp-load-path lowered)) + ,@(append-map (lambda (directory) + `("-C" ,directory)) + (lowered-gexp-load-compiled-path lowered)) ,builder) #:outputs outputs #:env-vars env-vars #:system system #:inputs `((,guile) (,builder) - ,@(if modules - `((,modules) (,compiled) ,@inputs) - inputs) - ,@(map list exts) + ,@(map gexp-input->tuple + (lowered-gexp-inputs lowered)) ,@(match graphs (((_ . inputs) ...) inputs) (_ '()))) @@ -804,6 +923,7 @@ The other arguments are as for 'derivation'." (define* (gexp-inputs exp #:key native?) "Return the input list for EXP. When NATIVE? is true, return only native references; otherwise, return only non-native references." + ;; TODO: Return records instead of tuples. (define (add-reference-inputs ref result) (match ref (($ (? gexp? exp) _ #t) diff --git a/tests/gexp.scm b/tests/gexp.scm index cee2c96610..23904fce2e 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -832,6 +832,43 @@ (built-derivations (list drv)) (return (equal? '(42 84) (call-with-input-file out read)))))) +(test-assertm "lower-gexp" + (mlet* %store-monad + ((extension -> %extension-package) + (extension-drv (package->derivation %extension-package)) + (coreutils-drv (package->derivation coreutils)) + (exp -> (with-extensions (list extension) + (with-imported-modules `((guix build utils)) + #~(begin + (use-modules (guix build utils) + (hg2g)) + #$coreutils:debug + mkdir-p + the-answer)))) + (lexp (lower-gexp exp + #:effective-version "2.0"))) + (define (matching-input drv output) + (lambda (input) + (and (eq? (gexp-input-thing input) drv) + (string=? (gexp-input-output input) output)))) + + (mbegin %store-monad + (return (and (find (matching-input extension-drv "out") + (lowered-gexp-inputs (pk 'lexp lexp))) + (find (matching-input coreutils-drv "debug") + (lowered-gexp-inputs lexp)) + (member (string-append + (derivation->output-path extension-drv) + "/share/guile/site/2.0") + (lowered-gexp-load-path lexp)) + (= 2 (length (lowered-gexp-load-path lexp))) + (member (string-append + (derivation->output-path extension-drv) + "/lib/guile/2.0/site-ccache") + (lowered-gexp-load-compiled-path lexp)) + (= 2 (length (lowered-gexp-load-compiled-path lexp))) + (eq? (lowered-gexp-guile lexp) (%guile-for-build))))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) From patchwork Mon Jun 10 21:41:28 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 14283 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 E4D2217064; Mon, 10 Jun 2019 22:44:43 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 6058C1704B for ; Mon, 10 Jun 2019 22:44:43 +0100 (BST) Received: from localhost ([::1]:49924 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1haS5q-0005Cv-Vk for patchwork@mira.cbaines.net; Mon, 10 Jun 2019 17:44:42 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:35133) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1haS3I-0003QE-5R for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1haS3G-0001K4-EB for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:44040) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1haS3G-0001Jv-9D for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1haS3G-0006Jm-5o for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36162] [PATCH 2/4] Add (guix repl). Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Mon, 10 Jun 2019 21:42:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36162 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 36162@debbugs.gnu.org Received: via spool by 36162-submit@debbugs.gnu.org id=B36162.156020291324251 (code B ref 36162); Mon, 10 Jun 2019 21:42:02 +0000 Received: (at 36162) by debbugs.gnu.org; 10 Jun 2019 21:41:53 +0000 Received: from localhost ([127.0.0.1]:57579 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1haS36-0006J4-Cs for submit@debbugs.gnu.org; Mon, 10 Jun 2019 17:41:52 -0400 Received: from eggs.gnu.org ([209.51.188.92]:54461) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1haS33-0006IS-NU for 36162@debbugs.gnu.org; Mon, 10 Jun 2019 17:41:50 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:60153) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1haS2y-00017C-FS; Mon, 10 Jun 2019 17:41:44 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=33892 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1haS2u-0001fJ-Ve; Mon, 10 Jun 2019 17:41:42 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Mon, 10 Jun 2019 23:41:28 +0200 Message-Id: <20190610214130.19378-2-ludo@gnu.org> X-Mailer: git-send-email 2.21.0 In-Reply-To: <20190610214130.19378-1-ludo@gnu.org> References: <20190610214130.19378-1-ludo@gnu.org> 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: 209.51.188.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/scripts/repl.scm: Use (guix repl). (self-quoting?, machine-repl): Remove. * guix/repl.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/repl.scm | 86 +++++++++++++++++++++++++++++++++++++++++++ guix/scripts/repl.scm | 56 ++-------------------------- 3 files changed, 90 insertions(+), 53 deletions(-) create mode 100644 guix/repl.scm diff --git a/Makefile.am b/Makefile.am index 80be73e4bf..0aa92ecfb9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -90,6 +90,7 @@ MODULES = \ guix/nar.scm \ guix/derivations.scm \ guix/grafts.scm \ + guix/repl.scm \ guix/inferior.scm \ guix/describe.scm \ guix/channels.scm \ diff --git a/guix/repl.scm b/guix/repl.scm new file mode 100644 index 0000000000..5cff5c71e9 --- /dev/null +++ b/guix/repl.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018, 2019 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix repl) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:export (send-repl-response + machine-repl)) + +;;; Commentary: +;;; +;;; This module implements the "machine-readable" REPL provided by +;;; 'guix repl -t machine'. It's a lightweight module meant to be +;;; embedded in any Guile process providing REPL functionality. +;;; +;;; Code: + +(define (self-quoting? x) + "Return #t if X is self-quoting." + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? pair? null? vector? + bytevector? number? boolean?))) + + +(define (send-repl-response exp output) + "Write the response corresponding to the evaluation of EXP to PORT, an +output port." + (define (value->sexp value) + (if (self-quoting? value) + `(value ,value) + `(non-self-quoting ,(object-address value) + ,(object->string value)))) + + (catch #t + (lambda () + (let ((results (call-with-values + (lambda () + (primitive-eval exp)) + list))) + (write `(values ,@(map value->sexp results)) + output) + (newline output) + (force-output output))) + (lambda (key . args) + (write `(exception ,key ,@(map value->sexp args))) + (newline output) + (force-output output)))) + +(define* (machine-repl #:optional + (input (current-input-port)) + (output (current-output-port))) + "Run a machine-usable REPL over ports INPUT and OUTPUT. + +The protocol of this REPL is meant to be machine-readable and provides proper +support to represent multiple-value returns, exceptions, objects that lack a +read syntax, and so on. As such it is more convenient and robust than parsing +Guile's REPL prompt." + (write `(repl-version 0 0) output) + (newline output) + (force-output output) + + (let loop () + (match (read input) + ((? eof-object?) #t) + (exp + (send-repl-response exp output) + (loop))))) diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index 02169e8004..e1cc759fc8 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +19,7 @@ (define-module (guix scripts repl) #:use-module (guix ui) #:use-module (guix scripts) + #:use-module (guix repl) #:use-module (guix utils) #:use-module (guix packages) #:use-module (gnu packages) @@ -29,8 +30,7 @@ #:autoload (system repl repl) (start-repl) #:autoload (system repl server) (make-tcp-server-socket make-unix-domain-server-socket) - #:export (machine-repl - guix-repl)) + #:export (guix-repl)) ;;; Commentary: ;;; @@ -68,62 +68,12 @@ Start a Guile REPL in the Guix execution environment.\n")) (newline) (show-bug-report-information)) -(define (self-quoting? x) - "Return #t if X is self-quoting." - (letrec-syntax ((one-of (syntax-rules () - ((_) #f) - ((_ pred rest ...) - (or (pred x) - (one-of rest ...)))))) - (one-of symbol? string? pair? null? vector? - bytevector? number? boolean?))) - (define user-module ;; Module where we execute user code. (let ((module (resolve-module '(guix-user) #f #f #:ensure #t))) (beautify-user-module! module) module)) -(define* (machine-repl #:optional - (input (current-input-port)) - (output (current-output-port))) - "Run a machine-usable REPL over ports INPUT and OUTPUT. - -The protocol of this REPL is meant to be machine-readable and provides proper -support to represent multiple-value returns, exceptions, objects that lack a -read syntax, and so on. As such it is more convenient and robust than parsing -Guile's REPL prompt." - (define (value->sexp value) - (if (self-quoting? value) - `(value ,value) - `(non-self-quoting ,(object-address value) - ,(object->string value)))) - - (write `(repl-version 0 0) output) - (newline output) - (force-output output) - - (let loop () - (match (read input) - ((? eof-object?) #t) - (exp - (catch #t - (lambda () - (let ((results (call-with-values - (lambda () - - (primitive-eval exp)) - list))) - (write `(values ,@(map value->sexp results)) - output) - (newline output) - (force-output output))) - (lambda (key . args) - (write `(exception ,key ,@(map value->sexp args))) - (newline output) - (force-output output))) - (loop))))) - (define (call-with-connection spec thunk) "Dynamically-bind the current input and output ports according to SPEC and call THUNK." From patchwork Mon Jun 10 21:41:29 2019 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: 14280 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 C527F17064; Mon, 10 Jun 2019 22:42:08 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 777D51704B for ; Mon, 10 Jun 2019 22:42:08 +0100 (BST) Received: from localhost ([::1]:49904 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1haS3L-0003Vx-7a for patchwork@mira.cbaines.net; Mon, 10 Jun 2019 17:42:07 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:35127) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1haS3H-0003Ps-S7 for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:04 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1haS3G-0001KK-RY for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:03 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:44041) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1haS3G-0001KF-O6 for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1haS3G-0006Ju-LT for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36162] [PATCH 3/4] inferior: Add 'read-repl-response'. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Mon, 10 Jun 2019 21:42:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36162 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 36162@debbugs.gnu.org Received: via spool by 36162-submit@debbugs.gnu.org id=B36162.156020291324257 (code B ref 36162); Mon, 10 Jun 2019 21:42:02 +0000 Received: (at 36162) by debbugs.gnu.org; 10 Jun 2019 21:41:53 +0000 Received: from localhost ([127.0.0.1]:57581 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1haS36-0006J6-SZ for submit@debbugs.gnu.org; Mon, 10 Jun 2019 17:41:53 -0400 Received: from eggs.gnu.org ([209.51.188.92]:54472) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1haS34-0006IU-Ia for 36162@debbugs.gnu.org; Mon, 10 Jun 2019 17:41:50 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:60154) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1haS2z-00018V-CB; Mon, 10 Jun 2019 17:41:45 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=33892 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1haS2y-0001fJ-SJ; Mon, 10 Jun 2019 17:41:45 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Mon, 10 Jun 2019 23:41:29 +0200 Message-Id: <20190610214130.19378-3-ludo@gnu.org> X-Mailer: git-send-email 2.21.0 In-Reply-To: <20190610214130.19378-1-ludo@gnu.org> References: <20190610214130.19378-1-ludo@gnu.org> 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: 209.51.188.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 (read-repl-response): New procedure. (read-inferior-response): Use it. --- guix/inferior.scm | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/guix/inferior.scm b/guix/inferior.scm index 63c95141d7..fee97750b6 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -59,6 +59,7 @@ inferior-eval inferior-eval-with-store inferior-object? + read-repl-response inferior-packages inferior-available-packages @@ -183,7 +184,8 @@ equivalent. Return #f if the inferior could not be launched." (set-record-type-printer! write-inferior-object) -(define (read-inferior-response inferior) +(define (read-repl-response port) + "Read a (guix repl) response from PORT and return it as a Scheme object." (define sexp->object (match-lambda (('value value) @@ -191,12 +193,15 @@ equivalent. Return #f if the inferior could not be launched." (('non-self-quoting address string) (inferior-object address string)))) - (match (read (inferior-socket inferior)) + (match (read port) (('values objects ...) (apply values (map sexp->object objects))) (('exception key objects ...) (apply throw key (map sexp->object objects))))) +(define (read-inferior-response inferior) + (read-repl-response (inferior-socket inferior))) + (define (send-inferior-request exp inferior) (write exp (inferior-socket inferior)) (newline (inferior-socket inferior))) From patchwork Mon Jun 10 21:41:30 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 14281 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 CED7017064; Mon, 10 Jun 2019 22:42:14 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id B251717063 for ; Mon, 10 Jun 2019 22:42:13 +0100 (BST) Received: from localhost ([::1]:49908 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1haS3R-0003Zt-C6 for patchwork@mira.cbaines.net; Mon, 10 Jun 2019 17:42:13 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:35145) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1haS3J-0003Sk-05 for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1haS3H-0001Kp-BD for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:44042) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1haS3H-0001Kh-7N for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1haS3H-0006K1-3h for guix-patches@gnu.org; Mon, 10 Jun 2019 17:42:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36162] [PATCH 4/4] Add (guix remote). Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Mon, 10 Jun 2019 21:42:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36162 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 36162@debbugs.gnu.org Received: via spool by 36162-submit@debbugs.gnu.org id=B36162.156020291424266 (code B ref 36162); Mon, 10 Jun 2019 21:42:03 +0000 Received: (at 36162) by debbugs.gnu.org; 10 Jun 2019 21:41:54 +0000 Received: from localhost ([127.0.0.1]:57583 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1haS38-0006JJ-7d for submit@debbugs.gnu.org; Mon, 10 Jun 2019 17:41:54 -0400 Received: from eggs.gnu.org ([209.51.188.92]:54483) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1haS35-0006IV-EU for 36162@debbugs.gnu.org; Mon, 10 Jun 2019 17:41:51 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:60155) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1haS30-000191-8c; Mon, 10 Jun 2019 17:41:46 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=33892 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1haS2z-0001fJ-P7; Mon, 10 Jun 2019 17:41:46 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Mon, 10 Jun 2019 23:41:30 +0200 Message-Id: <20190610214130.19378-4-ludo@gnu.org> X-Mailer: git-send-email 2.21.0 In-Reply-To: <20190610214130.19378-1-ludo@gnu.org> References: <20190610214130.19378-1-ludo@gnu.org> 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: 209.51.188.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/remote.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/remote.scm | 130 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 131 insertions(+) create mode 100644 guix/remote.scm diff --git a/Makefile.am b/Makefile.am index 0aa92ecfb9..42307abaed 100644 --- a/Makefile.am +++ b/Makefile.am @@ -274,6 +274,7 @@ if HAVE_GUILE_SSH MODULES += \ guix/ssh.scm \ + guix/remote.scm \ guix/scripts/copy.scm \ guix/store/ssh.scm diff --git a/guix/remote.scm b/guix/remote.scm new file mode 100644 index 0000000000..cc051dee8a --- /dev/null +++ b/guix/remote.scm @@ -0,0 +1,130 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix remote) + #:use-module (guix ssh) + #:use-module (guix gexp) + #:use-module (guix inferior) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix modules) + #:use-module (guix derivations) + #:use-module (ssh popen) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:export (remote-eval)) + +;;; Commentary: +;;; +;;; Evaluate a gexp on a remote machine, over SSH, ensuring that all the +;;; elements the gexp refers to are deployed beforehand. This is useful for +;;; expressions that have side effects; for pure expressions, you would rather +;;; build a derivation remotely or offload it. +;;; +;;; Code: + +(define (remote-pipe-for-gexp lowered session) + "Return a remote pipe for the given SESSION to evaluate LOWERED." + (define shell-quote + (compose object->string object->string)) + + (apply open-remote-pipe* session OPEN_READ + (string-append (derivation->output-path + (lowered-gexp-guile lowered)) + "/bin/guile") + "--no-auto-compile" + (append (append-map (lambda (directory) + `("-L" ,directory)) + (lowered-gexp-load-path lowered)) + (append-map (lambda (directory) + `("-C" ,directory)) + (lowered-gexp-load-path lowered)) + `("-c" + ,(shell-quote (lowered-gexp-sexp lowered)))))) + +(define (%remote-eval lowered session) + "Evaluate LOWERED, a lowered gexp, in SESSION. This assumes that all the +prerequisites of EXP are already available on the host at SESSION." + (let* ((pipe (remote-pipe-for-gexp lowered session)) + (result (read-repl-response pipe))) + (close-port pipe) + result)) + +(define (trampoline exp) + "Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation +result to the current output port using the (guix repl) protocol." + (define program + (scheme-file "remote-exp.scm" exp)) + + (with-imported-modules (source-module-closure '((guix repl))) + #~(begin + (use-modules (guix repl)) + (send-repl-response '(primitive-load #$program) + (current-output-port)) + (force-output)))) + +(define* (remote-eval exp session + #:key + (build-locally? #t) + (module-path %load-path) + (socket-name "/var/guix/daemon-socket/socket")) + "Evaluate EXP, a gexp, on the host at SESSION, an SSH session. Ensure that +all the elements EXP refers to are built and deployed to SESSION beforehand. +When BUILD-LOCALLY? is true, said dependencies are built locally and sent to +the remote store afterwards; otherwise, dependencies are built directly on the +remote store." + (mlet %store-monad ((lowered (lower-gexp (trampoline exp) + #:module-path %load-path)) + (remote -> (connect-to-remote-daemon session + socket-name))) + (define inputs + (cons (gexp-input (lowered-gexp-guile lowered)) + (lowered-gexp-inputs lowered))) + + (define to-build + (map (lambda (input) + (if (derivation? (gexp-input-thing input)) + (cons (gexp-input-thing input) + (gexp-input-output input)) + (gexp-input-thing input))) + inputs)) + + (if build-locally? + (let ((to-send (map (lambda (input) + (match (gexp-input-thing input) + ((? derivation? drv) + (derivation->output-path + drv (gexp-input-output input))) + ((? store-path? item) + item))) + inputs))) + (mbegin %store-monad + (built-derivations to-build) + ((store-lift send-files) to-send remote #:recursive? #t) + (return (%remote-eval lowered session)))) + (let ((to-send (map (lambda (input) + (match (gexp-input-thing input) + ((? derivation? drv) + (derivation-file-name drv)) + ((? store-path? item) + item))) + inputs))) + (mbegin %store-monad + ((store-lift send-files) to-send remote #:recursive? #t) + (return (build-derivations remote to-build)) + (return (%remote-eval lowered session)))))))