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/scripts | |
parent | 1c4b72cb34640638e40c5190676e5c8c352d292d (diff) | |
parent | 5a836ce38c9c29e9c2bd306007347486b90c5064 (diff) | |
download | guix-patches-fb9a23a3f3ad3d7b5b7f03b2007baf27684d6bbd.tar guix-patches-fb9a23a3f3ad3d7b5b7f03b2007baf27684d6bbd.tar.gz |
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/scripts')
-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 |
8 files changed, 211 insertions, 109 deletions
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 |