summaryrefslogtreecommitdiff
path: root/gnu/home
diff options
context:
space:
mode:
authorOleg Pykhalov <go.wigust@gmail.com>2021-10-05 02:09:41 +0300
committerOleg Pykhalov <go.wigust@gmail.com>2021-10-08 15:36:18 +0300
commitba8ddb348045f81f061a1c7f51c0f7c2b0024e71 (patch)
tree58feeca8579cccff3451a37ff0ef634e16f5b9c4 /gnu/home
parent2e74616446ba6cc554547436e848637e7f61cb32 (diff)
downloadguix-patches-ba8ddb348045f81f061a1c7f51c0f7c2b0024e71.tar
guix-patches-ba8ddb348045f81f061a1c7f51c0f7c2b0024e71.tar.gz
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.
Diffstat (limited to 'gnu/home')
-rw-r--r--gnu/home/services/configuration.scm109
-rw-r--r--gnu/home/services/fontutils.scm65
-rw-r--r--gnu/home/services/mcron.scm115
-rw-r--r--gnu/home/services/shells.scm634
-rw-r--r--gnu/home/services/shepherd.scm134
-rw-r--r--gnu/home/services/symlink-manager.scm247
-rw-r--r--gnu/home/services/utils.scm105
-rw-r--r--gnu/home/services/xdg.scm478
8 files changed, 1887 insertions, 0 deletions
diff --git a/gnu/home/services/configuration.scm b/gnu/home/services/configuration.scm
new file mode 100644
index 0000000000..5e7743e7d6
--- /dev/null
+++ b/gnu/home/services/configuration.scm
@@ -0,0 +1,109 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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 configuration)
+ #:use-module (gnu services configuration)
+ #:use-module (guix gexp)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 curried-definitions)
+ #:use-module (ice-9 match)
+ #:use-module (guix i18n)
+ #:use-module (guix diagnostics)
+
+ #:export (filter-configuration-fields
+
+ interpose
+ list-of
+
+ list-of-strings?
+ alist?
+ string-or-gexp?
+ serialize-string-or-gexp
+ text-config?
+ serialize-text-config
+ generic-serialize-alist-entry
+ generic-serialize-alist))
+
+(define* (filter-configuration-fields configuration-fields fields
+ #:optional negate?)
+ "Retrieve the fields listed in FIELDS from CONFIGURATION-FIELDS.
+If NEGATE? is @code{#t}, retrieve all fields except FIELDS."
+ (filter (lambda (field)
+ (let ((member? (member (configuration-field-name field) fields)))
+ (if (not negate?) member? (not member?))))
+ configuration-fields))
+
+
+(define* (interpose ls #:optional (delimiter "\n") (grammar 'infix))
+ "Same as @code{string-join}, but without join and string, returns an
+DELIMITER interposed LS. Support 'infix and 'suffix GRAMMAR values."
+ (when (not (member grammar '(infix suffix)))
+ (raise
+ (formatted-message
+ (G_ "The GRAMMAR value must be 'infix or 'suffix, but ~a provided.")
+ grammar)))
+ (fold-right (lambda (e acc)
+ (cons e
+ (if (and (null? acc) (eq? grammar 'infix))
+ acc
+ (cons delimiter acc))))
+ '() ls))
+
+(define (list-of pred?)
+ "Return a procedure that takes a list and check if all the elements of
+the list result in @code{#t} when applying PRED? on them."
+ (lambda (x)
+ (if (list? x)
+ (every pred? x)
+ #f)))
+
+
+(define list-of-strings?
+ (list-of string?))
+
+(define alist? list?)
+
+(define (string-or-gexp? sg) (or (string? sg) (gexp? sg)))
+(define (serialize-string-or-gexp field-name val) "")
+
+(define (text-config? config)
+ (and (list? config) (every string-or-gexp? config)))
+(define (serialize-text-config field-name val)
+ #~(string-append #$@(interpose val "\n" 'suffix)))
+
+(define ((generic-serialize-alist-entry serialize-field) entry)
+ "Apply the SERIALIZE-FIELD procedure on the field and value of ENTRY."
+ (match entry
+ ((field . val) (serialize-field field val))))
+
+(define (generic-serialize-alist combine serialize-field fields)
+ "Generate a configuration from an association list FIELDS.
+
+SERIALIZE-FIELD is a procedure that takes two arguments, it will be
+applied on the fields and values of FIELDS using the
+@code{generic-serialize-alist-entry} procedure.
+
+COMBINE is a procedure that takes one or more arguments and combines
+all the alist entries into one value, @code{string-append} or
+@code{append} are usually good candidates for this.
+
+See the @code{serialize-alist} procedure in `@code{(gnu home-services
+version-control}' for an example usage.)}"
+ (apply combine
+ (map (generic-serialize-alist-entry serialize-field) fields)))
diff --git a/gnu/home/services/fontutils.scm b/gnu/home/services/fontutils.scm
new file mode 100644
index 0000000000..72a84fdecd
--- /dev/null
+++ b/gnu/home/services/fontutils.scm
@@ -0,0 +1,65 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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 fontutils)
+ #:use-module (gnu home-services)
+ #:use-module (gnu packages fontutils)
+ #:use-module (guix gexp)
+
+ #:export (home-fontconfig-service-type))
+
+;;; Commentary:
+;;;
+;;; Services related to fonts. home-fontconfig service provides
+;;; fontconfig configuration, which allows fc-* utilities to find
+;;; fonts in Guix Home's profile and regenerates font cache on
+;;; activation.
+;;;
+;;; Code:
+
+(define (add-fontconfig-config-file he-symlink-path)
+ `(("config/fontconfig/fonts.conf"
+ ,(mixed-text-file
+ "fonts.conf"
+ "<?xml version='1.0'?>
+<!DOCTYPE fontconfig SYSTEM 'fonts.dtd'>
+<fontconfig>
+ <dir>~/.guix-home/profile/share/fonts</dir>
+</fontconfig>"))))
+
+(define (regenerate-font-cache-gexp _)
+ `(("profile/share/fonts"
+ ,#~(system* #$(file-append fontconfig "/bin/fc-cache") "-fv"))))
+
+(define home-fontconfig-service-type
+ (service-type (name 'home-fontconfig)
+ (extensions
+ (list (service-extension
+ home-files-service-type
+ add-fontconfig-config-file)
+ (service-extension
+ home-run-on-change-service-type
+ regenerate-font-cache-gexp)
+ (service-extension
+ home-profile-service-type
+ (const (list fontconfig)))))
+ (default-value #f)
+ (description
+ "Provides configuration file for fontconfig and make
+fc-* utilities aware of font packages installed in Guix Home's profile.")))
diff --git a/gnu/home/services/mcron.scm b/gnu/home/services/mcron.scm
new file mode 100644
index 0000000000..cc6faac47f
--- /dev/null
+++ b/gnu/home/services/mcron.scm
@@ -0,0 +1,115 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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 mcron)
+ #:use-module (gnu packages guile-xyz)
+ #:use-module (gnu home-services)
+ #:use-module (gnu services shepherd)
+ #:use-module (gnu home services shepherd)
+ #:use-module (guix records)
+ #:use-module (guix gexp)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
+
+ #:export (home-mcron-configuration
+ home-mcron-service-type))
+
+;;; Commentary:
+;;
+;; Service for the GNU mcron cron job manager.
+;;
+;; Example configuration, the first job runs mbsync once every ten
+;; minutes, the second one writes "Mcron service" to ~/mcron-file once
+;; every minute.
+;;
+;; (service home-mcron-service-type
+;; (home-mcron-configuration
+;; (jobs (list #~(job '(next-minute
+;; (range 0 60 10))
+;; (lambda ()
+;; (system* "mbsync" "--all")))
+;; #~(job next-minute-from
+;; (lambda ()
+;; (call-with-output-file (string-append (getenv "HOME")
+;; "/mcron-file")
+;; (lambda (port)
+;; (display "Mcron service" port)))))))))
+;;
+;;; Code:
+
+(define-record-type* <home-mcron-configuration> home-mcron-configuration
+ make-home-mcron-configuration
+ home-mcron-configuration?
+ (package home-mcron-configuration-package ; package
+ (default mcron))
+ (jobs home-mcron-configuration-jobs ; list of jobs
+ (default '())))
+
+(define job-files (@@ (gnu services mcron) job-files))
+(define shepherd-schedule-action
+ (@@ (gnu services mcron) shepherd-schedule-action))
+
+(define home-mcron-shepherd-services
+ (match-lambda
+ (($ <home-mcron-configuration> mcron '()) ; no jobs to run
+ '())
+ (($ <home-mcron-configuration> mcron jobs)
+ (let ((files (job-files mcron jobs)))
+ (list (shepherd-service
+ (documentation "User cron jobs.")
+ (provision '(mcron))
+ (modules `((srfi srfi-1)
+ (srfi srfi-26)
+ (ice-9 popen) ; for the 'schedule' action
+ (ice-9 rdelim)
+ (ice-9 match)
+ ,@%default-modules))
+ (start #~(make-forkexec-constructor
+ (list #$(file-append mcron "/bin/mcron") #$@files)
+ #:log-file (string-append
+ (or (getenv "XDG_LOG_HOME")
+ (format #f "~a/.local/var/log"
+ (getenv "HOME")))
+ "/mcron.log")))
+ (stop #~(make-kill-destructor))
+ (actions
+ (list (shepherd-schedule-action mcron files)))))))))
+
+(define home-mcron-profile (compose list home-mcron-configuration-package))
+
+(define (home-mcron-extend config jobs)
+ (home-mcron-configuration
+ (inherit config)
+ (jobs (append (home-mcron-configuration-jobs config)
+ jobs))))
+
+(define home-mcron-service-type
+ (service-type (name 'home-mcron)
+ (extensions
+ (list (service-extension
+ home-shepherd-service-type
+ home-mcron-shepherd-services)
+ (service-extension
+ home-profile-service-type
+ home-mcron-profile)))
+ (compose concatenate)
+ (extend home-mcron-extend)
+ (default-value (home-mcron-configuration))
+ (description
+ "Install and configure the GNU mcron cron job manager.")))
diff --git a/gnu/home/services/shells.scm b/gnu/home/services/shells.scm
new file mode 100644
index 0000000000..2308371dd0
--- /dev/null
+++ b/gnu/home/services/shells.scm
@@ -0,0 +1,634 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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 shells)
+ #: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 packages shells)
+ #:use-module (gnu packages bash)
+ #:use-module (guix gexp)
+ #:use-module (guix packages)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+
+ #:export (home-shell-profile-service-type
+ home-shell-profile-configuration
+
+ home-bash-service-type
+ home-bash-configuration
+ home-bash-extension
+
+ home-zsh-service-type
+ home-zsh-configuration
+ home-zsh-extension
+
+ home-fish-service-type
+ home-fish-configuration
+ home-fish-extension))
+
+;;; Commentary:
+;;;
+;;; This module contains shell related services like Zsh.
+;;;
+;;; Code:
+
+
+;;;
+;;; Shell profile.
+;;;
+
+(define path? string?)
+(define (serialize-path field-name val) val)
+
+(define-configuration home-shell-profile-configuration
+ (profile
+ (text-config '())
+ "\
+@code{home-shell-profile} is instantiated automatically by
+@code{home-environment}, DO NOT create this service manually, it can
+only be extended.
+
+@code{profile} is a list of strings or gexps, which will go to
+@file{~/.profile}. By default @file{~/.profile} contains the
+initialization code, which have to be evaluated by login shell to make
+home-environment's profile avaliable to the user, but other commands
+can be added to the file if it is really necessary.
+
+In most cases shell's configuration files are preferred places for
+user's customizations. Extend home-shell-profile service only if you
+really know what you do."))
+
+(define (add-shell-profile-file config)
+ `(("profile"
+ ,(mixed-text-file
+ "shell-profile"
+ "\
+HOME_ENVIRONMENT=$HOME/.guix-home
+. $HOME_ENVIRONMENT/setup-environment
+$HOME_ENVIRONMENT/on-first-login\n"
+ (serialize-configuration
+ config
+ (filter-configuration-fields
+ home-shell-profile-configuration-fields '(profile)))))))
+
+(define (add-profile-extensions config extensions)
+ (home-shell-profile-configuration
+ (inherit config)
+ (profile
+ (append (home-shell-profile-configuration-profile config)
+ extensions))))
+
+(define home-shell-profile-service-type
+ (service-type (name 'home-shell-profile)
+ (extensions
+ (list (service-extension
+ home-files-service-type
+ add-shell-profile-file)))
+ (compose concatenate)
+ (extend add-profile-extensions)
+ (default-value (home-shell-profile-configuration))
+ (description "Create @file{~/.profile}, which is used
+for environment initialization of POSIX compliant login shells. This
+service type can be extended with a list of strings or gexps.")))
+
+(define (serialize-boolean field-name val) "")
+(define (serialize-posix-env-vars field-name val)
+ #~(string-append
+ #$@(map
+ (match-lambda
+ ((key . #f)
+ "")
+ ((key . #t)
+ #~(string-append "export " #$key "\n"))
+ ((key . value)
+ #~(string-append "export " #$key "=" #$value "\n")))
+ val)))
+
+
+;;;
+;;; Zsh.
+;;;
+
+(define-configuration home-zsh-configuration
+ (package
+ (package zsh)
+ "The Zsh package to use.")
+ (xdg-flavor?
+ (boolean #t)
+ "Place all the configs to @file{$XDG_CONFIG_HOME/zsh}. Makes
+@file{~/.zshenv} to set @env{ZDOTDIR} to @file{$XDG_CONFIG_HOME/zsh}.
+Shell startup process will continue with
+@file{$XDG_CONFIG_HOME/zsh/.zshenv}.")
+ (environment-variables
+ (alist '())
+ "Association list of environment variables to set for the Zsh session."
+ serialize-posix-env-vars)
+ (zshenv
+ (text-config '())
+ "List of strings or gexps, which will be added to @file{.zshenv}.
+Used for setting user's shell environment variables. Must not contain
+commands assuming the presence of tty or producing output. Will be
+read always. Will be read before any other file in @env{ZDOTDIR}.")
+ (zprofile
+ (text-config '())
+ "List of strings or gexps, which will be added to @file{.zprofile}.
+Used for executing user's commands at start of login shell (In most
+cases the shell started on tty just after login). Will be read before
+@file{.zlogin}.")
+ (zshrc
+ (text-config '())
+ "List of strings or gexps, which will be added to @file{.zshrc}.
+Used for executing user's commands at start of interactive shell (The
+shell for interactive usage started by typing @code{zsh} or by
+terminal app or any other program).")
+ (zlogin
+ (text-config '())
+ "List of strings or gexps, which will be added to @file{.zlogin}.
+Used for executing user's commands at the end of starting process of
+login shell.")
+ (zlogout
+ (text-config '())
+ "List of strings or gexps, which will be added to @file{.zlogout}.
+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"
+ "\
+# Setups system and user profiles and related variables
+source /etc/profile
+# Setups home environment profile
+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))))))
+
+(define (add-zsh-packages config)
+ (list (home-zsh-configuration-package config)))
+
+(define-configuration/no-serialization home-zsh-extension
+ (environment-variables
+ (alist '())
+ "Association list of environment variables to set.")
+ (zshrc
+ (text-config '())
+ "List of strings or gexps.")
+ (zshenv
+ (text-config '())
+ "List of strings or gexps.")
+ (zprofile
+ (text-config '())
+ "List of strings or gexps.")
+ (zlogin
+ (text-config '())
+ "List of strings or gexps.")
+ (zlogout
+ (text-config '())
+ "List of strings or gexps."))
+
+(define (home-zsh-extensions original-config extension-configs)
+ (home-zsh-configuration
+ (inherit original-config)
+ (environment-variables
+ (append (home-zsh-configuration-environment-variables original-config)
+ (append-map
+ home-zsh-extension-environment-variables extension-configs)))
+ (zshrc
+ (append (home-zsh-configuration-zshrc original-config)
+ (append-map
+ home-zsh-extension-zshrc extension-configs)))
+ (zshenv
+ (append (home-zsh-configuration-zshenv original-config)
+ (append-map
+ home-zsh-extension-zshenv extension-configs)))
+ (zprofile
+ (append (home-zsh-configuration-zprofile original-config)
+ (append-map
+ home-zsh-extension-zprofile extension-configs)))
+ (zlogin
+ (append (home-zsh-configuration-zlogin original-config)
+ (append-map
+ home-zsh-extension-zlogin extension-configs)))
+ (zlogout
+ (append (home-zsh-configuration-zlogout original-config)
+ (append-map
+ home-zsh-extension-zlogout extension-configs)))))
+
+(define home-zsh-service-type
+ (service-type (name 'home-zsh)
+ (extensions
+ (list (service-extension
+ home-files-service-type
+ add-zsh-configuration)
+ (service-extension
+ home-profile-service-type
+ add-zsh-packages)))
+ (compose identity)
+ (extend home-zsh-extensions)
+ (default-value (home-zsh-configuration))
+ (description "Install and configure Zsh.")))
+
+
+;;;
+;;; Bash.
+;;;
+
+(define-configuration home-bash-configuration
+ (package
+ (package bash)
+ "The Bash package to use.")
+ (guix-defaults?
+ (boolean #t)
+ "Add sane defaults like reading @file{/etc/bashrc}, coloring output
+for @code{ls} provided by guix to @file{.bashrc}.")
+ (environment-variables
+ (alist '())
+ "Association list of environment variables to set for the Bash session."
+ serialize-posix-env-vars)
+ (bash-profile
+ (text-config '())
+ "List of strings or gexps, which will be added to @file{.bash_profile}.
+Used for executing user's commands at start of login shell (In most
+cases the shell started on tty just after login). @file{.bash_login}
+won't be ever read, because @file{.bash_profile} always present.")
+ (bashrc
+ (text-config '())
+ "List of strings or gexps, which will be added to @file{.bashrc}.
+Used for executing user's commands at start of interactive shell (The
+shell for interactive usage started by typing @code{bash} or by
+terminal app or any other program).")
+ (bash-logout
+ (text-config '())
+ "List of strings or gexps, which will be added to @file{.bash_logout}.
+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)."))
+
+;; TODO: Use value from (gnu system shadow)
+(define guix-bashrc
+ "\
+# Bash initialization for interactive non-login shells and
+# for remote shells (info \"(bash) Bash Startup Files\").
+
+# Export 'SHELL' to child processes. Programs such as 'screen'
+# honor it and otherwise use /bin/sh.
+export SHELL
+
+if [[ $- != *i* ]]
+then
+ # We are being invoked from a non-interactive shell. If this
+ # is an SSH session (as in \"ssh host command\"), source
+ # /etc/profile so we get PATH and other essential variables.
+ [[ -n \"$SSH_CLIENT\" ]] && source /etc/profile
+
+ # Don't do anything else.
+ return
+fi
+
+# Source the system-wide file.
+source /etc/bashrc
+
+# Adjust the prompt depending on whether we're in 'guix environment'.
+if [ -n \"$GUIX_ENVIRONMENT\" ]
+then
+ PS1='\\u@\\h \\w [env]\\$ '
+else
+ PS1='\\u@\\h \\w\\$ '
+fi
+alias ls='ls -p --color=auto'
+alias ll='ls -l'
+alias grep='grep --color=auto'\n")
+
+(define (add-bash-configuration config)
+ (define (filter-fields field)
+ (filter-configuration-fields home-bash-configuration-fields
+ (list field)))
+
+ (define (serialize-field field)
+ (serialize-configuration
+ config
+ (filter-fields field)))
+
+ (define* (file-if-not-empty field #:optional (extra-content #f))
+ (let ((file-name (symbol->string field))
+ (field-obj (car (filter-fields field))))
+ (if (or extra-content
+ (not (null? ((configuration-field-getter field-obj) config))))
+ `(,(object->snake-case-string file-name)
+ ,(mixed-text-file
+ (object->snake-case-string file-name)
+ (if extra-content extra-content "")
+ (serialize-field field)))
+ '())))
+
+ (filter
+ (compose not null?)
+ `(("bash_profile"
+ ,(mixed-text-file
+ "bash_profile"
+ "\
+# Setups system and user profiles and related variables
+# /etc/profile will be sourced by bash automatically
+# Setups home environment profile
+if [ -f ~/.profile ]; then source ~/.profile; fi
+
+# Honor per-interactive-shell startup file
+if [ -f ~/.bashrc ]; then source ~/.bashrc; fi
+"
+ (serialize-field 'bash-profile)
+ (serialize-field 'environment-variables)))
+
+ ,@(list (file-if-not-empty
+ 'bashrc
+ (if (home-bash-configuration-guix-defaults? config)
+ guix-bashrc
+ #f))
+ (file-if-not-empty 'bash-logout)))))
+
+(define (add-bash-packages config)
+ (list (home-bash-configuration-package config)))
+
+(define-configuration/no-serialization home-bash-extension
+ (environment-variables
+ (alist '())
+ "Association list of environment variables to set.")
+ (bash-profile
+ (text-config '())
+ "List of strings or gexps.")
+ (bashrc
+ (text-config '())
+ "List of strings or gexps.")
+ (bash-logout
+ (text-config '())
+ "List of strings or gexps."))
+
+(define (home-bash-extensions original-config extension-configs)
+ (home-bash-configuration
+ (inherit original-config)
+ (environment-variables
+ (append (home-bash-configuration-environment-variables original-config)
+ (append-map
+ home-bash-extension-environment-variables extension-configs)))
+ (bash-profile
+ (append (home-bash-configuration-bash-profile original-config)
+ (append-map
+ home-bash-extension-bash-profile extension-configs)))
+ (bashrc
+ (append (home-bash-configuration-bashrc original-config)
+ (append-map
+ home-bash-extension-bashrc extension-configs)))
+ (bash-logout
+ (append (home-bash-configuration-bash-logout original-config)
+ (append-map
+ home-bash-extension-bash-logout extension-configs)))))
+
+(define home-bash-service-type
+ (service-type (name 'home-bash)
+ (extensions
+ (list (service-extension
+ home-files-service-type
+ add-bash-configuration)
+ (service-extension
+ home-profile-service-type
+ add-bash-packages)))
+ (compose identity)
+ (extend home-bash-extensions)
+ (default-value (home-bash-configuration))
+ (description "Install and configure GNU Bash.")))
+
+
+;;;
+;;; Fish.
+;;;
+
+(define (serialize-fish-aliases field-name val)
+ #~(string-append
+ #$@(map (match-lambda
+ ((key . value)
+ #~(string-append "alias " #$key " \"" #$value "\"\n"))
+ (_ ""))
+ val)))
+
+(define (serialize-fish-abbreviations field-name val)
+ #~(string-append
+ #$@(map (match-lambda
+ ((key . value)
+ #~(string-append "abbr --add " #$key " " #$value "\n"))
+ (_ ""))
+ val)))
+
+(define (serialize-fish-env-vars field-name val)
+ #~(string-append
+ #$@(map (match-lambda
+ ((key . #f)
+ "")
+ ((key . #t)
+ #~(string-append "set " #$key "\n"))
+ ((key . value)
+ #~(string-append "set " #$key " " #$value "\n")))
+ val)))
+
+(define-configuration home-fish-configuration
+ (package
+ (package fish)
+ "The Fish package to use.")
+ (config
+ (text-config '())
+ "List of strings or gexps, which will be added to
+@file{$XDG_CONFIG_HOME/fish/config.fish}.")
+ (environment-variables
+ (alist '())
+ "Association list of environment variables to set in Fish."
+ serialize-fish-env-vars)
+ (aliases
+ (alist '())
+ "Association list of aliases for Fish, both the key and the value
+should be a string. An alias is just a simple function that wraps a
+command, If you want something more akin to @dfn{aliases} in POSIX
+shells, see the @code{abbreviations} field."
+ serialize-fish-aliases)
+ (abbreviations
+ (alist '())
+ "Association list of abbreviations for Fish. These are words that,
+when typed in the shell, will automatically expand to the full text."
+ serialize-fish-abbreviations))
+
+(define (fish-files-service config)
+ `(("config/fish/config.fish"
+ ,(mixed-text-file
+ "fish-config.fish"
+ #~(string-append "\
+# if we haven't sourced the login config, do it
+status --is-login; and not set -q __fish_login_config_sourced
+and begin
+
+ set --prepend fish_function_path "
+ #$fish-foreign-env
+ "/share/fish/functions
+ fenv source $HOME/.profile
+ set -e fish_function_path[1]
+
+ set -g __fish_login_config_sourced 1
+
+end\n\n")
+ (serialize-configuration
+ config
+ home-fish-configuration-fields)))))
+
+(define (fish-profile-service config)
+ (list (home-fish-configuration-package config)))
+
+(define-configuration/no-serialization home-fish-extension
+ (config
+ (text-config '())
+ "List of strings or gexps for extending the Fish initialization file.")
+ (environment-variables
+ (alist '())
+ "Association list of environment variables to set.")
+ (aliases
+ (alist '())
+ "Association list of Fish aliases.")
+ (abbreviations
+ (alist '())
+ "Association list of Fish abbreviations."))
+
+(define (home-fish-extensions original-config extension-configs)
+ (home-fish-configuration
+ (inherit original-config)
+ (config
+ (append (home-fish-configuration-config original-config)
+ (append-map
+ home-fish-extension-config extension-configs)))
+ (environment-variables
+ (append (home-fish-configuration-environment-variables original-config)
+ (append-map
+ home-fish-extension-environment-variables extension-configs)))
+ (aliases
+ (append (home-fish-configuration-aliases original-config)
+ (append-map
+ home-fish-extension-aliases extension-configs)))
+ (abbreviations
+ (append (home-fish-configuration-abbreviations original-config)
+ (append-map
+ home-fish-extension-abbreviations extension-configs)))))
+
+;; TODO: Support for generating completion files
+;; TODO: Support for installing plugins
+(define home-fish-service-type
+ (service-type (name 'home-fish)
+ (extensions
+ (list (service-extension
+ home-files-service-type
+ fish-files-service)
+ (service-extension
+ home-profile-service-type
+ fish-profile-service)))
+ (compose identity)
+ (extend home-fish-extensions)
+ (default-value (home-fish-configuration))
+ (description "\
+Install and configure Fish, the friendly interactive shell.")))
+
+
+(define (generate-home-shell-profile-documentation)
+ (generate-documentation
+ `((home-shell-profile-configuration
+ ,home-shell-profile-configuration-fields))
+ 'home-shell-profile-configuration))
+
+(define (generate-home-bash-documentation)
+ (generate-documentation
+ `((home-bash-configuration
+ ,home-bash-configuration-fields))
+ 'home-bash-configuration))
+
+(define (generate-home-zsh-documentation)
+ (generate-documentation
+ `((home-zsh-configuration
+ ,home-zsh-configuration-fields))
+ 'home-zsh-configuration))
+
+(define (generate-home-fish-documentation)
+ (string-append
+ (generate-documentation
+ `((home-fish-configuration
+ ,home-fish-configuration-fields))
+ 'home-fish-configuration)
+ "\n\n"
+ (generate-documentation
+ `((home-fish-extension
+ ,home-fish-extension-fields))
+ 'home-fish-extension)))
diff --git a/gnu/home/services/shepherd.scm b/gnu/home/services/shepherd.scm
new file mode 100644
index 0000000000..1a3e849bb2
--- /dev/null
+++ b/gnu/home/services/shepherd.scm
@@ -0,0 +1,134 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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 shepherd)
+ #:use-module (gnu home-services)
+ #:use-module (gnu packages admin)
+ #:use-module (gnu services shepherd)
+ #: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)
+ #:re-export (shepherd-service
+ shepherd-action))
+
+(define-record-type* <home-shepherd-configuration>
+ home-shepherd-configuration make-home-shepherd-configuration
+ home-shepherd-configuration?
+ (shepherd home-shepherd-configuration-shepherd
+ (default shepherd)) ; package
+ (auto-start? home-shepherd-configuration-auto-start?
+ (default #t))
+ (services home-shepherd-configuration-services
+ (default '())))
+
+(define (home-shepherd-configuration-file services shepherd)
+ "Return the shepherd configuration file for SERVICES. SHEPHERD is used
+as shepherd package."
+ (assert-valid-graph services)
+
+ (let ((files (map shepherd-service-file services))
+ ;; TODO: Add compilation of services, it can improve start
+ ;; time.
+ ;; (scm->go (cute scm->go <> shepherd))
+ )
+ (define config
+ #~(begin
+ (use-modules (srfi srfi-34)
+ (system repl error-handling))
+ (apply
+ register-services
+ (map
+ (lambda (file) (load file))
+ '#$files))
+ (action 'root 'daemonize)
+ (format #t "Starting services...~%")
+ (for-each
+ (lambda (service) (start service))
+ '#$(append-map shepherd-service-provision
+ (filter shepherd-service-auto-start?
+ services)))
+ (newline)))
+
+ (scheme-file "shepherd.conf" config)))
+
+(define (launch-shepherd-gexp config)
+ (let* ((shepherd (home-shepherd-configuration-shepherd config))
+ (services (home-shepherd-configuration-services config)))
+ (if (home-shepherd-configuration-auto-start? config)
+ (with-imported-modules '((guix build utils))
+ #~(let ((log-dir (or (getenv "XDG_LOG_HOME")
+ (format #f "~a/.local/var/log" (getenv "HOME")))))
+ ((@ (guix build utils) mkdir-p) log-dir)
+ (system*
+ #$(file-append shepherd "/bin/shepherd")
+ "--logfile"
+ (string-append
+ log-dir
+ "/shepherd.log")
+ "--config"
+ #$(home-shepherd-configuration-file services shepherd))))
+ #~"")))
+
+(define (reload-configuration-gexp config)
+ (let* ((shepherd (home-shepherd-configuration-shepherd config))
+ (services (home-shepherd-configuration-services config)))
+ #~(system*
+ #$(file-append shepherd "/bin/herd")
+ "load" "root"
+ #$(home-shepherd-configuration-file services shepherd))))
+
+(define (ensure-shepherd-gexp config)
+ #~(if (file-exists?
+ (string-append
+ (or (getenv "XDG_RUNTIME_DIR")
+ (format #f "/run/user/~a" (getuid)))
+ "/shepherd/socket"))
+ #$(reload-configuration-gexp config)
+ #$(launch-shepherd-gexp config)))
+
+(define-public home-shepherd-service-type
+ (service-type (name 'home-shepherd)
+ (extensions
+ (list (service-extension
+ home-run-on-first-login-service-type
+ launch-shepherd-gexp)
+ (service-extension
+ home-activation-service-type
+ ensure-shepherd-gexp)
+ (service-extension
+ home-profile-service-type
+ (lambda (config)
+ `(,(home-shepherd-configuration-shepherd config))))))
+ (compose concatenate)
+ (extend
+ (lambda (config extra-services)
+ (home-shepherd-configuration
+ (inherit config)
+ (services
+ (append (home-shepherd-configuration-services config)
+ extra-services)))))
+ (default-value (home-shepherd-configuration))
+ (description "Configure and install userland Shepherd.")))
+
+
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 <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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 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.")))
diff --git a/gnu/home/services/utils.scm b/gnu/home/services/utils.scm
new file mode 100644
index 0000000000..cea75ee896
--- /dev/null
+++ b/gnu/home/services/utils.scm
@@ -0,0 +1,105 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;;
+;;; 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 utils)
+ #:use-module (ice-9 string-fun)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+
+ #:export (maybe-object->string
+ object->snake-case-string
+ object->camel-case-string
+ list->human-readable-list))
+
+(define (maybe-object->string object)
+ "Like @code{object->string} but don't do anyting if OBJECT already is
+a string."
+ (if (string? object)
+ object
+ (object->string object)))
+
+;; Snake case: <https://en.wikipedia.org/wiki/Snake_case>
+(define* (object->snake-case-string object #:optional (style 'lower))
+ "Convert the object OBJECT to the equivalent string in ``snake
+case''. STYLE can be three `@code{lower}', `@code{upper}', or
+`@code{capitalize}', defaults to `@code{lower}'.
+
+@example
+(object->snake-case-string 'variable-name 'upper)
+@result{} \"VARIABLE_NAME\" @end example"
+ (if (not (member style '(lower upper capitalize)))
+ (error 'invalid-style (format #f "~a is not a valid style" style))
+ (let ((stringified (maybe-object->string object)))
+ (string-replace-substring
+ (cond
+ ((equal? style 'lower) stringified)
+ ((equal? style 'upper) (string-upcase stringified))
+ (else (string-capitalize stringified)))
+ "-" "_"))))
+
+(define* (object->camel-case-string object #:optional (style 'lower))
+ "Convert the object OBJECT to the equivalent string in ``camel case''.
+STYLE can be three `@code{lower}', `@code{upper}', defaults to
+`@code{lower}'.
+
+@example
+(object->camel-case-string 'variable-name 'upper)
+@result{} \"VariableName\"
+@end example"
+ (if (not (member style '(lower upper)))
+ (error 'invalid-style (format #f "~a is not a valid style" style))
+ (let ((stringified (maybe-object->string object)))
+ (cond
+ ((eq? style 'upper)
+ (string-concatenate
+ (map string-capitalize
+ (string-split stringified (cut eqv? <> #\-)))))
+ ((eq? style 'lower)
+ (let ((splitted-string (string-split stringified (cut eqv? <> #\-))))
+ (string-concatenate
+ (cons (first splitted-string)
+ (map string-capitalize
+ (cdr splitted-string))))))))))
+
+(define* (list->human-readable-list lst
+ #:key
+ (cumulative? #f)
+ (proc identity))
+ "Turn a list LST into a sequence of terms readable by humans.
+If CUMULATIVE? is @code{#t}, use ``and'', otherwise use ``or'' before
+the last term.
+
+PROC is a procedure to apply to each of the elements of a list before
+turning them into a single human readable string.
+
+@example
+(list->human-readable-list '(1 4 9) #:cumulative? #t #:proc sqrt)
+@result{} \"1, 2, and 3\"
+@end example
+
+yields:"
+ (let* ((word (if cumulative? "and " "or "))
+ (init (append (drop-right lst 1))))
+ (format #f "~a" (string-append
+ (string-join
+ (map (compose maybe-object->string proc) init)
+ ", " 'suffix)
+ word
+ (maybe-object->string (proc (last lst)))))))
+
diff --git a/gnu/home/services/xdg.scm b/gnu/home/services/xdg.scm
new file mode 100644
index 0000000000..4aed9a5803
--- /dev/null
+++ b/gnu/home/services/xdg.scm
@@ -0,0 +1,478 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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 xdg)
+ #:use-module (gnu services configuration)
+ #:use-module (gnu home services configuration)
+ #:use-module (gnu home-services)
+ #:use-module (gnu packages freedesktop)
+ #:use-module (gnu home services utils)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (guix i18n)
+ #:use-module (guix diagnostics)
+
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (rnrs enums)
+
+ #:export (home-xdg-base-directories-service-type
+ home-xdg-base-directories-configuration
+ home-xdg-base-directories-configuration?
+
+ home-xdg-user-directories-service-type
+ home-xdg-user-directories-configuration
+ home-xdg-user-directories-configuration?
+
+ xdg-desktop-action
+ xdg-desktop-entry
+ home-xdg-mime-applications-service-type
+ home-xdg-mime-applications-configuration))
+
+;;; Commentary:
+;;
+;; This module contains services related to XDG directories and
+;; applications.
+;;
+;; - XDG base directories
+;; - XDG user directories
+;; - XDG MIME applications
+;;
+;;; Code:
+
+
+;;;
+;;; XDG base directories.
+;;;
+
+(define (serialize-path field-name val) "")
+(define path? string?)
+
+(define-configuration home-xdg-base-directories-configuration
+ (cache-home
+ (path "$HOME/.cache")
+ "Base directory for programs to store user-specific non-essential
+(cached) data. Files in this directory can be deleted anytime without
+loss of important data.")
+ (config-home
+ (path "$HOME/.config")
+ "Base directory for programs to store configuration files.
+Some programs store here log or state files, but it's not desired,
+this directory should contain static configurations.")
+ (data-home
+ (path "$HOME/.local/share")
+ "Base directory for programs to store architecture independent
+read-only shared data, analogus to @file{/usr/share}, but for user.")
+ (runtime-dir
+ (path "${XDG_RUNTIME_DIR:-/run/user/$UID}")
+ "Base directory for programs to store user-specific runtime files,
+like sockets.")
+ (log-home
+ (path "$HOME/.local/var/log")
+ "Base directory for programs to store log files, analogus to
+@file{/var/log}, but for user. It is not a part of XDG Base Directory
+Specification, but helps to make implementation of home services more
+consistent.")
+ (state-home
+ (path "$HOME/.local/var/lib")
+ "Base directory for programs to store state files, like databases,
+analogus to @file{/var/lib}, but for user. It is not a part of XDG
+Base Directory Specification, but helps to make implementation of home
+services more consistent."))
+
+(define (home-xdg-base-directories-environment-variables-service config)
+ (map
+ (lambda (field)
+ (cons (format
+ #f "XDG_~a"
+ (object->snake-case-string (configuration-field-name field) 'upper))
+ ((configuration-field-getter field) config)))
+ home-xdg-base-directories-configuration-fields))
+
+(define (ensure-xdg-base-dirs-on-activation config)
+ #~(map (lambda (xdg-base-dir-variable)
+ ((@@ (guix build utils) mkdir-p)
+ (getenv
+ xdg-base-dir-variable)))
+ '#$(map (lambda (field)
+ (format
+ #f "XDG_~a"
+ (object->snake-case-string
+ (configuration-field-name field) 'upper)))
+ home-xdg-base-directories-configuration-fields)))
+
+(define (last-extension-or-cfg config extensions)
+ "Picks configuration value from last provided extension. If there
+are no extensions use configuration instead."
+ (or (and (not (null? extensions)) (last extensions)) config))
+
+(define home-xdg-base-directories-service-type
+ (service-type (name 'home-xdg-base-directories)
+ (extensions
+ (list (service-extension
+ home-environment-variables-service-type
+ home-xdg-base-directories-environment-variables-service)
+ (service-extension
+ home-activation-service-type
+ ensure-xdg-base-dirs-on-activation)))
+ (default-value (home-xdg-base-directories-configuration))
+ (compose identity)
+ (extend last-extension-or-cfg)
+ (description "Configure XDG base directories. This
+service introduces two additional variables @env{XDG_STATE_HOME},
+@env{XDG_LOG_HOME}. They are not a part of XDG specification, at
+least yet, but are convinient to have, it improves the consistency
+between different home services. The services of this service-type is
+instantiated by default, to provide non-default value, extend the
+service-type (using @code{simple-service} for example).")))
+
+(define (generate-home-xdg-base-directories-documentation)
+ (generate-documentation
+ `((home-xdg-base-directories-configuration
+ ,home-xdg-base-directories-configuration-fields))
+ 'home-xdg-base-directories-configuration))
+
+
+;;;
+;;; XDG user directories.
+;;;
+
+(define (serialize-string field-name val)
+ ;; The path has to be quoted
+ (format #f "XDG_~a_DIR=\"~a\"\n"
+ (object->snake-case-string field-name 'upper) val))
+
+(define-configuration home-xdg-user-directories-configuration
+ (desktop
+ (string "$HOME/Desktop")
+ "Default ``desktop'' directory, this is what you see on your
+desktop when using a desktop environment,
+e.g. GNOME (@pxref{XWindow,,,guix.info}).")
+ (documents
+ (string "$HOME/Documents")
+ "Default directory to put documents like PDFs.")
+ (download
+ (string "$HOME/Downloads")
+ "Default directory downloaded files, this is where your Web-broser
+will put downloaded files in.")
+ (music
+ (string "$HOME/Music")
+ "Default directory for audio files.")
+ (pictures
+ (string "$HOME/Pictures")
+ "Default directory for pictures and images.")
+ (publicshare
+ (string "$HOME/Public")
+ "Default directory for shared files, which can be accessed by other
+users on local machine or via network.")
+ (templates
+ (string "$HOME/Templates")
+ "Default directory for templates. They can be used by graphical
+file manager or other apps for creating new files with some
+pre-populated content.")
+ (videos
+ (string "$HOME/Videos")
+ "Default directory for videos."))
+
+(define (home-xdg-user-directories-files-service config)
+ `(("config/user-dirs.conf"
+ ,(mixed-text-file
+ "user-dirs.conf"
+ "enabled=False\n"))
+ ("config/user-dirs.dirs"
+ ,(mixed-text-file
+ "user-dirs.dirs"
+ (serialize-configuration
+ config
+ home-xdg-user-directories-configuration-fields)))))
+
+(define (home-xdg-user-directories-activation-service config)
+ (let ((dirs (map (lambda (field)
+ ((configuration-field-getter field) config))
+ home-xdg-user-directories-configuration-fields)))
+ #~(let ((ensure-dir
+ (lambda (path)
+ (mkdir-p
+ ((@@ (ice-9 string-fun) string-replace-substring)
+ path "$HOME" (getenv "HOME"))))))
+ (display "Creating XDG user directories...")
+ (map ensure-dir '#$dirs)
+ (display " done\n"))))
+
+(define home-xdg-user-directories-service-type
+ (service-type (name 'home-xdg-user-directories)
+ (extensions
+ (list (service-extension
+ home-files-service-type
+ home-xdg-user-directories-files-service)
+ (service-extension
+ home-activation-service-type
+ home-xdg-user-directories-activation-service)))
+ (default-value (home-xdg-user-directories-configuration))
+ (description "Configure XDG user directories. To
+disable a directory, point it to the $HOME.")))
+
+(define (generate-home-xdg-user-directories-documentation)
+ (generate-documentation
+ `((home-xdg-user-directories-configuration
+ ,home-xdg-user-directories-configuration-fields))
+ 'home-xdg-user-directories-configuration))
+
+
+;;;
+;;; XDG MIME applications.
+;;;
+
+;; Example config
+;;
+;; (home-xdg-mime-applications-configuration
+;; (added '((x-scheme-handler/magnet . torrent.desktop)))
+;; (default '((inode/directory . file.desktop)))
+;; (removed '((inode/directory . thunar.desktop)))
+;; (desktop-entries
+;; (list (xdg-desktop-entry
+;; (file "file")
+;; (name "File manager")
+;; (type 'application)
+;; (config
+;; '((exec . "emacsclient -c -a emacs %u"))))
+;; (xdg-desktop-entry
+;; (file "text")
+;; (name "Text editor")
+;; (type 'application)
+;; (config
+;; '((exec . "emacsclient -c -a emacs %u")))
+;; (actions
+;; (list (xdg-desktop-action
+;; (action 'create)
+;; (name "Create an action")
+;; (config
+;; '((exec . "echo hi"))))))))))
+
+;; See
+;; <https://specifications.freedesktop.org/shared-mime-info-spec/shared-mime-info-spec-latest.html>
+;; <https://specifications.freedesktop.org/mime-apps-spec/mime-apps-spec-latest.html>
+
+(define (serialize-alist field-name val)
+ (define (serialize-mimelist-entry key val)
+ (let ((val (cond
+ ((list? val)
+ (string-join (map maybe-object->string val) ";"))
+ ((or (string? val) (symbol? val))
+ val)
+ (else (raise (formatted-message
+ (G_ "\
+The value of an XDG MIME entry must be a list, string or symbol, was given ~a")
+ val))))))
+ (format #f "~a=~a\n" key val)))
+
+ (define (merge-duplicates alist acc)
+ "Merge values that have the same key.
+
+@example
+(merge-duplicates '((key1 . value1)
+ (key2 . value2)
+ (key1 . value3)
+ (key1 . value4)) '())
+
+@result{} ((key1 . (value4 value3 value1)) (key2 . value2))
+@end example"
+ (cond
+ ((null? alist) acc)
+ (else (let* ((head (first alist))
+ (tail (cdr alist))
+ (key (first head))
+ (value (cdr head))
+ (duplicate? (assoc key acc))
+ (ensure-list (lambda (x)
+ (if (list? x) x (list x)))))
+ (if duplicate?
+ ;; XXX: This will change the order of things,
+ ;; though, it shouldn't be a problem for XDG MIME.
+ (merge-duplicates
+ tail
+ (alist-cons key
+ (cons value (ensure-list (cdr duplicate?)))
+ (alist-delete key acc)))
+ (merge-duplicates tail (cons head acc)))))))
+
+ (string-append (if (equal? field-name 'default)
+ "\n[Default Applications]\n"
+ (format #f "\n[~a Associations]\n"
+ (string-capitalize (symbol->string field-name))))
+ (generic-serialize-alist string-append
+ serialize-mimelist-entry
+ (merge-duplicates val '()))))
+
+(define xdg-desktop-types (make-enumeration
+ '(application
+ link
+ directory)))
+
+(define (xdg-desktop-type? type)
+ (unless (enum-set-member? type xdg-desktop-types)
+ (raise (formatted-message
+ (G_ "XDG desktop type must be of of ~a, was given: ~a")
+ (list->human-readable-list (enum-set->list xdg-desktop-types))
+ type))))
+
+;; TODO: Add proper docs for this
+;; XXX: 'define-configuration' require that fields have a default
+;; value.
+(define-record-type* <xdg-desktop-action>
+ xdg-desktop-action make-xdg-desktop-action
+ xdg-desktop-action?
+ (action xdg-desktop-action-action) ; symbol
+ (name xdg-desktop-action-name) ; string
+ (config xdg-desktop-action-config ; alist
+ (default '())))
+
+(define-record-type* <xdg-desktop-entry>
+ xdg-desktop-entry make-xdg-desktop-entry
+ xdg-desktop-entry?
+ ;; ".desktop" will automatically be added
+ (file xdg-desktop-entry-file) ; string
+ (name xdg-desktop-entry-name) ; string
+ (type xdg-desktop-entry-type) ; xdg-desktop-type
+ (config xdg-desktop-entry-config ; alist
+ (default '()))
+ (actions xdg-desktop-entry-actions ; list of <xdg-desktop-action>
+ (default '())))
+
+(define desktop-entries? (list-of xdg-desktop-entry?))
+(define (serialize-desktop-entries field-name val) "")
+
+(define (serialize-xdg-desktop-entry entry)
+ "Return a tuple of the file name for ENTRY and the serialized
+configuration."
+ (define (format-config key val)
+ (let ((val (cond
+ ((list? val)
+ (string-join (map maybe-object->string val) ";"))
+ ((boolean? val)
+ (if val "true" "false"))
+ (else val)))
+ (key (string-capitalize (maybe-object->string key))))
+ (list (if (string-suffix? key "?")
+ (string-drop-right key (- (string-length key) 1))
+ key)
+ "=" val "\n")))
+
+ (define (serialize-alist config)
+ (generic-serialize-alist identity format-config config))
+
+ (define (serialize-xdg-desktop-action action)
+ (match action
+ (($ <xdg-desktop-action> action name config)
+ `(,(format #f "[Desktop Action ~a]\n"
+ (string-capitalize (maybe-object->string action)))
+ ,(format #f "Name=~a\n" name)
+ ,@(serialize-alist config)))))
+
+ (match entry
+ (($ <xdg-desktop-entry> file name type config actions)
+ (list (if (string-suffix? file ".desktop")
+ file
+ (string-append file ".desktop"))
+ `("[Desktop Entry]\n"
+ ,(format #f "Name=~a\n" name)
+ ,(format #f "Type=~a\n"
+ (string-capitalize (symbol->string type)))
+ ,@(serialize-alist config)
+ ,@(append-map serialize-xdg-desktop-action actions))))))
+
+(define-configuration home-xdg-mime-applications-configuration
+ (added
+ (alist '())
+ "An association list of MIME types and desktop entries which indicate
+that the application should used to open the specified MIME type. The
+value has to be string, symbol, or list of strings or symbols, this
+applies to the `@code{default}', and `@code{removed}' fields as well.")
+ (default
+ (alist '())
+ "An association list of MIME types and desktop entries which indicate
+that the application should be the default for opening the specified
+MIME type.")
+ (removed
+ (alist '())
+ "An association list of MIME types and desktop entries which indicate
+that the application cannot open the specified MIME type.")
+ (desktop-entries
+ (desktop-entries '())
+ "A list of XDG desktop entries to create. See
+@code{xdg-desktop-entry}."))
+
+(define (home-xdg-mime-applications-files-service config)
+ (define (add-xdg-desktop-entry-file entry)
+ (let ((file (first entry))
+ (config (second entry)))
+ (list (format #f "local/share/applications/~a" file)
+ (apply mixed-text-file
+ (format #f "xdg-desktop-~a-entry" file)
+ 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-extension old-config extension-configs)
+ (define (extract-fields config)
+ ;; return '(added default removed desktop-entries)
+ (list (home-xdg-mime-applications-configuration-added config)
+ (home-xdg-mime-applications-configuration-default config)
+ (home-xdg-mime-applications-configuration-removed config)
+ (home-xdg-mime-applications-configuration-desktop-entries config)))
+
+ (define (append-configs elem acc)
+ (list (append (first elem) (first acc))
+ (append (second elem) (second acc))
+ (append (third elem) (third acc))
+ (append (fourth elem) (fourth acc))))
+
+ ;; TODO: Implement procedure to check for duplicates without
+ ;; sacrificing performance.
+ ;;
+ ;; Combine all the alists from 'added', 'default' and 'removed'
+ ;; into one big alist.
+ (let ((folded-configs (fold append-configs
+ (extract-fields old-config)
+ (map extract-fields extension-configs))))
+ (home-xdg-mime-applications-configuration
+ (added (first folded-configs))
+ (default (second folded-configs))
+ (removed (third folded-configs))
+ (desktop-entries (fourth folded-configs)))))
+
+(define home-xdg-mime-applications-service-type
+ (service-type (name 'home-xdg-mime-applications)
+ (extensions
+ (list (service-extension
+ home-files-service-type
+ home-xdg-mime-applications-files-service)))
+ (compose identity)
+ (extend home-xdg-mime-applications-extension)
+ (default-value (home-xdg-mime-applications-configuration))
+ (description
+ "Configure XDG MIME applications, and XDG desktop entries.")))