projects/guix·blob javascript-team · refs

815 lines · 31.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2021-2023 Andrew Tropin <[email protected]>
3;;; Copyright © 2021 Xinglu Chen <[email protected]>
4;;; Copyright © 2022-2023, 2025-2026 Ludovic Courtès <[email protected]>
5;;; Copyright © 2023 Carlo Zancanaro <[email protected]>
6;;; Copyright © 2025 Giacomo Leidi <[email protected]>
7;;;
8;;; This file is part of GNU Guix.
9;;;
10;;; GNU Guix is free software; you can redistribute it and/or modify it
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
15;;; GNU Guix is distributed in the hope that it will be useful, but
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;;
25;;; This module is similar to (gnu system services) module, but
26;;; provides Home Services, which are supposed to be used for building
27;;; home-environment.
28;;;
29;;; Home Services use the same extension as System Services. Consult
30;;; (gnu system services) module or manual for more information.
31;;;
32;;; home-service-type is a root of home services DAG.
33;;;
34;;; home-profile-service-type is almost the same as profile-service-type, at least
35;;; for now.
36;;;
37;;; home-environment-variables-service-type generates a @file{setup-environment}
38;;; shell script, which is expected to be sourced by login shell or other program,
39;;; which starts early and spawns all other processes. Home services for shells
40;;; automatically add code for sourcing this file, if person do not use those home
41;;; services they have to source this script manually in their's shell *profile
42;;; file (details described in the manual).
43;;;
44;;; home-files-service-type is similar to etc-service-type, but doesn't extend
45;;; home-activation, because deploy mechanism for config files is pluggable
46;;; and can be different for different home environments: The default one is
47;;; called symlink-manager, which creates links for various dotfiles and xdg
48;;; configuration files to store, but is possible to implement alternative
49;;; approaches like read-only home from Julien's guix-home-manager.
50;;;
51;;; home-run-on-first-login-service-type provides an @file{on-first-login} guile
52;;; script, which runs provided gexps once, when user makes first login. It can
53;;; be used to start user's Shepherd and maybe some other process. It relies on
54;;; assumption that /run/user/$UID will be created on login by some login
55;;; manager (elogind for example).
56;;;
57;;; home-activation-service-type provides an @file{activate} guile script, which
58;;; do three main things:
59;;;
60;;; - Sets environment variables to the values declared in
61;;; @file{setup-environment} shell script. It's necessary, because user can set
62;;; for example XDG_CONFIG_HOME and it should be respected by activation gexp of
63;;; symlink-manager.
64;;;
65;;; - Sets GUIX_NEW_HOME and possibly GUIX_OLD_HOME vars to paths in the store.
66;;; Later those variables can be used by activation gexps, for example by
67;;; symlink-manager or run-on-change services.
68;;;
69;;; - Run all activation gexps provided by other home services.
70;;;
71;;; home-run-on-change-service-type allows to trigger actions during
72;;; activation if file or directory specified by pattern is changed.
73;;;
74;;; Code:
75
76(define-module (gnu home services)
77 #:use-module (gnu services)
78 #:use-module ((gnu packages package-management) #:select (guix))
79 #:use-module ((gnu packages base) #:select (coreutils))
80 #:use-module (guix channels)
81 #:use-module (guix monads)
82 #:use-module (guix store)
83 #:use-module (guix gexp)
84 #:use-module (guix profiles)
85 #:use-module (guix sets)
86 #:use-module (guix ui)
87 #:use-module (guix discovery)
88 #:use-module (guix diagnostics)
89 #:use-module (guix i18n)
90 #:use-module (guix modules)
91 #:use-module (guix memoization)
92 #:use-module (srfi srfi-1)
93 #:use-module (srfi srfi-9)
94 #:use-module (srfi srfi-34)
95 #:use-module (ice-9 match)
96 #:use-module (ice-9 vlist)
97
98 #:export (home-service-type
99 home-profile-service-type
100 home-environment-variables-service-type
101 home-files-service-type
102 home-xdg-configuration-files-service-type
103 home-xdg-data-files-service-type
104 home-run-on-first-login-service-type
105 home-activation-service-type
106 home-run-on-change-service-type
107 home-provenance-service-type
108 home-gc-root-service-type
109
110 literal-string
111 literal-string?
112 literal-string-value
113
114 with-shell-quotation-bindings
115 environment-variable-shell-definitions
116 shell-variable-definitions
117 home-files-directory
118 xdg-configuration-files-directory
119 xdg-data-files-directory
120
121 fold-home-service-types
122 lookup-home-service-types
123 home-provenance
124
125 define-service-type-mapping
126 system->home-service-type
127
128 %initialize-gettext)
129
130 #:re-export (service
131 service-type
132 service-extension
133 simple-service
134 for-home
135 for-home?))
136
137
138(define (home-derivation entries mextensions)
139 "Return as a monadic value the derivation of the 'home'
140directory containing the given entries."
141 (mlet %store-monad ((extensions (mapm/accumulate-builds identity
142 mextensions)))
143 (lower-object
144 (file-union "home" (append entries (concatenate extensions))))))
145
146(define home-service-type
147 ;; This is the ultimate service type, the root of the home service
148 ;; DAG. The service of this type is extended by monadic name/item
149 ;; pairs. These items end up in the "home-environment directory" as
150 ;; returned by 'home-environment-derivation'.
151 (service-type (name 'home)
152 (extensions '())
153 (compose identity)
154 (extend home-derivation)
155 (default-value '())
156 (description
157 "Build the home environment top-level directory,
158which in turn refers to everything the home environment needs: its
159packages, configuration files, activation script, and so on.")))
160
161(define (packages->profile-entry packages)
162 "Return a system entry for the profile containing PACKAGES."
163 ;; XXX: 'mlet' is needed here for one reason: to get the proper
164 ;; '%current-target' and '%current-target-system' bindings when
165 ;; 'packages->manifest' is called, and thus when the 'package-inputs'
166 ;; etc. procedures are called on PACKAGES. That way, conditionals in those
167 ;; inputs see the "correct" value of these two parameters. See
168 ;; <https://issues.guix.gnu.org/44952>.
169 (mlet %store-monad ((_ (current-target-system)))
170 (return `(("profile" ,(profile
171 (content (packages->manifest
172 (map identity
173 ;;(options->transformation transformations)
174 (delete-duplicates packages eq?))))))))))
175
176;; MAYBE: Add a list of transformations for packages. It's better to
177;; place it in home-profile-service-type to affect all profile
178;; packages and prevent conflicts, when other packages relies on
179;; non-transformed version of package.
180(define home-profile-service-type
181 (service-type (name 'home-profile)
182 (extensions
183 (list (service-extension home-service-type
184 packages->profile-entry)))
185 (compose concatenate)
186 (extend append)
187 (description
188 "This is the @dfn{home profile} and can be found in
189@file{~/.guix-home/profile}. It contains packages and
190configuration files that the user has declared in their
191@code{home-environment} record.")))
192
193;; Representation of a literal string.
194(define-record-type <literal-string>
195 (literal-string str)
196 literal-string?
197 (str literal-string-value))
198
199(define (with-shell-quotation-bindings exp)
200 "Insert EXP, a gexp, in a lexical environment providing the
201'shell-single-quote' and 'shell-double-quote' bindings."
202#~(let* ((quote-string
203 (lambda (value quoted-chars)
204 (list->string (string-fold-right
205 (lambda (chr lst)
206 (if (memq chr quoted-chars)
207 (append (list #\\ chr) lst)
208 (cons chr lst)))
209 '()
210 value))))
211 (shell-double-quote
212 (lambda (value)
213 ;; Double-quote VALUE, leaving dollar sign as is.
214 (string-append "\"" (quote-string value '(#\" #\\))
215 "\"")))
216 (shell-single-quote
217 (lambda (value)
218 ;; Single-quote VALUE to enter a literal string.
219 (string-append "'" (quote-string value '(#\'))
220 "'"))))
221 #$exp))
222
223(define (environment-variable-shell-definitions variables)
224 "Return a gexp that evaluates to a list of POSIX shell statements defining
225VARIABLES, a list of environment variable name/value pairs. The returned code
226ensures variable values are properly quoted."
227 (with-shell-quotation-bindings
228 #~(string-append
229 #$@(map (match-lambda
230 ((key . #f)
231 "")
232 ((key . #t)
233 #~(string-append "export " #$key "\n"))
234 ((key . (or (? string? value)
235 (? file-like? value)
236 (? gexp? value)))
237 #~(string-append "export " #$key "="
238 (shell-double-quote #$value)
239 "\n"))
240 ((key . (? literal-string? value))
241 #~(string-append "export " #$key "="
242 (shell-single-quote
243 #$(literal-string-value value))
244 "\n")))
245 variables))))
246
247(define (shell-variable-definitions variables)
248 "Return a gexp that evaluates to a list of POSIX shell statements defining
249VARIABLES, a list of variable name/value pairs, as shell variables (not
250environment variables). The returned code ensures variable values are
251properly quoted."
252 (with-shell-quotation-bindings
253 #~(string-append
254 #$@(map (match-lambda
255 ((key . (or (? string? value)
256 (? file-like? value)
257 (? gexp? value)))
258 #~(string-append #$key "="
259 (shell-double-quote #$value)
260 "\n"))
261 ((key . (? literal-string? value))
262 #~(string-append #$key "="
263 (shell-single-quote
264 #$(literal-string-value value))
265 "\n")))
266 variables))))
267
268(define (environment-variables->setup-environment-script vars)
269 "Return a file that can be sourced by a POSIX compliant shell which
270initializes the environment. The file will source the home
271environment profile, set some default environment variables, and set
272environment variables provided in @code{vars}. @code{vars} is a list
273of pairs (@code{(key . value)}), @code{key} is a string and
274@code{value} is a string or gexp.
275
276If value is @code{#f} variable will be omitted.
277If value is @code{#t} variable will be just exported.
278For any other, value variable will be set to the @code{value} and
279exported."
280 (define (warn-about-duplicate-definitions)
281 (fold
282 (lambda (x acc)
283 (when (equal? (car x) (car acc))
284 (warning
285 (G_ "duplicate definition for `~a' environment variable ~%") (car x)))
286 x)
287 (cons "" "")
288 (sort vars (lambda (a b)
289 (string<? (car a) (car b))))))
290
291 (warn-about-duplicate-definitions)
292 (with-monad
293 %store-monad
294 (return
295 `(("setup-environment"
296 ;; TODO: It's necessary to source ~/.guix-profile too
297 ;; on foreign distros
298 ,(computed-file "setup-environment"
299 #~(call-with-output-file #$output
300 (lambda (port)
301 (set-port-encoding! port "UTF-8")
302 (display "\
303# NOTE: Set HOME_ENVIRONMENT before sourcing (home-shell-profile-service-type ensures
304# ~/.profile does)
305GUIX_PROFILE=\"$HOME_ENVIRONMENT/profile\"
306PROFILE_FILE=\"$GUIX_PROFILE/etc/profile\"
307[ -f $PROFILE_FILE ] && . $PROFILE_FILE
308
309case $GUIX_LOCPATH in
310 *$GUIX_PROFILE/lib/locale*) ;;
311 *) export GUIX_LOCPATH=$GUIX_PROFILE/lib/locale:$GUIX_LOCPATH ;;
312esac
313case $XDG_DATA_DIRS in
314 *$GUIX_PROFILE/share*) ;;
315 *) export XDG_DATA_DIRS=$GUIX_PROFILE/share:$XDG_DATA_DIRS ;;
316esac
317case $MANPATH in
318 *$GUIX_PROFILE/share/man*) ;;
319 *) export MANPATH=$GUIX_PROFILE/share/man:$MANPATH
320esac
321case $INFOPATH in
322 *$GUIX_PROFILE/share/info*) ;;
323 *) export INFOPATH=$GUIX_PROFILE/share/info:$INFOPATH ;;
324esac
325case $XDG_CONFIG_DIRS in
326 *$GUIX_PROFILE/etc/xdg*) ;;
327 *) export XDG_CONFIG_DIRS=$GUIX_PROFILE/etc/xdg:$XDG_CONFIG_DIRS ;;
328esac
329case $XCURSOR_PATH in
330 *$GUIX_PROFILE/share/icons*) ;;
331 *) export XCURSOR_PATH=$GUIX_PROFILE/share/icons:$XCURSOR_PATH ;;
332esac
333case $GUIX_EXTENSIONS_PATH in
334 *$GUIX_PROFILE/share/guix/extensions*) ;;
335 *) export GUIX_EXTENSIONS_PATH=$GUIX_PROFILE/share/guix/extensions:$GUIX_EXTENSIONS_PATH ;;
336esac
337
338# Keep the shell environment clean.
339unset GUIX_PROFILE PROFILE_FILE
340
341" port)
342 (display
343 #$(environment-variable-shell-definitions vars)
344 port)))))))))
345
346(define home-environment-variables-service-type
347 (service-type (name 'home-environment-variables)
348 (extensions
349 (list (service-extension
350 home-service-type
351 environment-variables->setup-environment-script)))
352 (compose concatenate)
353 (extend append)
354 (default-value '())
355 (description "Set the environment variables.")))
356
357(define (files->files-directory files)
358 "Return a @code{files} directory that contains FILES."
359 (define (assert-no-duplicates files)
360 (let loop ((files files)
361 (seen (set)))
362 (match files
363 (() #t)
364 (((file _) rest ...)
365 (when (set-contains? seen file)
366 (raise (formatted-message (G_ "duplicate '~a' entry for files/")
367 file)))
368 (loop rest (set-insert file seen))))))
369
370 ;; Detect duplicates early instead of letting them through, eventually
371 ;; leading to a build failure of "files.drv".
372 (assert-no-duplicates files)
373
374 ;; Allow symlinks to locations outside the store.
375 (file-union "files" files #:dangling-symlinks? #t))
376
377;; Used by symlink-manager
378(define home-files-directory "files")
379
380(define (files-entry files)
381 "Return an entry for the @file{~/.guix-home/files}
382directory containing FILES."
383 (with-monad %store-monad
384 (return `((,home-files-directory ,(files->files-directory files))))))
385
386(define home-files-service-type
387 (service-type (name 'home-files)
388 (extensions
389 (list (service-extension home-service-type
390 files-entry)))
391 (compose concatenate)
392 (extend append)
393 (default-value '())
394 (description "Files that will be put in
395@file{~/.guix-home/files}, and further processed during activation.")))
396
397(define xdg-configuration-files-directory ".config")
398
399(define (xdg-configuration-files files)
400 "Add .config/ prefix to each file-path in FILES."
401 (map (match-lambda
402 ((file-path . rest)
403 (cons (string-append xdg-configuration-files-directory "/" file-path)
404 rest)))
405 files))
406
407(define home-xdg-configuration-files-service-type
408 (service-type (name 'home-xdg-configuration)
409 (extensions
410 (list (service-extension home-files-service-type
411 xdg-configuration-files)))
412 (compose concatenate)
413 (extend append)
414 (default-value '())
415 (description "Files that will be put in
416@file{~/.guix-home/files/.config}, and further processed during activation.")))
417
418(define xdg-data-files-directory ".local/share")
419
420(define (xdg-data-files files)
421 "Add .local/share prefix to each file-path in FILES."
422 (map (match-lambda
423 ((file-path . rest)
424 (cons (string-append xdg-data-files-directory "/" file-path)
425 rest)))
426 files))
427
428(define home-xdg-data-files-service-type
429 (service-type (name 'home-xdg-data)
430 (extensions
431 (list (service-extension home-files-service-type
432 xdg-data-files)))
433 (compose concatenate)
434 (extend append)
435 (default-value '())
436 (description "Files that will be put in
437@file{~/.guix-home/files/.local/share}, and further processed during
438activation.")))
439
440
441(define %initialize-gettext
442 #~(begin
443 (bindtextdomain %gettext-domain
444 (string-append #$guix "/share/locale"))
445 (textdomain %gettext-domain)))
446
447(define (compute-on-first-login-script _ gexps)
448 (program-file
449 "on-first-login"
450 (with-imported-modules (source-module-closure '((guix i18n)
451 (guix diagnostics)))
452 #~(begin
453 (use-modules (guix i18n)
454 (guix diagnostics))
455
456 (define (claim-first-run file)
457 (catch #t
458 (lambda ()
459 ;; This incantation raises an error if FILE already exists, and
460 ;; creates it otherwise.
461 (close-fdes
462 (open-fdes file (logior O_CREAT O_EXCL O_CLOEXEC)))
463 #t)
464 (const #f)))
465
466 #$%initialize-gettext
467
468 (let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR")
469 (format #f "/run/user/~a" (getuid))))
470 (flag-file-path (string-append
471 xdg-runtime-dir "/on-first-login-executed")))
472 ;; XDG_RUNTIME_DIR disappears on logout, that means such trick
473 ;; allows to launch on-first-login script on first login only
474 ;; after complete logout/reboot.
475 (if (file-exists? xdg-runtime-dir)
476 (when (claim-first-run flag-file-path)
477 ;; GEXPS can be empty, hence 'begin *unspecified*'. Having just
478 ;; 'begin' without '*unspecified*' leads to
479 ;; "Syntax error: ... sequence of zero expressions in form (begin)"
480 (begin *unspecified* #$@gexps))
481 ;; TRANSLATORS: 'on-first-login' is the name of a service and
482 ;; shouldn't be translated
483 (warning (G_ "XDG_RUNTIME_DIR doesn't exists, on-first-login script
484won't execute anything. You can check if xdg runtime directory exists,
485XDG_RUNTIME_DIR variable is set to appropriate value and manually execute the
486script by running '$HOME/.guix-home/on-first-login'~%"))))))))
487
488(define (on-first-login-script-entry on-first-login)
489 "Return, as a monadic value, an entry for the on-first-login script
490in the home environment directory."
491 (with-monad %store-monad
492 (return `(("on-first-login" ,on-first-login)))))
493
494(define home-run-on-first-login-service-type
495 (service-type (name 'home-run-on-first-login)
496 (extensions
497 (list (service-extension
498 home-service-type
499 on-first-login-script-entry)))
500 (compose identity)
501 (extend compute-on-first-login-script)
502 (default-value #f)
503 (description "Run gexps on first user login. Can be
504extended with one gexp.")))
505
506
507(define (compute-activation-script init-gexp gexps)
508 (gexp->script
509 "activate"
510 #~(let* ((he-init-file (lambda (he) (string-append he "/setup-environment")))
511 (home (or (getenv "HOME")
512 (let ((directory (passwd:dir (getpwuid (getuid)))))
513 (setenv "HOME" directory)
514 directory)))
515 (he-path (string-append home "/.guix-home"))
516 (new-home-env (getenv "GUIX_NEW_HOME"))
517 (new-home (or new-home-env
518 ;; Absolute path of the directory of the activation
519 ;; file if called interactively.
520 (canonicalize-path (dirname (car (command-line))))))
521 (old-home-env (getenv "GUIX_OLD_HOME"))
522 (old-home (or old-home-env
523 (if (file-exists? (he-init-file he-path))
524 (readlink he-path)
525 #f))))
526 (if (file-exists? (he-init-file new-home))
527 (let* ((port ((@ (ice-9 popen) open-input-pipe)
528 (format #f "source ~a && ~a -0"
529 (he-init-file new-home)
530 #$(file-append coreutils "/bin/env"))))
531 (result ((@ (ice-9 rdelim) read-delimited) "" port))
532 (vars (map (lambda (x)
533 (let ((si (string-index x #\=)))
534 (cons (string-take x si)
535 (string-drop x (1+ si)))))
536 ((@ (srfi srfi-1) remove)
537 string-null?
538 (string-split result #\nul)))))
539 (close-port port)
540 (map (lambda (x) (setenv (car x) (cdr x))) vars)
541
542 (setenv "GUIX_NEW_HOME" new-home)
543 (setenv "GUIX_OLD_HOME" old-home)
544
545 #$@gexps
546
547 ;; Do not unset env variable if it was set outside.
548 (unless new-home-env (setenv "GUIX_NEW_HOME" #f))
549 (unless old-home-env (setenv "GUIX_OLD_HOME" #f)))
550 (format #t "\
551Activation script was either called or loaded by file from this directory:
552~a
553It doesn't seem that home environment is somewhere around.
554Make sure that you call ./activate by symlink from -home store item.\n"
555 new-home)))))
556
557(define (activation-script-entry m-activation)
558 "Return, as a monadic value, an entry for the activation script
559in the home environment directory."
560 (mlet %store-monad ((activation m-activation))
561 (return `(("activate" ,activation)))))
562
563(define home-activation-service-type
564 (service-type (name 'home-activation)
565 (extensions
566 (list (service-extension
567 home-service-type
568 activation-script-entry)))
569 (compose identity)
570 (extend compute-activation-script)
571 (default-value #f)
572 (description "Run gexps to activate the current
573generation of home environment and update the state of the home
574directory. @command{activate} script automatically called during
575reconfiguration or generation switching. This service can be extended
576with one gexp, but many times, and all gexps must be idempotent.")))
577
578
579;;;
580;;; Service type graph rewriting.
581;;;
582
583(define (service-type-mapping proc)
584 "Return a procedure that applies PROC to map a service type graph to another
585one."
586 (define (rewrite extension)
587 (match (proc (service-extension-target extension))
588 (#f #f)
589 (target
590 (service-extension target
591 (service-extension-compute extension)))))
592
593 (define replace
594 (mlambdaq (type)
595 (service-type
596 (inherit type)
597 (name (symbol-append 'home- (service-type-name type)))
598 (location (service-type-location type))
599 (extensions (filter-map rewrite (service-type-extensions type))))))
600
601 replace)
602
603(define %system/home-service-type-mapping
604 ;; Mapping of System to Home services.
605 (make-hash-table))
606
607(define system->home-service-type
608 ;; Map the given System service type to the corresponding Home service type.
609 (let ()
610 (define (replace type)
611 (define replacement
612 (hashq-ref %system/home-service-type-mapping type
613 *unspecified*))
614
615 (if (eq? replacement *unspecified*)
616 type
617 replacement))
618
619 (service-type-mapping replace)))
620
621(define-syntax define-service-type-mapping
622 (syntax-rules (=>)
623 ((_ system-type => home-type)
624 (hashq-set! %system/home-service-type-mapping
625 system-type home-type))))
626
627(define-syntax define-service-type-mappings
628 (syntax-rules (=>)
629 ((_ (system-type => home-type) ...)
630 (begin
631 (define-service-type-mapping system-type => home-type)
632 ...))))
633
634(define-service-type-mappings
635 (system-service-type => home-service-type)
636 (activation-service-type => home-activation-service-type)
637 (profile-service-type => home-profile-service-type))
638
639
640;;;
641;;; On-change.
642;;;
643
644(define (compute-on-change-gexp eval-gexps? pattern-gexp-tuples)
645 (with-imported-modules (source-module-closure '((guix i18n)))
646 #~(begin
647 (use-modules (guix i18n))
648
649 #$%initialize-gettext
650
651 (define (equal-regulars? file1 file2)
652 "Check if FILE1 and FILE2 are bit for bit identical."
653 (let* ((cmp-binary #$(file-append
654 (@ (gnu packages base) diffutils) "/bin/cmp"))
655 (stats1 (lstat file1))
656 (stats2 (lstat file2)))
657 (cond
658 ((= (stat:ino stats1) (stat:ino stats2)) #t)
659 ((not (= (stat:size stats1) (stat:size stats2))) #f)
660
661 (else (= (system* cmp-binary file1 file2) 0)))))
662
663 (define (equal-symlinks? symlink1 symlink2)
664 "Check if SYMLINK1 and SYMLINK2 are pointing to the same target."
665 (string=? (readlink symlink1) (readlink symlink2)))
666
667 (define (equal-directories? dir1 dir2)
668 "Check if DIR1 and DIR2 have the same content."
669 (define (ordinary-file file)
670 (not (or (string=? file ".")
671 (string=? file ".."))))
672 (let* ((files1 (scandir dir1 ordinary-file))
673 (files2 (scandir dir2 ordinary-file)))
674 (if (equal? files1 files2)
675 (map (lambda (file)
676 (equal-files?
677 (string-append dir1 "/" file)
678 (string-append dir2 "/" file)))
679 files1)
680 #f)))
681
682 (define (equal-files? file1 file2)
683 "Compares files, symlinks or directories of the same type."
684 (case (file-type file1)
685 ((directory) (equal-directories? file1 file2))
686 ((symlink) (equal-symlinks? file1 file2))
687 ((regular) (equal-regulars? file1 file2))
688 (else
689 (display "The file type is unsupported by on-change service.\n")
690 #f)))
691
692 (define (file-type file)
693 (stat:type (lstat file)))
694
695 (define (something-changed? file1 file2)
696 (cond
697 ((and (not (file-exists? file1))
698 (not (file-exists? file2))) #f)
699 ((or (not (file-exists? file1))
700 (not (file-exists? file2))) #t)
701
702 ((not (eq? (file-type file1) (file-type file2))) #t)
703
704 (else
705 (not (equal-files? file1 file2)))))
706
707 (define expressions-to-eval
708 (map
709 (lambda (x)
710 (let* ((file1 (string-append
711 (or (getenv "GUIX_OLD_HOME")
712 "/gnu/store/non-existing-generation")
713 "/" (car x)))
714 (file2 (string-append (getenv "GUIX_NEW_HOME") "/" (car x)))
715 (_ (format #t (G_ "Comparing ~a and\n~10t~a...") file1 file2))
716 (any-changes? (something-changed? file1 file2))
717 (_ (format #t (G_ " done (~a)\n")
718 (if any-changes? "changed" "same"))))
719 (if any-changes? (cadr x) "")))
720 '#$pattern-gexp-tuples))
721
722 (if #$eval-gexps?
723 (begin
724 ;;; TRANSLATORS: 'on-change' is the name of a service type, it
725 ;;; probably shouldn't be translated.
726 (display (G_ "Evaluating on-change gexps.\n\n"))
727 (for-each primitive-eval expressions-to-eval)
728 (display (G_ "On-change gexps evaluation finished.\n\n")))
729 (display "\
730On-change gexps won't be evaluated; evaluation has been disabled in the
731service configuration")))))
732
733(define home-run-on-change-service-type
734 (service-type (name 'home-run-on-change)
735 (extensions
736 (list (service-extension
737 home-activation-service-type
738 identity)))
739 (compose concatenate)
740 (extend compute-on-change-gexp)
741 (default-value #t)
742 (description "\
743G-expressions to run if the specified files have changed since the
744last generation. The extension should be a list of lists where the
745first element is the pattern for file or directory that expected to be
746changed, and the second element is the G-expression to be evaluated.")))
747
748
749;;;
750;;; Provenance tracking.
751;;;
752
753(define home-provenance-service-type
754 (service-type
755 (name 'home-provenance)
756 (extensions
757 (list (service-extension
758 home-service-type
759 (service-extension-compute
760 (first (service-type-extensions provenance-service-type))))))
761 (default-value #f) ;the HE config file
762 (description "\
763Store provenance information about the home environment in the home
764environment itself: the channels used when building the home
765environment, and its configuration file, when available.")))
766
767(define sexp->home-provenance sexp->system-provenance)
768(define home-provenance system-provenance)
769
770
771;;;
772;;; Garbage collector roots.
773;;;
774
775(define home-gc-root-service-type
776 (service-type
777 (inherit (system->home-service-type gc-root-service-type))
778 (default-value '())))
779
780
781;;;
782;;; Searching
783;;;
784
785(define (parent-directory directory)
786 "Get the parent directory of DIRECTORY"
787 (string-join (drop-right (string-split directory #\/) 1) "/"))
788
789(define %guix-home-root-directory
790 ;; Absolute file name of the module hierarchy.
791 (parent-directory
792 (dirname (dirname (search-path %load-path "gnu/home/services.scm")))))
793
794(define %service-type-path
795 ;; Search path for service types.
796 (make-parameter `((,%guix-home-root-directory . "gnu/home/services"))))
797
798(define (all-home-service-modules)
799 "Return the default set of `home service' modules."
800 (cons (resolve-interface '(gnu home services))
801 (all-modules (%service-type-path)
802 #:warn warn-about-load-error)))
803
804(define* (fold-home-service-types proc seed)
805 (fold-service-types proc seed (all-home-service-modules)))
806
807(define lookup-home-service-types
808 (let ((table
809 (delay (fold-home-service-types (lambda (type result)
810 (vhash-consq (service-type-name type)
811 type result))
812 vlist-null))))
813 (lambda (name)
814 "Return the list of services with the given NAME (a symbol)."
815 (vhash-foldq* cons '() name (force table)))))