From ba8ddb348045f81f061a1c7f51c0f7c2b0024e71 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Tue, 5 Oct 2021 02:09:41 +0300 Subject: gnu: Move (gnu home-services) to (gnu home services). * gnu/home-services/configuration.scm: Move the content ... * gnu/home/services/configuration.scm: ... here. * doc/guix.texi: Replace (gnu home-services mcron) with (gnu home services mcron). Replace (gnu home-services) with (gnu home services). * gnu/home.scm: Replace (gnu home-services fontutils) with (gnu services fontutils). Replace (gnu home-services shells) with (gnu home services shells). Replace (gnu home-services symlink-manager) with (gnu home services symlink-manager). Replace (gnu home-services xdg) with (gnu home services xdg). * gnu/home-services/fontutils.scm: Rename to gnu/services/fontutils.scm. * gnu/home-services/mcron.scm: Move to gnu/home/services/mcron.scm. Replace (gnu home-services shepherd) with (gnu home services shepherd). * gnu/home-services.scm (%service-type-path): Search home services in "gnu/services". * gnu/home-services/shells.scm: Replace (gnu home-services configuration) with (gnu home services configuration). Rename to gnu/home/services/shells.scm. Replace (gnu home-services utils) with (gnu home services utils). * gnu/home-services/shepherd.scm: Move to gnu/home/services/shepherd.scm. * gnu/home-services/symlink-manager.scm: Rename to gnu/home/services/symlink-manager.scm. * gnu/home-services/utils.scm: Rename to gnu/home/services/utils.scm. * gnu/home-services/xdg.scm: Rename to gnu/home/services/xdg.scm. * guix/scripts/home/import.scm: Replace (gnu home-services bash) with (gnu home services bash). * gnu/home-services.scm: Update documentation string. * doc/he-config-bare-bones.scm: Apply new (gnu home-services ...) modules location. * gnu/local.mk (GNU_SYSTEM_MODULES): Same. --- gnu/home/services/symlink-manager.scm | 247 ++++++++++++++++++++++++++++++++++ 1 file changed, 247 insertions(+) create mode 100644 gnu/home/services/symlink-manager.scm (limited to 'gnu/home/services/symlink-manager.scm') diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm new file mode 100644 index 0000000000..d53e8f5046 --- /dev/null +++ b/gnu/home/services/symlink-manager.scm @@ -0,0 +1,247 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Andrew Tropin +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix 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. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home services symlink-manager) + #:use-module (gnu home-services) + #:use-module (guix gexp) + + #:export (home-symlink-manager-service-type)) + +;;; Comment: +;;; +;;; symlink-manager cares about configuration files: it backs up files +;;; created by user, removes symlinks and directories created by a +;;; previous generation, and creates new directories and symlinks to +;;; configuration files according to the content of files/ directory +;;; (created by home-files-service) of the current home environment +;;; generation. +;;; +;;; Code: + +(define (update-symlinks-script) + (program-file + "update-symlinks" + #~(begin + (use-modules (ice-9 ftw) + (ice-9 curried-definitions) + (ice-9 match) + (srfi srfi-1)) + (define ((simplify-file-tree parent) file) + "Convert the result produced by `file-system-tree' to less +verbose and more suitable for further processing format. + +Extract dir/file info from stat and compose a relative path to the +root of the file tree. + +Sample output: + +((dir . \".\") + ((dir . \"config\") + ((dir . \"config/fontconfig\") + (file . \"config/fontconfig/fonts.conf\")) + ((dir . \"config/isync\") + (file . \"config/isync/mbsyncrc\")))) +" + (match file + ((name stat) `(file . ,(string-append parent name))) + ((name stat children ...) + (cons `(dir . ,(string-append parent name)) + (map (simplify-file-tree + (if (equal? name ".") + "" + (string-append parent name "/"))) + children))))) + + (define ((file-tree-traverse preordering) node) + "Traverses the file tree in different orders, depending on PREORDERING. + +if PREORDERING is @code{#t} resulting list will contain directories +before files located in those directories, otherwise directory will +appear only after all nested items already listed." + (let ((prepend (lambda (a b) (append b a)))) + (match node + (('file . path) (list node)) + ((('dir . path) . rest) + ((if preordering append prepend) + (list (cons 'dir path)) + (append-map (file-tree-traverse preordering) rest)))))) + + (use-modules (guix build utils)) + + (let* ((config-home (or (getenv "XDG_CONFIG_HOME") + (string-append (getenv "HOME") "/.config"))) + + (he-path (string-append (getenv "HOME") "/.guix-home")) + (new-he-path (string-append he-path ".new")) + (new-home (getenv "GUIX_NEW_HOME")) + (old-home (getenv "GUIX_OLD_HOME")) + + (new-files-path (string-append new-home "/files")) + ;; Trailing dot is required, because files itself is symlink and + ;; to make file-system-tree works it should be a directory. + (new-files-dir-path (string-append new-files-path "/.")) + + (home-path (getenv "HOME")) + (backup-dir (string-append home-path "/" + (number->string (current-time)) + "-guix-home-legacy-configs-backup")) + + (old-tree (if old-home + ((simplify-file-tree "") + (file-system-tree + (string-append old-home "/files/."))) + #f)) + (new-tree ((simplify-file-tree "") + (file-system-tree new-files-dir-path))) + + (get-source-path + (lambda (path) + (readlink (string-append new-files-path "/" path)))) + + (get-target-path + (lambda (path) + (string-append home-path "/." path))) + + (get-backup-path + (lambda (path) + (string-append backup-dir "/." path))) + + (directory? + (lambda (path) + (equal? (stat:type (stat path)) 'directory))) + + (empty-directory? + (lambda (dir) + (equal? (scandir dir) '("." "..")))) + + (symlink-to-store? + (lambda (path) + (and + (equal? (stat:type (lstat path)) 'symlink) + (store-file-name? (readlink path))))) + + (backup-file + (lambda (path) + (mkdir-p backup-dir) + (format #t "Backing up ~a..." (get-target-path path)) + (mkdir-p (dirname (get-backup-path path))) + (rename-file (get-target-path path) (get-backup-path path)) + (display " done\n"))) + + (cleanup-symlinks + (lambda () + (let ((to-delete ((file-tree-traverse #f) old-tree))) + (display + "Cleaning up symlinks from previous home-environment.\n\n") + (map + (match-lambda + (('dir . ".") + (display "Cleanup finished.\n\n")) + + (('dir . path) + (if (and + (file-exists? (get-target-path path)) + (directory? (get-target-path path)) + (empty-directory? (get-target-path path))) + (begin + (format #t "Removing ~a..." + (get-target-path path)) + (rmdir (get-target-path path)) + (display " done\n")) + (format + #t "Skipping ~a (not an empty directory)... done\n" + (get-target-path path)))) + + (('file . path) + (when (file-exists? (get-target-path path)) + ;; DO NOT remove the file if it is no longer + ;; a symlink to the store, it will be backed + ;; up later during create-symlinks phase. + (if (symlink-to-store? (get-target-path path)) + (begin + (format #t "Removing ~a..." (get-target-path path)) + (delete-file (get-target-path path)) + (display " done\n")) + (format + #t + "Skipping ~a (not a symlink to store)... done\n" + (get-target-path path)))))) + to-delete)))) + + (create-symlinks + (lambda () + (let ((to-create ((file-tree-traverse #t) new-tree))) + (map + (match-lambda + (('dir . ".") + (display + "New symlinks to home-environment will be created soon.\n") + (format + #t "All conflicting files will go to ~a.\n\n" backup-dir)) + + (('dir . path) + (let ((target-path (get-target-path path))) + (when (and (file-exists? target-path) + (not (directory? target-path))) + (backup-file path)) + + (if (file-exists? target-path) + (format + #t "Skipping ~a (directory already exists)... done\n" + target-path) + (begin + (format #t "Creating ~a..." target-path) + (mkdir target-path) + (display " done\n"))))) + + (('file . path) + (when (file-exists? (get-target-path path)) + (backup-file path)) + (format #t "Symlinking ~a -> ~a..." + (get-target-path path) (get-source-path path)) + (symlink (get-source-path path) (get-target-path path)) + (display " done\n"))) + to-create))))) + + (when old-tree + (cleanup-symlinks)) + + (create-symlinks) + + (symlink new-home new-he-path) + (rename-file new-he-path he-path) + + (display " done\nFinished updating symlinks.\n\n"))))) + + +(define (update-symlinks-gexp _) + #~(primitive-load #$(update-symlinks-script))) + +(define home-symlink-manager-service-type + (service-type (name 'home-symlink-manager) + (extensions + (list + (service-extension + home-activation-service-type + update-symlinks-gexp))) + (default-value #f) + (description "Provide an @code{update-symlinks} +script, which creates symlinks to configuration files and directories +on every activation. If an existing file would be overwritten by a +symlink, backs up that file first."))) -- cgit v1.2.3 From 0e8d2df0f1a4ab25c482e1c427c54e19903e62f3 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Sat, 9 Oct 2021 16:51:25 +0300 Subject: Move (gnu home-services) to (gnu home services). * gnu/home-services.scm (%guix-home-root-directory): Replace gnu/home-services.scm with "gnu/home/services.scm". Rename to gnu/home/services.scm. * gnu/local.mk (GNU_SYSTEM_MODULES): Rename gnu/home-services.scm to gnu/home/services.scm. * doc/he-config-bare-bones.scm: Replace (gnu home-services) with (gnu home services). * gnu/home.scm: Same. * gnu/home/services/fontutils.scm: Same. * gnu/home/services/mcron.scm: Same. * gnu/home/services/shells.scm: Same. * gnu/home/services/shepherd.scm: Same. * gnu/home/services/symlink-manager.scm: Same. * gnu/home/services/xdg.scm: Same. * guix/scripts/home.scm: Same. * guix/self.scm: Same. --- doc/he-config-bare-bones.scm | 2 +- gnu/home-services.scm | 524 ---------------------------------- gnu/home.scm | 2 +- gnu/home/services.scm | 524 ++++++++++++++++++++++++++++++++++ gnu/home/services/fontutils.scm | 2 +- gnu/home/services/mcron.scm | 2 +- gnu/home/services/shells.scm | 2 +- gnu/home/services/shepherd.scm | 2 +- gnu/home/services/symlink-manager.scm | 2 +- gnu/home/services/xdg.scm | 2 +- gnu/local.mk | 2 +- guix/scripts/home.scm | 2 +- guix/self.scm | 2 +- 13 files changed, 535 insertions(+), 535 deletions(-) delete mode 100644 gnu/home-services.scm create mode 100644 gnu/home/services.scm (limited to 'gnu/home/services/symlink-manager.scm') diff --git a/doc/he-config-bare-bones.scm b/doc/he-config-bare-bones.scm index 1faf75b871..d2e4736e29 100644 --- a/doc/he-config-bare-bones.scm +++ b/doc/he-config-bare-bones.scm @@ -1,5 +1,5 @@ (use-modules (gnu home) - (gnu home-services) + (gnu home services) (gnu home services shells) (gnu services) (gnu packages admin) diff --git a/gnu/home-services.scm b/gnu/home-services.scm deleted file mode 100644 index a244a15511..0000000000 --- a/gnu/home-services.scm +++ /dev/null @@ -1,524 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Andrew Tropin -;;; Copyright © 2021 Xinglu Chen -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix 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. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu home-services) - #:use-module (gnu services) - #:use-module (guix channels) - #:use-module (guix monads) - #:use-module (guix store) - #:use-module (guix gexp) - #:use-module (guix profiles) - #:use-module (guix sets) - #:use-module (guix ui) - #:use-module (guix discovery) - #:use-module (guix diagnostics) - - #:use-module (srfi srfi-1) - #:use-module (ice-9 match) - - #:export (home-service-type - home-profile-service-type - home-environment-variables-service-type - home-files-service-type - home-run-on-first-login-service-type - home-activation-service-type - home-run-on-change-service-type - home-provenance-service-type - - fold-home-service-types) - - #:re-export (service - service-type - service-extension)) - -;;; Comment: -;;; -;;; This module is similar to (gnu system services) module, but -;;; provides Home Services, which are supposed to be used for building -;;; home-environment. -;;; -;;; Home Services use the same extension as System Services. Consult -;;; (gnu system services) module or manual for more information. -;;; -;;; home-service-type is a root of home services DAG. -;;; -;;; home-profile-service-type is almost the same as profile-service-type, at least -;;; for now. -;;; -;;; home-environment-variables-service-type generates a @file{setup-environment} -;;; shell script, which is expected to be sourced by login shell or other program, -;;; which starts early and spawns all other processes. Home services for shells -;;; automatically add code for sourcing this file, if person do not use those home -;;; services they have to source this script manually in their's shell *profile -;;; file (details described in the manual). -;;; -;;; home-files-service-type is similar to etc-service-type, but doesn't extend -;;; home-activation, because deploy mechanism for config files is pluggable and -;;; can be different for different home environments: The default one is called -;;; symlink-manager (will be introudced in a separate patch series), which creates -;;; links for various dotfiles (like $XDG_CONFIG_HOME/$APP/...) to store, but is -;;; possible to implement alternative approaches like read-only home from Julien's -;;; guix-home-manager. -;;; -;;; home-run-on-first-login-service-type provides an @file{on-first-login} guile -;;; script, which runs provided gexps once, when user makes first login. It can -;;; be used to start user's Shepherd and maybe some other process. It relies on -;;; assumption that /run/user/$UID will be created on login by some login -;;; manager (elogind for example). -;;; -;;; home-activation-service-type provides an @file{activate} guile script, which -;;; do three main things: -;;; -;;; - Sets environment variables to the values declared in -;;; @file{setup-environment} shell script. It's necessary, because user can set -;;; for example XDG_CONFIG_HOME and it should be respected by activation gexp of -;;; symlink-manager. -;;; -;;; - Sets GUIX_NEW_HOME and possibly GUIX_OLD_HOME vars to paths in the store. -;;; Later those variables can be used by activation gexps, for example by -;;; symlink-manager or run-on-change services. -;;; -;;; - Run all activation gexps provided by other home services. -;;; -;;; home-run-on-change-service-type allows to trigger actions during -;;; activation if file or directory specified by pattern is changed. -;;; -;;; Code: - - -(define (home-derivation entries mextensions) - "Return as a monadic value the derivation of the 'home' -directory containing the given entries." - (mlet %store-monad ((extensions (mapm/accumulate-builds identity - mextensions))) - (lower-object - (file-union "home" (append entries (concatenate extensions)))))) - -(define home-service-type - ;; This is the ultimate service type, the root of the home service - ;; DAG. The service of this type is extended by monadic name/item - ;; pairs. These items end up in the "home-environment directory" as - ;; returned by 'home-environment-derivation'. - (service-type (name 'home) - (extensions '()) - (compose identity) - (extend home-derivation) - (default-value '()) - (description - "Build the home environment top-level directory, -which in turn refers to everything the home environment needs: its -packages, configuration files, activation script, and so on."))) - -(define (packages->profile-entry packages) - "Return a system entry for the profile containing PACKAGES." - ;; XXX: 'mlet' is needed here for one reason: to get the proper - ;; '%current-target' and '%current-target-system' bindings when - ;; 'packages->manifest' is called, and thus when the 'package-inputs' - ;; etc. procedures are called on PACKAGES. That way, conditionals in those - ;; inputs see the "correct" value of these two parameters. See - ;; . - (mlet %store-monad ((_ (current-target-system))) - (return `(("profile" ,(profile - (content (packages->manifest - (map identity - ;;(options->transformation transformations) - (delete-duplicates packages eq?)))))))))) - -;; MAYBE: Add a list of transformations for packages. It's better to -;; place it in home-profile-service-type to affect all profile -;; packages and prevent conflicts, when other packages relies on -;; non-transformed version of package. -(define home-profile-service-type - (service-type (name 'home-profile) - (extensions - (list (service-extension home-service-type - packages->profile-entry))) - (compose concatenate) - (extend append) - (description - "This is the @dfn{home profile} and can be found in -@file{~/.guix-home/profile}. It contains packages and -configuration files that the user has declared in their -@code{home-environment} record."))) - -(define (environment-variables->setup-environment-script vars) - "Return a file that can be sourced by a POSIX compliant shell which -initializes the environment. The file will source the home -environment profile, set some default environment variables, and set -environment variables provided in @code{vars}. @code{vars} is a list -of pairs (@code{(key . value)}), @code{key} is a string and -@code{value} is a string or gexp. - -If value is @code{#f} variable will be omitted. -If value is @code{#t} variable will be just exported. -For any other, value variable will be set to the @code{value} and -exported." - (define (warn-about-duplicate-defenitions) - (fold - (lambda (x acc) - (when (equal? (car x) (car acc)) - (warning - (G_ "duplicate definition for `~a' environment variable ~%") (car x))) - x) - (cons "" "") - (sort vars (lambda (a b) - (stringsetup-environment-script))) - (compose concatenate) - (extend append) - (default-value '()) - (description "Set the environment variables."))) - -(define (files->files-directory files) - "Return a @code{files} directory that contains FILES." - (define (assert-no-duplicates files) - (let loop ((files files) - (seen (set))) - (match files - (() #t) - (((file _) rest ...) - (when (set-contains? seen file) - (raise (formatted-message (G_ "duplicate '~a' entry for files/") - file))) - (loop rest (set-insert file seen)))))) - - ;; Detect duplicates early instead of letting them through, eventually - ;; leading to a build failure of "files.drv". - (assert-no-duplicates files) - - (file-union "files" files)) - -(define (files-entry files) - "Return an entry for the @file{~/.guix-home/files} -directory containing FILES." - (with-monad %store-monad - (return `(("files" ,(files->files-directory files)))))) - -(define home-files-service-type - (service-type (name 'home-files) - (extensions - (list (service-extension home-service-type - files-entry))) - (compose concatenate) - (extend append) - (default-value '()) - (description "Configuration files for programs that -will be put in @file{~/.guix-home/files}."))) - -(define (compute-on-first-login-script _ gexps) - (gexp->script - "on-first-login" - #~(let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR") - (format #f "/run/user/~a" (getuid)))) - (flag-file-path (string-append - xdg-runtime-dir "/on-first-login-executed")) - (touch (lambda (file-name) - (call-with-output-file file-name (const #t))))) - ;; XDG_RUNTIME_DIR dissapears on logout, that means such trick - ;; allows to launch on-first-login script on first login only - ;; after complete logout/reboot. - (when (not (file-exists? flag-file-path)) - (begin #$@gexps (touch flag-file-path)))))) - -(define (on-first-login-script-entry m-on-first-login) - "Return, as a monadic value, an entry for the on-first-login script -in the home environment directory." - (mlet %store-monad ((on-first-login m-on-first-login)) - (return `(("on-first-login" ,on-first-login))))) - -(define home-run-on-first-login-service-type - (service-type (name 'home-run-on-first-login) - (extensions - (list (service-extension - home-service-type - on-first-login-script-entry))) - (compose identity) - (extend compute-on-first-login-script) - (default-value #f) - (description "Run gexps on first user login. Can be -extended with one gexp."))) - - -(define (compute-activation-script init-gexp gexps) - (gexp->script - "activate" - #~(let* ((he-init-file (lambda (he) (string-append he "/setup-environment"))) - (he-path (string-append (getenv "HOME") "/.guix-home")) - (new-home-env (getenv "GUIX_NEW_HOME")) - (new-home (or new-home-env - ;; Path of the activation file if called interactively - (dirname (car (command-line))))) - (old-home-env (getenv "GUIX_OLD_HOME")) - (old-home (or old-home-env - (if (file-exists? (he-init-file he-path)) - (readlink he-path) - #f)))) - (if (file-exists? (he-init-file new-home)) - (let* ((port ((@ (ice-9 popen) open-input-pipe) - (format #f "source ~a && env -0" - (he-init-file new-home)))) - (result ((@ (ice-9 rdelim) read-delimited) "" port)) - (vars (map (lambda (x) - (let ((si (string-index x #\=))) - (cons (string-take x si) - (string-drop x (1+ si))))) - ((@ (srfi srfi-1) remove) - string-null? - (string-split result #\nul))))) - (close-port port) - (map (lambda (x) (setenv (car x) (cdr x))) vars) - - (setenv "GUIX_NEW_HOME" new-home) - (setenv "GUIX_OLD_HOME" old-home) - - #$@gexps - - ;; Do not unset env variable if it was set outside. - (unless new-home-env (setenv "GUIX_NEW_HOME" #f)) - (unless old-home-env (setenv "GUIX_OLD_HOME" #f))) - (format #t "\ -Activation script was either called or loaded by file from this direcotry: -~a -It doesn't seem that home environment is somewhere around. -Make sure that you call ./activate by symlink from -home store item.\n" - new-home))))) - -(define (activation-script-entry m-activation) - "Return, as a monadic value, an entry for the activation script -in the home environment directory." - (mlet %store-monad ((activation m-activation)) - (return `(("activate" ,activation))))) - -(define home-activation-service-type - (service-type (name 'home-activation) - (extensions - (list (service-extension - home-service-type - activation-script-entry))) - (compose identity) - (extend compute-activation-script) - (default-value #f) - (description "Run gexps to activate the current -generation of home environment and update the state of the home -directory. @command{activate} script automatically called during -reconfiguration or generation switching. This service can be extended -with one gexp, but many times, and all gexps must be idempotent."))) - - -;;; -;;; On-change. -;;; - -(define (compute-on-change-gexp eval-gexps? pattern-gexp-tuples) - #~(begin - (define (equal-regulars? file1 file2) - "Check if FILE1 and FILE2 are bit for bit identical." - (let* ((cmp-binary #$(file-append - (@ (gnu packages base) diffutils) "/bin/cmp")) - (stats1 (lstat file1)) - (stats2 (lstat file2))) - (cond - ((= (stat:ino stats1) (stat:ino stats2)) #t) - ((not (= (stat:size stats1) (stat:size stats2))) #f) - - (else (= (system* cmp-binary file1 file2) 0))))) - - (define (equal-symlinks? symlink1 symlink2) - "Check if SYMLINK1 and SYMLINK2 are pointing to the same target." - (string=? (readlink symlink1) (readlink symlink2))) - - (define (equal-directories? dir1 dir2) - "Check if DIR1 and DIR2 have the same content." - (define (ordinary-file file) - (not (or (string=? file ".") - (string=? file "..")))) - (let* ((files1 (scandir dir1 ordinary-file)) - (files2 (scandir dir2 ordinary-file))) - (if (equal? files1 files2) - (map (lambda (file) - (equal-files? - (string-append dir1 "/" file) - (string-append dir2 "/" file))) - files1) - #f))) - - (define (equal-files? file1 file2) - "Compares files, symlinks or directories of the same type." - (case (file-type file1) - ((directory) (equal-directories? file1 file2)) - ((symlink) (equal-symlinks? file1 file2)) - ((regular) (equal-regulars? file1 file2)) - (else - (display "The file type is unsupported by on-change service.\n") - #f))) - - (define (file-type file) - (stat:type (lstat file))) - - (define (something-changed? file1 file2) - (cond - ((and (not (file-exists? file1)) - (not (file-exists? file2))) #f) - ((or (not (file-exists? file1)) - (not (file-exists? file2))) #t) - - ((not (eq? (file-type file1) (file-type file2))) #t) - - (else - (not (equal-files? file1 file2))))) - - (define expressions-to-eval - (map - (lambda (x) - (let* ((file1 (string-append - (or (getenv "GUIX_OLD_HOME") - "/gnu/store/non-existing-generation") - "/" (car x))) - (file2 (string-append (getenv "GUIX_NEW_HOME") "/" (car x))) - (_ (format #t "Comparing ~a and\n~10t~a..." file1 file2)) - (any-changes? (something-changed? file1 file2)) - (_ (format #t " done (~a)\n" - (if any-changes? "changed" "same")))) - (if any-changes? (cadr x) ""))) - '#$pattern-gexp-tuples)) - - (if #$eval-gexps? - (begin - (display "Evaling on-change gexps.\n\n") - (for-each primitive-eval expressions-to-eval) - (display "On-change gexps evaluation finished.\n\n")) - (display "\ -On-change gexps won't be evaluated, disabled by service -configuration.\n")))) - -(define home-run-on-change-service-type - (service-type (name 'home-run-on-change) - (extensions - (list (service-extension - home-activation-service-type - identity))) - (compose concatenate) - (extend compute-on-change-gexp) - (default-value #t) - (description "\ -G-expressions to run if the specified files have changed since the -last generation. The extension should be a list of lists where the -first element is the pattern for file or directory that expected to be -changed, and the second element is the G-expression to be evaluated."))) - - -;;; -;;; Provenance tracking. -;;; - -(define home-provenance-service-type - (service-type - (name 'home-provenance) - (extensions - (list (service-extension - home-service-type - (service-extension-compute - (first (service-type-extensions provenance-service-type)))))) - (default-value #f) ;the HE config file - (description "\ -Store provenance information about the home environment in the home -environment itself: the channels used when building the home -environment, and its configuration file, when available."))) - -(define sexp->home-provenance sexp->system-provenance) -(define home-provenance system-provenance) - - -;;; -;;; Searching -;;; - -(define (parent-directory directory) - "Get the parent directory of DIRECTORY" - (string-join (drop-right (string-split directory #\/) 1) "/")) - -(define %guix-home-root-directory - ;; Absolute file name of the module hierarchy. - (parent-directory (dirname (search-path %load-path "gnu/home-services.scm")))) - -(define %service-type-path - ;; Search path for service types. - (make-parameter `((,%guix-home-root-directory . "gnu/home/services")))) - -(define (all-home-service-modules) - "Return the default set of `home service' modules." - (cons (resolve-interface '(gnu home-services)) - (all-modules (%service-type-path) - #:warn warn-about-load-error))) - -(define* (fold-home-service-types proc seed) - (fold-service-types proc seed (all-home-service-modules))) diff --git a/gnu/home.scm b/gnu/home.scm index 5ac382dc5a..d8134693e5 100644 --- a/gnu/home.scm +++ b/gnu/home.scm @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu home) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu home services symlink-manager) #:use-module (gnu home services shells) #:use-module (gnu home services xdg) diff --git a/gnu/home/services.scm b/gnu/home/services.scm new file mode 100644 index 0000000000..c497b14617 --- /dev/null +++ b/gnu/home/services.scm @@ -0,0 +1,524 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Andrew Tropin +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix 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. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home services) + #:use-module (gnu services) + #:use-module (guix channels) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (guix gexp) + #:use-module (guix profiles) + #:use-module (guix sets) + #:use-module (guix ui) + #:use-module (guix discovery) + #:use-module (guix diagnostics) + + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + + #:export (home-service-type + home-profile-service-type + home-environment-variables-service-type + home-files-service-type + home-run-on-first-login-service-type + home-activation-service-type + home-run-on-change-service-type + home-provenance-service-type + + fold-home-service-types) + + #:re-export (service + service-type + service-extension)) + +;;; Comment: +;;; +;;; This module is similar to (gnu system services) module, but +;;; provides Home Services, which are supposed to be used for building +;;; home-environment. +;;; +;;; Home Services use the same extension as System Services. Consult +;;; (gnu system services) module or manual for more information. +;;; +;;; home-service-type is a root of home services DAG. +;;; +;;; home-profile-service-type is almost the same as profile-service-type, at least +;;; for now. +;;; +;;; home-environment-variables-service-type generates a @file{setup-environment} +;;; shell script, which is expected to be sourced by login shell or other program, +;;; which starts early and spawns all other processes. Home services for shells +;;; automatically add code for sourcing this file, if person do not use those home +;;; services they have to source this script manually in their's shell *profile +;;; file (details described in the manual). +;;; +;;; home-files-service-type is similar to etc-service-type, but doesn't extend +;;; home-activation, because deploy mechanism for config files is pluggable and +;;; can be different for different home environments: The default one is called +;;; symlink-manager (will be introudced in a separate patch series), which creates +;;; links for various dotfiles (like $XDG_CONFIG_HOME/$APP/...) to store, but is +;;; possible to implement alternative approaches like read-only home from Julien's +;;; guix-home-manager. +;;; +;;; home-run-on-first-login-service-type provides an @file{on-first-login} guile +;;; script, which runs provided gexps once, when user makes first login. It can +;;; be used to start user's Shepherd and maybe some other process. It relies on +;;; assumption that /run/user/$UID will be created on login by some login +;;; manager (elogind for example). +;;; +;;; home-activation-service-type provides an @file{activate} guile script, which +;;; do three main things: +;;; +;;; - Sets environment variables to the values declared in +;;; @file{setup-environment} shell script. It's necessary, because user can set +;;; for example XDG_CONFIG_HOME and it should be respected by activation gexp of +;;; symlink-manager. +;;; +;;; - Sets GUIX_NEW_HOME and possibly GUIX_OLD_HOME vars to paths in the store. +;;; Later those variables can be used by activation gexps, for example by +;;; symlink-manager or run-on-change services. +;;; +;;; - Run all activation gexps provided by other home services. +;;; +;;; home-run-on-change-service-type allows to trigger actions during +;;; activation if file or directory specified by pattern is changed. +;;; +;;; Code: + + +(define (home-derivation entries mextensions) + "Return as a monadic value the derivation of the 'home' +directory containing the given entries." + (mlet %store-monad ((extensions (mapm/accumulate-builds identity + mextensions))) + (lower-object + (file-union "home" (append entries (concatenate extensions)))))) + +(define home-service-type + ;; This is the ultimate service type, the root of the home service + ;; DAG. The service of this type is extended by monadic name/item + ;; pairs. These items end up in the "home-environment directory" as + ;; returned by 'home-environment-derivation'. + (service-type (name 'home) + (extensions '()) + (compose identity) + (extend home-derivation) + (default-value '()) + (description + "Build the home environment top-level directory, +which in turn refers to everything the home environment needs: its +packages, configuration files, activation script, and so on."))) + +(define (packages->profile-entry packages) + "Return a system entry for the profile containing PACKAGES." + ;; XXX: 'mlet' is needed here for one reason: to get the proper + ;; '%current-target' and '%current-target-system' bindings when + ;; 'packages->manifest' is called, and thus when the 'package-inputs' + ;; etc. procedures are called on PACKAGES. That way, conditionals in those + ;; inputs see the "correct" value of these two parameters. See + ;; . + (mlet %store-monad ((_ (current-target-system))) + (return `(("profile" ,(profile + (content (packages->manifest + (map identity + ;;(options->transformation transformations) + (delete-duplicates packages eq?)))))))))) + +;; MAYBE: Add a list of transformations for packages. It's better to +;; place it in home-profile-service-type to affect all profile +;; packages and prevent conflicts, when other packages relies on +;; non-transformed version of package. +(define home-profile-service-type + (service-type (name 'home-profile) + (extensions + (list (service-extension home-service-type + packages->profile-entry))) + (compose concatenate) + (extend append) + (description + "This is the @dfn{home profile} and can be found in +@file{~/.guix-home/profile}. It contains packages and +configuration files that the user has declared in their +@code{home-environment} record."))) + +(define (environment-variables->setup-environment-script vars) + "Return a file that can be sourced by a POSIX compliant shell which +initializes the environment. The file will source the home +environment profile, set some default environment variables, and set +environment variables provided in @code{vars}. @code{vars} is a list +of pairs (@code{(key . value)}), @code{key} is a string and +@code{value} is a string or gexp. + +If value is @code{#f} variable will be omitted. +If value is @code{#t} variable will be just exported. +For any other, value variable will be set to the @code{value} and +exported." + (define (warn-about-duplicate-defenitions) + (fold + (lambda (x acc) + (when (equal? (car x) (car acc)) + (warning + (G_ "duplicate definition for `~a' environment variable ~%") (car x))) + x) + (cons "" "") + (sort vars (lambda (a b) + (stringsetup-environment-script))) + (compose concatenate) + (extend append) + (default-value '()) + (description "Set the environment variables."))) + +(define (files->files-directory files) + "Return a @code{files} directory that contains FILES." + (define (assert-no-duplicates files) + (let loop ((files files) + (seen (set))) + (match files + (() #t) + (((file _) rest ...) + (when (set-contains? seen file) + (raise (formatted-message (G_ "duplicate '~a' entry for files/") + file))) + (loop rest (set-insert file seen)))))) + + ;; Detect duplicates early instead of letting them through, eventually + ;; leading to a build failure of "files.drv". + (assert-no-duplicates files) + + (file-union "files" files)) + +(define (files-entry files) + "Return an entry for the @file{~/.guix-home/files} +directory containing FILES." + (with-monad %store-monad + (return `(("files" ,(files->files-directory files)))))) + +(define home-files-service-type + (service-type (name 'home-files) + (extensions + (list (service-extension home-service-type + files-entry))) + (compose concatenate) + (extend append) + (default-value '()) + (description "Configuration files for programs that +will be put in @file{~/.guix-home/files}."))) + +(define (compute-on-first-login-script _ gexps) + (gexp->script + "on-first-login" + #~(let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR") + (format #f "/run/user/~a" (getuid)))) + (flag-file-path (string-append + xdg-runtime-dir "/on-first-login-executed")) + (touch (lambda (file-name) + (call-with-output-file file-name (const #t))))) + ;; XDG_RUNTIME_DIR dissapears on logout, that means such trick + ;; allows to launch on-first-login script on first login only + ;; after complete logout/reboot. + (when (not (file-exists? flag-file-path)) + (begin #$@gexps (touch flag-file-path)))))) + +(define (on-first-login-script-entry m-on-first-login) + "Return, as a monadic value, an entry for the on-first-login script +in the home environment directory." + (mlet %store-monad ((on-first-login m-on-first-login)) + (return `(("on-first-login" ,on-first-login))))) + +(define home-run-on-first-login-service-type + (service-type (name 'home-run-on-first-login) + (extensions + (list (service-extension + home-service-type + on-first-login-script-entry))) + (compose identity) + (extend compute-on-first-login-script) + (default-value #f) + (description "Run gexps on first user login. Can be +extended with one gexp."))) + + +(define (compute-activation-script init-gexp gexps) + (gexp->script + "activate" + #~(let* ((he-init-file (lambda (he) (string-append he "/setup-environment"))) + (he-path (string-append (getenv "HOME") "/.guix-home")) + (new-home-env (getenv "GUIX_NEW_HOME")) + (new-home (or new-home-env + ;; Path of the activation file if called interactively + (dirname (car (command-line))))) + (old-home-env (getenv "GUIX_OLD_HOME")) + (old-home (or old-home-env + (if (file-exists? (he-init-file he-path)) + (readlink he-path) + #f)))) + (if (file-exists? (he-init-file new-home)) + (let* ((port ((@ (ice-9 popen) open-input-pipe) + (format #f "source ~a && env -0" + (he-init-file new-home)))) + (result ((@ (ice-9 rdelim) read-delimited) "" port)) + (vars (map (lambda (x) + (let ((si (string-index x #\=))) + (cons (string-take x si) + (string-drop x (1+ si))))) + ((@ (srfi srfi-1) remove) + string-null? + (string-split result #\nul))))) + (close-port port) + (map (lambda (x) (setenv (car x) (cdr x))) vars) + + (setenv "GUIX_NEW_HOME" new-home) + (setenv "GUIX_OLD_HOME" old-home) + + #$@gexps + + ;; Do not unset env variable if it was set outside. + (unless new-home-env (setenv "GUIX_NEW_HOME" #f)) + (unless old-home-env (setenv "GUIX_OLD_HOME" #f))) + (format #t "\ +Activation script was either called or loaded by file from this direcotry: +~a +It doesn't seem that home environment is somewhere around. +Make sure that you call ./activate by symlink from -home store item.\n" + new-home))))) + +(define (activation-script-entry m-activation) + "Return, as a monadic value, an entry for the activation script +in the home environment directory." + (mlet %store-monad ((activation m-activation)) + (return `(("activate" ,activation))))) + +(define home-activation-service-type + (service-type (name 'home-activation) + (extensions + (list (service-extension + home-service-type + activation-script-entry))) + (compose identity) + (extend compute-activation-script) + (default-value #f) + (description "Run gexps to activate the current +generation of home environment and update the state of the home +directory. @command{activate} script automatically called during +reconfiguration or generation switching. This service can be extended +with one gexp, but many times, and all gexps must be idempotent."))) + + +;;; +;;; On-change. +;;; + +(define (compute-on-change-gexp eval-gexps? pattern-gexp-tuples) + #~(begin + (define (equal-regulars? file1 file2) + "Check if FILE1 and FILE2 are bit for bit identical." + (let* ((cmp-binary #$(file-append + (@ (gnu packages base) diffutils) "/bin/cmp")) + (stats1 (lstat file1)) + (stats2 (lstat file2))) + (cond + ((= (stat:ino stats1) (stat:ino stats2)) #t) + ((not (= (stat:size stats1) (stat:size stats2))) #f) + + (else (= (system* cmp-binary file1 file2) 0))))) + + (define (equal-symlinks? symlink1 symlink2) + "Check if SYMLINK1 and SYMLINK2 are pointing to the same target." + (string=? (readlink symlink1) (readlink symlink2))) + + (define (equal-directories? dir1 dir2) + "Check if DIR1 and DIR2 have the same content." + (define (ordinary-file file) + (not (or (string=? file ".") + (string=? file "..")))) + (let* ((files1 (scandir dir1 ordinary-file)) + (files2 (scandir dir2 ordinary-file))) + (if (equal? files1 files2) + (map (lambda (file) + (equal-files? + (string-append dir1 "/" file) + (string-append dir2 "/" file))) + files1) + #f))) + + (define (equal-files? file1 file2) + "Compares files, symlinks or directories of the same type." + (case (file-type file1) + ((directory) (equal-directories? file1 file2)) + ((symlink) (equal-symlinks? file1 file2)) + ((regular) (equal-regulars? file1 file2)) + (else + (display "The file type is unsupported by on-change service.\n") + #f))) + + (define (file-type file) + (stat:type (lstat file))) + + (define (something-changed? file1 file2) + (cond + ((and (not (file-exists? file1)) + (not (file-exists? file2))) #f) + ((or (not (file-exists? file1)) + (not (file-exists? file2))) #t) + + ((not (eq? (file-type file1) (file-type file2))) #t) + + (else + (not (equal-files? file1 file2))))) + + (define expressions-to-eval + (map + (lambda (x) + (let* ((file1 (string-append + (or (getenv "GUIX_OLD_HOME") + "/gnu/store/non-existing-generation") + "/" (car x))) + (file2 (string-append (getenv "GUIX_NEW_HOME") "/" (car x))) + (_ (format #t "Comparing ~a and\n~10t~a..." file1 file2)) + (any-changes? (something-changed? file1 file2)) + (_ (format #t " done (~a)\n" + (if any-changes? "changed" "same")))) + (if any-changes? (cadr x) ""))) + '#$pattern-gexp-tuples)) + + (if #$eval-gexps? + (begin + (display "Evaling on-change gexps.\n\n") + (for-each primitive-eval expressions-to-eval) + (display "On-change gexps evaluation finished.\n\n")) + (display "\ +On-change gexps won't be evaluated, disabled by service +configuration.\n")))) + +(define home-run-on-change-service-type + (service-type (name 'home-run-on-change) + (extensions + (list (service-extension + home-activation-service-type + identity))) + (compose concatenate) + (extend compute-on-change-gexp) + (default-value #t) + (description "\ +G-expressions to run if the specified files have changed since the +last generation. The extension should be a list of lists where the +first element is the pattern for file or directory that expected to be +changed, and the second element is the G-expression to be evaluated."))) + + +;;; +;;; Provenance tracking. +;;; + +(define home-provenance-service-type + (service-type + (name 'home-provenance) + (extensions + (list (service-extension + home-service-type + (service-extension-compute + (first (service-type-extensions provenance-service-type)))))) + (default-value #f) ;the HE config file + (description "\ +Store provenance information about the home environment in the home +environment itself: the channels used when building the home +environment, and its configuration file, when available."))) + +(define sexp->home-provenance sexp->system-provenance) +(define home-provenance system-provenance) + + +;;; +;;; Searching +;;; + +(define (parent-directory directory) + "Get the parent directory of DIRECTORY" + (string-join (drop-right (string-split directory #\/) 1) "/")) + +(define %guix-home-root-directory + ;; Absolute file name of the module hierarchy. + (parent-directory (dirname (search-path %load-path "gnu/home/services.scm")))) + +(define %service-type-path + ;; Search path for service types. + (make-parameter `((,%guix-home-root-directory . "gnu/home/services")))) + +(define (all-home-service-modules) + "Return the default set of `home service' modules." + (cons (resolve-interface '(gnu home services)) + (all-modules (%service-type-path) + #:warn warn-about-load-error))) + +(define* (fold-home-service-types proc seed) + (fold-service-types proc seed (all-home-service-modules))) diff --git a/gnu/home/services/fontutils.scm b/gnu/home/services/fontutils.scm index 72a84fdecd..772904367d 100644 --- a/gnu/home/services/fontutils.scm +++ b/gnu/home/services/fontutils.scm @@ -18,7 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu home services fontutils) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu packages fontutils) #:use-module (guix gexp) diff --git a/gnu/home/services/mcron.scm b/gnu/home/services/mcron.scm index cc6faac47f..0b3dbb810b 100644 --- a/gnu/home/services/mcron.scm +++ b/gnu/home/services/mcron.scm @@ -19,7 +19,7 @@ (define-module (gnu home services mcron) #:use-module (gnu packages guile-xyz) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu services shepherd) #:use-module (gnu home services shepherd) #:use-module (guix records) diff --git a/gnu/home/services/shells.scm b/gnu/home/services/shells.scm index 2308371dd0..21b250f35d 100644 --- a/gnu/home/services/shells.scm +++ b/gnu/home/services/shells.scm @@ -21,7 +21,7 @@ #:use-module (gnu services configuration) #:use-module (gnu home services configuration) #:use-module (gnu home services utils) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu packages shells) #:use-module (gnu packages bash) #:use-module (guix gexp) diff --git a/gnu/home/services/shepherd.scm b/gnu/home/services/shepherd.scm index 1a3e849bb2..7a9cc064bb 100644 --- a/gnu/home/services/shepherd.scm +++ b/gnu/home/services/shepherd.scm @@ -18,7 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu home services shepherd) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu packages admin) #:use-module (gnu services shepherd) #:use-module (guix sets) diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm index d53e8f5046..f4251e1e6a 100644 --- a/gnu/home/services/symlink-manager.scm +++ b/gnu/home/services/symlink-manager.scm @@ -18,7 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu home services symlink-manager) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (guix gexp) #:export (home-symlink-manager-service-type)) diff --git a/gnu/home/services/xdg.scm b/gnu/home/services/xdg.scm index 4aed9a5803..453c05ddbf 100644 --- a/gnu/home/services/xdg.scm +++ b/gnu/home/services/xdg.scm @@ -20,7 +20,7 @@ (define-module (gnu home services xdg) #:use-module (gnu services configuration) #:use-module (gnu home services configuration) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu packages freedesktop) #:use-module (gnu home services utils) #:use-module (guix gexp) diff --git a/gnu/local.mk b/gnu/local.mk index bb3063c4ac..ff51c500d4 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -74,7 +74,7 @@ GNU_SYSTEM_MODULES = \ %D%/bootloader/depthcharge.scm \ %D%/ci.scm \ %D%/home.scm \ - %D%/home-services.scm \ + %D%/home/services.scm \ %D%/home/services/symlink-manager.scm \ %D%/home/services/fontutils.scm \ %D%/home/services/configuration.scm \ diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index a4d4aaa562..8656db22c9 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -23,7 +23,7 @@ #:use-module ((gnu services) #:hide (delete)) #:use-module (gnu packages) #:use-module (gnu home) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (guix channels) #:use-module (guix derivations) #:use-module (guix ui) diff --git a/guix/self.scm b/guix/self.scm index 7bf6003261..61ff423086 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -961,7 +961,7 @@ itself." (define *home-modules* (scheme-node "guix-home" `((gnu home) - (gnu home-services) + (gnu home services) ,@(scheme-modules* source "gnu/home/services")) (list *core-package-modules* *package-modules* *extra-modules* *core-modules* *system-modules*) -- cgit v1.2.3