04/12: profiles: Add 'load-profile'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit ee61777a326c3395518dee5e50ffc9c35ae53f3d
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Jun 15 10:02:48 2021 +0200

    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.
---
 guix/profiles.scm            | 41 +++++++++++++++++++++++++++++++++++
 guix/scripts/environment.scm | 51 +++++++-------------------------------------
 tests/profiles.scm           | 27 +++++++++++++++++++++++
 3 files changed, 76 insertions(+), 43 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 8cbffa4..09b2d15 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -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))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 5ceb86f..6958bd6 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -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))))
diff --git a/tests/profiles.scm b/tests/profiles.scm
index ce77711..1a06ff8 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -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))