gnu/home/services.scm

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