guix: home: Add try command. * guix/scripts/home.scm: Support try command. Signed-off-by: Julien Lepiller <julien@lepiller.eu>
guix/scripts/home.scm
1 | - | ;;; GNU Guix --- Functional package management for GNU | |
1 | + | ;;; Guix Home Manager. | |
2 | + | ;;; Copyright ?? 2014, 2015, 2018 David Thompson <davet@gnu.org> | |
3 | + | ;;; Copyright ?? 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Court??s <ludo@gnu.org> | |
4 | + | ;;; Copyright ?? 2018 Mike Gerwitz <mtg@gnu.org> | |
2 | 5 | ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu> | |
6 | + | ;;; Copyright ?? 2020 Jelle Licht <jlicht@fsfe.org> | |
3 | 7 | ;;; | |
4 | - | ;;; This file is part of GNU Guix. | |
5 | - | ;;; | |
6 | - | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | - | ;;; under the terms of the GNU General Public License as published by | |
8 | - | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | - | ;;; your option) any later version. | |
8 | + | ;;; This program is free software: you can redistribute it and/or modify | |
9 | + | ;;; it under the terms of the GNU General Public License as published by | |
10 | + | ;;; the Free Software Foundation, either version 3 of the License, or | |
11 | + | ;;; (at your option) any later version. | |
10 | 12 | ;;; | |
11 | - | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | - | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | + | ;;; This program is distributed in the hope that it will be useful, | |
14 | + | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | 15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | 16 | ;;; GNU General Public License for more details. | |
15 | 17 | ;;; | |
16 | 18 | ;;; You should have received a copy of the GNU General Public License | |
17 | - | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | + | ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
20 | + | ;;; This file is part of GNU Guix. | |
18 | 21 | ||
19 | 22 | (define-module (guix scripts home) | |
20 | 23 | #:use-module (guix derivations) | |
… | |||
34 | 37 | #:use-module (srfi srfi-26) | |
35 | 38 | #:use-module (srfi srfi-35) | |
36 | 39 | #:use-module (srfi srfi-37) | |
40 | + | #:use-module (srfi srfi-98) | |
37 | 41 | #:export (guix-home)) | |
38 | 42 | ||
39 | 43 | ;;; | |
… | |||
60 | 64 | (display (G_ "\ | |
61 | 65 | build build the home configuration without installing anything\n")) | |
62 | 66 | (display (G_ "\ | |
67 | + | try try the home configuration without installing anything\n")) | |
68 | + | (display (G_ "\ | |
63 | 69 | list-generations list the home generations\n")) | |
64 | 70 | (show-build-options-help) | |
65 | 71 | (display (G_ " | |
… | |||
193 | 199 | (leave-on-EPIPE | |
194 | 200 | (for-each (lambda (number) (display-generation %current-home number)) numbers))))))) | |
195 | 201 | ||
202 | + | ;;; | |
203 | + | ;;; Try | |
204 | + | ;;; | |
205 | + | ;;; Very directly inspired by GNU Guix' (guix scripts environment) | |
206 | + | ||
207 | + | (define %precious-variables | |
208 | + | '("USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER")) | |
209 | + | ||
210 | + | (define %default-shell | |
211 | + | (or (getenv "SHELL") "/bin/sh")) | |
212 | + | ||
213 | + | (define (purify-environment white-list) | |
214 | + | "Unset all environment variables except those that match the regexps in | |
215 | + | WHITE-LIST and those listed in %PRECIOUS-VARIABLES. A small number of | |
216 | + | variables such as 'USER' are left untouched." | |
217 | + | (for-each unsetenv | |
218 | + | (remove (lambda (variable) | |
219 | + | (or (member variable %precious-variables) | |
220 | + | (find (cut regexp-exec <> variable) | |
221 | + | white-list))) | |
222 | + | (match (get-environment-variables) | |
223 | + | (((names . _) ...) | |
224 | + | names))))) | |
225 | + | ||
226 | + | (define* (create-environment #:optional (white-list '())) | |
227 | + | "Unset the variables in the current environment except those that match the | |
228 | + | regexps in WHITE-LIST." | |
229 | + | (purify-environment white-list)) | |
230 | + | ||
231 | + | ||
232 | + | (define* (launch-environment command new-home #:key (white-list '())) | |
233 | + | "Run COMMAND in a new environment containing INPUTS, using the native search | |
234 | + | paths defined by the list PATHS. When PURE?, pre-existing environment | |
235 | + | variables are cleared before setting the new ones, except those matching the | |
236 | + | regexps in WHITE-LIST." | |
237 | + | ;; Properly handle SIGINT, so pressing C-c in an interactive terminal | |
238 | + | ;; application works. | |
239 | + | (sigaction SIGINT SIG_DFL) | |
240 | + | (create-environment white-list) | |
241 | + | (setenv "HOME" new-home) | |
242 | + | (chdir new-home) | |
243 | + | (match command | |
244 | + | ((program . args) | |
245 | + | (apply execlp program program args)))) | |
246 | + | ||
247 | + | (define* (launch-environment/fork command new-home #:key (white-list '())) | |
248 | + | "Run COMMAND in a new process with an environment containing PROFILE, with | |
249 | + | the search paths specified by MANIFEST. When PURE?, pre-existing environment | |
250 | + | variables are cleared before setting the new ones, except those matching the | |
251 | + | regexps in WHITE-LIST." | |
252 | + | (match (primitive-fork) | |
253 | + | (0 (launch-environment command new-home #:white-list white-list)) | |
254 | + | (pid (match (waitpid pid) | |
255 | + | ((_ . status) status))))) | |
256 | + | ||
257 | + | (define (status->exit-code status) | |
258 | + | "Compute the exit code made from STATUS, a value as returned by 'waitpid', | |
259 | + | and suitable for 'exit'." | |
260 | + | ;; See <bits/waitstatus.h>. | |
261 | + | (or (status:exit-val status) | |
262 | + | (logior #x80 (status:term-sig status)))) | |
263 | + | (define exit/status (compose exit status->exit-code)) | |
196 | 264 | ||
197 | 265 | ;;; | |
198 | 266 | ;;; Entry point. | |
… | |||
215 | 283 | #:dry-run? dry-run?) | |
216 | 284 | ||
217 | 285 | (unless (or dry-run? derivations-only?) | |
218 | - | (begin | |
219 | - | (build-derivations store (list drv)) | |
220 | - | (case action | |
221 | - | ((reconfigure) | |
222 | - | (newline) | |
223 | - | (format #t (G_ "Activating home...~%")) | |
224 | - | (ensure-home-profile (home-data-directory home)) | |
225 | - | (let* ((number (generation-number %current-home)) | |
226 | - | (generation (generation-file-name %current-home (+ 1 number)))) | |
227 | - | (switch-symlinks generation profile) | |
228 | - | (switch-symlinks %current-home generation)) | |
229 | - | (format #t (G_ "Your home directory has been reconfigured.~%"))) | |
230 | - | (else | |
231 | - | (display profile) | |
232 | - | (newline)))))))) | |
286 | + | (begin | |
287 | + | (build-derivations store (list drv)) | |
288 | + | (case action | |
289 | + | ((reconfigure) | |
290 | + | (newline) | |
291 | + | (format #t (G_ "Activating home...~%")) | |
292 | + | (ensure-home-profile (home-data-directory home)) | |
293 | + | (let* ((number (generation-number %current-home)) | |
294 | + | (generation (generation-file-name %current-home (+ 1 number)))) | |
295 | + | (switch-symlinks generation profile) | |
296 | + | (switch-symlinks %current-home generation)) | |
297 | + | (format #t (G_ "Your home directory has been reconfigured.~%"))) | |
298 | + | ((try) | |
299 | + | (newline) | |
300 | + | (format #t (G_ "Trying out home...~%")) | |
301 | + | (exit/status | |
302 | + | (launch-environment/fork (list %default-shell "-l") profile))) | |
303 | + | (else | |
304 | + | (display profile) | |
305 | + | (newline)))))))) | |
233 | 306 | ||
234 | 307 | (define (process-action action args opts) | |
235 | 308 | "Process ACTION, a sub-command, with the arguments are listed in ARGS. | |
… | |||
312 | 385 | (alist-cons 'argument arg result) | |
313 | 386 | (let ((action (string->symbol arg))) | |
314 | 387 | (case action | |
315 | - | ((build reconfigure list-generations) | |
388 | + | ((build reconfigure list-generations try) | |
316 | 389 | (alist-cons 'action action result)) | |
317 | 390 | (else (leave (G_ "~a: unknown action~%") action)))))) | |
318 | 391 | ||
… | |||
341 | 414 | (exit 1)) | |
342 | 415 | ||
343 | 416 | (case action | |
344 | - | ((build reconfigure) | |
417 | + | ((build reconfigure try) | |
345 | 418 | (unless (= count 1) | |
346 | 419 | (fail)))) | |
347 | 420 | args)) |