diff options
Diffstat (limited to 'gnu/home')
| -rw-r--r-- | gnu/home/services.scm | 60 | ||||
| -rw-r--r-- | gnu/home/services/desktop.scm | 174 | ||||
| -rw-r--r-- | gnu/home/services/fontutils.scm | 4 | ||||
| -rw-r--r-- | gnu/home/services/shells.scm | 126 | ||||
| -rw-r--r-- | gnu/home/services/shepherd.scm | 21 | ||||
| -rw-r--r-- | gnu/home/services/symlink-manager.scm | 387 | ||||
| -rw-r--r-- | gnu/home/services/xdg.scm | 33 |
7 files changed, 509 insertions, 296 deletions
diff --git a/gnu/home/services.scm b/gnu/home/services.scm index 2a3cb44952..254663c6bb 100644 --- a/gnu/home/services.scm +++ b/gnu/home/services.scm @@ -30,6 +30,7 @@ #:use-module (guix discovery) #:use-module (guix diagnostics) #:use-module (guix i18n) + #:use-module (guix modules) #:use-module (srfi srfi-1) #:use-module (ice-9 match) @@ -37,12 +38,17 @@ home-profile-service-type home-environment-variables-service-type home-files-service-type + home-xdg-configuration-files-service-type home-run-on-first-login-service-type home-activation-service-type home-run-on-change-service-type home-provenance-service-type + home-files-directory + xdg-configuration-files-directory + fold-home-service-types + home-provenance %initialize-gettext) @@ -72,12 +78,11 @@ ;;; 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-activation, because deploy mechanism for config files is pluggable +;;; and can be different for different home environments: The default one is +;;; called symlink-manager, which creates links for various dotfiles and xdg +;;; configuration files 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 @@ -260,11 +265,14 @@ esac (file-union "files" files)) +;; Used by symlink-manager +(define home-files-directory "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)))))) + (return `((,home-files-directory ,(files->files-directory files)))))) (define home-files-service-type (service-type (name 'home-files) @@ -274,20 +282,41 @@ directory containing FILES." (compose concatenate) (extend append) (default-value '()) - (description "Configuration files for programs that -will be put in @file{~/.guix-home/files}."))) + (description "Files that will be put in +@file{~~/.guix-home/files}, and further processed during activation."))) + +(define xdg-configuration-files-directory "config") + +(define (xdg-configuration-files files) + "Add config/ prefix to each file-path in FILES." + (map (match-lambda + ((file-path . rest) + (cons (string-append xdg-configuration-files-directory "/" file-path) + rest))) + files)) + +(define home-xdg-configuration-files-service-type + (service-type (name 'home-files) + (extensions + (list (service-extension home-files-service-type + xdg-configuration-files))) + (compose concatenate) + (extend append) + (default-value '()) + (description "Files that will be put in +@file{~~/.guix-home/files/config}, and further processed during activation."))) (define %initialize-gettext #~(begin (bindtextdomain %gettext-domain (string-append #$guix "/share/locale")) - (textdomain %gettext-domain) - (setlocale LC_ALL ""))) + (textdomain %gettext-domain))) (define (compute-on-first-login-script _ gexps) (program-file "on-first-login" - #~(begin + (with-imported-modules (source-module-closure '((guix i18n))) + #~(begin (use-modules (guix i18n)) #$%initialize-gettext @@ -308,7 +337,7 @@ will be put in @file{~/.guix-home/files}."))) (display (G_ "XDG_RUNTIME_DIR doesn't exists, on-first-login script won't execute anything. You can check if xdg runtime directory exists, XDG_RUNTIME_DIR variable is set to appropriate value and manually execute the -script by running '$HOME/.guix-home/on-first-login'"))))))) +script by running '$HOME/.guix-home/on-first-login'")))))))) (define (on-first-login-script-entry on-first-login) "Return, as a monadic value, an entry for the on-first-login script @@ -400,7 +429,8 @@ with one gexp, but many times, and all gexps must be idempotent."))) ;;; (define (compute-on-change-gexp eval-gexps? pattern-gexp-tuples) - #~(begin + (with-imported-modules (source-module-closure '((guix i18n))) + #~(begin (use-modules (guix i18n)) #$%initialize-gettext @@ -485,7 +515,7 @@ with one gexp, but many times, and all gexps must be idempotent."))) (display (G_ "On-change gexps evaluation finished.\n\n"))) (display "\ On-change gexps won't be evaluated; evaluation has been disabled in the -service configuration")))) +service configuration"))))) (define home-run-on-change-service-type (service-type (name 'home-run-on-change) diff --git a/gnu/home/services/desktop.scm b/gnu/home/services/desktop.scm new file mode 100644 index 0000000000..cbb9cf76da --- /dev/null +++ b/gnu/home/services/desktop.scm @@ -0,0 +1,174 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu home services desktop) + #:use-module (gnu home services) + #:use-module (gnu home services shepherd) + #:use-module (gnu services configuration) + #:autoload (gnu packages xdisorg) (redshift) + #:use-module (guix records) + #:use-module (guix gexp) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:export (home-redshift-configuration + home-redshift-configuration? + + home-redshift-service-type)) + + +;;; +;;; Redshift. +;;; + +(define (serialize-integer field value) + (string-append (match field + ('daytime-temperature "temp-day") + ('nighttime-temperature "temp-night") + ('daytime-brightness "brightness-day") + ('nighttime-brightness "brightness-night") + ('latitude "lat") + ('longitude "lon") + (_ (symbol->string field))) + "=" (number->string value) "\n")) + +(define (serialize-symbol field value) + (string-append (symbol->string field) + "=" (symbol->string value) "\n")) + +(define (serialize-string field value) + (string-append (symbol->string field) + "=" value "\n")) + +(define serialize-inexact-number serialize-integer) + +(define (inexact-number? n) + (and (number? n) (inexact? n))) +(define-maybe inexact-number) +(define-maybe string) + +(define (serialize-raw-configuration-string field value) + value) +(define raw-configuration-string? string?) + +(define-configuration home-redshift-configuration + (redshift + (file-like redshift) + "Redshift package to use.") + + (location-provider + (symbol 'geoclue2) + "Geolocation provider---@code{'manual} or @code{'geoclue2}. + +In the former case, you must also specify the @code{latitude} and +@code{longitude} fields so Redshift can determine daytime at your place. In +the latter case, the Geoclue system service must be running; it will be +queried for location information.") + (adjustment-method + (symbol 'randr) + "Color adjustment method.") + + ;; Default values from redshift(1). + (daytime-temperature + (integer 6500) + "Daytime color temperature (kelvins).") + (nighttime-temperature + (integer 4500) + "Nighttime color temperature (kelvins).") + + (daytime-brightness + (maybe-inexact-number 'disabled) + "Daytime screen brightness, between 0.1 and 1.0.") + (nighttime-brightness + (maybe-inexact-number 'disabled) + "Nighttime screen brightness, between 0.1 and 1.0.") + + (latitude + (maybe-inexact-number 'disabled) + "Latitude, when @code{location-provider} is @code{'manual}.") + (longitude + (maybe-inexact-number 'disabled) + "Longitude, when @code{location-provider} is @code{'manual}.") + + (dawn-time + (maybe-string 'disabled) + "Custom time for the transition from night to day in the +morning---@code{\"HH:MM\"} format. When specified, solar elevation is not +used to determine the daytime/nighttime period.") + (dusk-time + (maybe-string 'disabled) + "Likewise, custom time for the transition from day to night in the +evening.") + + (extra-content + (raw-configuration-string "") + "Extra content appended as-is to the Redshift configuration file. Run +@command{man redshift} for more information about the configuration file +format.")) + +(define (serialize-redshift-configuration config) + (define location-fields + '(latitude longitude)) + + (define (location-field? field) + (memq (configuration-field-name field) location-fields)) + + (define (secondary-field? field) + (or (location-field? field) + (memq (configuration-field-name field) + '(redshift extra-content)))) + + #~(string-append + "[redshift]\n" + #$(serialize-configuration config + (remove secondary-field? + home-redshift-configuration-fields)) + + #$(home-redshift-configuration-extra-content config) + + "\n[manual]\n" + #$(serialize-configuration config + (filter location-field? + home-redshift-configuration-fields)))) + +(define (redshift-shepherd-service config) + (define config-file + (computed-file "redshift.conf" + #~(call-with-output-file #$output + (lambda (port) + (display #$(serialize-redshift-configuration config) + port))))) + + (list (shepherd-service + (documentation "Redshift program.") + (provision '(redshift)) + ;; FIXME: This fails to start if Home is first activated from a + ;; non-X11 session. + (start #~(make-forkexec-constructor + (list #$(file-append redshift "/bin/redshift") + "-c" #$config-file))) + (stop #~(make-kill-destructor))))) + +(define home-redshift-service-type + (service-type + (name 'home-redshift) + (extensions (list (service-extension home-shepherd-service-type + redshift-shepherd-service))) + (default-value (home-redshift-configuration)) + (description + "Run Redshift, a program that adjusts the color temperature of display +according to time of day."))) diff --git a/gnu/home/services/fontutils.scm b/gnu/home/services/fontutils.scm index 772904367d..6062eaed6a 100644 --- a/gnu/home/services/fontutils.scm +++ b/gnu/home/services/fontutils.scm @@ -34,7 +34,7 @@ ;;; Code: (define (add-fontconfig-config-file he-symlink-path) - `(("config/fontconfig/fonts.conf" + `(("fontconfig/fonts.conf" ,(mixed-text-file "fonts.conf" "<?xml version='1.0'?> @@ -51,7 +51,7 @@ (service-type (name 'home-fontconfig) (extensions (list (service-extension - home-files-service-type + home-xdg-configuration-files-service-type add-fontconfig-config-file) (service-extension home-run-on-change-service-type diff --git a/gnu/home/services/shells.scm b/gnu/home/services/shells.scm index ca7f4ac0ad..7b9769bcf3 100644 --- a/gnu/home/services/shells.scm +++ b/gnu/home/services/shells.scm @@ -171,56 +171,27 @@ Used for executing user's commands at the exit of login shell. It won't be read in some cases (if the shell terminates by exec'ing another process for example).")) -(define (add-zsh-configuration config) - (let* ((xdg-flavor? (home-zsh-configuration-xdg-flavor? config))) - - (define prefix-file - (cut string-append - (if xdg-flavor? - "config/zsh/." - "") <>)) - - (define (filter-fields field) - (filter-configuration-fields home-zsh-configuration-fields - (list field))) - - (define (serialize-field field) - (serialize-configuration - config - (filter-fields field))) - - (define (file-if-not-empty field) - (let ((file-name (symbol->string field)) - (field-obj (car (filter-fields field)))) - (if (not (null? ((configuration-field-getter field-obj) config))) - `(,(prefix-file file-name) - ,(mixed-text-file - file-name - (serialize-field field))) - '()))) - - (filter - (compose not null?) - `(,(if xdg-flavor? - `("zshenv" - ,(mixed-text-file - "auxiliary-zshenv" - (if xdg-flavor? - "source ${XDG_CONFIG_HOME:-$HOME/.config}/zsh/.zshenv\n" - ""))) - '()) - (,(prefix-file "zshenv") - ,(mixed-text-file - "zshenv" - (if xdg-flavor? - "export ZDOTDIR=${XDG_CONFIG_HOME:-$HOME/.config}/zsh\n" - "") - (serialize-field 'zshenv) - (serialize-field 'environment-variables))) - (,(prefix-file "zprofile") - ,(mixed-text-file - "zprofile" - "\ +(define (zsh-filter-fields field) + (filter-configuration-fields home-zsh-configuration-fields (list field))) + +(define (zsh-serialize-field config field) + (serialize-configuration config (zsh-filter-fields field))) + +(define* (zsh-field-not-empty? config field) + (let ((file-name (symbol->string field)) + (field-obj (car (zsh-filter-fields field)))) + (not (null? ((configuration-field-getter field-obj) config))))) + +(define (zsh-file-zshenv config) + (mixed-text-file + "zshenv" + (zsh-serialize-field config 'zshenv) + (zsh-serialize-field config 'environment-variables))) + +(define (zsh-file-zprofile config) + (mixed-text-file + "zprofile" + "\ # Setups system and user profiles and related variables source /etc/profile # Setups home environment profile @@ -229,11 +200,47 @@ source ~/.profile # It's only necessary if zsh is a login shell, otherwise profiles will # be already sourced by bash " - (serialize-field 'zprofile))) - - ,@(list (file-if-not-empty 'zshrc) - (file-if-not-empty 'zlogin) - (file-if-not-empty 'zlogout)))))) + (zsh-serialize-field config 'zprofile))) + +(define (zsh-file-by-field config field) + (match field + ('zshenv (zsh-file-zshenv config)) + ('zprofile (zsh-file-zprofile config)) + (e (mixed-text-file + (symbol->string field) + (zsh-serialize-field config field))))) + +(define (zsh-get-configuration-files config) + `(("zprofile" ,(zsh-file-by-field config 'zprofile)) ;; Always non-empty + ,@(if (and (zsh-field-not-empty? config 'zshenv) + (zsh-field-not-empty? config 'environment-variables)) + `(("zshenv" ,(zsh-file-by-field config 'zshenv))) '()) + ,@(if (zsh-field-not-empty? config 'zshrc) + `(("zshrc" ,(zsh-file-by-field config 'zshrc))) '()) + ,@(if (zsh-field-not-empty? config 'zlogin) + `(("zlogin" ,(zsh-file-by-field config 'zlogin))) '()) + ,@(if (zsh-field-not-empty? config 'zlogout) + `(("zlogout" ,(zsh-file-by-field config 'zlogout))) '()))) + +(define (zsh-home-files config) + (define zshenv-auxiliary-file + (mixed-text-file + "zshenv-auxiliary" + "export ZDOTDIR=${XDG_CONFIG_HOME:-$HOME/.config}/zsh\n" + "[[ -f $ZDOTDIR/.zshenv ]] && source $ZDOTDIR/.zshenv\n")) + + (if (home-zsh-configuration-xdg-flavor? config) + `(("zshenv" ,zshenv-auxiliary-file)) + (zsh-get-configuration-files config))) + +(define (zsh-xdg-configuration-files config) + (if (home-zsh-configuration-xdg-flavor? config) + (map + (lambda (lst) + (cons (string-append "zsh/." (car lst)) + (cdr lst))) + (zsh-get-configuration-files config)) + '())) (define (add-zsh-packages config) (list (home-zsh-configuration-package config))) @@ -291,7 +298,10 @@ source ~/.profile (extensions (list (service-extension home-files-service-type - add-zsh-configuration) + zsh-home-files) + (service-extension + home-xdg-configuration-files-service-type + zsh-xdg-configuration-files) (service-extension home-profile-service-type add-zsh-packages))) @@ -324,7 +334,7 @@ source ~/.profile (guix-defaults? (boolean #t) "Add sane defaults like reading @file{/etc/bashrc} and coloring the output of -@command{ls} to the end of the @file{.bashrc} file.") +@command{ls} to the top of the @file{.bashrc} file.") (environment-variables (alist '()) "Association list of environment variables to set for the Bash session. The @@ -448,7 +458,7 @@ if [ -f ~/.bashrc ]; then source ~/.bashrc; fi 'bashrc (if (home-bash-configuration-guix-defaults? config) (list (serialize-field 'aliases) guix-bashrc) - (list (serialize-field 'alises)))) + (list (serialize-field 'aliases)))) (file-if-not-empty 'bash-logout))))) (define (add-bash-packages config) diff --git a/gnu/home/services/shepherd.scm b/gnu/home/services/shepherd.scm index 7a9cc064bb..feff130259 100644 --- a/gnu/home/services/shepherd.scm +++ b/gnu/home/services/shepherd.scm @@ -24,12 +24,27 @@ #:use-module (guix sets) #:use-module (guix gexp) #:use-module (guix records) - #:use-module (srfi srfi-1) - #:export (home-shepherd-service-type - home-shepherd-configuration) + + home-shepherd-configuration + home-shepherd-configuration? + home-shepherd-configuration-shepherd + home-shepherd-configuration-auto-start? + home-shepherd-configuration-services) #:re-export (shepherd-service + shepherd-service? + shepherd-service-documentation + shepherd-service-provision + shepherd-service-canonical-name + shepherd-service-requirement + shepherd-service-one-shot? + shepherd-service-respawn? + shepherd-service-start + shepherd-service-stop + shepherd-service-auto-start? + shepherd-service-modules + shepherd-action)) (define-record-type* <home-shepherd-configuration> diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm index 314da3ba3e..3b851229f3 100644 --- a/gnu/home/services/symlink-manager.scm +++ b/gnu/home/services/symlink-manager.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,219 +21,199 @@ (define-module (gnu home services symlink-manager) #:use-module (gnu home services) #:use-module (guix gexp) - + #:use-module (guix modules) #: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. +;;; symlink-manager cares about xdg configurations and other files: it backs +;;; up files created by user, removes symlinks and directories created by a +;;; previous generation, and creates new directories and symlinks to files +;;; according to the content of directories (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) - (guix i18n)) - #$%initialize-gettext - (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 (G_ "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 (G_ " done\n")))) - - (cleanup-symlinks - (lambda () - (let ((to-delete ((file-tree-traverse #f) old-tree))) - (display - (G_ - "Cleaning up symlinks from previous home-environment.\n\n")) - (map - (match-lambda - (('dir . ".") - (display (G_ "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 (G_ "Removing ~a...") - (get-target-path path)) - (rmdir (get-target-path path)) - (display (G_ " done\n"))) - (format - #t - (G_ "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 (G_ "Removing ~a...") (get-target-path path)) - (delete-file (get-target-path path)) - (display (G_ " done\n"))) - (format - #t - (G_ "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 - (G_ "New symlinks to home-environment will be created soon.\n")) - (format - #t (G_ "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 (G_ "Skipping ~a (directory already exists)... done\n") - target-path) - (begin - (format #t (G_ "Creating ~a...") target-path) - (mkdir target-path) - (display (G_ " done\n")))))) - - (('file . path) - (when (file-exists? (get-target-path path)) - (backup-file path)) - (format #t (G_ "Symlinking ~a -> ~a...") - (get-target-path path) (get-source-path path)) - (symlink (get-source-path path) (get-target-path path)) - (display (G_ " 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 (G_" done\nFinished updating symlinks.\n\n")))))) - + (with-imported-modules (source-module-closure + '((guix build utils) + (guix i18n))) + #~(begin + (use-modules (ice-9 ftw) + (ice-9 match) + (srfi srfi-1) + (guix i18n) + (guix build utils)) + + (define home-directory + (getenv "HOME")) + + (define xdg-config-home + (or (getenv "XDG_CONFIG_HOME") + (string-append (getenv "HOME") "/.config"))) + + (define backup-directory + (string-append home-directory "/" (number->string (current-time)) + "-guix-home-legacy-configs-backup")) + + (define (preprocess-file file) + "If file is in XDG-CONFIGURATION-FILES-DIRECTORY use +subdirectory from XDG_CONFIG_HOME to generate a target path." + (if (string-prefix? #$xdg-configuration-files-directory file) + (string-append + (substring xdg-config-home + (1+ (string-length home-directory))) + (substring file + (string-length #$xdg-configuration-files-directory))) + (string-append "." file))) + + (define (target-file file) + ;; Return the target of FILE, a config file name sans leading dot + ;; such as "config/fontconfig/fonts.conf" or "bashrc". + (string-append home-directory "/" (preprocess-file file))) + + (define (symlink-to-store? file) + (catch 'system-error + (lambda () + (store-file-name? (readlink file))) + (lambda args + (if (= EINVAL (system-error-errno args)) + #f + (apply throw args))))) + + (define (backup-file file) + (define backup + (string-append backup-directory "/" (preprocess-file file))) + + (mkdir-p backup-directory) + (format #t (G_ "Backing up ~a...") (target-file file)) + (mkdir-p (dirname backup)) + (rename-file (target-file file) backup) + (display (G_ " done\n"))) + + (define (cleanup-symlinks home-generation) + ;; Delete from $HOME files that originate in HOME-GENERATION, the + ;; store item containing a home generation. + (define config-file-directory + ;; Note: Trailing slash is needed because "files" is a symlink. + (string-append home-generation "/" #$home-files-directory "/")) + + (define (strip file) + (string-drop file + (+ 1 (string-length config-file-directory)))) + + (format #t (G_ "Cleaning up symlinks from previous home at ~a.~%") + home-generation) + (newline) + + (file-system-fold + (const #t) + (lambda (file stat _) ;leaf + (let ((file (target-file (strip file)))) + (when (file-exists? file) + ;; 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? file) + (begin + (format #t (G_ "Removing ~a...") file) + (delete-file file) + (display (G_ " done\n"))) + (format + #t + (G_ "Skipping ~a (not a symlink to store)... done\n") + file))))) + + (const #t) ;down + (lambda (directory stat _) ;up + (unless (string=? directory config-file-directory) + (let ((directory (target-file (strip directory)))) + (catch 'system-error + (lambda () + (rmdir directory) + (format #t (G_ "Removed ~a.\n") directory)) + (lambda args + (let ((errno (system-error-errno args))) + (cond + ((= ENOTEMPTY errno) + (format + #t + (G_ "Skipping ~a (not an empty directory)... done\n") + directory)) + ((= ENOTDIR errno) #t) + (else + (apply throw args))))))))) + (const #t) ;skip + (const #t) ;error + #t ;init + config-file-directory + lstat) + + (display (G_ "Cleanup finished.\n\n"))) + + (define (create-symlinks home-generation) + ;; Create in $HOME symlinks for the files in HOME-GENERATION. + (define config-file-directory + ;; Note: Trailing slash is needed because "files" is a symlink. + (string-append home-generation "/" #$home-files-directory "/")) + + (define (strip file) + (string-drop file + (+ 1 (string-length config-file-directory)))) + + (define (source-file file) + (readlink (string-append config-file-directory file))) + + (file-system-fold + (const #t) ;enter? + (lambda (file stat result) ;leaf + (let ((source (source-file (strip file))) + (target (target-file (strip file)))) + (when (file-exists? target) + (backup-file (strip file))) + (format #t (G_ "Symlinking ~a -> ~a...") + target source) + (symlink source target) + (display (G_ " done\n")))) + (lambda (directory stat result) ;down + (unless (string=? directory config-file-directory) + (let ((target (target-file (strip directory)))) + (when (and (file-exists? target) + (not (file-is-directory? target))) + (backup-file (strip directory))) + + (catch 'system-error + (lambda () + (mkdir target)) + (lambda args + (let ((errno (system-error-errno args))) + (unless (= EEXIST errno) + (format #t (G_ "failed to create directory ~a: ~s~%") + target (strerror errno)) + (apply throw args)))))))) + (const #t) ;up + (const #t) ;skip + (const #t) ;error + #t ;init + config-file-directory)) + + #$%initialize-gettext + + (let* ((home (string-append home-directory "/.guix-home")) + (pivot (string-append home ".new")) + (new-home (getenv "GUIX_NEW_HOME")) + (old-home (getenv "GUIX_OLD_HOME"))) + (when old-home + (cleanup-symlinks old-home)) + + (create-symlinks new-home) + + (symlink new-home pivot) + (rename-file pivot home) + + (display (G_" done\nFinished updating symlinks.\n\n"))))))) (define (update-symlinks-gexp _) #~(primitive-load #$(update-symlinks-script))) diff --git a/gnu/home/services/xdg.scm b/gnu/home/services/xdg.scm index d230dd7665..361a2a6148 100644 --- a/gnu/home/services/xdg.scm +++ b/gnu/home/services/xdg.scm @@ -190,11 +190,11 @@ pre-populated content.") "Default directory for videos.")) (define (home-xdg-user-directories-files-service config) - `(("config/user-dirs.conf" + `(("user-dirs.conf" ,(mixed-text-file "user-dirs.conf" "enabled=False\n")) - ("config/user-dirs.dirs" + ("user-dirs.dirs" ,(mixed-text-file "user-dirs.dirs" (serialize-configuration @@ -218,7 +218,7 @@ pre-populated content.") (service-type (name 'home-xdg-user-directories) (extensions (list (service-extension - home-files-service-type + home-xdg-configuration-files-service-type home-xdg-user-directories-files-service) (service-extension home-activation-service-type @@ -374,7 +374,7 @@ configuration." "=" val "\n"))) (define (serialize-alist config) - (generic-serialize-alist identity format-config config)) + (generic-serialize-alist append format-config config)) (define (serialize-xdg-desktop-action action) (match action @@ -417,7 +417,7 @@ that the application cannot open the specified MIME type.") "A list of XDG desktop entries to create. See @code{xdg-desktop-entry}.")) -(define (home-xdg-mime-applications-files-service config) +(define (home-xdg-mime-applications-files config) (define (add-xdg-desktop-entry-file entry) (let ((file (first entry)) (config (second entry))) @@ -425,16 +425,16 @@ that the application cannot open the specified MIME type.") (apply mixed-text-file (format #f "xdg-desktop-~a-entry" file) config)))) + (map (compose add-xdg-desktop-entry-file serialize-xdg-desktop-entry) + (home-xdg-mime-applications-configuration-desktop-entries config))) - (append - `(("config/mimeapps.list" - ,(mixed-text-file - "xdg-mime-appplications" - (serialize-configuration - config - home-xdg-mime-applications-configuration-fields)))) - (map (compose add-xdg-desktop-entry-file serialize-xdg-desktop-entry) - (home-xdg-mime-applications-configuration-desktop-entries config)))) +(define (home-xdg-mime-applications-xdg-files config) + `(("mimeapps.list" + ,(mixed-text-file + "xdg-mime-appplications" + (serialize-configuration + config + home-xdg-mime-applications-configuration-fields))))) (define (home-xdg-mime-applications-extension old-config extension-configs) (define (extract-fields config) @@ -469,7 +469,10 @@ that the application cannot open the specified MIME type.") (extensions (list (service-extension home-files-service-type - home-xdg-mime-applications-files-service))) + home-xdg-mime-applications-files) + (service-extension + home-xdg-configuration-files-service-type + home-xdg-mime-applications-xdg-files))) (compose identity) (extend home-xdg-mime-applications-extension) (default-value (home-xdg-mime-applications-configuration)) |