profiles: Add 'load-profile'.
* guix/profiles.scm (%precious-variables): New variable.
(purify-environment, load-profile): New procedures.
* guix/scripts/environment.scm (%precious-variables)
(purify-environment, create-environment): Remove.
(launch-environment): Call 'load-profile' instead of 'create-environment'.
* tests/profiles.scm ("load-profile"): New test.
This commit is contained in:
Ludovic Courtès
parent
c5b1b48f09
commit
ee61777a32
@ -11,6 +11,7 @@
|
||||
;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com>
|
||||
;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
|
||||
;;; Copyright © 2014 David Thompson <davet@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
@ -54,6 +55,7 @@
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:autoload (srfi srfi-98) (get-environment-variables)
|
||||
#:export (&profile-error
|
||||
profile-error?
|
||||
profile-error-profile
|
||||
@ -127,6 +129,7 @@
|
||||
%default-profile-hooks
|
||||
profile-derivation
|
||||
profile-search-paths
|
||||
load-profile
|
||||
|
||||
profile
|
||||
profile?
|
||||
@ -1916,6 +1919,44 @@ already effective."
|
||||
(evaluate-search-paths (manifest-search-paths manifest)
|
||||
(list profile) getenv))
|
||||
|
||||
(define %precious-variables
|
||||
;; Environment variables in the default 'load-profile' white list.
|
||||
'("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER"))
|
||||
|
||||
(define (purify-environment white-list white-list-regexps)
|
||||
"Unset all environment variables except those that match the regexps in
|
||||
WHITE-LIST-REGEXPS and those listed in WHITE-LIST."
|
||||
(for-each unsetenv
|
||||
(remove (lambda (variable)
|
||||
(or (member variable white-list)
|
||||
(find (cut regexp-exec <> variable)
|
||||
white-list-regexps)))
|
||||
(match (get-environment-variables)
|
||||
(((names . _) ...)
|
||||
names)))))
|
||||
|
||||
(define* (load-profile profile
|
||||
#:optional (manifest (profile-manifest profile))
|
||||
#:key pure? (white-list-regexps '())
|
||||
(white-list %precious-variables))
|
||||
"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-REGEXPS and those listed in WHITE-LIST.
|
||||
Otherwise, augment existing environment variables with additional search
|
||||
paths."
|
||||
(when pure?
|
||||
(purify-environment white-list white-list-regexps))
|
||||
(for-each (match-lambda
|
||||
((($ <search-path-specification> variable _ separator) . value)
|
||||
(let ((current (getenv variable)))
|
||||
(setenv variable
|
||||
(if (and current (not pure?))
|
||||
(if separator
|
||||
(string-append value separator current)
|
||||
value)
|
||||
value)))))
|
||||
(profile-search-paths profile manifest)))
|
||||
|
||||
(define (profile-regexp profile)
|
||||
"Return a regular expression that matches PROFILE's name and number."
|
||||
(make-regexp (string-append "^" (regexp-quote (basename profile))
|
||||
|
||||
@ -52,50 +52,9 @@
|
||||
#:export (assert-container-features
|
||||
guix-environment))
|
||||
|
||||
;; Protect some env vars from purification. Borrowed from nix-shell.
|
||||
(define %precious-variables
|
||||
'("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER"))
|
||||
|
||||
(define %default-shell
|
||||
(or (getenv "SHELL") "/bin/sh"))
|
||||
|
||||
(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 (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? (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)))
|
||||
(setenv variable
|
||||
(if (and current (not pure?))
|
||||
(if separator
|
||||
(string-append value separator current)
|
||||
value)
|
||||
value)))))
|
||||
(profile-search-paths profile manifest))
|
||||
|
||||
;; Give users a way to know that they're in 'guix environment', so they can
|
||||
;; adjust 'PS1' accordingly, for instance. Set it to PROFILE so users can
|
||||
;; conveniently access its contents.
|
||||
(setenv "GUIX_ENVIRONMENT" profile))
|
||||
|
||||
(define* (show-search-paths profile manifest #:key pure?)
|
||||
"Display the search paths of MANIFEST applied to PROFILE. When PURE? is #t,
|
||||
do not augment existing environment variables with additional search paths."
|
||||
@ -425,8 +384,14 @@ 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? #:white-list white-list)
|
||||
(load-profile profile manifest
|
||||
#:pure? pure? #:white-list-regexps white-list)
|
||||
|
||||
;; Give users a way to know that they're in 'guix environment', so they can
|
||||
;; adjust 'PS1' accordingly, for instance. Set it to PROFILE so users can
|
||||
;; conveniently access its contents.
|
||||
(setenv "GUIX_ENVIRONMENT" profile)
|
||||
|
||||
(match command
|
||||
((program . args)
|
||||
(apply execlp program program args))))
|
||||
|
||||
@ -279,6 +279,33 @@
|
||||
(string=? (dirname (readlink bindir))
|
||||
(derivation->output-path guile))))))
|
||||
|
||||
(test-assertm "load-profile"
|
||||
(mlet* %store-monad
|
||||
((entry -> (package->manifest-entry %bootstrap-guile))
|
||||
(guile (package->derivation %bootstrap-guile))
|
||||
(drv (profile-derivation (manifest (list entry))
|
||||
#:hooks '()
|
||||
#:locales? #f))
|
||||
(profile -> (derivation->output-path drv))
|
||||
(bindir -> (string-append profile "/bin"))
|
||||
(_ (built-derivations (list drv))))
|
||||
(define-syntax-rule (with-environment-excursion exp ...)
|
||||
(let ((env (environ)))
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda () exp ...)
|
||||
(lambda () (environ env)))))
|
||||
|
||||
(return (and (with-environment-excursion
|
||||
(load-profile profile)
|
||||
(and (string-prefix? (string-append bindir ":")
|
||||
(getenv "PATH"))
|
||||
(getenv "GUILE_LOAD_PATH")))
|
||||
(with-environment-excursion
|
||||
(load-profile profile #:pure? #t #:white-list '())
|
||||
(equal? (list (string-append "PATH=" bindir))
|
||||
(environ)))))))
|
||||
|
||||
(test-assertm "<profile>"
|
||||
(mlet* %store-monad
|
||||
((entry -> (package->manifest-entry %bootstrap-guile))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user