diff options
author | Marius Bakke <mbakke@fastmail.com> | 2019-07-12 01:03:53 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2019-07-12 01:03:53 +0200 |
commit | fb9a23a3f3ad3d7b5b7f03b2007baf27684d6bbd (patch) | |
tree | afbd3f4f33771c61254b0c3d977092542fbe8009 /guix | |
parent | 1c4b72cb34640638e40c5190676e5c8c352d292d (diff) | |
parent | 5a836ce38c9c29e9c2bd306007347486b90c5064 (diff) |
Merge branch 'master' into core-updates
Conflicts:
gnu/local.mk
gnu/packages/python-xyz.scm
gnu/packages/xml.scm
guix/gexp.scm
po/guix/POTFILES.in
Diffstat (limited to 'guix')
-rw-r--r-- | guix/channels.scm | 59 | ||||
-rw-r--r-- | guix/derivations.scm | 115 | ||||
-rw-r--r-- | guix/discovery.scm | 4 | ||||
-rw-r--r-- | guix/docker.scm | 17 | ||||
-rw-r--r-- | guix/gexp.scm | 233 | ||||
-rw-r--r-- | guix/inferior.scm | 9 | ||||
-rw-r--r-- | guix/remote.scm | 134 | ||||
-rw-r--r-- | guix/repl.scm | 86 | ||||
-rw-r--r-- | guix/scripts/deploy.scm | 84 | ||||
-rw-r--r-- | guix/scripts/environment.scm | 67 | ||||
-rw-r--r-- | guix/scripts/gc.scm | 18 | ||||
-rw-r--r-- | guix/scripts/pack.scm | 64 | ||||
-rw-r--r-- | guix/scripts/package.scm | 17 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 4 | ||||
-rw-r--r-- | guix/scripts/repl.scm | 56 | ||||
-rw-r--r-- | guix/scripts/system.scm | 10 | ||||
-rw-r--r-- | guix/self.scm | 3 | ||||
-rw-r--r-- | guix/ssh.scm | 10 | ||||
-rw-r--r-- | guix/store.scm | 11 | ||||
-rw-r--r-- | guix/ui.scm | 21 |
20 files changed, 739 insertions, 283 deletions
diff --git a/guix/channels.scm b/guix/channels.scm index e7278c6060..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) @@ -429,32 +431,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) diff --git a/guix/derivations.scm b/guix/derivations.scm index 186d7a3f8f..731f1f698f 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -293,74 +293,78 @@ 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) ((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)) (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. @@ -391,7 +395,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 +406,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/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)))))) '() 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/gexp.scm b/guix/gexp.scm index 9bf68a91f4..186bce19a8 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,127 @@ 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> + (lowered-gexp sexp inputs guile load-path load-compiled-path) + lowered-gexp? + (sexp lowered-gexp-sexp) ;sexp + (inputs lowered-gexp-inputs) ;list of <gexp-input> + (guile lowered-gexp-guile) ;<derivation> | #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) + "*Note: This API is subject to change; use at your own risk!* + +Lower EXP, a gexp, instantiating it for SYSTEM and TARGET. Return a +<lowered-gexp> 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 + #: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 <gexp-input> 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) @@ -676,10 +815,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. @@ -693,11 +830,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 >>= @@ -708,38 +847,19 @@ 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 - #: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)) + (graphs (if references-graphs (lower-reference-graphs references-graphs #:system system @@ -755,32 +875,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) (_ '()))) @@ -796,6 +914,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 <gexp-input> records instead of tuples. (define (add-reference-inputs ref result) (match ref (($ <gexp-input> (? gexp? exp) _ #t) 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! <inferior-object> 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))) 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 <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(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))))))) 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 <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(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/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 <davet@gnu.org> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(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/guix/scripts/environment.scm b/guix/scripts/environment.scm index ac269083c8..f7f7edda48 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -163,6 +163,10 @@ COMMAND or an interactive shell in that environment.\n")) 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")) (display (G_ " @@ -270,6 +274,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 @@ -445,7 +452,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 @@ -480,26 +488,29 @@ 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 + ;; 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? + %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)))) @@ -537,8 +548,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 @@ -664,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)) @@ -684,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) @@ -740,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/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/pack.scm b/guix/scripts/pack.scm index c8cb7b959d..1524607623 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) @@ -285,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") @@ -304,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) @@ -338,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 @@ -378,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" @@ -440,11 +480,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 +508,7 @@ the image." #$profile #:database #+database #:system (or #$target (utsname:machine (uname))) + #:environment environment #:entry-point #$(and entry-point #~(string-append #$profile "/" #$entry-point)) 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/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 <ludo@gnu.org> +;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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." 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/self.scm b/guix/self.scm index 6a876bd822..249705fcee 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -770,7 +770,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 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 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)))) ;;; diff --git a/guix/ui.scm b/guix/ui.scm index 6d243ef041..76f6fc8eed 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) @@ -844,18 +843,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))) @@ -1497,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." |