diff options
Diffstat (limited to 'gnu/home-services')
-rw-r--r-- | gnu/home-services/configuration.scm | 109 | ||||
-rw-r--r-- | gnu/home-services/fontutils.scm | 65 | ||||
-rw-r--r-- | gnu/home-services/mcron.scm | 115 | ||||
-rw-r--r-- | gnu/home-services/shells.scm | 634 | ||||
-rw-r--r-- | gnu/home-services/shepherd.scm | 134 | ||||
-rw-r--r-- | gnu/home-services/symlink-manager.scm | 247 | ||||
-rw-r--r-- | gnu/home-services/utils.scm | 105 | ||||
-rw-r--r-- | gnu/home-services/xdg.scm | 478 |
8 files changed, 0 insertions, 1887 deletions
diff --git a/gnu/home-services/configuration.scm b/gnu/home-services/configuration.scm deleted file mode 100644 index e8f4bc77ec..0000000000 --- a/gnu/home-services/configuration.scm +++ /dev/null @@ -1,109 +0,0 @@ -;;; 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 deleted file mode 100644 index 28bfc3d3f7..0000000000 --- a/gnu/home-services/fontutils.scm +++ /dev/null @@ -1,65 +0,0 @@ -;;; 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 deleted file mode 100644 index fdfde179a5..0000000000 --- a/gnu/home-services/mcron.scm +++ /dev/null @@ -1,115 +0,0 @@ -;;; 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 home-services shepherd) - #:use-module (gnu 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 deleted file mode 100644 index ecb02098f7..0000000000 --- a/gnu/home-services/shells.scm +++ /dev/null @@ -1,634 +0,0 @@ -;;; 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 deleted file mode 100644 index 120cfde1a1..0000000000 --- a/gnu/home-services/shepherd.scm +++ /dev/null @@ -1,134 +0,0 @@ -;;; 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 deleted file mode 100644 index 11f5d503d4..0000000000 --- a/gnu/home-services/symlink-manager.scm +++ /dev/null @@ -1,247 +0,0 @@ -;;; 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 deleted file mode 100644 index f13133a7ae..0000000000 --- a/gnu/home-services/utils.scm +++ /dev/null @@ -1,105 +0,0 @@ -;;; 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 deleted file mode 100644 index 94275f3b65..0000000000 --- a/gnu/home-services/xdg.scm +++ /dev/null @@ -1,478 +0,0 @@ -;;; 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."))) |