From 2ca41030d5189d83ea2a28ea64cf0e19efed5fd7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Jun 2019 14:34:36 +0200 Subject: gexp: Add 'lower-gexp' and express 'gexp->derivation' in terms of it. * 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 | 240 +++++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 181 insertions(+), 59 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 4f2adba90a..ce48d8d001 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,130 @@ 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 + "*Note: This API is subject to change; use at your own risk!* + +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 + #: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 + 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 +824,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 +839,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 +856,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 +886,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 +925,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) -- cgit v1.2.3 From 92a4087bf4862d5ba9b77111eba3c68c2a1c4679 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Jun 2019 17:09:35 +0200 Subject: Add (guix repl). * 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 (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 8adf23c699..9c070cd5b8 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." -- cgit v1.2.3 From d0ffa321dd4917ddb9777728ccf90bd147fe51fb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Jun 2019 17:11:43 +0200 Subject: inferior: Add 'read-repl-response'. * guix/inferior.scm (read-repl-response): New procedure. (read-inferior-response): Use it. --- guix/inferior.scm | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'guix') 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))) -- cgit v1.2.3 From 9d8ab8034ea4efe5f6ac317df7cf2c7c7e76590d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Jun 2019 22:39:39 +0200 Subject: Add (guix remote). * guix/remote.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/remote.scm | 134 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 135 insertions(+) create mode 100644 guix/remote.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 9c070cd5b8..31430545cb 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..e503c76167 --- /dev/null +++ b/guix/remote.scm @@ -0,0 +1,134 @@ +;;; 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: +;;; +;;; Note: This API is experimental and subject to change! +;;; +;;; 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 (close-connection remote)) + (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 (close-connection remote)) + (return (%remote-eval lowered session))))))) -- cgit v1.2.3 From b9fcf0c82a14df48c7c6f36a08dbdcd3184fcbf8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Jul 2019 09:19:48 +0200 Subject: pack: 'docker' backend records the profile's search paths. * guix/docker.scm (config): Add #:environment parameter and honor it. (build-docker-image): Likewise, and pass it to 'config'. * guix/scripts/pack.scm (docker-image): Import (guix profiles) and (guix search-paths). Call 'profile-search-paths' and pass #:environment to 'build-docker-image'. * gnu/tests/docker.scm (run-docker-test)["Load docker image and run it"]: Add example that expects (json) to be available. * gnu/tests/docker.scm (build-tarball&run-docker-test): Replace %BOOTSTRAP-GUILE by GUILE-2.2 and GUILE-JSON in the environment. --- gnu/tests/docker.scm | 18 ++++++++++++------ guix/docker.scm | 17 +++++++++++++---- guix/scripts/pack.scm | 23 +++++++++++++++++++---- 3 files changed, 44 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm index f2674cdbe8..3ec5c3d6ee 100644 --- a/gnu/tests/docker.scm +++ b/gnu/tests/docker.scm @@ -27,7 +27,6 @@ #:use-module (gnu services networking) #:use-module (gnu services docker) #:use-module (gnu services desktop) - #:use-module (gnu packages bootstrap) ; %bootstrap-guile #:use-module (gnu packages docker) #:use-module (gnu packages guile) #:use-module (guix gexp) @@ -101,7 +100,7 @@ inside %DOCKER-OS." marionette)) (test-equal "Load docker image and run it" - '("hello world" "hi!") + '("hello world" "hi!" "JSON!") (marionette-eval `(begin (define slurp @@ -125,8 +124,15 @@ inside %DOCKER-OS." (response2 (slurp ;default entry point ,(string-append #$docker-cli "/bin/docker") "run" repository&tag - "-c" "(display \"hi!\")"))) - (list response1 response2))) + "-c" "(display \"hi!\")")) + + ;; Check whether (json) is in $GUILE_LOAD_PATH. + (response3 (slurp ;default entry point + environment + ,(string-append #$docker-cli "/bin/docker") + "run" repository&tag + "-c" "(use-modules (json)) + (display (json-string->scm (scm->json-string \"JSON!\")))"))) + (list response1 response2 response3))) marionette)) (test-end) @@ -144,7 +150,7 @@ inside %DOCKER-OS." (version "0") (source #f) (build-system trivial-build-system) - (arguments `(#:guile ,%bootstrap-guile + (arguments `(#:guile ,guile-2.2 #:builder (let ((out (assoc-ref %outputs "out"))) (mkdir out) @@ -158,7 +164,7 @@ standard output device and then enters a new line.") (home-page #f) (license license:public-domain))) (profile (profile-derivation (packages->manifest - (list %bootstrap-guile + (list guile-2.2 guile-json guest-script-package)) #:hooks '() #:locales? #f)) diff --git a/guix/docker.scm b/guix/docker.scm index 7fe83d9797..b1bd226fa1 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -73,7 +73,7 @@ `((,(generate-tag path) . ((latest . ,id))))) ;; See https://github.com/opencontainers/image-spec/blob/master/config.md -(define* (config layer time arch #:key entry-point) +(define* (config layer time arch #:key entry-point (environment '())) "Generate a minimal image configuration for the given LAYER file." ;; "architecture" must be values matching "platform.arch" in the ;; runtime-spec at @@ -81,9 +81,13 @@ `((architecture . ,arch) (comment . "Generated by GNU Guix") (created . ,time) - (config . ,(if entry-point - `((entrypoint . ,entry-point)) - #nil)) + (config . ,`((env . ,(map (match-lambda + ((name . value) + (string-append name "=" value))) + environment)) + ,@(if entry-point + `((entrypoint . ,entry-point)) + '()))) (container_config . #nil) (os . "linux") (rootfs . ((type . "layers") @@ -113,6 +117,7 @@ return \"a\"." (system (utsname:machine (uname))) database entry-point + (environment '()) compressor (creation-time (current-time time-utc))) "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX @@ -124,6 +129,9 @@ When DATABASE is true, copy it to /var/guix/db in the image and create When ENTRY-POINT is true, it must be a list of strings; it is stored as the entry point in the Docker image JSON structure. +ENVIRONMENT must be a list of name/value pairs. It specifies the environment +variables that must be defined in the resulting image. + SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be created in the image, where each TARGET is relative to PREFIX. TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to @@ -234,6 +242,7 @@ SRFI-19 time-utc object, as the creation time in metadata." (lambda () (scm->json (config (string-append id "/layer.tar") time arch + #:environment environment #:entry-point entry-point)))) (with-output-to-file "manifest.json" (lambda () diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index c90b777222..bb6a8cda1a 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -27,6 +27,7 @@ #:use-module (guix utils) #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) + #:use-module ((guix self) #:select (make-config.scm)) #:use-module (guix grafts) #:autoload (guix inferior) (inferior-package?) #:use-module (guix monads) @@ -440,11 +441,24 @@ the image." (define build ;; Guile-JSON and Guile-Gcrypt are required by (guix docker). (with-extensions (list guile-json guile-gcrypt) - (with-imported-modules (source-module-closure '((guix docker) - (guix build store-copy)) - #:select? not-config?) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + `((guix docker) + (guix build store-copy) + (guix profiles) + (guix search-paths)) + #:select? not-config?)) #~(begin - (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) + (use-modules (guix docker) (guix build store-copy) + (guix profiles) (guix search-paths) + (srfi srfi-19) (ice-9 match)) + + (define environment + (map (match-lambda + ((spec . value) + (cons (search-path-specification-variable spec) + value))) + (profile-search-paths #$profile))) (setenv "PATH" (string-append #$archiver "/bin")) @@ -455,6 +469,7 @@ the image." #$profile #:database #+database #:system (or #$target (utsname:machine (uname))) + #:environment environment #:entry-point #$(and entry-point #~(string-append #$profile "/" #$entry-point)) -- cgit v1.2.3 From dea62932bc929243dae5e8b08f4fbe0b6f70be95 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Jul 2019 10:30:23 +0200 Subject: pack: 'squashfs' backend records the profile's search paths. * guix/scripts/pack.scm (singularity-environment-file): New procedure. (squashfs-image): Use it, and create /.singularity/env/90-environment.sh. * gnu/tests/singularity.scm (run-singularity-test)["singularity run, with environment"]: New test, currently skipped. * gnu/tests/singularity.scm (build-tarball&run-singularity-test): Add GUILE-JSON to the profile. --- gnu/tests/singularity.scm | 18 +++++++++++++++++- guix/scripts/pack.scm | 41 ++++++++++++++++++++++++++++++++++++++++- 2 files changed, 57 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/gnu/tests/singularity.scm b/gnu/tests/singularity.scm index 668043a0bc..2f3a6f289d 100644 --- a/gnu/tests/singularity.scm +++ b/gnu/tests/singularity.scm @@ -111,6 +111,21 @@ "run" #$image "-c" "(exit 42)")) marionette)) + ;; FIXME: Singularity 2.x doesn't directly honor + ;; /.singularity.d/env/*.sh. Instead, you have to load those files + ;; manually, which we don't do. Remove 'test-skip' call once we've + ;; switch to Singularity 3.x. + (test-skip 1) + (test-equal "singularity run, with environment" + 0 + (marionette-eval + ;; Check whether GUILE_LOAD_PATH is properly set, allowing us to + ;; find the (json) module. + `(status:exit-val + (system* #$(file-append singularity "/bin/singularity") + "--debug" "run" #$image "-c" "(use-modules (json))")) + marionette)) + (test-end) (exit (= (test-runner-fail-count (test-runner-current)) 0))))) @@ -122,7 +137,8 @@ (guile (set-guile-for-build (default-guile))) ;; 'singularity exec' insists on having /bin/sh in the image. (profile (profile-derivation (packages->manifest - (list bash-minimal guile-2.2)) + (list bash-minimal + guile-2.2 guile-json)) #:hooks '() #:locales? #f)) (tarball (squashfs-image "singularity-pack" profile diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index bb6a8cda1a..4ac5dfc896 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -286,6 +286,32 @@ added to the pack." build #:references-graphs `(("profile" ,profile)))) +(define (singularity-environment-file profile) + "Return a shell script that defines the environment variables corresponding +to the search paths of PROFILE." + (define build + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + `((guix profiles) + (guix search-paths)) + #:select? not-config?)) + #~(begin + (use-modules (guix profiles) (guix search-paths) + (ice-9 match)) + + (call-with-output-file #$output + (lambda (port) + (for-each (match-lambda + ((spec . value) + (format port "~a=~a~%export ~a~%" + (search-path-specification-variable spec) + value + (search-path-specification-variable spec)))) + (profile-search-paths #$profile)))))))) + + (computed-file "singularity-environment.sh" build)) + (define* (squashfs-image name profile #:key target (profile-name "guix-profile") @@ -305,6 +331,9 @@ added to the pack." (file-append (store-database (list profile)) "/db/db.sqlite"))) + (define environment + (singularity-environment-file profile)) + (define build (with-imported-modules (source-module-closure '((guix build utils) @@ -339,6 +368,7 @@ added to the pack." `(,@(map store-info-item (call-with-input-file "profile" read-reference-graph)) + #$environment ,#$output ;; Do not perform duplicate checking because we @@ -379,10 +409,19 @@ added to the pack." target))))))) '#$symlinks) + "-p" "/.singularity.d d 555 0 0" + + ;; Create the environment file. + "-p" "/.singularity.d/env d 555 0 0" + "-p" ,(string-append + "/.singularity.d/env/90-environment.sh s 777 0 0 " + (relative-file-name "/.singularity.d/env" + #$environment)) + ;; Create /.singularity.d/actions, and optionally the 'run' ;; script, used by 'singularity run'. - "-p" "/.singularity.d d 555 0 0" "-p" "/.singularity.d/actions d 555 0 0" + ,@(if entry-point `(;; This one if for Singularity 2.x. "-p" -- cgit v1.2.3 From b1510fd8d252c1ab0d32a32f064513105b99cf39 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Jul 2019 23:09:11 +0200 Subject: derivations: 'derivation-build-plan' recurses on substituables. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This fixes a bug whereby "guix build texlive -n" would report: 0.0 MB would be downloaded: /gnu/store/…-texlive-20180414 instead of: The following derivation would be built: /gnu/store/…-texlive-texmf-20180414.drv 2,595.2 MB would be downloaded: /gnu/store/…-texlive-20180414-texmf.tar.xz /gnu/store/…-texlive-20180414 where 'texlive-texmf' is a non-substitutable dependency of 'texlive'. * guix/derivations.scm (dependencies-of-substitutables): New procedure. (derivation-build-plan): When 'input-substitutable-info' returns true, append the subset of DEPS that corresponds to SUBSTITUABLES to the first argument of 'loop'. * guix/ui.scm (show-what-to-build): Remove half-baked traversal of DOWNLOAD. * tests/derivations.scm ("derivation-build-plan and substitutes, non-substitutable dep"): New test. --- guix/derivations.scm | 29 +++++++++++++++++++++-------- guix/ui.scm | 12 ------------ tests/derivations.scm | 29 +++++++++++++++++++++++++++++ 3 files changed, 50 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 186d7a3f8f..caa76bd16c 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -352,6 +352,16 @@ substituter many times." (#f #f) ((key . value) value))))) +(define (dependencies-of-substitutables substitutables inputs) + "Return the subset of INPUTS whose output file names is among the references +of SUBSTITUTABLES." + (let ((items (fold set-insert (set) + (append-map substitutable-references substitutables)))) + (filter (lambda (input) + (any (cut set-contains? items <>) + (derivation-input-output-paths input))) + inputs))) + (define* (derivation-build-plan store inputs #:key (mode (build-mode normal)) @@ -391,7 +401,9 @@ by 'substitution-oracle'." (() (values build substitute)) ((input rest ...) - (let ((key (derivation-input-key input))) + (let ((key (derivation-input-key input)) + (deps (derivation-inputs + (derivation-input-derivation input)))) (cond ((set-contains? visited key) (loop rest build substitute visited)) ((input-built? input) @@ -400,16 +412,17 @@ by 'substitution-oracle'." ((input-substitutable-info input) => (lambda (substitutables) - (loop rest build + (loop (append (dependencies-of-substitutables substitutables + deps) + rest) + build (append substitutables substitute) (set-insert key visited)))) (else - (let ((deps (derivation-inputs - (derivation-input-derivation input)))) - (loop (append deps rest) - (cons (derivation-input-derivation input) build) - substitute - (set-insert key visited)))))))))) + (loop (append deps rest) + (cons (derivation-input-derivation input) build) + substitute + (set-insert key visited))))))))) (define-deprecated (derivation-prerequisites-to-build store drv #:rest rest) derivation-build-plan diff --git a/guix/ui.scm b/guix/ui.scm index 6d243ef041..2ce82ff658 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -844,18 +844,6 @@ check and report what is prerequisites are available for download." #:mode mode #:substitutable-info substitutable-info)) - ((download) ; add the references of DOWNLOAD - (if use-substitutes? - (delete-duplicates - (append download - (filter-map (lambda (item) - (if (valid-path? store item) - #f - (substitutable-info item))) - (append-map - substitutable-references - download)))) - download)) ((graft hook build) (match (fold (lambda (drv acc) (let ((file (derivation-file-name drv))) diff --git a/tests/derivations.scm b/tests/derivations.scm index d173a78906..7be7726163 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -896,6 +896,35 @@ (((= derivation-file-name build)) (string=? build (derivation-file-name drv))))))))) +(test-assert "derivation-build-plan and substitutes, non-substitutable dep" + (with-store store + (let* ((drv1 (build-expression->derivation store "prereq-no-subst" + (random 1000) + #:substitutable? #f)) + (drv2 (build-expression->derivation store "substitutable" + (random 1000) + #:inputs `(("dep" ,drv1))))) + + ;; Make sure substitutes are usable. + (set-build-options store #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) + + (with-derivation-narinfo drv2 + (sha256 => (make-bytevector 32 0)) + (references => (list (derivation->output-path drv1))) + + (let-values (((build download) + (derivation-build-plan store + (list (derivation-input drv2))))) + ;; Although DRV2 is available as a substitute, we must build its + ;; dependency, DRV1, due to #:substitutable? #f. + (and (match download + (((= substitutable-path item)) + (string=? item (derivation->output-path drv2)))) + (match build + (((= derivation-file-name build)) + (string=? build (derivation-file-name drv1)))))))))) + (test-assert "derivation-build-plan and substitutes, local build" (with-store store (let* ((drv (build-expression->derivation store "prereq-subst-local" -- cgit v1.2.3 From d74392a85cfd0992d034b903ca21180a6d73eaed Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 5 Jul 2019 00:09:27 +0200 Subject: derivations: Simplify 'substitution-oracle'. * guix/derivations.scm (substitution-oracle)[valid?, dependencies]: Remove. [closure]: New procedure. Rename parameter from 'drv' to 'inputs-or-drv' and adjust accordingly. (derivation-build-plan): Pass INPUTS directly to 'substitution-oracle'. * guix/ui.scm (show-what-to-build)[substitutable-info]: Likewise. --- guix/derivations.scm | 86 ++++++++++++++++++++++++---------------------------- guix/ui.scm | 3 +- 2 files changed, 41 insertions(+), 48 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index caa76bd16c..731f1f698f 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -293,60 +293,57 @@ result is the set of prerequisites of DRV not already in valid." (derivation-output-path (assoc-ref outputs sub-drv))) sub-drvs)))) -(define* (substitution-oracle store drv +(define* (substitution-oracle store inputs-or-drv #:key (mode (build-mode normal))) "Return a one-argument procedure that, when passed a store file name, returns a 'substitutable?' if it's substitutable and #f otherwise. -The returned procedure -knows about all substitutes for all the derivations listed in DRV, *except* -those that are already valid (that is, it won't bother checking whether an -item is substitutable if it's already on disk); it also knows about their -prerequisites, unless they are themselves substitutable. + +The returned procedure knows about all substitutes for all the derivation +inputs or derivations listed in INPUTS-OR-DRV, *except* those that are already +valid (that is, it won't bother checking whether an item is substitutable if +it's already on disk); it also knows about their prerequisites, unless they +are themselves substitutable. Creating a single oracle (thus making a single 'substitutable-path-info' call) and reusing it is much more efficient than calling 'has-substitutes?' or similar repeatedly, because it avoids the costs associated with launching the substituter many times." - (define valid? - (cut valid-path? store <>)) - (define valid-input? (cut valid-derivation-input? store <>)) - (define (dependencies drv) - ;; Skip prerequisite sub-trees of DRV whose root is valid. This allows us - ;; to ask the substituter for just as much as needed, instead of asking it - ;; for the whole world, which can be significantly faster when substitute - ;; info is not already in cache. - ;; Also, skip derivations marked as non-substitutable. - (append-map (lambda (input) + (define (closure inputs) + (let loop ((inputs inputs) + (closure '()) + (visited (set))) + (match inputs + (() + (reverse closure)) + ((input rest ...) + (let ((key (derivation-input-key input))) + (cond ((set-contains? visited key) + (loop rest closure visited)) + ((valid-input? input) + (loop rest closure (set-insert key visited))) + (else (let ((drv (derivation-input-derivation input))) - (if (substitutable-derivation? drv) - (derivation-input-output-paths input) - '()))) - (derivation-prerequisites drv valid-input?))) - - (let* ((paths (delete-duplicates - (concatenate - (fold (lambda (drv result) - (let ((self (match (derivation->output-paths drv) - (((names . paths) ...) - paths)))) - (cond ((eqv? mode (build-mode check)) - (cons (dependencies drv) result)) - ((not (substitutable-derivation? drv)) - (cons (dependencies drv) result)) - ((every valid? self) - result) - (else - (cons* self (dependencies drv) result))))) - '() - drv)))) - (subst (fold (lambda (subst vhash) - (vhash-cons (substitutable-path subst) subst - vhash)) - vlist-null - (substitutable-path-info store paths)))) + (loop (append (derivation-inputs drv) rest) + (if (substitutable-derivation? drv) + (cons input closure) + closure) + (set-insert key visited)))))))))) + + (let* ((inputs (closure (map (match-lambda + ((? derivation-input? input) + input) + ((? derivation? drv) + (derivation-input drv))) + inputs-or-drv))) + (items (append-map derivation-input-output-paths inputs)) + (subst (fold (lambda (subst vhash) + (vhash-cons (substitutable-path subst) subst + vhash)) + vlist-null + (substitutable-path-info store items)))) (lambda (item) (match (vhash-assoc item subst) (#f #f) @@ -367,10 +364,7 @@ of SUBSTITUTABLES." (mode (build-mode normal)) (substitutable-info (substitution-oracle - store - (map derivation-input-derivation - inputs) - #:mode mode))) + store inputs #:mode mode))) "Given INPUTS, a list of derivation-inputs, return two values: the list of derivation to build, and the list of substitutable items that, together, allows INPUTS to be realized. diff --git a/guix/ui.scm b/guix/ui.scm index 2ce82ff658..7d6ab9a2a7 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -835,8 +835,7 @@ check and report what is prerequisites are available for download." ;; substituter many times. This makes a big difference, especially when ;; DRV is a long list as is the case with 'guix environment'. (if use-substitutes? - (substitution-oracle store (map derivation-input-derivation inputs) - #:mode mode) + (substitution-oracle store inputs #:mode mode) (const #f))) (let*-values (((build download) -- cgit v1.2.3 From 728a4ab1019fda2f14a5c69d3f1b277fb5e09cda Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 5 Jul 2019 00:48:20 +0200 Subject: store: 'run-with-store' gracefully deals with #f store. This is a followup to dd0ee954c4fa965023fd887452927c02edb8b52f, which introduced a failure in tests/graph.scm. * guix/store.scm (run-with-store): Check whether STORE and NEW-STORE are true before calling 'store-connection-object-cache' etc. Fixes a failure in tests/graph.scm related to %REVERSE-PACKAGE-NODE-TYPE, which uses #f as the store. --- guix/store.scm | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 52940ff751..d7c603898c 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1802,11 +1802,12 @@ connection, and return the result." (call-with-values (lambda () (run-with-state mval store)) (lambda (result new-store) - ;; Copy the object cache from NEW-STORE so we don't fully discard the - ;; state. - (let ((cache (store-connection-object-cache new-store))) - (set-store-connection-object-cache! store cache) - result))))) + (when (and store new-store) + ;; Copy the object cache from NEW-STORE so we don't fully discard + ;; the state. + (let ((cache (store-connection-object-cache new-store))) + (set-store-connection-object-cache! store cache))) + result)))) ;;; -- cgit v1.2.3 From a9b09ed7764762f93c1a8b7c96769b9da72dc8c4 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Fri, 5 Jul 2019 14:54:32 -0400 Subject: ssh: Add 'identity' keyword to 'open-ssh-session'. * guix/ssh.scm (open-ssh-session): Add 'identity' keyword argument. --- guix/ssh.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index 9b9baf54ea..ede00133c8 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -57,12 +57,14 @@ (define %compression "zlib@openssh.com,zlib") -(define* (open-ssh-session host #:key user port +(define* (open-ssh-session host #:key user port identity (compression %compression)) - "Open an SSH session for HOST and return it. When USER and PORT are #f, use -default values or whatever '~/.ssh/config' specifies; otherwise use them. -Throw an error on failure." + "Open an SSH session for HOST and return it. IDENTITY specifies the file +name of a private key to use for authenticating with the host. When USER, +PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config' +specifies; otherwise use them. Throw an error on failure." (let ((session (make-session #:user user + #:identity identity #:host host #:port port #:timeout 10 ;seconds -- cgit v1.2.3 From 5cbb832fb107a8ca55938a52f6699ad8c6f08c8d Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Fri, 5 Jul 2019 14:56:07 -0400 Subject: Add 'guix deploy'. * guix/scripts/deploy.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/scripts/deploy.scm | 84 +++++++++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + 3 files changed, 86 insertions(+) create mode 100644 guix/scripts/deploy.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index beb60097a4..34bef76b47 100644 --- a/Makefile.am +++ b/Makefile.am @@ -267,6 +267,7 @@ MODULES = \ guix/scripts/weather.scm \ guix/scripts/container.scm \ guix/scripts/container/exec.scm \ + guix/scripts/deploy.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm new file mode 100644 index 0000000000..978cfb2a81 --- /dev/null +++ b/guix/scripts/deploy.scm @@ -0,0 +1,84 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson +;;; Copyright © 2019 Jakob L. Kreuze +;;; +;;; 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 scripts deploy) + #:use-module (gnu machine) + #:use-module (guix scripts) + #:use-module (guix scripts build) + #:use-module (guix store) + #:use-module (guix ui) + #:use-module (ice-9 format) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:export (guix-deploy)) + +;;; Commentary: +;;; +;;; This program provides a command-line interface to (gnu machine), allowing +;;; users to perform remote deployments through specification files. +;;; +;;; Code: + + + +(define (show-help) + (display (G_ "Usage: guix deploy [OPTION] FILE... +Perform the deployment specified by FILE.\n")) + (show-build-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + %standard-build-options)) + +(define %default-options + '((system . ,(%current-system)) + (substitutes? . #t) + (build-hook? . #t) + (graft? . #t) + (debug . 0) + (verbosity . 1))) + +(define (load-source-file file) + "Load FILE as a user module." + (let ((module (make-user-module '((gnu) (gnu machine) (gnu machine ssh))))) + (load* file module))) + +(define (guix-deploy . args) + (define (handle-argument arg result) + (alist-cons 'file arg result)) + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + (file (assq-ref opts 'file)) + (machines (or (and file (load-source-file file)) '()))) + (with-store store + (set-build-options-from-command-line store opts) + (for-each (lambda (machine) + (info (G_ "deploying to ~a...") (machine-display-name machine)) + (run-with-store store (deploy-machine machine))) + machines)))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index bcd6f76371..f5fc4956b4 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -67,6 +67,7 @@ guix/scripts/pack.scm guix/scripts/weather.scm guix/scripts/describe.scm guix/scripts/processes.scm +guix/scripts/deploy.scm guix/gnu-maintenance.scm guix/scripts/container.scm guix/scripts/container/exec.scm -- cgit v1.2.3 From d9e6217f4e978777d1e6f7b82a1e096740cc419a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Jul 2019 15:54:45 +0200 Subject: channels: Simplify 'channel-instances->manifest'. * guix/channels.scm (channel-instances->manifest)[instance->entry]: Change to take two arguments instead of a tuple. Turn into a non-monadic procedure. Call it via 'map' instead of 'mapm'. --- guix/channels.scm | 43 +++++++++++++++++++------------------------ 1 file changed, 19 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index e7278c6060..fcf9fed829 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -429,32 +429,27 @@ derivation." (define (channel-instances->manifest instances) "Return a profile manifest with entries for all of INSTANCES, a list of channel instances." - (define instance->entry - (match-lambda - ((instance drv) - (let ((commit (channel-instance-commit instance)) - (channel (channel-instance-channel instance))) - (with-monad %store-monad - (return (manifest-entry - (name (symbol->string (channel-name channel))) - (version (string-take commit 7)) - (item (if (guix-channel? channel) - (if (old-style-guix? drv) - (whole-package-for-legacy - (string-append name "-" version) - drv) - drv) - drv)) - (properties - `((source (repository - (version 0) - (url ,(channel-url channel)) - (branch ,(channel-branch channel)) - (commit ,commit)))))))))))) + (define (instance->entry instance drv) + (let ((commit (channel-instance-commit instance)) + (channel (channel-instance-channel instance))) + (manifest-entry + (name (symbol->string (channel-name channel))) + (version (string-take commit 7)) + (item (if (guix-channel? channel) + (if (old-style-guix? drv) + (whole-package-for-legacy (string-append name "-" version) + drv) + drv) + drv)) + (properties + `((source (repository + (version 0) + (url ,(channel-url channel)) + (branch ,(channel-branch channel)) + (commit ,commit)))))))) (mlet* %store-monad ((derivations (channel-instance-derivations instances)) - (entries (mapm %store-monad instance->entry - (zip instances derivations)))) + (entries -> (map instance->entry instances derivations))) (return (manifest entries)))) (define (package-cache-file manifest) -- cgit v1.2.3 From 079c93e1c1dd93639417095000d5e56d8db62d61 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 6 Jul 2019 20:02:02 -0400 Subject: self: Ship the (gnu machine …) modules. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is a followup to commit fa9edf09e992db7510c7471486dffc93e1e707e5. * guix/self.scm (compiled-guix)[*system-modules*]: Explicitly add all of gnu/machine/*. --- guix/self.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index be90b60863..b8581d01d5 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -769,7 +769,8 @@ Info manual." (gnu services) ,@(scheme-modules* source "gnu/bootloader") ,@(scheme-modules* source "gnu/system") - ,@(scheme-modules* source "gnu/services")) + ,@(scheme-modules* source "gnu/services") + ,@(scheme-modules* source "gnu/machine")) (list *core-package-modules* *package-modules* *extra-modules* *core-modules*) #:extensions dependencies -- cgit v1.2.3 From cdf689471a7f360efc798eb6e4dcdc4297d64043 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Jul 2019 10:53:41 +0200 Subject: channels: Key cached channel derivations by system. Previously, the channel instance to derivation mapping would be independent of the system. Thus, building the same channel instance for several different systems would always return the derivation that was first computed. This is a followup to c3ab921eed2a471022e9863a94ea521508782e53. * guix/channels.scm (channel-instance-derivations)[instance->derivation]: Pass the current system as a third argument to 'mcached'. --- guix/channels.scm | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index fcf9fed829..e6bb9b891b 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -349,13 +349,15 @@ INSTANCES." (resolve-dependencies instances)) (define (instance->derivation instance) - (mcached (if (eq? instance core-instance) - (build-channel-instance instance) - (mlet %store-monad ((core (instance->derivation core-instance)) - (deps (mapm %store-monad instance->derivation - (edges instance)))) - (build-channel-instance instance core deps))) - instance)) + (mlet %store-monad ((system (current-system))) + (mcached (if (eq? instance core-instance) + (build-channel-instance instance) + (mlet %store-monad ((core (instance->derivation core-instance)) + (deps (mapm %store-monad instance->derivation + (edges instance)))) + (build-channel-instance instance core deps))) + instance + system))) (unless core-instance (let ((loc (and=> (any (compose channel-location channel-instance-channel) -- cgit v1.2.3 From a655d504aa1dc04ab9c8916f2022f07ca89ceb3b Mon Sep 17 00:00:00 2001 From: Carl Dong Date: Sat, 29 Jun 2019 16:59:22 -0400 Subject: scripts: environment: Only rewrite user-specified mappings. * guix/scripts/environment.scm (launch-environment/container): Only apply override-user-mappings to user-mappings and cwd. Do not apply to network configuration mapping and inputs. --- guix/scripts/environment.scm | 41 +++++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index c1341628a8..949ba1124f 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -479,26 +479,27 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from ;; /bin/sh, the current working directory, and possibly networking ;; configuration files within the container. (mappings - (override-user-mappings - user home - (append user-mappings - ;; Current working directory. - (list (file-system-mapping - (source cwd) - (target cwd) - (writable? #t))) - ;; When in Rome, do as Nix build.cc does: Automagically - ;; map common network configuration files. - (if network? - %network-file-mappings - '()) - ;; Mappings for the union closure of all inputs. - (map (lambda (dir) - (file-system-mapping - (source dir) - (target dir) - (writable? #f))) - reqs)))) + (append + (override-user-mappings + user home + (append user-mappings + ;; Current working directory. + (list (file-system-mapping + (source cwd) + (target cwd) + (writable? #t))))) + ;; When in Rome, do as Nix build.cc does: Automagically + ;; map common network configuration files. + (if network? + %network-file-mappings + '()) + ;; Mappings for the union closure of all inputs. + (map (lambda (dir) + (file-system-mapping + (source dir) + (target dir) + (writable? #f))) + reqs))) (file-systems (append %container-file-systems (map file-system-mapping->bind-mount mappings)))) -- cgit v1.2.3 From b6dc08393e6a8313b88ce422fc3c1e4e9c0efc6f Mon Sep 17 00:00:00 2001 From: Carl Dong Date: Sat, 29 Jun 2019 17:15:11 -0400 Subject: scripts: environment: Add --no-cwd. * doc/guix.texi (Invoking guix environment): Add --no-cwd. * guix/scripts/environment.scm (show-help, %options): Add --no-cwd. (launch-environment/container): Add 'map-cwd?' param; only add mapping for cwd if #t. Only change to cwd within container if #t, otherwise home. (guix-environment): Error if --no-cwd without --container. Provide '(not no-cwd?)' to launch-environment/container as 'map-cwd?'. * tests/guix-environment.sh: Add test for no-cwd. Co-authored-by: Mike Gerwitz --- doc/guix.texi | 8 ++++++++ guix/scripts/environment.scm | 36 +++++++++++++++++++++++++++--------- tests/guix-environment.sh | 8 ++++++++ 3 files changed, 43 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 0b50482530..3e0788ed3a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4657,6 +4657,14 @@ While this will limit the leaking of user identity through home paths and each of the user fields, this is only one useful component of a broader privacy/anonymity solution---not one in and of itself. +@item --no-cwd +For containers, the default behavior is to share the current working +directory with the isolated container and immediately change to that +directory within the container. If this is undesirable, @code{--no-cwd} +will cause the current working directory to @emph{not} be automatically +shared and will change to the user's home directory within the container +instead. See also @code{--user}. + @item --expose=@var{source}[=@var{target}] For containers, expose the file system @var{source} from the host system as the read-only file system @var{target} within the container. If diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 949ba1124f..cf58768300 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -161,6 +161,10 @@ COMMAND or an interactive shell in that environment.\n")) -u, --user=USER instead of copying the name and home of the current user into an isolated container, use the name USER with home directory /home/USER")) + (display (G_ " + --no-cwd do not share current working directory with an + isolated container")) + (display (G_ " --share=SPEC for containers, share writable host file system according to SPEC")) @@ -269,6 +273,9 @@ use '--preserve' instead~%")) (lambda (opt name arg result) (alist-cons 'user arg (alist-delete 'user result eq?)))) + (option '("no-cwd") #f #f + (lambda (opt name arg result) + (alist-cons 'no-cwd? #t result))) (option '("share") #t #f (lambda (opt name arg result) (alist-cons 'file-system-mapping @@ -444,7 +451,8 @@ regexps in WHITE-LIST." ((_ . status) status))))) (define* (launch-environment/container #:key command bash user user-mappings - profile manifest link-profile? network?) + profile manifest link-profile? network? + map-cwd?) "Run COMMAND within a container that features the software in PROFILE. Environment variables are set according to the search paths of MANIFEST. The global shell is BASH, a file name for a GNU Bash binary in the @@ -483,11 +491,13 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (override-user-mappings user home (append user-mappings - ;; Current working directory. - (list (file-system-mapping - (source cwd) - (target cwd) - (writable? #t))))) + ;; Share current working directory, unless asked not to. + (if map-cwd? + (list (file-system-mapping + (source cwd) + (target cwd) + (writable? #t))) + '()))) ;; When in Rome, do as Nix build.cc does: Automagically ;; map common network configuration files. (if network? @@ -537,8 +547,10 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (write-group groups) ;; For convenience, start in the user's current working - ;; directory rather than the root directory. - (chdir (override-user-dir user home cwd)) + ;; directory or, if unmapped, the home directory. + (chdir (if map-cwd? + (override-user-dir user home cwd) + home-dir)) (primitive-exit/status ;; A container's environment is already purified, so no need to @@ -665,6 +677,7 @@ message if any test fails." (container? (assoc-ref opts 'container?)) (link-prof? (assoc-ref opts 'link-profile?)) (network? (assoc-ref opts 'network?)) + (no-cwd? (assoc-ref opts 'no-cwd?)) (user (assoc-ref opts 'user)) (bootstrap? (assoc-ref opts 'bootstrap?)) (system (assoc-ref opts 'system)) @@ -685,6 +698,9 @@ message if any test fails." (leave (G_ "'--link-profile' cannot be used without '--container'~%"))) (when (and (not container?) user) (leave (G_ "'--user' cannot be used without '--container'~%"))) + (when (and (not container?) no-cwd?) + (leave (G_ "--no-cwd cannot be used without --container~%"))) + (with-store store (with-status-verbosity (assoc-ref opts 'verbosity) @@ -741,7 +757,9 @@ message if any test fails." #:profile profile #:manifest manifest #:link-profile? link-prof? - #:network? network?))) + #:network? network? + #:map-cwd? (not no-cwd?)))) + (else (return (exit/status diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index a670db36be..5a5a69d58c 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -84,6 +84,14 @@ echo "(use-modules (guix profiles) (gnu packages bootstrap)) guix environment --bootstrap --manifest=$tmpdir/manifest.scm --pure \ -- "$SHELL" -c 'test -f "$GUIX_ENVIRONMENT/bin/guile"' +# if not sharing CWD, chdir home +( + cd "$tmpdir" \ + && guix environment --bootstrap --container --no-cwd --user=foo \ + --ad-hoc guile-bootstrap --pure \ + -- /bin/sh -c 'test $(pwd) == "/home/foo" -a ! -d '"$tmpdir" +) + # Make sure '-r' works as expected. rm -f "$gcroot" expected="`guix environment --bootstrap --ad-hoc guile-bootstrap \ -- cgit v1.2.3 From 1d0bde2ee4009a301fee6ceeaf140396bb49a748 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 7 Jul 2019 12:14:58 +0100 Subject: discovery: Handle edge case in scheme-files when looking at symlinks. Previously, this code would cause crashes in Guix (running guix package -s for example) which could be experienced when Emacs creates temporary files in the gnu/packages/patches directory when a patch file has been edited, but not saved. * guix/discovery.scm (scheme-files): Add else clause to cond used when handling symlinks. --- guix/discovery.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/discovery.scm b/guix/discovery.scm index 5bb494941b..86f20ec344 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -78,7 +78,9 @@ DIRECTORY is not accessible." ((= stat:type 'directory) (append (scheme-files absolute) result)) - (_ result))))) + (_ result))) + (else + result))) (else result)))))) '() -- cgit v1.2.3 From 5c3d44303e1bb75d45334af5cf86cde723da0371 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Jul 2019 19:58:30 +0200 Subject: guix gc: Correctly handle '--delete-generations' with no arguments. Previously, 'guix gc --delete-generations' would crash: the "" pattern would be passed to 'matching-generations', which would return #f instead of returning a list. Reported by Raghav Gururajan in . * guix/ui.scm (matching-generations): Raise an error when passed an invalid pattern. * guix/scripts/gc.scm (delete-old-generations): Check if PATTERN is true. (%options): Leave ARG as-is for 'delete-generations'. (guix-gc): Use 'assq' instead of 'assoc-ref' for 'delete-generations'. * guix/scripts/package.scm (delete-matching-generations): Replace (string-null? pattern) with (not pattern). Remove 'else' clause. (%options): Leave ARG as-is for 'delete-generations'. * guix/scripts/pull.scm (%options): Leave ARG as-is for 'list-generations'. (process-query): Replace (string-null? pattern) with (not pattern). * guix/scripts/system.scm (list-generations): Likewise, and remove 'else' clause. (process-command): Use #f instead of "" when no pattern is given. --- guix/scripts/gc.scm | 18 ++++++++++-------- guix/scripts/package.scm | 17 ++++++----------- guix/scripts/pull.scm | 4 ++-- guix/scripts/system.scm | 10 ++++------ guix/ui.scm | 6 +++++- 5 files changed, 27 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 9a57e5fd1e..31657326b6 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -104,11 +104,14 @@ Invoke the garbage collector.\n")) '())))) (define (delete-old-generations store profile pattern) - "Remove the generations of PROFILE that match PATTERN, a duration pattern. -Do nothing if none matches." + "Remove the generations of PROFILE that match PATTERN, a duration pattern; +do nothing if none matches. If PATTERN is #f, delete all generations but the +current one." (let* ((current (generation-number profile)) - (numbers (matching-generations pattern profile - #:duration-relation >))) + (numbers (if (not pattern) + (profile-generations profile) + (matching-generations pattern profile + #:duration-relation >)))) ;; Make sure we don't inadvertently remove the current generation. (delete-generations store profile (delv current numbers)))) @@ -155,8 +158,7 @@ is deprecated; use '-D'~%")) (when (and arg (not (string->duration arg))) (leave (G_ "~s does not denote a duration~%") arg)) - (alist-cons 'delete-generations (or arg "") - result))))) + (alist-cons 'delete-generations arg result))))) (option '("optimize") #f #f (lambda (opt name arg result) (alist-cons 'action 'optimize @@ -287,9 +289,9 @@ is deprecated; use '-D'~%")) (assert-no-extra-arguments) (let ((min-freed (assoc-ref opts 'min-freed)) (free-space (assoc-ref opts 'free-space))) - (match (assoc-ref opts 'delete-generations) + (match (assq 'delete-generations opts) (#f #t) - ((? string? pattern) + ((_ . pattern) (delete-generations store pattern))) (cond (free-space diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 7b277b63f1..a43c96516f 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -98,7 +98,7 @@ denote ranges as interpreted by 'matching-generations'." (cond ((not (file-exists? profile)) ; XXX: race condition (raise (condition (&profile-not-found-error (profile profile))))) - ((string-null? pattern) + ((not pattern) (delete-generations store profile (delv current (profile-generations profile)))) ;; Do not delete the zeroth generation. @@ -120,9 +120,7 @@ denote ranges as interpreted by 'matching-generations'." (let ((numbers (delv current numbers))) (when (null-list? numbers) (leave (G_ "no matching generation~%"))) - (delete-generations store profile numbers)))) - (else - (leave (G_ "invalid syntax: ~a~%") pattern))))) + (delete-generations store profile numbers))))))) (define* (build-and-use-profile store profile manifest #:key @@ -457,12 +455,12 @@ command-line option~%") arg-handler))) (option '(#\l "list-generations") #f #t (lambda (opt name arg result arg-handler) - (values (cons `(query list-generations ,(or arg "")) + (values (cons `(query list-generations ,arg) result) #f))) (option '(#\d "delete-generations") #f #t (lambda (opt name arg result arg-handler) - (values (alist-cons 'delete-generations (or arg "") + (values (alist-cons 'delete-generations arg result) #f))) (option '(#\S "switch-generation") #t #f @@ -683,7 +681,7 @@ processed, #f otherwise." (cond ((not (file-exists? profile)) ; XXX: race condition (raise (condition (&profile-not-found-error (profile profile))))) - ((string-null? pattern) + ((not pattern) (match (profile-generations profile) (() #t) @@ -697,10 +695,7 @@ processed, #f otherwise." (exit 1) (begin (list-generation display-profile-content (car numbers)) - (diff-profiles profile numbers))))) - (else - (leave (G_ "invalid syntax: ~a~%") - pattern)))) + (diff-profiles profile numbers))))))) #t) (('list-installed regexp) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 2d428546c9..7895c19914 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -117,7 +117,7 @@ Download and deploy the latest version of Guix.\n")) (alist-cons 'channel-file arg result))) (option '(#\l "list-generations") #f #t (lambda (opt name arg result) - (cons `(query list-generations ,(or arg "")) + (cons `(query list-generations ,arg) result))) (option '(#\N "news") #f #f (lambda (opt name arg result) @@ -486,7 +486,7 @@ list of package changes."))))) (cond ((not (file-exists? profile)) ; XXX: race condition (raise (condition (&profile-not-found-error (profile profile))))) - ((string-null? pattern) + ((not pattern) (list-generations profile (profile-generations profile))) ((matching-generations pattern profile) => diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 60c1ca5c9a..67a4071684 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -614,7 +614,7 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (cond ((not (file-exists? profile)) ; XXX: race condition (raise (condition (&profile-not-found-error (profile profile))))) - ((string-null? pattern) + ((not pattern) (for-each display-system-generation (profile-generations profile))) ((matching-generations pattern profile) => @@ -622,9 +622,7 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (if (null-list? numbers) (exit 1) (leave-on-EPIPE - (for-each display-system-generation numbers))))) - (else - (leave (G_ "invalid syntax: ~a~%") pattern)))) + (for-each display-system-generation numbers))))))) ;;; @@ -1232,7 +1230,7 @@ argument list and OPTS is the option alist." ;; an operating system configuration file. ((list-generations) (let ((pattern (match args - (() "") + (() #f) ((pattern) pattern) (x (leave (G_ "wrong number of arguments~%")))))) (list-generations pattern))) @@ -1242,7 +1240,7 @@ argument list and OPTS is the option alist." ;; operating system configuration file. ((delete-generations) (let ((pattern (match args - (() "") + (() #f) ((pattern) pattern) (x (leave (G_ "wrong number of arguments~%")))))) (with-store store diff --git a/guix/ui.scm b/guix/ui.scm index 7d6ab9a2a7..76f6fc8eed 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1484,7 +1484,11 @@ DURATION-RELATION with the current time." ((string->duration str) => filter-by-duration) - (else #f))) + (else + (raise + (condition (&message + (message (format #f (G_ "invalid syntax: ~a~%") + str)))))))) (define (display-generation profile number) "Display a one-line summary of generation NUMBER of PROFILE." -- cgit v1.2.3