[bug#49034] [PATCH] profiles: Add 'load-profile'.

[Leo Prikler]

Am Dienstag, den 15.06.2021, 10:13 +0200 schrieb Ludovic Courtès:
> * 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(-)
> 
> Hi!
> 
> While explaining the profile bit of the ‘render-videos.scm’ example
> at <
> https://guix.gnu.org/en/blog/2021/reproducible-data-processing-pipelines/>
> ;,
> I realized we were missing a helper to “load” a profile—i.e., set all
> its environment variables.
> 
> This patch moves said helper from (guix scripts environment) to
> (guix profiles) and streamlines it.
> 
> Thoughts?
> 
> Ludo’.
I, for one, welcome this patch.  Adding “load-profile” to (guix
profiles) will improve the multi-profile use-case, as one will be able
to use it from a Guile REPL or a shell wrapper.

Regards,
Leo
> 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))
> diff --git a/guix/scripts/environment.scm
> b/guix/scripts/environment.scm
> index 5ceb86f7a9..6958bd6238 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 ce77711d63..1a06ff88f3 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))