;;; Guix Home Manager.

;;; Copyright ?? 2014, 2015, 2018 David Thompson <davet@gnu.org>

;;; Copyright ?? 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Court??s <ludo@gnu.org>

;;; Copyright ?? 2018 Mike Gerwitz <mtg@gnu.org>

;;; Copyright ?? 2020 Jelle Licht <jlicht@fsfe.org>

;;; This program is free software: you can redistribute it and/or modify

;;; it under the terms of the GNU General Public License as published by

;;; the Free Software Foundation, either version 3 of the License, or

;;; (at your option) any later version.

;;; This program is distributed in the hope that it will be useful,

;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; This file is part of GNU Guix.

  #:use-module (srfi srfi-98)

   try              try the home configuration without installing anything\n"))

  (display (G_ "\

;;;

;;; Try

;;;

;;; Very directly inspired by GNU Guix' (guix scripts environment)

(define %precious-variables

  '("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 '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 #:optional (white-list '()))

 "Unset the variables in the current environment except those that match the

regexps in WHITE-LIST."

 (purify-environment white-list))

(define* (launch-environment command new-home #:key (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, 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 white-list)

  (setenv "HOME" new-home)

  (chdir new-home)

  (match command

    ((program . args)

     (apply execlp program program args))))

(define* (launch-environment/fork command new-home #:key (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, except those matching the

regexps in WHITE-LIST."

  (match (primitive-fork)

    (0 (launch-environment command new-home #:white-list white-list))

    (pid (match (waitpid pid)

           ((_ . status) status)))))

(define (status->exit-code status)

  "Compute the exit code made from STATUS, a value as returned by 'waitpid',

and suitable for 'exit'."

  ;; See <bits/waitstatus.h>.

  (or (status:exit-val status)

      (logior #x80 (status:term-sig status))))

(define exit/status (compose exit status->exit-code))

        (begin

          (build-derivations store (list drv))

          (case action

            ((reconfigure)

             (newline)

             (format #t (G_ "Activating home...~%"))

             (ensure-home-profile (home-data-directory home))

             (let* ((number (generation-number %current-home))

                    (generation (generation-file-name %current-home (+ 1 number))))

               (switch-symlinks generation profile)

               (switch-symlinks %current-home generation))

             (format #t (G_ "Your home directory has been reconfigured.~%")))

            ((try)

             (newline)

             (format #t (G_ "Trying out home...~%"))

             (exit/status

              (launch-environment/fork (list %default-shell "-l") profile)))

            (else

             (display profile)

             (newline))))))))

            ((build reconfigure list-generations try)

        ((build reconfigure try)