From ee61777a326c3395518dee5e50ffc9c35ae53f3d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 15 Jun 2021 10:02:48 +0200
Subject: 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 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 41 insertions(+)

(limited to 'guix/profiles.scm')

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 8cbffa4d2b..09b2d1525a 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))
-- 
cgit v1.2.3