diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/copy.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 55 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 65 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 22 |
8 files changed, 103 insertions, 54 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 950f0f41d8..d349b5d590 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -23,7 +23,7 @@ #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix store) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index fb7e04904d..6b29c470fb 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -47,7 +47,7 @@ #:autoload (guix download) (download-to-store) #:autoload (guix git-download) (git-reference?) #:autoload (guix git) (git-checkout?) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) #:export (%standard-build-options diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index be4ce4364b..ce70f2f0b3 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -21,7 +21,7 @@ #:use-module (guix scripts) #:use-module (guix ssh) #:use-module (guix store) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix utils) #:use-module (guix derivations) #:use-module (guix scripts build) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 116b8dcbce..3966531efa 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -21,7 +21,7 @@ (define-module (guix scripts environment) #:use-module (guix ui) #:use-module (guix store) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) @@ -57,20 +57,27 @@ (define %default-shell (or (getenv "SHELL") "/bin/sh")) -(define (purify-environment) - "Unset almost all environment variables. A small number of variables such -as 'HOME' and 'USER' are left untouched." +(define (purify-environment white-list) + "Unset all environment variables except those that match the regexps in +WHITE-LIST and those listed in %PRECIOUS-VARIABLES. A small number of +variables such as 'HOME' and 'USER' are left untouched." (for-each unsetenv - (remove (cut member <> %precious-variables) + (remove (lambda (variable) + (or (member variable %precious-variables) + (find (cut regexp-exec <> variable) + white-list))) (match (get-environment-variables) (((names . _) ...) names))))) -(define* (create-environment profile manifest #:key pure?) - "Set the environment variables specified by MANIFEST for PROFILE. When PURE? -is #t, unset the variables in the current environment. Otherwise, augment -existing environment variables with additional search paths." - (when pure? (purify-environment)) +(define* (create-environment profile manifest + #:key pure? (white-list '())) + "Set the environment variables specified by MANIFEST for PROFILE. When +PURE? is #t, unset the variables in the current environment except those that +match the regexps in WHITE-LIST. Otherwise, augment existing environment +variables with additional search paths." + (when pure? + (purify-environment white-list)) (for-each (match-lambda ((($ <search-path-specification> variable _ separator) . value) (let ((current (getenv variable))) @@ -134,6 +141,8 @@ COMMAND or an interactive shell in that environment.\n")) (display (G_ " --pure unset existing environment variables")) (display (G_ " + --inherit=REGEXP inherit environment variables that match REGEXP")) + (display (G_ " --search-paths display needed environment variable definitions")) (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) @@ -206,6 +215,11 @@ COMMAND or an interactive shell in that environment.\n")) (option '("pure") #f #f (lambda (opt name arg result) (alist-cons 'pure #t result))) + (option '("inherit") #t #f + (lambda (opt name arg result) + (alist-cons 'inherit-regexp + (make-regexp* arg) + result))) (option '(#\E "exec") #t #f ; deprecated (lambda (opt name arg result) (alist-cons 'exec (list %default-shell "-c" arg) result))) @@ -397,25 +411,30 @@ and suitable for 'exit'." (define primitive-exit/status (compose primitive-exit status->exit-code)) (define* (launch-environment command profile manifest - #:key pure?) + #:key pure? (white-list '())) "Run COMMAND in a new environment containing INPUTS, using the native search paths defined by the list PATHS. When PURE?, pre-existing environment -variables are cleared before setting the new ones." +variables are cleared before setting the new ones, except those matching the +regexps in WHITE-LIST." ;; Properly handle SIGINT, so pressing C-c in an interactive terminal ;; application works. (sigaction SIGINT SIG_DFL) - (create-environment profile manifest #:pure? pure?) + (create-environment profile manifest + #:pure? pure? #:white-list white-list) (match command ((program . args) (apply execlp program program args)))) -(define* (launch-environment/fork command profile manifest #:key pure?) +(define* (launch-environment/fork command profile manifest + #:key pure? (white-list '())) "Run COMMAND in a new process with an environment containing PROFILE, with the search paths specified by MANIFEST. When PURE?, pre-existing environment -variables are cleared before setting the new ones." +variables are cleared before setting the new ones, except those matching the +regexps in WHITE-LIST." (match (primitive-fork) (0 (launch-environment command profile manifest - #:pure? pure?)) + #:pure? pure? + #:white-list white-list)) (pid (match (waitpid pid) ((_ . status) status))))) @@ -672,7 +691,8 @@ message if any test fails." ;; within the container. '("/bin/sh") (list %default-shell)))) - (mappings (pick-all opts 'file-system-mapping))) + (mappings (pick-all opts 'file-system-mapping)) + (white-list (pick-all opts 'inherit-regexp))) (when container? (assert-container-features)) @@ -741,4 +761,5 @@ message if any test fails." (return (exit/status (launch-environment/fork command profile manifest + #:white-list white-list #:pure? pure?)))))))))))))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 40e59a6101..3f76336abf 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -26,7 +26,7 @@ #:use-module (guix gexp) #:use-module (guix utils) #:use-module (guix store) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix modules) @@ -104,7 +104,9 @@ found." ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. (append-map (lambda (package) (cons package - (package-transitive-propagated-inputs package))) + (match (package-transitive-propagated-inputs package) + (((labels packages) ...) + packages)))) (list guile-gcrypt guile-sqlite3))) (define (store-database items) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 8a71467b52..0e70315708 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -24,7 +24,7 @@ (define-module (guix scripts package) #:use-module (guix ui) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix store) #:use-module (guix grafts) #:use-module (guix derivations) @@ -55,6 +55,7 @@ #:autoload (gnu packages bootstrap) (%bootstrap-guile) #:export (build-and-use-profile delete-generations + delete-matching-generations display-search-paths guix-package)) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 3320200c07..730b6a0bf2 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -20,7 +20,7 @@ (define-module (guix scripts pull) #:use-module (guix ui) #:use-module (guix utils) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix config) @@ -45,6 +45,7 @@ #:select (%bootstrap-guile)) #:use-module ((gnu packages certs) #:select (le-certs)) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -169,11 +170,14 @@ Download and deploy the latest version of Guix.\n")) (reverse (profile-generations profile))) ((current previous _ ...) (newline) - (let ((old (fold-packages (lambda (package result) - (alist-cons (package-name package) - (package-version package) - result)) - '())) + (let ((old (fold-available-packages + (lambda* (name version result + #:key supported? deprecated? + #:allow-other-keys) + (if (and supported? (not deprecated?)) + (alist-cons name version result) + result)) + '())) (new (profile-package-alist (generation-file-name profile current)))) (display-new/upgraded-packages old new @@ -338,24 +342,24 @@ way and displaying details about the channel's source code." (define profile-package-alist (mlambda (profile) "Return a name/version alist representing the packages in PROFILE." - (fold (lambda (package lst) - (alist-cons (inferior-package-name package) - (inferior-package-version package) - lst)) - '() - (let* ((inferior (open-inferior profile)) - (packages (inferior-packages inferior))) - (close-inferior inferior) - packages)))) - -(define* (display-new/upgraded-packages alist1 alist2 - #:key (heading "")) - "Given the two package name/version alists ALIST1 and ALIST2, display the -list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1 -and ALIST2 differ, display HEADING upfront." + (let* ((inferior (open-inferior profile)) + (packages (inferior-available-packages inferior))) + (close-inferior inferior) + packages))) + +(define (new/upgraded-packages alist1 alist2) + "Compare ALIST1 and ALIST2, both of which are lists of package name/version +pairs, and return two values: the list of packages new in ALIST2, and the list +of packages upgraded in ALIST2." (let* ((old (fold (match-lambda* (((name . version) table) - (vhash-cons name version table))) + (match (vhash-assoc name table) + (#f + (vhash-cons name version table)) + ((_ . previous-version) + (if (version>? version previous-version) + (vhash-cons name version table) + table))))) vlist-null alist1)) (new (remove (match-lambda @@ -364,14 +368,21 @@ and ALIST2 differ, display HEADING upfront." alist2)) (upgraded (filter-map (match-lambda ((name . new-version) - (match (vhash-fold* cons '() name old) - (() #f) - ((= (cut sort <> version>?) old-versions) - (and (version>? new-version - (first old-versions)) + (match (vhash-assoc name old) + (#f #f) + ((_ . old-version) + (and (version>? new-version old-version) (string-append name "@" new-version)))))) alist2))) + (values new upgraded))) + +(define* (display-new/upgraded-packages alist1 alist2 + #:key (heading "")) + "Given the two package name/version alists ALIST1 and ALIST2, display the +list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1 +and ALIST2 differ, display HEADING upfront." + (let-values (((new upgraded) (new/upgraded-packages alist1 alist2))) (unless (and (null? new) (null? upgraded)) (display heading)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 569b826acd..d67b9f8185 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -23,7 +23,7 @@ (define-module (guix scripts system) #:use-module (guix config) #:use-module (guix ui) - #:use-module (guix status) + #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix store) #:autoload (guix store database) (register-path) #:use-module (guix grafts) @@ -36,6 +36,8 @@ #:use-module (guix profiles) #:use-module (guix scripts) #:use-module (guix scripts build) + #:autoload (guix scripts package) (delete-generations + delete-matching-generations) #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix build utils) @@ -490,7 +492,8 @@ STORE is an open connection to the store." ;; Make the specified system generation the default entry. (params (profile-boot-parameters %system-profile (list number))) - (old-generations (delv number (generation-numbers %system-profile))) + (old-generations + (delv number (reverse (generation-numbers %system-profile)))) (old-params (profile-boot-parameters %system-profile old-generations)) (entries (map boot-parameters->menu-entry params)) @@ -963,9 +966,11 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ "\ roll-back switch to the previous operating system configuration\n")) (display (G_ "\ + list-generations list the system generations\n")) + (display (G_ "\ switch-generation switch to an existing operating system configuration\n")) (display (G_ "\ - list-generations list the system generations\n")) + delete-generations delete old system generations\n")) (display (G_ "\ build build the operating system without installing anything\n")) (display (G_ "\ @@ -1202,6 +1207,14 @@ argument list and OPTS is the option alist." (apply (resolve-subcommand "search") args)) ;; The following commands need to use the store, but they do not need an ;; operating system configuration file. + ((delete-generations) + (let ((pattern (match args + (() "") + ((pattern) pattern) + (x (leave (G_ "wrong number of arguments~%")))))) + (with-store store + (delete-matching-generations store %system-profile pattern) + (reinstall-bootloader store (generation-number %system-profile))))) ((switch-generation) (let ((pattern (match args ((pattern) pattern) @@ -1228,7 +1241,8 @@ argument list and OPTS is the option alist." (let ((action (string->symbol arg))) (case action ((build container vm vm-image disk-image reconfigure init - extension-graph shepherd-graph list-generations roll-back + extension-graph shepherd-graph + list-generations delete-generations roll-back switch-generation search docker-image) (alist-cons 'action action result)) (else (leave (G_ "~a: unknown action~%") action)))))) |