From aaffa43c1752e062934580f55616e0380963a1be Mon Sep 17 00:00:00 2001 From: Andrew Tropin Date: Wed, 1 Sep 2021 11:47:04 +0300 Subject: doc: Add Guix Home documentation. * doc/guix.texi: Add Guix Home documentation. * doc/he-config-bare-bones.scm: New file. Signed-off-by: Oleg Pykhalov --- doc/guix.texi | 665 +++++++++++++++++++++++++++++++++++++++++++ doc/he-config-bare-bones.scm | 24 ++ 2 files changed, 689 insertions(+) create mode 100644 doc/he-config-bare-bones.scm (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 220499503d..637ec2799b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -96,6 +96,7 @@ Copyright @copyright{} 2021 Domagoj Stolfa@* Copyright @copyright{} 2021 Hui Lu@* Copyright @copyright{} 2021 pukkamustard@* Copyright @copyright{} 2021 Alice Brenon@* +Copyright @copyright{} 2021 Andrew Tropin@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -167,6 +168,7 @@ Weblate} (@pxref{Translating Guix}). * Programming Interface:: Using Guix in Scheme. * Utilities:: Package management commands. * System Configuration:: Configuring the operating system. +* Home Configuration:: Configuring the home environment. * Documentation:: Browsing software user manuals. * Installing Debugging Files:: Feeding the debugger. * Security Updates:: Deploying security fixes quickly. @@ -328,6 +330,10 @@ System Configuration * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. +Home Environment Configuration + +* Invoking guix home:: Instantiating a home environment configuration. + Services * Base Services:: Essential system services. @@ -35241,6 +35247,665 @@ system: This service represents PID@tie{}1. @end defvr +@node Home Configuration +@chapter Home Configuration +@cindex home configuration +Guix supports declarative configuration of @dfn{home environments} by +utilizing the configuration mechanism described in the previous chapter +(@pxref{Defining Services}), but for user's dotfiles and packages. It +works both on Guix System and foreign distros and allows users to +declare all the packages and services that should be installed and +configured for the user. Once a user has written a file containing +@code{home-environment} record, such a configuration can be +@dfn{instantiated} by an unprivileged user with the @command{guix home} +command (@pxref{Invoking guix home}). +@c Maybe later, it will be possible to make home configuration a part of +@c system configuration to make everything managed by guix system. + +The user's home environment usually consists of three basic parts: +software, configuration, and state. Software in mainstream distros are +usually installed system-wide, but with GNU Guix most software packages +can be installed on a per-user basis without needing root privileges, +and are thus considered part of the user’s @dfn{home environment}. +Packages on their own not very useful in many cases, because often they +require some additional configuration, usually config files that reside +in @env{XDG_CONFIG_HOME} (@file{~/.config} by default) or other +directories. Everything else can be considered state, like media files, +application databases, and logs. + +Using Guix for managing home environments provides a number of +advantages: + +@itemize + +@item All software can be configured in one language (Guile Scheme), +this gives users the ability to share values between configurations of +different programs. + +@item A well-defined home environment is self-contained and can be +created in a declarative and reproducible way---there is no need to grab +external binaries or manually edit some configuration file. + +@item After every @command{guix home reconfigure} invocation, a new home +environment generation will be created. This means that users can +rollback to a previous home environment generation so they don’t have to +worry about breaking their configuration. + +@item It is possible to manage stateful data with Guix Home, this +includes the ability to automatically clone Git repositories on the +initial setup of the machine, and periodically running commands like +@command{rsync} to sync data with another host. This functionality is +still in an experimental stage, though. + +@end itemize + +@menu +* Declaring the Home Environment:: Customizing your Home. +* Configuring the Shell:: Enabling home environment. +* Home Services:: Specifying home services. +* Invoking guix home:: Instantiating a home configuration. +@end menu + +@node Declaring the Home Environment +@section Declaring the Home Environment +The home environment is configured by providing a +@code{home-environment} declaration in a file that can be passed to the +@command{guix home} command (@pxref{Invoking guix home}). A simple +setup can include Bash and a custom text configuration, like in the +example below. Don't be afraid to declare home environment parts, which +overlaps with your current dotfiles, before installing any configuration +files, Guix Home will back up existing config files to a separate place +in the home folder. + +@quotation Note +It is highly recommended that you manage your shell or shells with Guix +Home, because it will make sure that all the necessary scripts are +sourced by the shell configuration file. Otherwise you will need to do +it manually. (@pxref{Configuring the Shell}). +@end quotation + +@findex home-environment +@lisp +@include he-config-bare-bones.scm +@end lisp + +The @code{packages} field should be self-explanatory, it will install +the list of packages into the user's profile. The most important field +is @code{services}, it contains a list of @dfn{home services}, which are +the basic building blocks of a home environment. + +There is no daemon (at least not necessarily) related to a home service, +a home service is just an element that is used to declare part of home +environment and extend other parts of it. The extension mechanism +discussed in the previous chapter (@pxref{Defining Services}) should not +be confused with @ref{Shepherd Services}. Using this extension +mechanism and some Scheme code that glues things together gives the user +the freedom to declare their own, very custom, home environments. + +@node Configuring the Shell +@section Configuring the Shell +This section is safe to skip if your shell or shells are managed by +Guix Home. Otherwise, read it carefully. + +There are a few scripts that must be evaluated by a login shell to +activate the home environment. The shell startup files only read by +login shells often have @code{profile} suffix. For more information +about login shells see @ref{Invoking Bash,,, bash, The GNU Bash +Reference Manual} and see @ref{Bash Startup Files,,, bash, The GNU Bash +Reference Manual}. + +The first script that needs to be sourced is @file{setup-environment}, +which sets all the necessary environment variables (including variables +declared by the user) and the second one is @file{on-first-login}, which +starts Shepherd for the current user and performs actions declared by +other home services that extends +@code{home-run-on-first-login-service-type}. + +Guix Home will always create @file{~/.profile}, which contains the +following lines: + +@example +HOME_ENVIRONMENT=$HOME/.guix-home +. $HOME_ENVIRONMENT/setup-environment +$HOME_ENVIRONMENT/on-first-login +@end example + +This makes POSIX compliant login shells activate the home environment. +However, in most cases this file won't be read by most modern shells, +because they are run in non POSIX mode by default and have their own +@file{*profile} startup files. For example Bash will prefer +@file{~/.bash_profile} in case it exists and only if it doesn't will it +fallback to @file{~/.profile}. Zsh (if no additional options are +specified) will ignore @file{~/.profile}, even if @file{~/.zprofile} +doesn't exist. + +To make your shell respect @file{~/.profile}, add @code{. ~/.profile} or +@code{source ~/profile} to the startup file for the login shell. In +case of Bash, it is @file{~/.bash_profile}, and in case of Zsh, it is +@file{~/.zprofile}. + +@quotation Note +This step is only required if your shell is NOT managed by Guix Home. +Otherwise, everything will be done automatically. +@end quotation + +@node Home Services +@section Home Services +@cindex home services + +A @dfn{home service} is not necessarily something that has a daemon and +is managed by Shepherd (@pxref{Jump Start,,, shepherd, The GNU Shepherd +Manual}), in most cases it doesn't. It's a simple building block of the +home environment, often declaring a set of packages to be installed in +the home environment profile, a set of config files to be symlinked into +@env{XDG_CONFIG_HOME} (@file{~/.config} by default), and environment +variables to be set by a login shell. + +There is a service extension mechanism (@pxref{Service Composition}) +which allows home services to extend other home services and utilize +capabilities they provide; for example: declare mcron jobs +(@pxref{Top,,, mcron, GNU@tie{}Mcron}) by extending @ref{Mcron Home +Service}; declare daemons by extending @ref{Shepherd Home Service}; add +commands, which will be invoked on by the Bash by extending +@ref{Shells Home Services, @code{home-bash-service-type}}. + +A good way to discover avaliable home services is using the +@command{guix home search} command (@pxref{Invoking guix home}). After +the required home services are found, include its module with the +@code{use-modules} form (@pxref{use-modules,, Using Guile Modules, +guile, The GNU Guile Reference Manual}), or the @code{#:use-modules} +directive (@pxref{define-module,, Creating Guile Modules, guile, The GNU +Guile Reference Manual}) and declare a home service using the +@code{service} function, or extend a service type by declaring a new +service with the @code{simple-service} procedure from @code{(gnu +services)}. + +@menu +* Essential Home Services:: Environment variables, packages, on-* scripts. +* Shells: Shells Home Services. POSIX shells, Bash, Zsh. +* Mcron: Mcron Home Service. Scheduled User's Job Execution. +* Shepherd: Shepherd Home Service. Managing User's Daemons. +@end menu +@c In addition to that Home Services can provide + +@node Essential Home Services +@subsection Essential Home Services +There are a few essential services defined in @code{(gnu +home-services)}, they are mostly for internal use and are required to +build a home environment, but some of them will be useful for the end +user. + +@cindex environment variables + +@defvr {Scheme Variable} home-environment-variables-service-type +The service of this type will be instantiated by every home environment +automatically by default, there is no need to define it, but someone may +want to extend it with a list of pairs to set some environment +variables. + +@lisp +(list ("ENV_VAR1" . "value1") + ("ENV_VAR2" . "value2")) +@end lisp + +The easiest way to extend a service type, without defining new service +type is to use the @code{simple-service} helper from @code{(gnu +services)}. + +@lisp +(simple-service 'some-useful-env-vars-service + home-environment-variables-service-type + `(("LESSHISTFILE" . "$XDG_CACHE_HOME/.lesshst") + ("SHELL" . ,(file-append zsh "/bin/zsh")) + ("USELESS_VAR" . #f) + ("_JAVA_AWT_WM_NONREPARENTING" . #t))) +@end lisp + +If you include such a service in you home environment definition, it +will add the following content to the @file{setup-environment} script +(which is expected to be sourced by the login shell): + +@example +export LESSHISTFILE=$XDG_CACHE_HOME/.lesshst +export SHELL=/gnu/store/2hsg15n644f0glrcbkb1kqknmmqdar03-zsh-5.8/bin/zsh +export _JAVA_AWT_WM_NONREPARENTING +@end example + +@quotation Note +Make sure that module @code{(gnu packages shells)} is imported with +@code{use-modules} or any other way, this namespace contains the +definition of the @code{zsh} packages, which is used in the example +above. +@end quotation + +The association list (@pxref{Association Lists, alists, Association +Lists, guile, The GNU Guile Reference manual}) is a data structure +containing key-value pairs, for +@code{home-environment-variables-service-type} the key is always a +string, the value can be a string, string-valued gexp +(@pxref{G-Expressions}), file-like object (@pxref{G-Expressions, +file-like object}) or boolean. For gexps, the variable will be set to +the value of the gexp; for file-like objects, it will be set to the path +of the file in the store (@pxref{The Store}); for @code{#t}, it will +export the variable without any value; and for @code{#f}, it will omit +variable. + +@end defvr + +@defvr {Scheme Variable} home-profile-service-type +The service of this type will be instantiated by every home environment +automatically, there is no need to define it, but you may want to extend +it with a list of packages if you want to install additional packages +into your profile. Other services, which need to make some programs +avaliable to the user will also extend this service type. + +The extension value is just a list of packages: + +@lisp +(list htop vim emacs) +@end lisp + +The same approach as @code{simple-service} (@pxref{Service Reference, +simple-service}) for @code{home-environment-variables-service-type} can +be used here, too. Make sure that modules containing the specified +packages are imported with @code{use-modules}. To find a package or +information about its module use @command{guix search} (@pxref{Invoking +guix package}). Alternatively, @code{specification->package} can be +used to get the package record from string without importing related +module. +@end defvr + +There are few more essential services, but users are not expected to +extend them. + +@defvr {Scheme Variable} home-service-type +The root of home services DAG, it generates a folder, which later will be +symlinked to @file{~/.guix-home}, it contains configurations, +profile with binaries and libraries, and some necessary scripts to glue +things together. +@end defvr + +@defvr {Scheme Variable} home-run-on-first-login-service-type +The service of this type generates a Guile script, which is expected to +be executed by the login shell. It is only executed if the special flag +file inside @env{XDG_RUNTIME_DIR} hasn't been created, this prevents +redundant executions of the script if multiple login shells are spawned. + +It can be extended with a gexp. However, to autostart an application, +users @emph{should not} use this service, in most cases it's better to extend +@code{home-shpeherd-service-type} with a Shepherd service +(@pxref{Shepherd Services}), or extend the shell's startup file with +required command using the appropriate service type. +@end defvr + +@defvr {Scheme Variable} home-activation-service-type +The service of this type generates a guile script, which runs on every +@command{guix home reconfigure} invocation or any other action, which +leads to the activation of the home environment. +@end defvr + +@node Shells Home Services +@subsection Shells + +@cindex shell +@cindex login shell +@cindex interactive shell +@cindex bash +@cindex zsh + +Shells play a quite important role in the environment initialization +process, you can configure them manually as described in section +@ref{Configuring the Shell}, but the recommended way is to use home services +listed below. It's both easier and more reliable. + +Each home environment instantiates +@code{home-shell-profile-service-type}, which creates a +@file{~/.profile} startup file for all POSIX-compatible shells. This +file contains all the necessary steps to properly initialize the +environment, but many modern shells like Bash or Zsh prefer their own +startup files, that's why the respective home services +(@code{home-bash-service-type} and @code{home-zsh-service-type}) ensure +that @file{~/.profile} is sourced by @file{~/.bash_profile} and +@file{~/.zprofile}, respectively. + +@subsubheading Shell Profile Service + +@deftp {Data Type} home-shell-profile-configuration +Available @code{home-shell-profile-configuration} fields are: + +@table @asis +@item @code{profile} (default: @code{()}) (type: 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. + +@end table + +@end deftp + +@subsubheading Bash Home Service + +@deftp {Data Type} home-bash-configuration +Available @code{home-bash-configuration} fields are: + +@table @asis +@item @code{package} (default: @code{bash}) (type: package) +The Bash package to use. + +@item @code{guix-defaults?} (default: @code{#t}) (type: boolean) +Add sane defaults like reading @file{/etc/bashrc}, coloring output for +@code{ls} provided by guix to @file{.bashrc}. + +@item @code{environment-variables} (default: @code{()}) (type: alist) +Association list of environment variables to set for the Bash session. + +@item @code{bash-profile} (default: @code{()}) (type: 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. + +@item @code{bashrc} (default: @code{()}) (type: 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). + +@item @code{bash-logout} (default: @code{()}) (type: 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). + +@end table + +@end deftp + +@subsubheading Zsh Home Service + +@deftp {Data Type} home-zsh-configuration +Available @code{home-zsh-configuration} fields are: + +@table @asis +@item @code{package} (default: @code{zsh}) (type: package) +The Zsh package to use. + +@item @code{xdg-flavor?} (default: @code{#t}) (type: boolean) +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}. + +@item @code{environment-variables} (default: @code{()}) (type: alist) +Association list of environment variables to set for the Zsh session. + +@item @code{zshenv} (default: @code{()}) (type: 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}. + +@item @code{zprofile} (default: @code{()}) (type: 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}. + +@item @code{zshrc} (default: @code{()}) (type: 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). + +@item @code{zlogin} (default: @code{()}) (type: 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. + +@item @code{zlogout} (default: @code{()}) (type: 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). + +@end table + +@end deftp + +@node Mcron Home Service +@subsection Scheduled User's Job Execution + +@cindex cron +@cindex mcron +@cindex scheduling jobs + +mcron info here + +@node Shepherd Home Service +@subsection Managing User's Daemons +shepherd info here + +@node Invoking guix home +@section Invoking @code{guix home} + +Once you have written a home environment declaration (@pxref{Declaring +the Home Environment,,,,}, it can be @dfn{instantiated} using the +@command{guix home} command. The synopsis is: + +@example +guix home @var{options}@dots{} @var{action} @var{file} +@end example + +@var{file} must be the name of a file containing a +@code{home-environment} declaration. @var{action} specifies how the +home environment is instantiated, but there are few auxuliary actions +which don't instantiate it. Currently the following values are +supported: + +@table @code +@item search +Display available home service type definitions that match the given +regular expressions, sorted by relevance: + +@cindex shell +@cindex shell-profile +@cindex bash +@cindex zsh +@example +$ guix home search shell +name: home-shell-profile +location: gnu/home-services/shells.scm:73:2 +extends: home-files +description: Create `~/.profile', which is used for environment initialization ++ of POSIX compatible login shells. Can be extended with a list of strings or ++ gexps. +relevance: 6 + +name: home-zsh-plugin-manager +location: gnu/home-services/shellutils.scm:28:2 +extends: home-zsh home-profile +description: Install plugins in profile and configure Zsh to load them. +relevance: 1 + +name: home-zsh-direnv +location: gnu/home-services/shellutils.scm:69:2 +extends: home-profile home-zsh +description: Enables `direnv' for `zsh'. Adds hook to `.zshrc' and installs a ++ package in the profile. +relevance: 1 + +name: home-zsh-autosuggestions +location: gnu/home-services/shellutils.scm:43:2 +extends: home-zsh-plugin-manager home-zsh +description: Enables Fish-like fast/unobtrusive autosuggestions for `zsh' and ++ sets reasonable default values for some plugin's variables to improve perfomance ++ and adjust behavior: `(history completion)' is set for strategy, manual rebind ++ and async are enabled. +relevance: 1 + +name: home-zsh +location: gnu/home-services/shells.scm:236:2 +extends: home-files home-profile +description: Install and configure Zsh. +relevance: 1 + +name: home-bash +location: gnu/home-services/shells.scm:388:2 +extends: home-files home-profile +description: Install and configure Bash. +relevance: 1 + +@dots{} +@end example + +As for @command{guix package --search}, the result is written in +@code{recutils} format, which makes it easy to filter the output +(@pxref{Top, GNU recutils databases,, recutils, GNU recutils manual}). + +@item reconfigure +Build the home environment described in @var{file}, and switch to it. +Switching means that the activation script will be evaluated and (in +basic scenario) symlinks to configuration files generated from +@code{home-environment} declaration will be created in @file{~}. If the +file with the same path already exists in home folder it will be moved +to @file{~/TIMESTAMP-guix-home-legacy-configs-backup}, where TIMESTAMP +is a current UNIX epoch time. + +@quotation Note +It is highly recommended to run @command{guix pull} once before you run +@command{guix home reconfigure} for the first time (@pxref{Invoking guix +pull}). +@end quotation + +This effects all the configuration specified in @var{file}. The command +starts Shepherd services specified in @var{file} that are not currently +running; if a service is currently running, this command will arrange +for it to be upgraded the next time it is stopped (e.g.@: by @code{herd +stop X} or @code{herd restart X}). + +This command creates a new generation whose number is one greater than +the current generation (as reported by @command{guix home +list-generations}). If that generation already exists, it will be +overwritten. This behavior mirrors that of @command{guix package} +(@pxref{Invoking guix package}). + +@cindex provenance tracking, of the home environment +Upon completion, the new home is deployed under @file{~/.guix-home}. +This directory contains @dfn{provenance meta-data}: the list of channels +in use (@pxref{Channels}) and @var{file} itself, when available. You +can view the provenance information by running: + +@example +guix home describe +@end example + +This information is useful should you later want to inspect how this +particular generation was built. In fact, assuming @var{file} is +self-contained, you can later rebuild generation @var{n} of your +home environment with: + +@example +guix time-machine \ + -C /var/guix/profiles/per-user/@var{USER}/guix-home-@var{n}-link/channels.scm -- \ + home reconfigure \ + /var/guix/profiles/per-user/@var{USER}/guix-home-@var{n}-link/configuration.scm + +@end example + +You can think of it as some sort of built-in version control! Your +home is not just a binary artifact: @emph{it carries its own source}. +@c @xref{Service Reference, @code{provenance-service-type}}, for more +@c information on provenance tracking. + +@c @footnote{This action (and the related actions +@c @code{switch-generation} and @code{roll-back}) are usable after the +@c home environment is initialized.}. + +@item switch-generation +@cindex home generations +Switch to an existing home generation. This action atomically switches +the home profile to the specified home generation. + +The target generation can be specified explicitly by its generation +number. For example, the following invocation would switch to home +generation 7: + +@example +guix home switch-generation 7 +@end example + +The target generation can also be specified relative to the current +generation with the form @code{+N} or @code{-N}, where @code{+3} means +``3 generations ahead of the current generation,'' and @code{-1} means +``1 generation prior to the current generation.'' When specifying a +negative value such as @code{-1}, you must precede it with @code{--} to +prevent it from being parsed as an option. For example: + +@example +guix home switch-generation -- -1 +@end example + +This action will fail if the specified generation does not exist. + +@item roll-back +@cindex rolling back +Switch to the preceding home generation. This is the inverse +of @command{reconfigure}, and it is exactly the same as invoking +@command{switch-generation} with an argument of @code{-1}. + +@item delete-generations +@cindex deleting home generations +@cindex saving space +Delete home generations, making them candidates for garbage collection +(@pxref{Invoking guix gc}, for information on how to run the ``garbage +collector''). + +This works in the same way as @samp{guix package --delete-generations} +(@pxref{Invoking guix package, @option{--delete-generations}}). With no +arguments, all home generations but the current one are deleted: + +@example +guix home delete-generations +@end example + +You can also select the generations you want to delete. The example below +deletes all the home generations that are more than two month old: + +@example +guix home delete-generations 2m +@end example + +@item build +Build the derivation of the home environment, which includes all the +configuration files and programs needed. This action does not actually +install anything. + +@item describe +Describe the current home generation: its file name, as well as +provenance information when available. + +@item list-generations +List a summary of each generation of the home environment available on +disk, in a human-readable way. This is similar to the +@option{--list-generations} option of @command{guix package} +(@pxref{Invoking guix package}). + +Optionally, one can specify a pattern, with the same syntax that is used +in @command{guix package --list-generations}, to restrict the list of +generations displayed. For instance, the following command displays +generations that are up to 10 days old: + +@example +$ guix home list-generations 10d +@end example + +@end table @node Documentation @chapter Documentation diff --git a/doc/he-config-bare-bones.scm b/doc/he-config-bare-bones.scm new file mode 100644 index 0000000000..01be46a7b0 --- /dev/null +++ b/doc/he-config-bare-bones.scm @@ -0,0 +1,24 @@ +(use-modules (gnu home) + (gnu home-services) + (gnu home-services shells) + (gnu services) + (gnu packages admin) + (guix gexp)) + + +(home-environment + (packages (list htop)) + (services + (list + (service home-bash-service-type + (home-bash-configuration + (guix-defaults? #t) + (bash-profile '("\ +export HISTFILE=$XDG_CACHE_HOME/.bash_history")))) + + (simple-service 'test-config + home-files-service-type + (list `("config/test.conf" + ,(plain-file "tmp-file.txt" + "the content of ~/.config/test.conf"))))))) + -- cgit v1.2.3 From 6b5ff71b993611d413d3c179b3d50115cd87f408 Mon Sep 17 00:00:00 2001 From: Andrew Tropin Date: Thu, 2 Sep 2021 12:33:36 +0300 Subject: home-services: Add Shepherd. * gnu/home-services/shepherd.scm: New file. * gnu/local.mk: Add this. * doc/guix.texi: Add documentation about Shepherd Home Service. Signed-off-by: Oleg Pykhalov --- doc/guix.texi | 32 +++++++++- gnu/home-services/shepherd.scm | 132 +++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + 3 files changed, 164 insertions(+), 1 deletion(-) create mode 100644 gnu/home-services/shepherd.scm (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 637ec2799b..e546fcc0d2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -35689,7 +35689,37 @@ mcron info here @node Shepherd Home Service @subsection Managing User's Daemons -shepherd info here + +@cindex shepherd services + +@defvr {Scheme Variable} home-shepherd-service-type +The service type for the userland Shepherd, which allows one to manage +long-running processes or one-shot tasks. User's Shepherd is not an +init process (PID 1), but almost all other information described in +(@pxref{Shepherd Services}) is applicable here too. + +This is the service type that extensions target when they want to create +shepherd services (@pxref{Service Types and Services}, for an example). +Each extension must pass a list of @code{}. Its +value must be a @code{shepherd-configuration}, as described below. +@end defvr + +@deftp {Data Type} shepherd-configuration +This data type represents the Shepherd's configuration. + +@table @code +@item shepherd (default: @code{shepherd}) +The Shepherd package to use. + +@item auto-start? (default: @code{#t}) +Whether or not to start Shepherd on first login. + +@item services (default: @code{'()}) +A list of @code{} to start. +You should probably use the service extension +mechanism instead (@pxref{Shepherd Services}). +@end table +@end deftp @node Invoking guix home @section Invoking @code{guix home} diff --git a/gnu/home-services/shepherd.scm b/gnu/home-services/shepherd.scm new file mode 100644 index 0000000000..b9fd3c367b --- /dev/null +++ b/gnu/home-services/shepherd.scm @@ -0,0 +1,132 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Andrew Tropin +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home-services 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) + + #:re-export (shepherd-service + shepherd-action)) + +(define-record-type* + 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/local.mk b/gnu/local.mk index 0e2074a042..31ad1a43db 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -79,6 +79,7 @@ GNU_SYSTEM_MODULES = \ %D%/home-services/fontutils.scm \ %D%/home-services/configuration.scm \ %D%/home-services/shells.scm \ + %D%/home-services/shepherd.scm \ %D%/home-services/utils.scm \ %D%/home-services/xdg.scm \ %D%/image.scm \ -- cgit v1.2.3 From bac597cc968a4fd6c1bf41cffebf921e8581ca72 Mon Sep 17 00:00:00 2001 From: Andrew Tropin Date: Fri, 10 Sep 2021 09:26:33 +0300 Subject: home-services: Add Mcron. * gnu/home-services/mcron.scm: New file. * gnu/local.mk: Add this. * doc/guix.texi: Add documentation about Mcron Home Service. Signed-off-by: Oleg Pykhalov --- doc/guix.texi | 39 +++++++++++++-- gnu/home-services/mcron.scm | 115 ++++++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + 3 files changed, 151 insertions(+), 4 deletions(-) create mode 100644 gnu/home-services/mcron.scm (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index e546fcc0d2..419d9429d6 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -16090,9 +16090,9 @@ This is the type of the @code{mcron} service, whose value is an @code{mcron-configuration} object. This service type can be the target of a service extension that provides -it additional job specifications (@pxref{Service Composition}). In -other words, it is possible to define services that provide additional -mcron jobs to run. +additional job specifications (@pxref{Service Composition}). In other +words, it is possible to define services that provide additional mcron +jobs to run. @end defvr @deftp {Data Type} mcron-configuration @@ -35685,7 +35685,38 @@ for example). @cindex mcron @cindex scheduling jobs -mcron info here +The @code{(gnu home-services mcron)} module provides an interface to +GNU@tie{}mcron, a daemon to run jobs at scheduled times (@pxref{Top,,, +mcron, GNU@tie{}mcron}). The information about system's mcron is +applicable here (@pxref{Scheduled Job Execution}), the only difference +for home services is that they have to be declared in a +@code{home-envirnoment} record instead of an @code{operating-system} +record. + +@defvr {Scheme Variable} home-mcron-service-type +This is the type of the @code{mcron} home service, whose value is an +@code{home-mcron-configuration} object. It allows to manage scheduled +tasks. + +This service type can be the target of a service extension that provides +additional job specifications (@pxref{Service Composition}). In other +words, it is possible to define services that provide additional mcron +jobs to run. +@end defvr + +@deftp {Data Type} home-mcron-configuration +Data type representing the configuration of mcron. + +@table @asis +@item @code{mcron} (default: @var{mcron}) +The mcron package to use. + +@item @code{jobs} +This is a list of gexps (@pxref{G-Expressions}), where each gexp +corresponds to an mcron job specification (@pxref{Syntax, mcron job +specifications,, mcron, GNU@tie{}mcron}). +@end table +@end deftp @node Shepherd Home Service @subsection Managing User's Daemons diff --git a/gnu/home-services/mcron.scm b/gnu/home-services/mcron.scm new file mode 100644 index 0000000000..fdfde179a5 --- /dev/null +++ b/gnu/home-services/mcron.scm @@ -0,0 +1,115 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Andrew Tropin +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home-services 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 + 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 + (($ mcron '()) ; no jobs to run + '()) + (($ 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/local.mk b/gnu/local.mk index 31ad1a43db..8212bc5391 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -80,6 +80,7 @@ GNU_SYSTEM_MODULES = \ %D%/home-services/configuration.scm \ %D%/home-services/shells.scm \ %D%/home-services/shepherd.scm \ + %D%/home-services/mcron.scm \ %D%/home-services/utils.scm \ %D%/home-services/xdg.scm \ %D%/image.scm \ -- cgit v1.2.3 From 59ee10754eddddb99e4a80b9e18aa12ed1b3d77a Mon Sep 17 00:00:00 2001 From: Xinglu Chen Date: Fri, 17 Sep 2021 10:04:49 +0200 Subject: import: Add 'generic-git' updater. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/git.scm (ls-remote-refs): New procedure. * tests/git.scm ("remote-refs" "remote-refs: only tags"): New tests. * guix/import/git.scm: New file. * doc/guix.texi (Invoking guix refresh): Document it. * tests/import-git.scm: New test file. * Makefile.am (MODULES, SCM_TESTS): Register the new files. Co-authored-by: Sarah Morgensen Signed-off-by: Ludovic Courtès --- Makefile.am | 2 + doc/guix.texi | 34 +++++++ guix/git.scm | 41 +++++++++ guix/import/git.scm | 225 ++++++++++++++++++++++++++++++++++++++++++++++ tests/git.scm | 28 ++++++ tests/import-git.scm | 245 +++++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 575 insertions(+) create mode 100644 guix/import/git.scm create mode 100644 tests/import-git.scm (limited to 'doc') diff --git a/Makefile.am b/Makefile.am index 299bc0f7fb..f3bdc7448e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -254,6 +254,7 @@ MODULES = \ guix/import/egg.scm \ guix/import/elpa.scm \ guix/import/gem.scm \ + guix/import/git.scm \ guix/import/github.scm \ guix/import/gnome.scm \ guix/import/gnu.scm \ @@ -473,6 +474,7 @@ SCM_TESTS = \ tests/graph.scm \ tests/gremlin.scm \ tests/hackage.scm \ + tests/import-git.scm \ tests/import-utils.scm \ tests/inferior.scm \ tests/lint.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 2fc9687910..6436e83a7c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11928,6 +11928,40 @@ the updater for @uref{https://launchpad.net, Launchpad} packages. @item generic-html a generic updater that crawls the HTML page where the source tarball of the package is hosted, when applicable. + +@item generic-git +a generic updater for packages hosted on Git repositories. It tries to +be smart about parsing Git tag names, but if it is not able to parse the +tag name and compare tags correctly, users can define the following +properties for a package. + +@itemize +@item @code{release-tag-prefix}: a regular expression for matching a prefix of +the tag name. + +@item @code{release-tag-suffix}: a regular expression for matching a suffix of +the tag name. + +@item @code{release-tag-version-delimiter}: a string used as the delimiter in +the tag name for separating the numbers of the version. + +@item @code{accept-pre-releases}: by default, the updater will ignore +pre-releases; to make it also look for pre-releases, set the this +property to @code{#t}. + +@end itemize + +@lisp +(package + (name "foo") + ;; ... + (properties + '((release-tag-prefix . "^release0-") + (release-tag-suffix . "[a-z]?$") + (release-tag-version-delimiter . ":")))) +@end lisp + + @end table For instance, the following command only checks for updates of Emacs diff --git a/guix/git.scm b/guix/git.scm index acc48fd12f..bbff4fc890 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -57,6 +57,8 @@ commit-difference commit-relation + remote-refs + git-checkout git-checkout? git-checkout-url @@ -571,6 +573,45 @@ objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or (if (set-contains? oldest new) 'descendant 'unrelated)))))) + +;; +;;; Remote operations. +;;; + +(define* (remote-refs url #:key tags?) + "Return the list of references advertised at Git repository URL. If TAGS? +is true, limit to only refs/tags." + (define (ref? ref) + ;; Like `git ls-remote --refs', only show actual references. + (and (string-prefix? "refs/" ref) + (not (string-suffix? "^{}" ref)))) + + (define (tag? ref) + (string-prefix? "refs/tags/" ref)) + + (define (include? ref) + (and (ref? ref) + (or (not tags?) (tag? ref)))) + + (define (remote-head->ref remote) + (let ((name (remote-head-name remote))) + (and (include? name) + name))) + + (with-libgit2 + (call-with-temporary-directory + (lambda (cache-directory) + (let* ((repository (repository-init cache-directory)) + ;; Create an in-memory remote so we don't touch disk. + (remote (remote-create-anonymous repository url))) + (remote-connect remote) + + (let* ((remote-heads (remote-ls remote)) + (refs (filter-map remote-head->ref remote-heads))) + ;; Wait until we're finished with the repository before closing it. + (remote-disconnect remote) + (repository-close! repository) + refs)))))) ;;; diff --git a/guix/import/git.scm b/guix/import/git.scm new file mode 100644 index 0000000000..1eb219f3fe --- /dev/null +++ b/guix/import/git.scm @@ -0,0 +1,225 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen +;;; Copyright © 2021 Sarah Morgensen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix import git) + #:use-module (guix build utils) + #:use-module (guix diagnostics) + #:use-module (guix git) + #:use-module (guix git-download) + #:use-module (guix i18n) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:export (%generic-git-updater + + ;; For tests. + latest-git-tag-version)) + +;;; Commentary: +;;; +;;; This module provides a generic package updater for packages hosted on Git +;;; repositories. +;;; +;;; It tries to be smart about tag names, but if it is not automatically able +;;; to parse the tag names correctly, users can set the `release-tag-prefix', +;;; `release-tag-suffix' and `release-tag-version-delimiter' properties of the +;;; package to make the updater parse the Git tag name correctly. +;;; +;;; Possible improvements: +;;; +;;; * More robust method for trying to guess the delimiter. Maybe look at the +;;; previous version/tag combo to determine the delimiter. +;;; +;;; * Differentiate between "normal" versions, e.g., 1.2.3, and dates, e.g., +;;; 2021.12.31. Honor a `release-tag-date-scheme?' property? +;;; +;;; Code: + +;;; Errors & warnings + +(define-condition-type &git-no-valid-tags-error &error + git-no-valid-tags-error?) + +(define (git-no-valid-tags-error) + (raise (condition (&message (message "no valid tags found")) + (&git-no-valid-tags-error)))) + +(define-condition-type &git-no-tags-error &error + git-no-tags-error?) + +(define (git-no-tags-error) + (raise (condition (&message (message "no tags were found")) + (&git-no-tags-error)))) + + +;;; Updater + +(define %pre-release-words + '("alpha" "beta" "rc" "dev" "test" "pre")) + +(define %pre-release-rx + (map (lambda (word) + (make-regexp (string-append ".+" word) regexp/icase)) + %pre-release-words)) + +(define* (version-mapping tags #:key prefix suffix delim pre-releases?) + "Given a list of Git TAGS, return an association list where the car is the +version corresponding to the tag, and the cdr is the name of the tag." + (define (guess-delimiter) + (let ((total (length tags)) + (dots (reduce + 0 (map (cut string-count <> #\.) tags))) + (dashes (reduce + 0 (map (cut string-count <> #\-) tags))) + (underscores (reduce + 0 (map (cut string-count <> #\_) tags)))) + (cond + ((>= dots (* total 0.35)) ".") + ((>= dashes (* total 0.8)) "-") + ((>= underscores (* total 0.8)) "_") + (else "")))) + + (define delim-rx (regexp-quote (or delim (guess-delimiter)))) + (define suffix-rx (string-append (or suffix "") "$")) + (define prefix-rx (string-append "^" (or prefix "[^[:digit:]]*"))) + (define pre-release-rx + (if pre-releases? + (string-append "(.*(" (string-join %pre-release-words "|") ").*)") + "")) + + (define tag-rx + (string-append prefix-rx "([[:digit:]][^" delim-rx "[:punct:]]*" + "(" delim-rx "[^[:punct:]" delim-rx "]+)" + ;; If there are no delimiters, it could mean that the + ;; version just contains one number (e.g., "2"), thus, use + ;; "*" instead of "+" to match zero or more numbers. + (if (string=? delim-rx "") "*" "+") ")" + ;; We don't want the pre-release stuff (e.g., "-alpha") be + ;; part of the first group; otherwise, the "-" in "-alpha" + ;; might be interpreted as a delimiter, and thus replaced + ;; with "." + pre-release-rx suffix-rx)) + + + + (define (get-version tag) + (let ((tag-match (regexp-exec (make-regexp tag-rx) tag))) + (and=> (and tag-match + (regexp-substitute/global + #f delim-rx (match:substring tag-match 1) + ;; If there were no delimiters, don't insert ".". + 'pre (if (string=? delim-rx "") "" ".") 'post)) + (lambda (version) + (if pre-releases? + (string-append version (match:substring tag-match 3)) + version))))) + + (define (entry tag) + %pre-release-rx)) + + (let* ((tags (map (cut string-drop <> (string-length "refs/tags/")) + (remote-refs url #:tags? #t))) + (versions->tags + (version-mapping (if pre-releases? + tags + (filter (negate pre-release?) tags)) + #:prefix prefix + #:suffix suffix + #:delim delim + #:pre-releases? pre-releases?))) + (cond + ((null? tags) + (git-no-tags-error)) + ((null? versions->tags) + (git-no-valid-tags-error)) + (else + (match (last versions->tags) + ((version . tag) + (values version tag))))))) + +(define (latest-git-tag-version package) + "Given a PACKAGE, return the latest version of it, or #f if the latest version +could not be determined." + (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c)) + (warning (or (package-field-location package 'source) + (package-location package)) + (G_ "~a for ~a~%") + (condition-message c) + (package-name package)) + #f) + ((eq? (exception-kind c) 'git-error) + (warning (or (package-field-location package 'source) + (package-location package)) + (G_ "failed to fetch Git repository for ~a~%") + (package-name package)) + #f)) + (let* ((source (package-source package)) + (url (git-reference-url (origin-uri source))) + (property (cute assq-ref (package-properties package) <>))) + (latest-tag url + #:prefix (property 'release-tag-prefix) + #:suffix (property 'release-tag-suffix) + #:delim (property 'release-tag-version-delimiter) + #:pre-releases? (property 'accept-pre-releases?))))) + +(define (git-package? package) + "Return true if PACKAGE is hosted on a Git repository." + (match (package-source package) + ((? origin? origin) + (and (eq? (origin-method origin) git-fetch) + (git-reference? (origin-uri origin)))) + (_ #f))) + +(define (latest-git-release package) + "Return an for the latest release of PACKAGE." + (let* ((name (package-name package)) + (old-version (package-version package)) + (url (git-reference-url (origin-uri (package-source package)))) + (new-version (latest-git-tag-version package))) + + (and new-version + (upstream-source + (package name) + (version new-version) + (urls (list url)))))) + +(define %generic-git-updater + (upstream-updater + (name 'generic-git) + (description "Updater for packages hosted on Git repositories") + (pred git-package?) + (latest latest-git-release))) diff --git a/tests/git.scm b/tests/git.scm index aa4f03ca62..d0646bbc85 100644 --- a/tests/git.scm +++ b/tests/git.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019, 2020 Ludovic Courtès +;;; Copyright © 2021 Xinglu Chen . + +(define-module (test-import-git) + #:use-module (git) + #:use-module (guix git) + #:use-module (guix tests) + #:use-module (guix packages) + #:use-module (guix import git) + #:use-module (guix git-download) + #:use-module (guix tests git) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +;; Test the (guix import git) tools. + +(test-begin "git") + +(define* (make-package directory version #:optional (properties '())) + (dummy-package "test-package" + (version version) + (properties properties) + (source + (origin + (method git-fetch) + (uri (git-reference + (url (string-append "file://" directory)) + (commit version))) + (sha256 + (base32 + "0000000000000000000000000000000000000000000000000000")))))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: no custom prefix, suffix, and delimiter" + "1.0.1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "1.0.1" "Release 1.0.1")) + (let ((package (make-package directory "1.0.0"))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: custom prefix, no suffix and delimiter" + "1.0.1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "prefix-1.0.1" "Release 1.0.1")) + (let ((package (make-package directory "1.0.0" + '((release-tag-prefix . "prefix-"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: custom suffix, no prefix and delimiter" + "1.0.1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "1.0.1-suffix-123" "Release 1.0.1")) + (let ((package (make-package directory "1.0.0" + '((release-tag-suffix . "-suffix-[0-9]*"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: custom delimiter, no prefix and suffix" + "2021.09.07" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "2021-09-07" "Release 2021-09-07")) + (let ((package (make-package directory "2021-09-06" + '((release-tag-version-delimiter . "-"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: empty delimiter, no prefix and suffix" + "20210907" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "20210907" "Release 20210907")) + (let ((package (make-package directory "20210906" + '((release-tag-version-delimiter . ""))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: custom prefix and suffix, no delimiter" + "2.0.0" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "Release-2.0.0suffix-1" "Release 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((release-tag-prefix . "Release-") + (release-tag-suffix . "suffix-[0-9]"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: custom prefix, suffix, and delimiter" + "2.0.0" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "Release-2_0_0suffix-1" "Release 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((release-tag-prefix . "Release-") + (release-tag-suffix . "suffix-[0-9]") + (release-tag-version-delimiter . "_"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: only pre-releases available" + #f + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "2.0.0-rc1" "Release candidate for 2.0.0")) + (let ((package (make-package directory "1.0.0"))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases" + "2.0.0-rc1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "2.0.0-rc1" "Release candidate for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, and custom prefix" + "2.0.0-rc1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "version-2.0.0-rc1" "Release candidate for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-prefix . "version-"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix" + "2.0.0-rc1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "2.0.0-rc1-suffix" "Release candidate for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-suffix . "-suffix"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, delimiter conflicts with pre-release part" + "2.0.0_alpha" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "2_0_0_alpha" "Alpha release for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-version-delimiter . "_"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix and prefix" + "2.0.0-alpha" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "prefix123-2.0.0-alpha-suffix" "Alpha release for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-prefix . "prefix[0-9]{3}-") + (release-tag-suffix . "-suffix"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix, prefix, and delimiter" + "2.0.0-alpha" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "prefix123-2-0-0-alpha-suffix" "Alpha release for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-prefix . "prefix[0-9]{3}-") + (release-tag-suffix . "-suffix") + (release-tag-version-delimiter . "-"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, no delimiter, and custom suffix, prefix" + "2alpha" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "prefix123-2alpha-suffix" "Alpha release for version 2")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-prefix . "prefix[0-9]{3}-") + (release-tag-suffix . "-suffix") + (release-tag-version-delimiter . ""))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: no tags found" + #f + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit")) + (let ((package (make-package directory "1.0.0"))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: no valid tags found" + #f + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "Test" "Test tag")) + (let ((package (make-package directory "1.0.0"))) + (latest-git-tag-version package)))) + +(test-end "git") -- cgit v1.2.3 From 5c4fd77097e2cecfd4780e099af7954f86779fe1 Mon Sep 17 00:00:00 2001 From: Thiago Jung Bauermann Date: Wed, 15 Sep 2021 20:36:38 -0300 Subject: etc: Add systemd files for running ‘guix gc’ periodically MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * etc/guix-gc.service.in: New file. * etc/guix-gc.timer: Likewise. * .gitignore: Ignore generated ‘guix-gc.service’. * nix/local.mk (nodist_systemdservice_DATA): Add ‘guix-gc.service’ and ‘guix-gc.timer’. (EXTRA_DIST): Add ‘guix-gc.service.in’ and ‘guix-gc.timer’. * doc/guix.texi (Binary Installation): Mention the new systemd files. Signed-off-by: Mathieu Othacehe --- .gitignore | 1 + doc/guix.texi | 12 ++++++++++++ etc/guix-gc.service.in | 20 ++++++++++++++++++++ etc/guix-gc.timer | 15 +++++++++++++++ nix/local.mk | 6 +++++- 5 files changed, 53 insertions(+), 1 deletion(-) create mode 100644 etc/guix-gc.service.in create mode 100644 etc/guix-gc.timer (limited to 'doc') diff --git a/.gitignore b/.gitignore index 88fe24586d..59e1460fef 100644 --- a/.gitignore +++ b/.gitignore @@ -74,6 +74,7 @@ /etc/guix-daemon.service /etc/guix-publish.conf /etc/guix-publish.service +/etc/guix-gc.service /etc/init.d/guix-daemon /etc/openrc/guix-daemon /guix-* diff --git a/doc/guix.texi b/doc/guix.texi index 6436e83a7c..cd8e249ae8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -743,6 +743,18 @@ with these commands: # systemctl enable --now gnu-store.mount guix-daemon @end example +You may also want to arrange for @command{guix gc} to run periodically: + +@example +# cp ~root/.config/guix/current/lib/systemd/system/guix-gc.service \ + ~root/.config/guix/current/lib/systemd/system/guix-gc.timer \ + /etc/systemd/system/ +# systemctl enable --now guix-gc.timer +@end example + +You may want to edit @file{guix-gc.service} to adjust the command line +options to fit your needs (@pxref{Invoking guix gc}). + If your host distro uses the Upstart init system: @example diff --git a/etc/guix-gc.service.in b/etc/guix-gc.service.in new file mode 100644 index 0000000000..2f1ca6584b --- /dev/null +++ b/etc/guix-gc.service.in @@ -0,0 +1,20 @@ +# This is a "service unit file" for the systemd init system to perform a +# one-shot 'guix gc' operation. It is meant to be triggered by a timer. +# Drop it in /etc/systemd/system or similar together with 'guix-gc.timer' +# to set it up. + +[Unit] +Description=Discard unused Guix store items + +[Service] +Type=oneshot +# Customize the 'guix gc' arguments to fit your needs. +ExecStart=@localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix gc -d 1m -F 10G +PrivateDevices=yes +PrivateNetwork=yes +PrivateUsers=no +ProtectKernelTunables=yes +ProtectKernelModules=yes +ProtectControlGroups=yes +MemoryDenyWriteExecute=yes +SystemCallFilter=@default @file-system @basic-io @system-service diff --git a/etc/guix-gc.timer b/etc/guix-gc.timer new file mode 100644 index 0000000000..192132fbda --- /dev/null +++ b/etc/guix-gc.timer @@ -0,0 +1,15 @@ +# This is a "timer unit file" for the systemd init system to trigger +# 'guix-gc.service' periodically. Drop it in /etc/systemd/system or similar +# together with 'guix-gc.service' to set it up. + +[Unit] +Description=Discard unused Guix store items + +[Timer] +OnCalendar=weekly +AccuracySec=1h +Persistent=true +RandomizedDelaySec=6000 + +[Install] +WantedBy=timers.target diff --git a/nix/local.mk b/nix/local.mk index 7c438ea78c..d6b4d7faeb 100644 --- a/nix/local.mk +++ b/nix/local.mk @@ -153,7 +153,9 @@ systemdservicedir = $(libdir)/systemd/system nodist_systemdservice_DATA = \ etc/gnu-store.mount \ etc/guix-daemon.service \ - etc/guix-publish.service + etc/guix-publish.service \ + etc/guix-gc.service \ + etc/guix-gc.timer etc/%.mount: etc/%.mount.in \ $(top_builddir)/config.status @@ -216,6 +218,8 @@ EXTRA_DIST += \ etc/guix-daemon.conf.in \ etc/guix-publish.service.in \ etc/guix-publish.conf.in \ + etc/guix-gc.service.in \ + etc/guix-gc.timer \ etc/init.d/guix-daemon.in \ etc/openrc/guix-daemon.in -- cgit v1.2.3 From 5b32ad4f6f555d305659cee825879df075b06331 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Sep 2021 10:13:15 +0200 Subject: graph: Add '--max-depth'. * guix/graph.scm (export-graph): Add #:max-depth and honor it, adding 'depths' argument to 'loop'. * guix/scripts/graph.scm (%options, show-help): Add '--max-depth'. (%default-options): Add 'max-depth'. (guix-graph): Pass #:max-depth to 'export-graph'. * tests/graph.scm ("package DAG, limited depth"): New test. * doc/guix.texi (Invoking guix graph): Document it. --- doc/guix.texi | 14 ++++++++++++++ guix/graph.scm | 45 ++++++++++++++++++++++++++++----------------- guix/scripts/graph.scm | 11 ++++++++++- tests/graph.scm | 21 ++++++++++++++++++++- 4 files changed, 72 insertions(+), 19 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index cd8e249ae8..b15a45a977 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -12644,6 +12644,20 @@ $ guix graph --path -t references emacs libunistring /gnu/store/@dots{}-libunistring-0.9.10 @end example +Sometimes you still want to visualize the graph but would like to trim +it so it can actually be displayed. One way to do it is via the +@option{--max-depth} (or @option{-M}) option, which lets you specify the +maximum depth of the graph. In the example below, we visualize only +@code{libreoffice} and the nodes whose distance to @code{libreoffice} is +at most 2: + +@example +guix graph -M 2 libreoffice | xdot -f fdp - +@end example + +Mind you, that's still a big ball of spaghetti, but at least +@command{dot} can render it quickly and it can be browsed somewhat. + The available options are the following: @table @option diff --git a/guix/graph.scm b/guix/graph.scm index 0d4cd83667..3a1cab244b 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -337,11 +337,12 @@ nodeArray.push(nodes[\"~a\"]);~%" (define* (export-graph sinks port #:key - reverse-edges? node-type + reverse-edges? node-type (max-depth +inf.0) (backend %graphviz-backend)) "Write to PORT the representation of the DAG with the given SINKS, using the given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is -true, draw reverse arrows." +true, draw reverse arrows. Do not represent nodes whose distance to one of +the SINKS is greater than MAX-DEPTH." (match backend (($ _ _ emit-prologue emit-epilogue emit-node emit-edge) (emit-prologue (node-type-name node-type) port) @@ -349,6 +350,7 @@ true, draw reverse arrows." (match node-type (($ node-identifier node-label node-edges) (let loop ((nodes sinks) + (depths (make-list (length sinks) 0)) (visited (set))) (match nodes (() @@ -356,20 +358,29 @@ true, draw reverse arrows." (emit-epilogue port) (store-return #t))) ((head . tail) - (mlet %store-monad ((id (node-identifier head))) - (if (set-contains? visited id) - (loop tail visited) - (mlet* %store-monad ((dependencies (node-edges head)) - (ids (mapm %store-monad - node-identifier - dependencies))) - (emit-node id (node-label head) port) - (for-each (lambda (dependency dependency-id) - (if reverse-edges? - (emit-edge dependency-id id port) - (emit-edge id dependency-id port))) - dependencies ids) - (loop (append dependencies tail) - (set-insert id visited))))))))))))) + (match depths + ((depth . depths) + (mlet %store-monad ((id (node-identifier head))) + (if (set-contains? visited id) + (loop tail depths visited) + (mlet* %store-monad ((dependencies + (if (= depth max-depth) + (return '()) + (node-edges head))) + (ids + (mapm %store-monad + node-identifier + dependencies))) + (emit-node id (node-label head) port) + (for-each (lambda (dependency dependency-id) + (if reverse-edges? + (emit-edge dependency-id id port) + (emit-edge id dependency-id port))) + dependencies ids) + (loop (append dependencies tail) + (append (make-list (length dependencies) + (+ 1 depth)) + depths) + (set-insert id visited))))))))))))))) ;;; graph.scm ends here diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 66de824ef4..439fae0b52 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -500,6 +500,10 @@ package modules, while attempting to retain user package modules." (lambda (opt name arg result) (alist-cons 'backend (lookup-backend arg) result))) + (option '(#\M "max-depth") #t #f + (lambda (opt name arg result) + (alist-cons 'max-depth (string->number* arg) + result))) (option '("list-backends") #f #f (lambda (opt name arg result) (list-backends) @@ -537,6 +541,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) -t, --type=TYPE represent nodes of the given TYPE")) (display (G_ " --list-types list the available graph types")) + (display (G_ " + --max-depth=DEPTH limit to nodes within distance DEPTH")) (display (G_ " --path display the shortest path between the given nodes")) (display (G_ " @@ -559,6 +565,7 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (define %default-options `((node-type . ,%package-node-type) (backend . ,%graphviz-backend) + (max-depth . +inf.0) (system . ,(%current-system)))) @@ -582,6 +589,7 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (with-store store (let* ((transform (options->transformation opts)) + (max-depth (assoc-ref opts 'max-depth)) (items (filter-map (match-lambda (('argument . (? store-path? item)) item) @@ -613,7 +621,8 @@ nodes (given ~a)~%") (export-graph (concatenate nodes) (current-output-port) #:node-type type - #:backend backend))) + #:backend backend + #:max-depth max-depth))) #:system (assq-ref opts 'system))))) #t) diff --git a/tests/graph.scm b/tests/graph.scm index e374dad1a5..fadac265f9 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -94,6 +94,25 @@ edges." (list p3 p3 p2) (list p2 p1 p1)))))))) +(test-assert "package DAG, limited depth" + (let-values (((backend nodes+edges) (make-recording-backend))) + (let* ((p1 (dummy-package "p1")) + (p2 (dummy-package "p2" (inputs `(("p1" ,p1))))) + (p3 (dummy-package "p3" (inputs `(("p1" ,p1))))) + (p4 (dummy-package "p4" (inputs `(("p2" ,p2) ("p3" ,p3)))))) + (run-with-store %store + (export-graph (list p4) 'port + #:max-depth 1 + #:node-type %package-node-type + #:backend backend)) + ;; We should see nothing more than these 3 packages. + (let-values (((nodes edges) (nodes+edges))) + (and (equal? nodes (map package->tuple (list p4 p2 p3))) + (equal? edges + (map edge->tuple + (list p4 p4) + (list p2 p3)))))))) + (test-assert "reverse package DAG" (let-values (((backend nodes+edges) (make-recording-backend))) (run-with-store %store -- cgit v1.2.3 From d18b787d8a5cada8d239f1335257d0c1bca7f825 Mon Sep 17 00:00:00 2001 From: zimoun Date: Mon, 12 Oct 2020 10:20:03 +0200 Subject: doc: Add item to "Submitting Patches" section. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/contributing.texi (Submitting Patches): Add item about 'git-format-patch --base'. Signed-off-by: Ludovic Courtès --- doc/contributing.texi | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'doc') diff --git a/doc/contributing.texi b/doc/contributing.texi index d1b77d7d05..fbb3c47c78 100644 --- a/doc/contributing.texi +++ b/doc/contributing.texi @@ -1011,6 +1011,12 @@ Before submitting a patch that adds or modifies a package definition, please run through this check list: @enumerate +@cindex @code{git format-patch} +@cindex @code{git-format-patch} +@item +We recommend to use the command @code{git format-patch --base} to +include the commit where your patch applies. + @item If the authors of the packaged software provide a cryptographic signature for the release tarball, make an effort to verify the -- cgit v1.2.3 From 602994847b748937b6fa39a7b819429857cdd8d3 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sat, 15 May 2021 15:29:40 +0200 Subject: file-systems: Support forced checks & repairs. * gnu/build/file-systems.scm (check-ext2-file-system) (check-bcachefs-file-system, check-btrfs-file-system) (check-fat-file-system, check-jfs-file-system, check-f2fs-file-system) (check-ntfs-file-system, check-file-system): Take and honour new FORCE? and REPAIR arguments. Update the docstring. Adjust all callers. * gnu/system/file-systems.scm : Add new SKIP-CHECK-IF-CLEAN? and REPAIR fields. (file-system->spec, spec->file-system): Adjust accordingly. * gnu/build/linux-boot.scm (mount-root-file-system): Take new SKIP-CHECK-IF-CLEAN? and REPAIR keyword arguments. Thread them through to CHECK-FILE-SYSTEM. * doc/guix.texi (File Systems): Document both new options. --- doc/guix.texi | 34 ++++++- gnu/build/file-systems.scm | 209 +++++++++++++++++++++++++++++++------------- gnu/build/linux-boot.scm | 19 +++- gnu/system/file-systems.scm | 20 ++++- 4 files changed, 212 insertions(+), 70 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index b15a45a977..a62578be26 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -14187,8 +14187,38 @@ initial RAM disk (initrd) is loaded. This is always the case, for instance, for the root file system. @item @code{check?} (default: @code{#t}) -This Boolean indicates whether the file system needs to be checked for -errors before being mounted. +This Boolean indicates whether the file system should be checked for +errors before being mounted. How and when this happens can be further +adjusted with the following options. + +@item @code{skip-check-if-clean?} (default: @code{#t}) +When true, this Boolean indicates that a file system check triggered +by @code{check?} may exit early if the file system is marked as +``clean'', meaning that it was previously correctly unmounted and +should not contain errors. + +Setting this to false will always force a full consistency check when +@code{check?} is true. This may take a very long time and is not +recommended on healthy systems---in fact, it may reduce reliability! + +Conversely, some primitive file systems like @code{fat} do not keep +track of clean shutdowns and will perform a full scan regardless of the +value of this option. + +@item @code{repair} (default: @code{'preen}) +When @code{check?} finds errors, it can (try to) repair them and +continue booting. This option controls when and how to do so. + +If false, try not to modify the file system at all. Checking certain +file systems like @code{jfs} may still write to the device to replay +the journal. No repairs will be attempted. + +If @code{#t}, try to repair any errors found and assume ``yes'' to +all questions. This will fix the most errors, but may be risky. + +If @code{'preen}, repair only errors that are safe to fix without +human interaction. What that means is left up to the developers of +each file system and may be equivalent to ``none'' or ``all''. @item @code{create-mount-point?} (default: @code{#f}) When true, the mount point is created if it does not exist yet. diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 4eeb81cf26..a54127e888 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -170,10 +170,19 @@ if DEVICE does not contain an ext2 file system." #f if SBLOCK has no volume name." (null-terminated-latin1->string (sub-bytevector sblock 120 16))) -(define (check-ext2-file-system device) - "Return the health of an ext2 file system on DEVICE." +(define (check-ext2-file-system device force? repair) + "Return the health of an unmounted ext2 file system on DEVICE. If FORCE? is +true, check the file system even if it's marked as clean. If REPAIR is false, +do not write to the file system to fix errors. If it's #t, fix all +errors. Otherwise, fix only those considered safe to repair automatically." (match (status:exit-val - (system* "e2fsck" "-v" "-p" "-C" "0" device)) + (apply system* `("e2fsck" "-v" "-C" "0" + ,@(if force? '("-f") '()) + ,@(match repair + (#f '("-n")) + (#t '("-y")) + (_ '("-p"))) + ,device))) (0 'pass) (1 'errors-corrected) (2 'reboot-required) @@ -260,15 +269,23 @@ bytevector." #f if SBLOCK has no volume name." (null-terminated-latin1->string (sub-bytevector sblock 72 32))) -(define (check-bcachefs-file-system device) - "Return the health of a bcachefs file system on DEVICE." +(define (check-bcachefs-file-system device force? repair) + "Return the health of an unmounted bcachefs file system on DEVICE. If FORCE? +is true, check the file system even if it's marked as clean. If REPAIR is +false, do not write to the file system to fix errors. If it's #t, fix all +errors. Otherwise, fix only those considered safe to repair automatically." (let ((ignored-bits (logior 2)) ; DEVICE was mounted read-only (status ;; A number, or #f on abnormal termination (e.g., assertion failure). (status:exit-val - (apply system* "bcachefs" "fsck" "-p" "-v" - ;; Make each multi-device member a separate argument. - (string-split device #\:))))) + (apply system* `("bcachefs" "fsck" "-v" + ,@(if force? '("-f") '()) + ,@(match repair + (#f '("-n")) + (#t '("-y")) + (_ '("-p"))) + ;; Make each multi-device member a separate argument. + ,@(string-split device #\:)))))) (match (and=> status (cut logand <> (lognot ignored-bits))) (0 'pass) (1 'errors-corrected) @@ -304,12 +321,28 @@ if DEVICE does not contain a btrfs file system." #f if SBLOCK has no volume name." (null-terminated-latin1->string (sub-bytevector sblock 299 256))) -(define (check-btrfs-file-system device) - "Return the health of a btrfs file system on DEVICE." - (match (status:exit-val - (system* "btrfs" "device" "scan")) - (0 'pass) - (_ 'fatal-error))) +(define (check-btrfs-file-system device force? repair) + "Return the health of an unmounted btrfs file system on DEVICE. If FORCE? is +false, return 'PASS unconditionally as btrfs claims no need for off-line checks. +When FORCE? is true, do perform a real check. This is not recommended! See +@uref{https://bugzilla.redhat.com/show_bug.cgi?id=625967#c8}. If REPAIR is +false, do not write to DEVICE. If it's #t, fix any errors found. Otherwise, +fix only those considered safe to repair automatically." + ;; XXX Why make this conditional on (check? #t) at all? + (system* "btrfs" "device" "scan") ; ignore errors + (if force? + (match (status:exit-val + (apply system* `("btrfs" "check" "--progress" + ;; Btrfs's ‘--force’ is not relevant to us here. + ,@(match repair + ;; Upstream considers ALL repairs dangerous + ;; and will warn the user at run time. + (#t '("--repair")) + (_ '("--readonly"))) ; a no-op for clarity + ,device))) + (0 'pass) + (_ 'fatal-error)) + 'pass)) ;;; @@ -338,10 +371,17 @@ if DEVICE does not contain a btrfs file system." Trailing spaces are trimmed." (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space)) -(define (check-fat-file-system device) - "Return the health of a fat file system on DEVICE." +(define (check-fat-file-system device force? repair) + "Return the health of an unmounted FAT file system on DEVICE. FORCE? is +ignored: a full file system scan is always performed. If REPAIR is false, do +not write to the file system to fix errors. Otherwise, automatically fix them +using the least destructive approach." (match (status:exit-val - (system* "fsck.vfat" "-v" "-a" device)) + (apply system* `("fsck.vfat" "-v" + ,@(match repair + (#f '("-n")) + (_ '("-a"))) ; no 'safe/#t distinction + ,device))) (0 'pass) (1 'errors-corrected) (_ 'fatal-error))) @@ -463,10 +503,28 @@ if DEVICE does not contain a JFS file system." #f if SBLOCK has no volume name." (null-terminated-latin1->string (sub-bytevector sblock 152 16))) -(define (check-jfs-file-system device) - "Return the health of a JFS file system on DEVICE." +(define (check-jfs-file-system device force? repair) + "Return the health of an unmounted JFS file system on DEVICE. If FORCE? is +true, check the file system even if it's marked as clean. If REPAIR is false, +do not write to the file system to fix errors, and replay the transaction log +only if FORCE? is true. Otherwise, replay the transaction log before checking +and automatically fix found errors." (match (status:exit-val - (system* "jfs_fsck" "-p" "-v" device)) + (apply system* + `("jfs_fsck" "-v" + ;; The ‘LEVEL’ logic is convoluted. To quote fsck/xchkdsk.c + ;; (‘-p’, ‘-a’, and ‘-r’ are aliases in every way): + ;; “If -f was chosen, have it override [-p] by [forcing] a + ;; check regardless of the outcome after the log is + ;; replayed”. + ;; “If -n is specified by itself, don't replay the journal. + ;; If -n is specified with [-p], replay the journal but + ;; don't make any other changes”. + ,@(if force? '("-f") '()) + ,@(match repair + (#f '("-n")) + (_ '("-p"))) ; no 'safe/#t distinction + ,device))) (0 'pass) (1 'errors-corrected) (2 'reboot-required) @@ -517,12 +575,22 @@ if DEVICE does not contain an F2FS file system." (sub-bytevector sblock (- (+ #x470 12) #x400) 512) %f2fs-endianness)) -(define (check-f2fs-file-system device) - "Return the health of a F2FS file system on DEVICE." +(define (check-f2fs-file-system device force? repair) + "Return the health of an unmuounted F2FS file system on DEVICE. If FORCE? is +true, check the file system even if it's marked as clean. If either FORCE? or +REPAIR are true, automatically fix found errors." + ;; There's no ‘-n’ equivalent (‘--dry-run’ does not disable writes). + ;; ’-y’ is an alias of ‘-f’. The man page is bad: read main.c. + (when (and force? (not repair)) + (format (current-error-port) + "warning: forced check of F2FS ~a implies repairing any errors~%" + device)) (match (status:exit-val - (system* "fsck.f2fs" "-p" device)) - ;; 0 and -1 are the only two possibilities - ;; (according to the manpage) + (apply system* `("fsck.f2fs" + ,@(if force? '("-f") '()) + ,@(if repair '("-p") '("--dry-run")) + ,device))) + ;; 0 and -1 are the only two possibilities according to the man page. (0 'pass) (_ 'fatal-error))) @@ -600,10 +668,15 @@ if DEVICE does not contain a NTFS file system." ;; in the BOOT SECTOR like the UUID, but in the MASTER FILE TABLE, which seems ;; way harder to access. -(define (check-ntfs-file-system device) - "Return the health of a NTFS file system on DEVICE." +(define (check-ntfs-file-system device force? repair) + "Return the health of an unmounted NTFS file system on DEVICE. FORCE? is +ignored: a full check is always performed. Repair is not possible: if REPAIR is +true and the volume has been repaired by an external tool, clear the volume +dirty flag to indicate that it's now safe to mount." (match (status:exit-val - (system* "ntfsfix" device)) + (apply system* `("ntfsfix" + ,@(if repair '("--clear-dirty") '("--no-action")) + ,device))) (0 'pass) (_ 'fatal-error))) @@ -816,8 +889,13 @@ containing ':/')." (uuid-bytevector spec) uuid->string)))) -(define (check-file-system device type) - "Run a file system check of TYPE on DEVICE." +(define (check-file-system device type force? repair) + "Check an unmounted TYPE file system on DEVICE. Do nothing but warn if it is +mounted. If FORCE? is true, check even when considered unnecessary. If REPAIR +is false, try not to write to DEVICE at all. If it's #t, try to fix all errors +found. Otherwise, fix only those considered safe to repair automatically. Not +all TYPEs support all values or combinations of FORCE? and REPAIR. Don't throw +an exception in such cases but perform the nearest sane action." (define check-procedure (cond ((string-prefix? "ext" type) check-ext2-file-system) @@ -831,33 +909,40 @@ containing ':/')." (else #f))) (if check-procedure - (match (check-procedure device) - ('pass - #t) - ('errors-corrected - (format (current-error-port) - "File system check corrected errors on ~a; continuing~%" - device)) - ('reboot-required - (format (current-error-port) - "File system check corrected errors on ~a; rebooting~%" - device) - (sleep 3) - (reboot)) - ('fatal-error - (format (current-error-port) "File system check on ~a failed~%" - device) - - ;; Spawn a REPL only if someone would be able to interact with it. - (when (isatty? (current-input-port)) - (format (current-error-port) "Spawning Bourne-like REPL.~%") - - ;; 'current-output-port' is typically connected to /dev/klog (in - ;; PID 1), but here we want to make sure we talk directly to the - ;; user. - (with-output-to-file "/dev/console" - (lambda () - (start-repl %bournish-language)))))) + (let ((mount (find (lambda (mount) + (string=? device (mount-source mount))) + (mounts)))) + (if mount + (format (current-error-port) + "Refusing to check ~a file system already mounted at ~a~%" + device (mount-point mount)) + (match (check-procedure device force? repair) + ('pass + #t) + ('errors-corrected + (format (current-error-port) + "File system check corrected errors on ~a; continuing~%" + device)) + ('reboot-required + (format (current-error-port) + "File system check corrected errors on ~a; rebooting~%" + device) + (sleep 3) + (reboot)) + ('fatal-error + (format (current-error-port) "File system check on ~a failed~%" + device) + + ;; Spawn a REPL only if someone might interact with it. + (when (isatty? (current-input-port)) + (format (current-error-port) "Spawning Bourne-like REPL.~%") + + ;; 'current-output-port' is typically connected to /dev/klog + ;; (in PID 1), but here we want to make sure we talk directly + ;; to the user. + (with-output-to-file "/dev/console" + (lambda () + (start-repl %bournish-language)))))))) (format (current-error-port) "No file system check procedure for ~a; skipping~%" device))) @@ -886,7 +971,11 @@ corresponds to the symbols listed in FLAGS." (() 0)))) -(define* (mount-file-system fs #:key (root "/root")) +(define* (mount-file-system fs #:key (root "/root") + (check? (file-system-check? fs)) + (skip-check-if-clean? + (file-system-skip-check-if-clean? fs)) + (repair (file-system-repair fs))) "Mount the file system described by FS, a object, under ROOT." (define (mount-nfs source mount-point type flags options) @@ -924,8 +1013,8 @@ corresponds to the symbols listed in FLAGS." (file-system-mount-flags (statfs source))) 0))) (options (file-system-options fs))) - (when (file-system-check? fs) - (check-file-system source type)) + (when check? + (check-file-system source type (not skip-check-if-clean?) repair)) (catch 'system-error (lambda () diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index 95d0a1fe79..ab05d1ba5e 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -408,12 +408,17 @@ the last argument of `mknod'." (define* (mount-root-file-system root type #:key volatile-root? (flags 0) options - check?) + check? skip-check-if-clean? repair) "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is true, mount ROOT read-only and make it an overlay with a writable tmpfs using the kernel built-in overlayfs. FLAGS and OPTIONS indicates the options to use to mount ROOT, and behave the same as for the `mount' procedure. -If CHECK? is true, first run ROOT's fsck tool (if any) non-interactively." + +If CHECK? is true, first run ROOT's fsck tool (if any) non-interactively. +If SKIP-CHECK-IF-CLEAN? is true, ask fsck to return immediately if ROOT is +marked as clean. If REPAIR is true, fsck may write to ROOT to perform repairs. +If REPAIR is also 'PREEN, ask fsck to perform only those repairs that it +considers safe." (if volatile-root? (begin @@ -435,7 +440,7 @@ If CHECK? is true, first run ROOT's fsck tool (if any) non-interactively." "lowerdir=/real-root,upperdir=/rw-root/upper,workdir=/rw-root/work")) (begin (when check? - (check-file-system root type)) + (check-file-system root type (not skip-check-if-clean?) repair)) (mount root "/root" type flags options))) ;; Make sure /root/etc/mtab is a symlink to /proc/self/mounts. @@ -612,7 +617,13 @@ upon error." #:options root-options #:check? (if root-fs (file-system-check? root-fs) - #t)) + #t) + #:skip-check-if-clean? + (and=> root-fs + file-system-skip-check-if-clean?) + #:repair (if root-fs + (file-system-repair root-fs) + 'preen)) (mount "none" "/root" "tmpfs")) ;; Mount the specified file systems. diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index b9eda80958..0350bf984f 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2020 Google LLC ;;; Copyright © 2020 Jakub Kądziołka ;;; Copyright © 2020, 2021 Maxim Cournoyer +;;; Copyright © 2021 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,6 +52,8 @@ file-system-mount? file-system-mount-may-fail? file-system-check? + file-system-skip-check-if-clean? + file-system-repair file-system-create-mount-point? file-system-dependencies file-system-location @@ -123,6 +126,10 @@ (default #f)) (check? file-system-check? ; Boolean (default #t)) + (skip-check-if-clean? file-system-skip-check-if-clean? ; Boolean + (default #f)) + (repair file-system-repair ; symbol or #f + (default 'preen)) (create-mount-point? file-system-create-mount-point? ; Boolean (default #f)) (dependencies file-system-dependencies ; list of @@ -318,19 +325,22 @@ store--e.g., if FS is the root file system." initrd code." (match fs (($ device mount-point type flags options mount? - mount-may-fail? needed-for-boot? check?) + mount-may-fail? needed-for-boot? + check? skip-check-if-clean? repair) ;; Note: Add new fields towards the end for compatibility. (list (cond ((uuid? device) `(uuid ,(uuid-type device) ,(uuid-bytevector device))) ((file-system-label? device) `(file-system-label ,(file-system-label->string device))) (else device)) - mount-point type flags options mount-may-fail? check?)))) + mount-point type flags options mount-may-fail? + check? skip-check-if-clean? repair)))) (define (spec->file-system sexp) "Deserialize SEXP, a list, to the corresponding object." (match sexp - ((device mount-point type flags options mount-may-fail? check? + ((device mount-point type flags options mount-may-fail? + check? skip-check-if-clean? repair _ ...) ;placeholder for new fields (file-system (device (match device @@ -343,7 +353,9 @@ initrd code." (mount-point mount-point) (type type) (flags flags) (options options) (mount-may-fail? mount-may-fail?) - (check? check?))))) + (check? check?) + (skip-check-if-clean? skip-check-if-clean?) + (repair repair))))) (define (specification->file-system-mapping spec writable?) "Read the SPEC and return the corresponding . SPEC is -- cgit v1.2.3 From a75a3d71329d3ca07a2ef18b81fc7b463f703ed7 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 23 May 2021 17:02:29 +0200 Subject: linux-boot: Honour fsck.mode & fsck.repair. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/build/linux-boot.scm (boot-system): Honour ‘fsck.mode=’ and ‘fsck.repair=’ kernel command line options. * doc/guix.texi (Initial RAM Disk): Document both. --- doc/guix.texi | 19 +++++++++++++ gnu/build/linux-boot.scm | 72 +++++++++++++++++++++++++++++------------------- 2 files changed, 63 insertions(+), 28 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index a62578be26..dc9b039aab 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -33285,6 +33285,25 @@ name like @code{/dev/sda1}, a file system label, or a file system UUID. When unspecified, the device name from the root file system of the operating system declaration is used. +@item fsck.mode=@var{mode} +Whether to check the @var{root} file system for errors before mounting +it. @var{mode} is one of @code{skip} (never check), @code{force} (always +check), or @code{auto} to respect the root file-system object's 'check?' +setting (@pxref{File Systems}) and run a full scan only if the file system +was not cleanly shut down. + +@code{auto} is the default if this option is not present or if @var{mode} +is not one of the above. + +@item fsck.repair=@var{level} +The level of repairs to perform automatically if errors are found in the +@var{root} file system. @var{level} is one of @code{no} (do not write to +@var{root} at all if possible), @code{yes} (repair as much as possible), +or @code{preen} to repair problems considered safe to repair automatically. + +@code{preen} is the default if this option is not present or if @var{level} +is not one of the above. + @item --system=@var{system} Have @file{/run/booted-system} and @file{/run/current-system} point to @var{system}. diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index ab05d1ba5e..8f0f3eb2fc 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -541,21 +541,36 @@ upon error." (mount-essential-file-systems) (let* ((args (linux-command-line)) (to-load (find-long-option "--load" args)) - (root-fs (find root-mount-point? mounts)) - (root-fs-type (or (and=> root-fs file-system-type) - "ext4")) - (root-fs-device (and=> root-fs file-system-device)) - (root-fs-flags (mount-flags->bit-mask - (or (and=> root-fs file-system-flags) - '()))) - (root-options (if root-fs - (file-system-options root-fs) - #f)) - ;; --root takes precedence over the 'device' field of the root - ;; record. - (root-device (or (and=> (find-long-option "--root" args) - device-string->file-system-device) - root-fs-device))) + ;; If present, ‘--root’ on the kernel command line takes precedence + ;; over the ‘device’ field of the root record. + (root-device (and=> (find-long-option "--root" args) + device-string->file-system-device)) + (root-fs (or (find root-mount-point? mounts) + ;; Fall back to fictitious defaults. + (file-system (device (or root-device "/dev/root")) + (mount-point "/") + (type "ext4")))) + (fsck.mode (find-long-option "fsck.mode" args))) + + (define (check? fs) + (match fsck.mode + ("skip" #f) + ("force" #t) + (_ (file-system-check? fs)))) ; assume "auto" + + (define (skip-check-if-clean? fs) + (match fsck.mode + ("force" #f) + (_ (file-system-skip-check-if-clean? fs)))) + + (define (repair fs) + (let ((arg (find-long-option "fsck.repair" args))) + (if arg + (match arg + ("no" #f) + ("yes" #t) + (_ 'preen)) + (file-system-repair fs)))) (when (member "--repl" args) (start-repl)) @@ -611,23 +626,24 @@ upon error." (if root-device (mount-root-file-system (canonicalize-device-spec root-device) - root-fs-type + (file-system-type root-fs) #:volatile-root? volatile-root? - #:flags root-fs-flags - #:options root-options - #:check? (if root-fs - (file-system-check? root-fs) - #t) + #:flags (mount-flags->bit-mask + (file-system-flags root-fs)) + #:options (file-system-options root-fs) + #:check? (check? root-fs) #:skip-check-if-clean? - (and=> root-fs - file-system-skip-check-if-clean?) - #:repair (if root-fs - (file-system-repair root-fs) - 'preen)) + (skip-check-if-clean? root-fs) + #:repair (repair root-fs)) (mount "none" "/root" "tmpfs")) - ;; Mount the specified file systems. - (for-each mount-file-system + ;; Mount the specified non-root file systems. + (for-each (lambda (fs) + (mount-file-system fs + #:check? (check? fs) + #:skip-check-if-clean? + (skip-check-if-clean? fs) + #:repair (repair fs))) (remove root-mount-point? mounts)) (setenv "EXT2FS_NO_MTAB_OK" #f) -- cgit v1.2.3 From 34c105f929b73560a2476486660c0cbba7a7410a Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Wed, 22 Sep 2021 19:00:42 +0200 Subject: file-systems: Add support for XFS. * gnu/build/file-systems.scm (%xfs-endianness): New syntax. (xfs-superblock?, read-xfs-superblock, xfs-superblock-uuid) (xfs-superblock-volume-name, check-xfs-file-system): New procedures. (%partition-label-readers, %partition-uuid-readers, check-file-system): Register them. * doc/guix.texi (Keyboard Layout and Networking and Partitioning): Note XFS support. --- doc/guix.texi | 2 +- gnu/build/file-systems.scm | 72 ++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 71 insertions(+), 3 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index dc9b039aab..9bb91b94fd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2453,7 +2453,7 @@ bootloaders. Once you are done partitioning the target hard disk drive, you have to create a file system on the relevant partition(s)@footnote{Currently -Guix System only supports ext4, btrfs, JFS, and F2FS file systems. In +Guix System only supports ext4, btrfs, JFS, F2FS, and XFS file systems. In particular, code that reads file system UUIDs and labels only works for these file system types.}. For the ESP, if you have one and assuming it is @file{/dev/sda1}, run: diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index e79037c12c..2a4dcd4c82 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -678,6 +678,69 @@ dirty flag to indicate that it's now safe to mount." (0 'pass) (_ 'fatal-error))) + + +;;; +;;; XFS file systems. +;;; + +;; + +(define-syntax %xfs-endianness + ;; Endianness of XFS file systems. + (identifier-syntax (endianness big))) + +(define (xfs-superblock? sblock) + "Return #t when SBLOCK is an XFS superblock." + (bytevector=? (sub-bytevector sblock 0 4) + (string->utf8 "XFSB"))) + +(define (read-xfs-superblock device) + "Return the raw contents of DEVICE's XFS superblock as a bytevector, or #f +if DEVICE does not contain an XFS file system." + (read-superblock device 0 120 xfs-superblock?)) + +(define (xfs-superblock-uuid sblock) + "Return the UUID of XFS superblock SBLOCK as a 16-byte bytevector." + (sub-bytevector sblock 32 16)) + +(define (xfs-superblock-volume-name sblock) + "Return the volume name of XFS superblock SBLOCK as a string of at most 12 +characters, or #f if SBLOCK has no volume name." + (null-terminated-latin1->string (sub-bytevector sblock 108 12))) + +(define (check-xfs-file-system device force? repair) + "Return the health of an unmounted XFS file system on DEVICE. If FORCE? is +false, return 'PASS unconditionally as XFS claims no need for off-line checks. +When FORCE? is true, do perform a thorough check. If REPAIR is false, do not +write to DEVICE. If it's #t, replay the log, check, and fix any errors found. +Otherwise, only replay the log, and check without attempting further repairs." + (define (xfs_repair) + (status:exit-val + (apply system* `("xfs_repair" "-Pv" + ,@(match repair + (#t '("-e")) + (_ '("-n"))) ; will miss some errors + ,device)))) + (if force? + ;; xfs_repair fails with exit status 2 if the log is dirty, which is + ;; likely in situations where you're running xfs_repair. Only the kernel + ;; can replay the log by {,un}mounting it cleanly. + (match (let ((status (xfs_repair))) + (if (and repair (eq? 2 status)) + (let ((target "/replay-XFS-log")) + ;; The kernel helpfully prints a ‘Mounting…’ notice for us. + (mkdir target) + (mount device target "xfs") + (umount target) + (rmdir target) + (xfs_repair)) + status)) + (0 'pass) + (4 'errors-corrected) + (_ 'fatal-error)) + 'pass)) + ;;; ;;; Partition lookup. @@ -771,7 +834,9 @@ partition field reader that returned a value." (partition-field-reader read-jfs-superblock jfs-superblock-volume-name) (partition-field-reader read-f2fs-superblock - f2fs-superblock-volume-name))) + f2fs-superblock-volume-name) + (partition-field-reader read-xfs-superblock + xfs-superblock-volume-name))) (define %partition-uuid-readers (list (partition-field-reader read-iso9660-superblock @@ -793,7 +858,9 @@ partition field reader that returned a value." (partition-field-reader read-f2fs-superblock f2fs-superblock-uuid) (partition-field-reader read-ntfs-superblock - ntfs-superblock-uuid))) + ntfs-superblock-uuid) + (partition-field-reader read-xfs-superblock + xfs-superblock-uuid))) (define read-partition-label (cut read-partition-field <> %partition-label-readers)) @@ -904,6 +971,7 @@ an exception in such cases but perform the nearest sane action." ((string-prefix? "f2fs" type) check-f2fs-file-system) ((string-prefix? "ntfs" type) check-ntfs-file-system) ((string-prefix? "nfs" type) (const 'pass)) + ((string-prefix? "xfs" type) check-xfs-file-system) (else #f))) (if check-procedure -- cgit v1.2.3 From 719bbcc15e2216b59bde34f297b92ceb9d349ce0 Mon Sep 17 00:00:00 2001 From: Liliana Marie Prikler Date: Sat, 25 Sep 2021 09:27:02 +0200 Subject: Update copyright assignments for Liliana Marie Prikler. * doc/guix.texi: Update copyright name for Liliana Marie Prikler. * gnu/packages/build-tools.scm: Update copyright name and email for Liliana Marie Prikler. * gnu/packages/convmv.scm: Likewise. * gnu/packages/emacs-xyz.scm: Likewise. * gnu/packages/emacs.scm: Likewise. * gnu/packages/esolangs.scm: Likewise. * gnu/packages/game-development.scm: Likewise. * gnu/packages/games.scm: Likewise. * gnu/packages/gnome-xyz.scm: Likewise. * gnu/packages/gnome.scm: Likewise. * gnu/packages/gstreamer.scm: Likewise. * gnu/packages/guile-xyz.scm: Likewise. * gnu/packages/minetest.scm: Likewise. * gnu/packages/music.scm: Likewise. * gnu/packages/patches/minetest-add-MINETEST_MOD_PATH.patch: Likewise. * gnu/packages/patches/ppsspp-disable-upgrade-and-gold.patch: Likewise. * gnu/packages/patches/webkitgtk-bind-all-fonts.patch: Likewise. * gnu/packages/python-xyz.scm: Likewise. * gnu/packages/unicode.scm: Likewise. * gnu/packages/xorg.scm: Likewise. * gnu/services/sound.scm: Likewise. * guix/build-system/renpy.scm: Likewise. * guix/build/emacs-utils.scm: Likewise. * guix/build/renpy-build-system.scm: Likewise. --- doc/guix.texi | 2 +- gnu/packages/build-tools.scm | 2 +- gnu/packages/convmv.scm | 2 +- gnu/packages/emacs-xyz.scm | 2 +- gnu/packages/emacs.scm | 2 +- gnu/packages/esolangs.scm | 2 +- gnu/packages/game-development.scm | 2 +- gnu/packages/games.scm | 2 +- gnu/packages/gnome-xyz.scm | 2 +- gnu/packages/gnome.scm | 2 +- gnu/packages/gstreamer.scm | 2 +- gnu/packages/guile-xyz.scm | 2 +- gnu/packages/minetest.scm | 2 +- gnu/packages/music.scm | 2 +- gnu/packages/patches/minetest-add-MINETEST_MOD_PATH.patch | 2 +- gnu/packages/patches/ppsspp-disable-upgrade-and-gold.patch | 4 ++-- gnu/packages/patches/webkitgtk-bind-all-fonts.patch | 2 +- gnu/packages/python-xyz.scm | 2 +- gnu/packages/unicode.scm | 2 +- gnu/packages/xorg.scm | 2 +- gnu/services/sound.scm | 2 +- guix/build-system/renpy.scm | 2 +- guix/build/emacs-utils.scm | 2 +- guix/build/renpy-build-system.scm | 2 +- 24 files changed, 25 insertions(+), 25 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 9bb91b94fd..4bf14014eb 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -70,7 +70,7 @@ Copyright @copyright{} 2019 Jakob L. Kreuze@* Copyright @copyright{} 2019 Kyle Andrews@* Copyright @copyright{} 2019 Alex Griffin@* Copyright @copyright{} 2019, 2020, 2021 Guillaume Le Vaillant@* -Copyright @copyright{} 2020 Leo Prikler@* +Copyright @copyright{} 2020 Liliana Marie Prikler@* Copyright @copyright{} 2019, 2020 Simon Tournier@* Copyright @copyright{} 2020 Wiktor Żelazny@* Copyright @copyright{} 2020 Damien Cassou@* diff --git a/gnu/packages/build-tools.scm b/gnu/packages/build-tools.scm index d2fb9e05df..7c44d2b80f 100644 --- a/gnu/packages/build-tools.scm +++ b/gnu/packages/build-tools.scm @@ -8,7 +8,7 @@ ;;; Copyright © 2018 Alex Vong ;;; Copyright © 2019, 2020 Brett Gilio ;;; Copyright © 2019 Jonathan Brielmaier -;;; Copyright © 2020 Leo Prikler +;;; Copyright © 2020 Liliana Marie Prikler ;;; Copyright © 2020 Yuval Kogman ;;; Copyright © 2020 Jakub Kądziołka ;;; Copyright © 2020 Efraim Flashner diff --git a/gnu/packages/convmv.scm b/gnu/packages/convmv.scm index 2a9a4ec68c..9e6f141818 100644 --- a/gnu/packages/convmv.scm +++ b/gnu/packages/convmv.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020 Leo Prikler +;;; Copyright © 2020 Liliana Marie Prikler ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/gnu/packages/emacs-xyz.scm b/gnu/packages/emacs-xyz.scm index 2754ce7049..e390d87253 100644 --- a/gnu/packages/emacs-xyz.scm +++ b/gnu/packages/emacs-xyz.scm @@ -55,7 +55,7 @@ ;;; Copyright © 2019 Jelle Licht ;;; Copyright © 2019 Björn Höfling ;;; Copyright © 2019 Stephen Webber -;;; Copyright © 2019, 2021 Leo Prikler +;;; Copyright © 2019, 2021 Liliana Marie Prikler ;;; Copyright © 2019 David Wilson ;;; Copyright © 2020 Paul Garlick ;;; Copyright © 2020 Robert Smith diff --git a/gnu/packages/emacs.scm b/gnu/packages/emacs.scm index 1edbaa463a..6d9950d068 100644 --- a/gnu/packages/emacs.scm +++ b/gnu/packages/emacs.scm @@ -18,7 +18,7 @@ ;;; Copyright © 2018, 2019, 2021 Tobias Geerinckx-Rice ;;; Copyright © 2019 Jesse John Gildersleve ;;; Copyright © 2019 Valentin Ignatev -;;; Copyright © 2019 Leo Prikler +;;; Copyright © 2019 Liliana Marie Prikler ;;; Copyright © 2019 Amin Bandali ;;; Copyright © 2020 Jack Hill ;;; Copyright © 2020 Morgan Smith diff --git a/gnu/packages/esolangs.scm b/gnu/packages/esolangs.scm index 45feedfa28..753221a5f1 100644 --- a/gnu/packages/esolangs.scm +++ b/gnu/packages/esolangs.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2016 Nikita ;;; Copyright © 2019 Tobias Geerinckx-Rice ;;; Copyright © 2020 Hendursaga -;;; Copyright © 2020 Leo Prikler +;;; Copyright © 2020 Liliana Marie Prikler ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/gnu/packages/game-development.scm b/gnu/packages/game-development.scm index 7d185caa0e..039945467b 100644 --- a/gnu/packages/game-development.scm +++ b/gnu/packages/game-development.scm @@ -15,7 +15,7 @@ ;;; Copyright © 2017, 2019 Rutger Helling ;;; Copyright © 2018 Marius Bakke ;;; Copyright © 2019 Pierre Neidhardt -;;; Copyright © 2019, 2020, 2021 Leo Prikler +;;; Copyright © 2019, 2020, 2021 Liliana Marie Prikler ;;; Copyright © 2019 Jethro Cao ;;; Copyright © 2020, 2021 Nicolas Goaziou ;;; Copyright © 2020 Timotej Lazar diff --git a/gnu/packages/games.scm b/gnu/packages/games.scm index bd1802517b..e59d416905 100644 --- a/gnu/packages/games.scm +++ b/gnu/packages/games.scm @@ -53,7 +53,7 @@ ;;; Copyright © 2020 Vincent Legoll ;;; Copyright © 2020, 2021 Michael Rohleder ;;; Copyright © 2020 Trevor Hass -;;; Copyright © 2020, 2021 Leo Prikler +;;; Copyright © 2020, 2021 Liliana Marie Prikler ;;; Copyright © 2020 Lu hux ;;; Copyright © 2020 Tomás Ortín Fernández ;;; Copyright © 2021 Olivier Rojon diff --git a/gnu/packages/gnome-xyz.scm b/gnu/packages/gnome-xyz.scm index b9f7afcaf8..d4a6772254 100644 --- a/gnu/packages/gnome-xyz.scm +++ b/gnu/packages/gnome-xyz.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019, 2020, 2021 Leo Prikler +;;; Copyright © 2019, 2020, 2021 Liliana Marie Prikler ;;; Copyright © 2019, 2021 Alexandros Theodotou ;;; Copyright © 2019 Giacomo Leidi ;;; Copyright © 2020 Alex Griffin diff --git a/gnu/packages/gnome.scm b/gnu/packages/gnome.scm index 7de12fe525..f81e169abb 100644 --- a/gnu/packages/gnome.scm +++ b/gnu/packages/gnome.scm @@ -44,7 +44,7 @@ ;;; Copyright © 2019 David Wilson ;;; Copyright © 2019, 2020 Raghav Gururajan ;;; Copyright © 2019, 2020 Jonathan Brielmaier -;;; Copyright © 2019, 2020, 2021 Leo Prikler +;;; Copyright © 2019, 2020, 2021 Liliana Marie Prikler ;;; Copyright © 2020 Oleg Pykhalov ;;; Copyright © 2020 Pierre Neidhardt ;;; Copyright © 2020 raingloom diff --git a/gnu/packages/gstreamer.scm b/gnu/packages/gstreamer.scm index 3047773e0f..c734d0c74e 100644 --- a/gnu/packages/gstreamer.scm +++ b/gnu/packages/gstreamer.scm @@ -8,7 +8,7 @@ ;;; Copyright © 2017 Ricardo Wurmus ;;; Copyright © 2018, 2020 Tobias Geerinckx-Rice ;;; Copyright © 2019, 2020 Marius Bakke -;;; Copyright © 2020 Leo Prikler +;;; Copyright © 2020 Liliana Marie Prikler ;;; Copyright © 2020 Michael Rohleder ;;; ;;; This file is part of GNU Guix. diff --git a/gnu/packages/guile-xyz.scm b/gnu/packages/guile-xyz.scm index 457701a436..7188058b42 100644 --- a/gnu/packages/guile-xyz.scm +++ b/gnu/packages/guile-xyz.scm @@ -31,7 +31,7 @@ ;;; Copyright © 2020, 2021 Masaya Tojo ;;; Copyright © 2020 Jesse Gibbons ;;; Copyright © 2020 Mike Rosset -;;; Copyright © 2020 Leo Prikler +;;; Copyright © 2020 Liliana Marie Prikler ;;; Copyright © 2020, 2021 pukkamustard ;;; Copyright © 2021 Bonface Munyoki Kilyungi ;;; Copyright © 2021 Xinglu Chen diff --git a/gnu/packages/minetest.scm b/gnu/packages/minetest.scm index fd1439d4d2..28fa40b410 100644 --- a/gnu/packages/minetest.scm +++ b/gnu/packages/minetest.scm @@ -6,7 +6,7 @@ ;;; Copyright © 2019 Marius Bakke ;;; Copyright © 2019–2021 Tobias Geerinckx-Rice ;;; Copyright © 2021 Trevor Hass -;;; Copyright © 2020, 2021 Leo Prikler +;;; Copyright © 2020, 2021 Liliana Marie Prikler ;;; Copyright © 2021 Maxime Devos ;;; This file is part of GNU Guix. ;;; diff --git a/gnu/packages/music.scm b/gnu/packages/music.scm index ff1330d228..4c77fb7461 100644 --- a/gnu/packages/music.scm +++ b/gnu/packages/music.scm @@ -33,7 +33,7 @@ ;;; Copyright © 2020 Marius Bakke ;;; Copyright © 2019 Riku Viitanen ;;; Copyright © 2020 Ryan Prior -;;; Copyright © 2021 Leo Prikler +;;; Copyright © 2021 Liliana Marie Prikler ;;; Copyright © 2021 Vinicius Monego ;;; Copyright © 2021 Brendan Tildesley ;;; Copyright © 2021 Bonface Munyoki Kilyungi diff --git a/gnu/packages/patches/minetest-add-MINETEST_MOD_PATH.patch b/gnu/packages/patches/minetest-add-MINETEST_MOD_PATH.patch index a74034a2c5..41338e6e6f 100644 --- a/gnu/packages/patches/minetest-add-MINETEST_MOD_PATH.patch +++ b/gnu/packages/patches/minetest-add-MINETEST_MOD_PATH.patch @@ -8,7 +8,7 @@ When it exists, Minetest will look there for mods in addition to ~/.minetest/mods/. Mods can still be installed to ~/.minetest/mods/ with the built-in installer. -With thanks to Leo Prikler. +With thanks to Liliana Marie Prikler. --- builtin/mainmenu/pkgmgr.lua | 7 +++---- doc/menu_lua_api.txt | 8 +++++++- diff --git a/gnu/packages/patches/ppsspp-disable-upgrade-and-gold.patch b/gnu/packages/patches/ppsspp-disable-upgrade-and-gold.patch index 155ba35efd..3a5ae1a2cd 100644 --- a/gnu/packages/patches/ppsspp-disable-upgrade-and-gold.patch +++ b/gnu/packages/patches/ppsspp-disable-upgrade-and-gold.patch @@ -1,9 +1,9 @@ From 942730ce7148cd54a30d4a606ce71a2654c8a2e0 Mon Sep 17 00:00:00 2001 -From: Leo Prikler +From: Liliana Marie Prikler Date: Sat, 5 Jun 2021 22:47:00 -0400 Subject: [PATCH] ppsspp: Remove upgrade code and gold support. -Original patch from Leo Prikler. +Original patch from Liliana Marie Prikler. Rebased on master (commit 69fa20744958aef8da9ca052ba7675fdc1636e46) by Maxim Cournoyer. --- diff --git a/gnu/packages/patches/webkitgtk-bind-all-fonts.patch b/gnu/packages/patches/webkitgtk-bind-all-fonts.patch index 3fe9704727..e7b06cc650 100644 --- a/gnu/packages/patches/webkitgtk-bind-all-fonts.patch +++ b/gnu/packages/patches/webkitgtk-bind-all-fonts.patch @@ -1,7 +1,7 @@ Add fonts from all XDG_DATA_DIRS, not just XDG_DATA_HOME. See . -Author: Leo Prikler +Author: Liliana Marie Prikler Index: webkitgtk-2.28.2/Source/WebKit/UIProcess/Launcher/glib/BubblewrapLauncher.cpp =================================================================== --- a/Source/WebKit/UIProcess/Launcher/glib/BubblewrapLauncher.cpp diff --git a/gnu/packages/python-xyz.scm b/gnu/packages/python-xyz.scm index 20502ac255..15a35cda17 100644 --- a/gnu/packages/python-xyz.scm +++ b/gnu/packages/python-xyz.scm @@ -89,7 +89,7 @@ ;;; Copyright © 2020, 2021 Bonface Munyoki Kilyungi ;;; Copyright © 2020 Ekaitz Zarraga ;;; Copyright © 2020 Diego N. Barbato -;;; Copyright © 2020 Leo Prikler +;;; Copyright © 2020 Liliana Marie Prikler ;;; Copyright © 2019 Kristian Trandem ;;; Copyright © 2020, 2021 Zheng Junjie <873216071@qq.com> ;;; Copyright © 2021 Morgan Smith diff --git a/gnu/packages/unicode.scm b/gnu/packages/unicode.scm index 2ecfebd379..806fe05fb6 100644 --- a/gnu/packages/unicode.scm +++ b/gnu/packages/unicode.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020 Leo Prikler +;;; Copyright © 2020 Liliana Marie Prikler ;;; Copyright © 2020 Efraim Flashner ;;; ;;; This file is part of GNU Guix. diff --git a/gnu/packages/xorg.scm b/gnu/packages/xorg.scm index b335435614..3b10573635 100644 --- a/gnu/packages/xorg.scm +++ b/gnu/packages/xorg.scm @@ -21,7 +21,7 @@ ;;; Copyright © 2019 nee ;;; Copyright © 2019 Yoshinori Arai ;;; Copyright © 2019 Mathieu Othacehe -;;; Copyright © 2020 Leo Prikler +;;; Copyright © 2020 Liliana Marie Prikler ;;; Copyright © 2020 Florian Pelz ;;; Copyright © 2020, 2021 Michael Rohleder ;;; Copyright © 2020 Maxim Cournoyer diff --git a/gnu/services/sound.scm b/gnu/services/sound.scm index bdf819b422..55610f27e0 100644 --- a/gnu/services/sound.scm +++ b/gnu/services/sound.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2020 Oleg Pykhalov -;;; Copyright © 2020 Leo Prikler +;;; Copyright © 2020 Liliana Marie Prikler ;;; Copyright © 2020 Marius Bakke ;;; ;;; This file is part of GNU Guix. diff --git a/guix/build-system/renpy.scm b/guix/build-system/renpy.scm index 35edc0056d..5ed59bf5a5 100644 --- a/guix/build-system/renpy.scm +++ b/guix/build-system/renpy.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Leo Prikler +;;; Copyright © 2021 Liliana Marie Prikler ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index 5f7ba71244..64ef40e25a 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2014, 2018 Mark H Weaver ;;; Copyright © 2014 Alex Kost ;;; Copyright © 2018, 2020 Maxim Cournoyer -;;; Copyright © 2019 Leo Prikler +;;; Copyright © 2019 Liliana Marie Prikler ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/guix/build/renpy-build-system.scm b/guix/build/renpy-build-system.scm index 66683971c5..e4a88456be 100644 --- a/guix/build/renpy-build-system.scm +++ b/guix/build/renpy-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Leo Prikler +;;; Copyright © 2021 Liliana Marie Prikler ;;; ;;; This file is part of GNU Guix. ;;; -- cgit v1.2.3 From 3c604968a1b51d60094baf36404102a66bf1668e Mon Sep 17 00:00:00 2001 From: Andrew Tropin Date: Fri, 24 Sep 2021 09:14:19 +0300 Subject: doc: Add a note about Guix Home status. * doc/guix.texi: Add a note about Guix Home status. Signed-off-by: Oleg Pykhalov --- doc/guix.texi | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 419d9429d6..0306df73a4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -35262,6 +35262,12 @@ command (@pxref{Invoking guix home}). @c Maybe later, it will be possible to make home configuration a part of @c system configuration to make everything managed by guix system. +@quotation Note +The functionality described in this section is still under development +and is subject to change. Get in touch with us on +@email{guix-devel@@gnu.org}! +@end quotation + The user's home environment usually consists of three basic parts: software, configuration, and state. Software in mainstream distros are usually installed system-wide, but with GNU Guix most software packages -- cgit v1.2.3 From b0c03aa4d80cb551d693c454403286f7fdbd7065 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Mon, 27 Sep 2021 16:03:21 +0200 Subject: doc: Fix typos. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/guix.texi (Invoking guix import): Fix ‘accross’ typo. (Version Control Services): Fix ‘infomation’ typo. --- doc/guix.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 7956652050..3124ed2ef8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11707,7 +11707,7 @@ Repositories are assumed to be passed to this option by order of preference. The additional repositories will not replace the default @code{opam} repository, which is always kept as a fallback. -Also, please note that versions are not compared accross repositories. +Also, please note that versions are not compared across repositories. The first repository (from left to right) that has at least one version of a given package will prevail over any others, and the version imported will be the latest one found @emph{in this repository only}. @@ -31704,7 +31704,7 @@ repo foo @end example In addition, Gitile can read the repository configuration to display more -infomation on the repository. Gitile uses the gitweb namespace for its +information on the repository. Gitile uses the gitweb namespace for its configuration. As an example, you can use the following in your @file{conf/gitolite.conf}: -- cgit v1.2.3 From edcc9ebc03a12f027bcb439f14962efa9dadb04f Mon Sep 17 00:00:00 2001 From: Jacob Adams Date: Sun, 26 Sep 2021 14:14:31 -0400 Subject: doc: Document Wireguard port configuration option. * doc/gnu.texi (VPN Services): Document wireguard port configuration option. Signed-off-by: Mathieu Othacehe --- doc/guix.texi | 3 +++ 1 file changed, 3 insertions(+) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 3124ed2ef8..a72a726b54 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -27656,6 +27656,9 @@ The interface name for the VPN. @item @code{addresses} (default: @code{'("10.0.0.1/32")}) The IP addresses to be assigned to the above interface. +@item @code{port} (default: @code{51820}) +The port on which to listen for incoming connections. + @item @code{private-key} (default: @code{"/etc/wireguard/private.key"}) The private key file for the interface. It is automatically generated if the file does not exist. -- cgit v1.2.3 From 20bc9ecc204a610a0d5fa8b88c74421f57dbaf3b Mon Sep 17 00:00:00 2001 From: Pierre Langlois Date: Tue, 28 Sep 2021 22:50:39 +0100 Subject: scripts: home: Wire and document --expression flag. * guix/scripts/home.scm (show-help): Add --expression option. (%options): Likewise. * doc/guix.texi (Invoking guix home): Document it. --- doc/guix.texi | 16 +++++++++++++++- guix/scripts/home.scm | 7 +++++++ 2 files changed, 22 insertions(+), 1 deletion(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index a72a726b54..2a1fea2987 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -79,7 +79,7 @@ Copyright @copyright{} 2020 Jack Hill@* Copyright @copyright{} 2020 Naga Malleswari@* Copyright @copyright{} 2020, 2021 Brice Waegeneire@* Copyright @copyright{} 2020 R Veera Kumar@* -Copyright @copyright{} 2020 Pierre Langlois@* +Copyright @copyright{} 2020, 2021 Pierre Langlois@* Copyright @copyright{} 2020 pinoaffe@* Copyright @copyright{} 2020 André Batista@* Copyright @copyright{} 2020, 2021 Alexandru-Sergiu Marton@* @@ -36093,6 +36093,20 @@ $ guix home list-generations 10d @end table +@var{options} can contain any of the common build options (@pxref{Common +Build Options}). In addition, @var{options} can contain one of the +following: + +@table @option + +@item --expression=@var{expr} +@itemx -e @var{expr} +Consider the home-environment @var{expr} evaluates to. +This is an alternative to specifying a file which evaluates to a home +environment. + +@end table + @node Documentation @chapter Documentation diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index 75df6d707d..a466f3deb1 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Andrew Tropin ;;; Copyright © 2021 Xinglu Chen +;;; Copyright © 2021 Pierre Langlois ;;; ;;; This file is part of GNU Guix. ;;; @@ -86,6 +87,9 @@ Some ACTIONS support additional ARGS.\n")) (show-build-options-help) (display (G_ " + -e, --expression=EXPR consider the home-environment EXPR evaluates to + instead of reading FILE, when applicable")) + (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (display (G_ " @@ -115,6 +119,9 @@ Some ACTIONS support additional ARGS.\n")) (let ((level (string->number* arg))) (alist-cons 'verbosity level (alist-delete 'verbosity result))))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) %standard-build-options)) (define %default-options -- cgit v1.2.3 From 8b5b7478ab474019630551b3c07ef534cf6e2520 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 3 Oct 2021 23:09:38 +0200 Subject: services: knot: Remove obsolete DISABLE-ANY? zone option. It is now silently ignored by knotd. * gnu/services/dns.scm (): Remove DISABLE-ANY? field. Adjust all previous users. * doc/guix.texi (DNS Services): Undocument it. --- doc/guix.texi | 3 --- gnu/services/dns.scm | 4 ---- 2 files changed, 7 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 2a1fea2987..423b26ef64 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -26799,9 +26799,6 @@ A list of acl identifiers. @item @code{semantic-checks?} (default: @code{#f}) When set, this adds more semantic checks to the zone. -@item @code{disable-any?} (default: @code{#f}) -When set, this forbids queries of the ANY type. - @item @code{zonefile-sync} (default: @code{0}) The delay between a modification in memory and on disk. 0 means immediate synchronization. diff --git a/gnu/services/dns.scm b/gnu/services/dns.scm index aeb2bfdc86..93055eba38 100644 --- a/gnu/services/dns.scm +++ b/gnu/services/dns.scm @@ -185,8 +185,6 @@ (default '())) (semantic-checks? knot-zone-configuration-semantic-checks? (default #f)) - (disable-any? knot-zone-configuration-disable-any? - (default #f)) (zonefile-sync knot-zone-configuration-zonefile-sync (default 0)) (zonefile-load knot-zone-configuration-zonefile-load @@ -509,7 +507,6 @@ (notify (list #$@(knot-zone-configuration-notify zone))) (acl (list #$@(knot-zone-configuration-acl zone))) (semantic-checks? #$(knot-zone-configuration-semantic-checks? zone)) - (disable-any? #$(knot-zone-configuration-disable-any? zone)) (zonefile-sync #$(knot-zone-configuration-zonefile-sync zone)) (zonefile-load '#$(knot-zone-configuration-zonefile-load zone)) (journal-content #$(knot-zone-configuration-journal-content zone)) @@ -541,7 +538,6 @@ #$(format-string-list (knot-zone-configuration-acl zone)))) (format #t " semantic-checks: ~a\n" (if semantic-checks? "on" "off")) - (format #t " disable-any: ~a\n" (if disable-any? "on" "off")) (if zonefile-sync (format #t " zonefile-sync: ~a\n" zonefile-sync)) (if zonefile-load -- cgit v1.2.3 From 5fec14807f027e62e1c74f8d15ce8b97fed54e58 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Sun, 3 Oct 2021 20:10:24 +0200 Subject: doc: Fix 'setuid-program' example. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The '#$' doesn't belong there, and will cause ‘unbound variable’ errors. Reported-By: ss2 (on IRC) * doc/guix.texi (Setuid Programs): Remove #$ from example. Signed-off-by: Tobias Geerinckx-Rice --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 423b26ef64..2728f342e4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -32965,7 +32965,7 @@ designated like this: @example (setuid-program - (program (file-append #$shadow "/bin/passwd"))) + (program (file-append shadow "/bin/passwd"))) @end example @deftp {Data Type} setuid-program -- cgit v1.2.3 From 9fc8ae4171e5da4939a64fc6d684c8b9d85bbe84 Mon Sep 17 00:00:00 2001 From: Sarah Morgensen Date: Mon, 20 Sep 2021 16:37:44 -0700 Subject: maint: Improve default diff hunk header detection. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Tell git where to look for diff hunk headers: top-level definitions for Scheme files, and (sub)section headers for texi files. * .gitattributes, etc/git/gitconfig: New files. * doc/contributing.texi ("Submitting Patches"): Add subsection "Configuring Git". Document etc/git/gitconfig. Signed-off-by: Ludovic Courtès --- doc/contributing.texi | 46 ++++++++++++++++++++++++++++++++++++++++++---- doc/guix.texi | 1 + 2 files changed, 43 insertions(+), 4 deletions(-) (limited to 'doc') diff --git a/doc/contributing.texi b/doc/contributing.texi index fbb3c47c78..21caa9c08f 100644 --- a/doc/contributing.texi +++ b/doc/contributing.texi @@ -992,9 +992,12 @@ keyword parameters for procedures that take more than four parameters. Development is done using the Git distributed version control system. Thus, access to the repository is not strictly necessary. We welcome contributions in the form of patches as produced by @code{git -format-patch} sent to the @email{guix-patches@@gnu.org} mailing list. -Seasoned Guix developers may also want to look at the section on commit -access (@pxref{Commit Access}). +format-patch} sent to the @email{guix-patches@@gnu.org} mailing list +(@pxref{submitting patches,, Submitting patches to a project, git, Git +User Manual}). Contributors are encouraged to take a moment to set some +Git repository options (@pxref{Configuring Git}) first, which can +improve the readability of patches. Seasoned Guix developers may also +want to look at the section on commit access (@pxref{Commit Access}). This mailing list is backed by a Debbugs instance, which allows us to keep track of submissions (@pxref{Tracking Bugs and Patches}). Each @@ -1211,11 +1214,46 @@ should not be delayed. When a bug is resolved, please close the thread by sending an email to @email{@var{NNN}-done@@debbugs.gnu.org}. +@node Configuring Git +@subsection Configuring Git +@cindex git configuration +@cindex @code{git format-patch} +@cindex @code{git send-email} + +If you have not done so already, you may wish to set a name and email +that will be associated with your commits (@pxref{telling git your name, +, Telling Git your name, git, Git User Manual}). If you wish to use a +different name or email just for commits in this respository, you can +use @command{git config --local}, or edit @file{.git/config} in the +repository instead of @file{~/.gitconfig}. + +We provide some default settings in @file{etc/git/gitconfig} which +modify how patches are generated, making them easier to read and apply. +These settings can be applied by manually copying them to +@file{.git/config} in your checkout, or by telling Git to include the +whole file: + +@example +git config --local include.path ../etc/git/gitconfig +@end example + +From then on, any changes to @file{etc/git/gitconfig} would +automatically take effect. + +Since the first patch in a series must be sent separately +(@pxref{Sending a Patch Series}), it can also be helpful to tell +@command{git format-patch} to handle the e-mail threading instead of +@command{git send-email}: + +@example +git config --local format.thread shallow +git config --local sendemail.thread no +@end example + @unnumberedsubsec Sending a Patch Series @anchor{Sending a Patch Series} @cindex patch series @cindex @code{git send-email} -@cindex @code{git-send-email} When sending a patch series (e.g., using @code{git send-email}), please first send one message to @email{guix-patches@@gnu.org}, and then send diff --git a/doc/guix.texi b/doc/guix.texi index 2728f342e4..a9d61461ad 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -97,6 +97,7 @@ Copyright @copyright{} 2021 Hui Lu@* Copyright @copyright{} 2021 pukkamustard@* Copyright @copyright{} 2021 Alice Brenon@* Copyright @copyright{} 2021 Andrew Tropin@* +Copyright @copyright{} 2021 Sarah Morgensen@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or -- cgit v1.2.3 From 1267c2e9efdb6e324ce1c7b1fcef242f8208a61f Mon Sep 17 00:00:00 2001 From: Sarah Morgensen Date: Fri, 24 Sep 2021 16:29:48 -0700 Subject: doc: Update htmlxref.cnf. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Update and fix broken references to cuirass, git, and guix-cookbook. * doc/htmlxref.cnf: Update from Texinfo. Factorize Guix manuals. (cuirass, git, guix-cookbook, guix-cookbook.de, guix-cookbook.fr): New entries. Signed-off-by: Ludovic Courtès --- doc/htmlxref.cnf | 76 +++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 51 insertions(+), 25 deletions(-) (limited to 'doc') diff --git a/doc/htmlxref.cnf b/doc/htmlxref.cnf index c1589453ed..c00a9a53b8 100644 --- a/doc/htmlxref.cnf +++ b/doc/htmlxref.cnf @@ -1,9 +1,9 @@ # htmlxref.cnf - reference file for free Texinfo manuals on the web. # Modified by Ludovic Courtès for the GNU Guix manual. -htmlxrefversion=2020-01-11.22; # UTC +htmlxrefversion=2021-09-24.23; # UTC -# Copyright 2010, 2011, 2012, 2013, 2014, 2015, 2019, 2020 Free Software Foundation, Inc. +# Copyright 2010-2020 Free Software Foundation, Inc. # # Copying and distribution of this file, with or without modification, # are permitted in any medium without royalty provided the copyright @@ -110,6 +110,10 @@ cpio node ${GS}/cpio/manual/html_node/ cssc node ${GS}/cssc/manual/ +CUIRASS = ${GS}/guix/cuirass/manual + cuirass mono ${CUIRASS}/cuirass.html + cuirass node ${CUIRASS}/html_node/ + CVS = ${GS}/trans-coord/manual cvs mono ${CVS}/cvs/cvs.html cvs node ${CVS}/cvs/html_node/ @@ -118,6 +122,8 @@ ddd mono ${GS}/ddd/manual/html_mono/ddd.html ddrescue mono ${GS}/ddrescue/manual/ddrescue_manual.html +dejagnu node ${GS}/dejagnu/manual/ + DICO = https://puszcza.gnu.org.ua/software/dico/manual dico mono ${DICO}/dico.html dico chapter ${DICO}/html_chapter/ @@ -127,6 +133,9 @@ dico node ${DICO}/html_node/ diffutils mono ${GS}/diffutils/manual/diffutils diffutils node ${GS}/diffutils/manual/html_node/ +dmd mono ${GS}/dmd/manual/dmd +dmd node ${GS}/dmd/manual/html_node/ + ed mono ${GS}/ed/manual/ed_manual.html EMACS = ${GS}/emacs/manual @@ -181,6 +190,9 @@ emacs node ${EMACS}/html_node/emacs/ idlwave mono ${EMACS}/html_mono/idlwave.html idlwave node ${EMACS}/html_node/idlwave/ # + info mono ${EMACS}/html_mono/info.html + info node ${EMACS}/html_node/info/ + # message mono ${EMACS}/html_mono/message.html message node ${EMACS}/html_node/message/ # @@ -259,7 +271,7 @@ gcc node ${GCC}/gcc/ gcj node ${GCC}/gcj/ gfortran node ${GCC}/gfortran/ gnat_rm node ${GCC}/gnat_rm/ - gnat_ugn_unw node ${GCC}/gnat_ugn_unw/ + gnat_ugn node ${GCC}/gnat_ugn/ libgomp node ${GCC}/libgomp/ libstdc++ node ${GCC}/libstdc++/ # @@ -288,6 +300,11 @@ gettext node ${GS}/gettext/manual/html_node/ gforth node https://www.complang.tuwien.ac.at/forth/gforth/Docs-html/ +# Also found at: +# https://mirrors.edge.kernel.org/pub/software/scm/git/docs/user-manual.html +# https://git.github.io/htmldocs/user-manual.html +git mono https://git-scm.com/docs/user-manual + global mono ${GS}/global/manual/global.html gmediaserver node ${GS}/gmediaserver/manual/ @@ -335,8 +352,8 @@ GNUSTANDARDS = ${G}/prep standards mono ${GNUSTANDARDS}/standards/standards.html standards node ${GNUSTANDARDS}/standards/html_node/ -gnutls mono http://gnutls.org/manual/gnutls.html -gnutls node http://gnutls.org/manual/html_node/ +gnutls mono ${GS}/gnutls/manual/gnutls.html +gnutls node ${GS}/gnutls/manual/html_node/ gnutls-guile mono http://gnutls.org/manual/gnutls-guile.html gnutls-guile node http://gnutls.org/manual/gnutls-guile/ @@ -397,18 +414,27 @@ guile-gtk node ${GS}/guile-gtk/docs/guile-gtk/ guile-rpc mono ${GS}/guile-rpc/manual/guile-rpc.html guile-rpc node ${GS}/guile-rpc/manual/html_node/ -guix.de mono ${GS}/guix/manual/de/guix.de.html -guix.de node ${GS}/guix/manual/de/html_node/ -guix.es mono ${GS}/guix/manual/es/guix.es.html -guix.es node ${GS}/guix/manual/es/html_node/ -guix.fr mono ${GS}/guix/manual/fr/guix.fr.html -guix.fr node ${GS}/guix/manual/fr/html_node/ -guix.ru mono ${GS}/guix/manual/ru/guix.ru.html -guix.ru node ${GS}/guix/manual/ru/html_node/ -guix.zh_CN mono ${GS}/guix/manual/zh-cn/guix.zh_CN.html -guix.zh_CN node ${GS}/guix/manual/zh-cn/html_node/ -guix mono ${GS}/guix/manual/en/guix.html -guix node ${GS}/guix/manual/en/html_node/ +GUIX = ${GS}/guix/manual + guix.de mono ${GUIX}/de/guix.de.html + guix.de node ${GUIX}/de/html_node/ + guix.es mono ${GUIX}/es/guix.es.html + guix.es node ${GUIX}/es/html_node/ + guix.fr mono ${GUIX}/fr/guix.fr.html + guix.fr node ${GUIX}/fr/html_node/ + guix.ru mono ${GUIX}/ru/guix.ru.html + guix.ru node ${GUIX}/ru/html_node/ + guix.zh_CN mono ${GUIX}/zh-cn/guix.zh_CN.html + guix.zh_CN node ${GUIX}/zh-cn/html_node/ + guix mono ${GUIX}/en/guix.html + guix node ${GUIX}/en/html_node/ + +GUIX_COOKBOOK = ${GS}/guix/cookbook + guix-cookbook.de mono ${GUIX_COOKBOOK}/de/guix-cookbook.html + guix-cookbook.de node ${GUIX_COOKBOOK}/de/html_node/ + guix-cookbook.fr mono ${GUIX_COOKBOOK}/fr/guix-cookbook.html + guix-cookbook.fr node ${GUIX_COOKBOOK}/fr/html_node/ + guix-cookbook mono ${GUIX_COOKBOOK}/en/guix-cookbook.html + guix-cookbook node ${GUIX_COOKBOOK}/en/html_node/ gv mono ${GS}/gv/manual/gv.html gv node ${GS}/gv/manual/html_node/ @@ -503,18 +529,21 @@ mcron node ${GS}/mcron/manual/html_node/ mdk mono ${GS}/mdk/manual/mdk.html mdk node ${GS}/mdk/manual/html_node/ -METAEXCHANGE = http://ftp.gwdg.de/pub/gnu2/iwfmdh/doc/texinfo +METAEXCHANGE = https://ftp.gwdg.de/pub/gnu2/iwfmdh/doc/texinfo iwf_mh node ${METAEXCHANGE}/iwf_mh.html scantest node ${METAEXCHANGE}/scantest.html mes mono ${GS}/mes/manual/mes.html mes node ${GS}/mes/manual/html_node/ -MIT_SCHEME = ${GS}/mit-scheme/documentation +MIT_SCHEME = ${GS}/mit-scheme/documentation/stable + mit-scheme-ref mono ${MIT_SCHEME}/mit-scheme-ref.html mit-scheme-ref node ${MIT_SCHEME}/mit-scheme-ref/ + mit-scheme-user mono ${MIT_SCHEME}/mit-scheme-user.html mit-scheme-user node ${MIT_SCHEME}/mit-scheme-user/ + sos mono ${MIT_SCHEME}/mit-scheme-sos.html sos node ${MIT_SCHEME}/mit-scheme-sos/ - mit-scheme-imail node ${MIT_SCHEME}/mit-scheme-imail/ + mit-scheme-imail mono ${MIT_SCHEME}/mit-scheme-imail.html moe mono ${GS}/moe/manual/moe_manual.html @@ -572,7 +601,7 @@ R = https://cran.r-project.org/doc/manuals rcs mono ${GS}/rcs/manual/rcs.html rcs node ${GS}/rcs/manual/html_node/ -READLINE = http://cnswww.cns.cwru.edu/php/chet/readline +READLINE = https://tiswww.cwru.edu/php/chet/readline readline mono ${READLINE}/readline.html rluserman mono ${READLINE}/rluserman.html history mono ${READLINE}/history.html @@ -629,7 +658,7 @@ swbis mono ${GS}/swbis/manual.html tar mono ${GS}/tar/manual/tar.html tar chapter ${GS}/tar/manual/html_chapter/ tar section ${GS}/tar/manual/html_section/ -tar node ${GS}/autoconf/manual/html_node/ +tar node ${GS}/tar/manual/html_node/ teseq mono ${GS}/teseq/teseq.html teseq node ${GS}/teseq/html_node/ @@ -637,9 +666,6 @@ teseq node ${GS}/teseq/html_node/ TEXINFO = ${GS}/texinfo/manual texinfo mono ${TEXINFO}/texinfo/texinfo.html texinfo node ${TEXINFO}/texinfo/html_node/ - # - info mono ${TEXINFO}/info/info.html - info node ${TEXINFO}/info/html_node/ # info-stnd mono ${TEXINFO}/info-stnd/info-stnd.html info-stnd node ${TEXINFO}/info-stnd/html_node/ -- cgit v1.2.3 From e0e65ed69d62a759c1b88f035f246baef47bd551 Mon Sep 17 00:00:00 2001 From: Sarah Morgensen Date: Fri, 24 Sep 2021 16:30:24 -0700 Subject: doc: cookbook: Mention translations of the cookbook. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/guix-cookbook.texi (Top): Add note about l10n. Signed-off-by: Ludovic Courtès --- doc/guix-cookbook.texi | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'doc') diff --git a/doc/guix-cookbook.texi b/doc/guix-cookbook.texi index fda5093825..dc52f6d38c 100644 --- a/doc/guix-cookbook.texi +++ b/doc/guix-cookbook.texi @@ -57,10 +57,12 @@ its API, and related concepts. @c TRANSLATORS: You can replace the following paragraph with information on @c how to join your own translation team and how to report issues with the @c translation. -If you would like to translate this document in your native language, consider -joining +This manual is also available in French (@pxref{Top,,, guix-cookbook.fr, +Livre de recettes de GNU Guix}) and German (@pxref{Top,,, +guix-cookbook.de, GNU-Guix-Kochbuch}). If you would like to translate +this document in your native language, consider joining @uref{https://translate.fedoraproject.org/projects/guix/documentation-cookbook, -Weblate}. +Weblate} (@pxref{Translating Guix,,, guix, GNU Guix reference manual}). @menu * Scheme tutorials:: Meet your new favorite language! -- cgit v1.2.3 From ba8ddb348045f81f061a1c7f51c0f7c2b0024e71 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Tue, 5 Oct 2021 02:09:41 +0300 Subject: gnu: Move (gnu home-services) to (gnu home services). * gnu/home-services/configuration.scm: Move the content ... * gnu/home/services/configuration.scm: ... here. * doc/guix.texi: Replace (gnu home-services mcron) with (gnu home services mcron). Replace (gnu home-services) with (gnu home services). * gnu/home.scm: Replace (gnu home-services fontutils) with (gnu services fontutils). Replace (gnu home-services shells) with (gnu home services shells). Replace (gnu home-services symlink-manager) with (gnu home services symlink-manager). Replace (gnu home-services xdg) with (gnu home services xdg). * gnu/home-services/fontutils.scm: Rename to gnu/services/fontutils.scm. * gnu/home-services/mcron.scm: Move to gnu/home/services/mcron.scm. Replace (gnu home-services shepherd) with (gnu home services shepherd). * gnu/home-services.scm (%service-type-path): Search home services in "gnu/services". * gnu/home-services/shells.scm: Replace (gnu home-services configuration) with (gnu home services configuration). Rename to gnu/home/services/shells.scm. Replace (gnu home-services utils) with (gnu home services utils). * gnu/home-services/shepherd.scm: Move to gnu/home/services/shepherd.scm. * gnu/home-services/symlink-manager.scm: Rename to gnu/home/services/symlink-manager.scm. * gnu/home-services/utils.scm: Rename to gnu/home/services/utils.scm. * gnu/home-services/xdg.scm: Rename to gnu/home/services/xdg.scm. * guix/scripts/home/import.scm: Replace (gnu home-services bash) with (gnu home services bash). * gnu/home-services.scm: Update documentation string. * doc/he-config-bare-bones.scm: Apply new (gnu home-services ...) modules location. * gnu/local.mk (GNU_SYSTEM_MODULES): Same. --- doc/guix.texi | 8 +- doc/he-config-bare-bones.scm | 2 +- gnu/home-services.scm | 4 +- gnu/home-services/configuration.scm | 109 ------ gnu/home-services/fontutils.scm | 65 ---- gnu/home-services/mcron.scm | 115 ------ gnu/home-services/shells.scm | 634 ---------------------------------- gnu/home-services/shepherd.scm | 134 ------- gnu/home-services/symlink-manager.scm | 247 ------------- gnu/home-services/utils.scm | 105 ------ gnu/home-services/xdg.scm | 478 ------------------------- gnu/home.scm | 8 +- gnu/home/services/configuration.scm | 109 ++++++ gnu/home/services/fontutils.scm | 65 ++++ gnu/home/services/mcron.scm | 115 ++++++ gnu/home/services/shells.scm | 634 ++++++++++++++++++++++++++++++++++ gnu/home/services/shepherd.scm | 134 +++++++ gnu/home/services/symlink-manager.scm | 247 +++++++++++++ gnu/home/services/utils.scm | 105 ++++++ gnu/home/services/xdg.scm | 478 +++++++++++++++++++++++++ gnu/local.mk | 16 +- guix/scripts/home/import.scm | 2 +- 22 files changed, 1907 insertions(+), 1907 deletions(-) delete mode 100644 gnu/home-services/configuration.scm delete mode 100644 gnu/home-services/fontutils.scm delete mode 100644 gnu/home-services/mcron.scm delete mode 100644 gnu/home-services/shells.scm delete mode 100644 gnu/home-services/shepherd.scm delete mode 100644 gnu/home-services/symlink-manager.scm delete mode 100644 gnu/home-services/utils.scm delete mode 100644 gnu/home-services/xdg.scm create mode 100644 gnu/home/services/configuration.scm create mode 100644 gnu/home/services/fontutils.scm create mode 100644 gnu/home/services/mcron.scm create mode 100644 gnu/home/services/shells.scm create mode 100644 gnu/home/services/shepherd.scm create mode 100644 gnu/home/services/symlink-manager.scm create mode 100644 gnu/home/services/utils.scm create mode 100644 gnu/home/services/xdg.scm (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index a9d61461ad..91ff692e4f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -35553,9 +35553,9 @@ services)}. @node Essential Home Services @subsection Essential Home Services -There are a few essential services defined in @code{(gnu -home-services)}, they are mostly for internal use and are required to -build a home environment, but some of them will be useful for the end +There are a few essential home services defined in +@code{(gnu services)}, they are mostly for internal use and are required +to build a home environment, but some of them will be useful for the end user. @cindex environment variables @@ -35808,7 +35808,7 @@ for example). @cindex mcron @cindex scheduling jobs -The @code{(gnu home-services mcron)} module provides an interface to +The @code{(gnu home services mcron)} module provides an interface to GNU@tie{}mcron, a daemon to run jobs at scheduled times (@pxref{Top,,, mcron, GNU@tie{}mcron}). The information about system's mcron is applicable here (@pxref{Scheduled Job Execution}), the only difference diff --git a/doc/he-config-bare-bones.scm b/doc/he-config-bare-bones.scm index 01be46a7b0..1faf75b871 100644 --- a/doc/he-config-bare-bones.scm +++ b/doc/he-config-bare-bones.scm @@ -1,6 +1,6 @@ (use-modules (gnu home) (gnu home-services) - (gnu home-services shells) + (gnu home services shells) (gnu services) (gnu packages admin) (guix gexp)) diff --git a/gnu/home-services.scm b/gnu/home-services.scm index 9f1e986616..a244a15511 100644 --- a/gnu/home-services.scm +++ b/gnu/home-services.scm @@ -512,10 +512,10 @@ environment, and its configuration file, when available."))) (define %service-type-path ;; Search path for service types. - (make-parameter `((,%guix-home-root-directory . "gnu/home-services")))) + (make-parameter `((,%guix-home-root-directory . "gnu/home/services")))) (define (all-home-service-modules) - "Return the default set of home-service modules." + "Return the default set of `home service' modules." (cons (resolve-interface '(gnu home-services)) (all-modules (%service-type-path) #:warn warn-about-load-error))) 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 -;;; Copyright © 2021 Xinglu Chen -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu home-services 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 -;;; Copyright © 2021 Xinglu Chen -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu home-services 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" - " - - - ~/.guix-home/profile/share/fonts -")))) - -(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 -;;; Copyright © 2021 Xinglu Chen -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu home-services 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 - 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 - (($ mcron '()) ; no jobs to run - '()) - (($ 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 -;;; Copyright © 2021 Xinglu Chen -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu home-services 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 -;;; Copyright © 2021 Xinglu Chen -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu home-services 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 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 -;;; Copyright © 2021 Xinglu Chen -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu home-services symlink-manager) - #:use-module (gnu home-services) - #:use-module (guix gexp) - - #:export (home-symlink-manager-service-type)) - -;;; Comment: -;;; -;;; symlink-manager cares about configuration files: it backs up files -;;; created by user, removes symlinks and directories created by a -;;; previous generation, and creates new directories and symlinks to -;;; configuration files according to the content of files/ directory -;;; (created by home-files-service) of the current home environment -;;; generation. -;;; -;;; Code: - -(define (update-symlinks-script) - (program-file - "update-symlinks" - #~(begin - (use-modules (ice-9 ftw) - (ice-9 curried-definitions) - (ice-9 match) - (srfi srfi-1)) - (define ((simplify-file-tree parent) file) - "Convert the result produced by `file-system-tree' to less -verbose and more suitable for further processing format. - -Extract dir/file info from stat and compose a relative path to the -root of the file tree. - -Sample output: - -((dir . \".\") - ((dir . \"config\") - ((dir . \"config/fontconfig\") - (file . \"config/fontconfig/fonts.conf\")) - ((dir . \"config/isync\") - (file . \"config/isync/mbsyncrc\")))) -" - (match file - ((name stat) `(file . ,(string-append parent name))) - ((name stat children ...) - (cons `(dir . ,(string-append parent name)) - (map (simplify-file-tree - (if (equal? name ".") - "" - (string-append parent name "/"))) - children))))) - - (define ((file-tree-traverse preordering) node) - "Traverses the file tree in different orders, depending on PREORDERING. - -if PREORDERING is @code{#t} resulting list will contain directories -before files located in those directories, otherwise directory will -appear only after all nested items already listed." - (let ((prepend (lambda (a b) (append b a)))) - (match node - (('file . path) (list node)) - ((('dir . path) . rest) - ((if preordering append prepend) - (list (cons 'dir path)) - (append-map (file-tree-traverse preordering) rest)))))) - - (use-modules (guix build utils)) - - (let* ((config-home (or (getenv "XDG_CONFIG_HOME") - (string-append (getenv "HOME") "/.config"))) - - (he-path (string-append (getenv "HOME") "/.guix-home")) - (new-he-path (string-append he-path ".new")) - (new-home (getenv "GUIX_NEW_HOME")) - (old-home (getenv "GUIX_OLD_HOME")) - - (new-files-path (string-append new-home "/files")) - ;; Trailing dot is required, because files itself is symlink and - ;; to make file-system-tree works it should be a directory. - (new-files-dir-path (string-append new-files-path "/.")) - - (home-path (getenv "HOME")) - (backup-dir (string-append home-path "/" - (number->string (current-time)) - "-guix-home-legacy-configs-backup")) - - (old-tree (if old-home - ((simplify-file-tree "") - (file-system-tree - (string-append old-home "/files/."))) - #f)) - (new-tree ((simplify-file-tree "") - (file-system-tree new-files-dir-path))) - - (get-source-path - (lambda (path) - (readlink (string-append new-files-path "/" path)))) - - (get-target-path - (lambda (path) - (string-append home-path "/." path))) - - (get-backup-path - (lambda (path) - (string-append backup-dir "/." path))) - - (directory? - (lambda (path) - (equal? (stat:type (stat path)) 'directory))) - - (empty-directory? - (lambda (dir) - (equal? (scandir dir) '("." "..")))) - - (symlink-to-store? - (lambda (path) - (and - (equal? (stat:type (lstat path)) 'symlink) - (store-file-name? (readlink path))))) - - (backup-file - (lambda (path) - (mkdir-p backup-dir) - (format #t "Backing up ~a..." (get-target-path path)) - (mkdir-p (dirname (get-backup-path path))) - (rename-file (get-target-path path) (get-backup-path path)) - (display " done\n"))) - - (cleanup-symlinks - (lambda () - (let ((to-delete ((file-tree-traverse #f) old-tree))) - (display - "Cleaning up symlinks from previous home-environment.\n\n") - (map - (match-lambda - (('dir . ".") - (display "Cleanup finished.\n\n")) - - (('dir . path) - (if (and - (file-exists? (get-target-path path)) - (directory? (get-target-path path)) - (empty-directory? (get-target-path path))) - (begin - (format #t "Removing ~a..." - (get-target-path path)) - (rmdir (get-target-path path)) - (display " done\n")) - (format - #t "Skipping ~a (not an empty directory)... done\n" - (get-target-path path)))) - - (('file . path) - (when (file-exists? (get-target-path path)) - ;; DO NOT remove the file if it is no longer - ;; a symlink to the store, it will be backed - ;; up later during create-symlinks phase. - (if (symlink-to-store? (get-target-path path)) - (begin - (format #t "Removing ~a..." (get-target-path path)) - (delete-file (get-target-path path)) - (display " done\n")) - (format - #t - "Skipping ~a (not a symlink to store)... done\n" - (get-target-path path)))))) - to-delete)))) - - (create-symlinks - (lambda () - (let ((to-create ((file-tree-traverse #t) new-tree))) - (map - (match-lambda - (('dir . ".") - (display - "New symlinks to home-environment will be created soon.\n") - (format - #t "All conflicting files will go to ~a.\n\n" backup-dir)) - - (('dir . path) - (let ((target-path (get-target-path path))) - (when (and (file-exists? target-path) - (not (directory? target-path))) - (backup-file path)) - - (if (file-exists? target-path) - (format - #t "Skipping ~a (directory already exists)... done\n" - target-path) - (begin - (format #t "Creating ~a..." target-path) - (mkdir target-path) - (display " done\n"))))) - - (('file . path) - (when (file-exists? (get-target-path path)) - (backup-file path)) - (format #t "Symlinking ~a -> ~a..." - (get-target-path path) (get-source-path path)) - (symlink (get-source-path path) (get-target-path path)) - (display " done\n"))) - to-create))))) - - (when old-tree - (cleanup-symlinks)) - - (create-symlinks) - - (symlink new-home new-he-path) - (rename-file new-he-path he-path) - - (display " done\nFinished updating symlinks.\n\n"))))) - - -(define (update-symlinks-gexp _) - #~(primitive-load #$(update-symlinks-script))) - -(define home-symlink-manager-service-type - (service-type (name 'home-symlink-manager) - (extensions - (list - (service-extension - home-activation-service-type - update-symlinks-gexp))) - (default-value #f) - (description "Provide an @code{update-symlinks} -script, which creates symlinks to configuration files and directories -on every activation. If an existing file would be overwritten by a -symlink, backs up that file first."))) 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 -;;; Copyright © 2021 Andrew Tropin -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu home-services 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: -(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 -;;; Copyright © 2021 Xinglu Chen -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu home-services 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 -;; -;; - -(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 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 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 - (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 - (($ 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 - (($ 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."))) diff --git a/gnu/home.scm b/gnu/home.scm index f4c9359e25..5ac382dc5a 100644 --- a/gnu/home.scm +++ b/gnu/home.scm @@ -18,10 +18,10 @@ (define-module (gnu home) #:use-module (gnu home-services) - #:use-module (gnu home-services symlink-manager) - #:use-module (gnu home-services shells) - #:use-module (gnu home-services xdg) - #:use-module (gnu home-services fontutils) + #:use-module (gnu home services symlink-manager) + #:use-module (gnu home services shells) + #:use-module (gnu home services xdg) + #:use-module (gnu home services fontutils) #:use-module (gnu services) #:use-module (guix records) #:use-module (guix diagnostics) 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 +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home services 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 +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home services 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" + " + + + ~/.guix-home/profile/share/fonts +")))) + +(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 +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home services 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 + 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 + (($ mcron '()) ; no jobs to run + '()) + (($ 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 +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home services 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 +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home services 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 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 +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home services symlink-manager) + #:use-module (gnu home-services) + #:use-module (guix gexp) + + #:export (home-symlink-manager-service-type)) + +;;; Comment: +;;; +;;; symlink-manager cares about configuration files: it backs up files +;;; created by user, removes symlinks and directories created by a +;;; previous generation, and creates new directories and symlinks to +;;; configuration files according to the content of files/ directory +;;; (created by home-files-service) of the current home environment +;;; generation. +;;; +;;; Code: + +(define (update-symlinks-script) + (program-file + "update-symlinks" + #~(begin + (use-modules (ice-9 ftw) + (ice-9 curried-definitions) + (ice-9 match) + (srfi srfi-1)) + (define ((simplify-file-tree parent) file) + "Convert the result produced by `file-system-tree' to less +verbose and more suitable for further processing format. + +Extract dir/file info from stat and compose a relative path to the +root of the file tree. + +Sample output: + +((dir . \".\") + ((dir . \"config\") + ((dir . \"config/fontconfig\") + (file . \"config/fontconfig/fonts.conf\")) + ((dir . \"config/isync\") + (file . \"config/isync/mbsyncrc\")))) +" + (match file + ((name stat) `(file . ,(string-append parent name))) + ((name stat children ...) + (cons `(dir . ,(string-append parent name)) + (map (simplify-file-tree + (if (equal? name ".") + "" + (string-append parent name "/"))) + children))))) + + (define ((file-tree-traverse preordering) node) + "Traverses the file tree in different orders, depending on PREORDERING. + +if PREORDERING is @code{#t} resulting list will contain directories +before files located in those directories, otherwise directory will +appear only after all nested items already listed." + (let ((prepend (lambda (a b) (append b a)))) + (match node + (('file . path) (list node)) + ((('dir . path) . rest) + ((if preordering append prepend) + (list (cons 'dir path)) + (append-map (file-tree-traverse preordering) rest)))))) + + (use-modules (guix build utils)) + + (let* ((config-home (or (getenv "XDG_CONFIG_HOME") + (string-append (getenv "HOME") "/.config"))) + + (he-path (string-append (getenv "HOME") "/.guix-home")) + (new-he-path (string-append he-path ".new")) + (new-home (getenv "GUIX_NEW_HOME")) + (old-home (getenv "GUIX_OLD_HOME")) + + (new-files-path (string-append new-home "/files")) + ;; Trailing dot is required, because files itself is symlink and + ;; to make file-system-tree works it should be a directory. + (new-files-dir-path (string-append new-files-path "/.")) + + (home-path (getenv "HOME")) + (backup-dir (string-append home-path "/" + (number->string (current-time)) + "-guix-home-legacy-configs-backup")) + + (old-tree (if old-home + ((simplify-file-tree "") + (file-system-tree + (string-append old-home "/files/."))) + #f)) + (new-tree ((simplify-file-tree "") + (file-system-tree new-files-dir-path))) + + (get-source-path + (lambda (path) + (readlink (string-append new-files-path "/" path)))) + + (get-target-path + (lambda (path) + (string-append home-path "/." path))) + + (get-backup-path + (lambda (path) + (string-append backup-dir "/." path))) + + (directory? + (lambda (path) + (equal? (stat:type (stat path)) 'directory))) + + (empty-directory? + (lambda (dir) + (equal? (scandir dir) '("." "..")))) + + (symlink-to-store? + (lambda (path) + (and + (equal? (stat:type (lstat path)) 'symlink) + (store-file-name? (readlink path))))) + + (backup-file + (lambda (path) + (mkdir-p backup-dir) + (format #t "Backing up ~a..." (get-target-path path)) + (mkdir-p (dirname (get-backup-path path))) + (rename-file (get-target-path path) (get-backup-path path)) + (display " done\n"))) + + (cleanup-symlinks + (lambda () + (let ((to-delete ((file-tree-traverse #f) old-tree))) + (display + "Cleaning up symlinks from previous home-environment.\n\n") + (map + (match-lambda + (('dir . ".") + (display "Cleanup finished.\n\n")) + + (('dir . path) + (if (and + (file-exists? (get-target-path path)) + (directory? (get-target-path path)) + (empty-directory? (get-target-path path))) + (begin + (format #t "Removing ~a..." + (get-target-path path)) + (rmdir (get-target-path path)) + (display " done\n")) + (format + #t "Skipping ~a (not an empty directory)... done\n" + (get-target-path path)))) + + (('file . path) + (when (file-exists? (get-target-path path)) + ;; DO NOT remove the file if it is no longer + ;; a symlink to the store, it will be backed + ;; up later during create-symlinks phase. + (if (symlink-to-store? (get-target-path path)) + (begin + (format #t "Removing ~a..." (get-target-path path)) + (delete-file (get-target-path path)) + (display " done\n")) + (format + #t + "Skipping ~a (not a symlink to store)... done\n" + (get-target-path path)))))) + to-delete)))) + + (create-symlinks + (lambda () + (let ((to-create ((file-tree-traverse #t) new-tree))) + (map + (match-lambda + (('dir . ".") + (display + "New symlinks to home-environment will be created soon.\n") + (format + #t "All conflicting files will go to ~a.\n\n" backup-dir)) + + (('dir . path) + (let ((target-path (get-target-path path))) + (when (and (file-exists? target-path) + (not (directory? target-path))) + (backup-file path)) + + (if (file-exists? target-path) + (format + #t "Skipping ~a (directory already exists)... done\n" + target-path) + (begin + (format #t "Creating ~a..." target-path) + (mkdir target-path) + (display " done\n"))))) + + (('file . path) + (when (file-exists? (get-target-path path)) + (backup-file path)) + (format #t "Symlinking ~a -> ~a..." + (get-target-path path) (get-source-path path)) + (symlink (get-source-path path) (get-target-path path)) + (display " done\n"))) + to-create))))) + + (when old-tree + (cleanup-symlinks)) + + (create-symlinks) + + (symlink new-home new-he-path) + (rename-file new-he-path he-path) + + (display " done\nFinished updating symlinks.\n\n"))))) + + +(define (update-symlinks-gexp _) + #~(primitive-load #$(update-symlinks-script))) + +(define home-symlink-manager-service-type + (service-type (name 'home-symlink-manager) + (extensions + (list + (service-extension + home-activation-service-type + update-symlinks-gexp))) + (default-value #f) + (description "Provide an @code{update-symlinks} +script, which creates symlinks to configuration files and directories +on every activation. If an existing file would be overwritten by a +symlink, backs up that file first."))) 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 +;;; Copyright © 2021 Andrew Tropin +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home services 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: +(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 +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home services 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 +;; +;; + +(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 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 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 + (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 + (($ 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 + (($ 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."))) diff --git a/gnu/local.mk b/gnu/local.mk index e74946a837..b1f0cab55e 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -75,14 +75,14 @@ GNU_SYSTEM_MODULES = \ %D%/ci.scm \ %D%/home.scm \ %D%/home-services.scm \ - %D%/home-services/symlink-manager.scm \ - %D%/home-services/fontutils.scm \ - %D%/home-services/configuration.scm \ - %D%/home-services/shells.scm \ - %D%/home-services/shepherd.scm \ - %D%/home-services/mcron.scm \ - %D%/home-services/utils.scm \ - %D%/home-services/xdg.scm \ + %D%/home/services/symlink-manager.scm \ + %D%/home/services/fontutils.scm \ + %D%/home/services/configuration.scm \ + %D%/home/services/shells.scm \ + %D%/home/services/shepherd.scm \ + %D%/home/services/mcron.scm \ + %D%/home/services/utils.scm \ + %D%/home/services/xdg.scm \ %D%/image.scm \ %D%/packages.scm \ %D%/packages/abduco.scm \ diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm index 79fb23a2fd..c977ec3861 100644 --- a/guix/scripts/home/import.scm +++ b/guix/scripts/home/import.scm @@ -41,7 +41,7 @@ (let ((rc (string-append (getenv "HOME") "/.bashrc")) (profile (string-append (getenv "HOME") "/.bash_profile")) (logout (string-append (getenv "HOME") "/.bash_logout"))) - `((gnu home-services bash) + `((gnu home services bash) (service home-bash-service-type (home-bash-configuration ,@(if (file-exists? rc) -- cgit v1.2.3 From 2600002b9a2189c9dfb079b60959dbfcd45348df Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Sat, 9 Oct 2021 18:08:18 +0300 Subject: doc: guix: Fix home services locations. This commit follows ba8ddb348045f81f061a1c7f51c0f7c2b0024e71. * doc/guix.texi (Invoking guix home): Fix home services locations. --- doc/guix.texi | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index 91ff692e4f..b577684eb7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -35904,7 +35904,7 @@ regular expressions, sorted by relevance: @example $ guix home search shell name: home-shell-profile -location: gnu/home-services/shells.scm:73:2 +location: gnu/home/services/shells.scm:73:2 extends: home-files description: Create `~/.profile', which is used for environment initialization + of POSIX compatible login shells. Can be extended with a list of strings or @@ -35912,20 +35912,20 @@ description: Create `~/.profile', which is used for environment initialization relevance: 6 name: home-zsh-plugin-manager -location: gnu/home-services/shellutils.scm:28:2 +location: gnu/home/services/shellutils.scm:28:2 extends: home-zsh home-profile description: Install plugins in profile and configure Zsh to load them. relevance: 1 name: home-zsh-direnv -location: gnu/home-services/shellutils.scm:69:2 +location: gnu/home/services/shellutils.scm:69:2 extends: home-profile home-zsh description: Enables `direnv' for `zsh'. Adds hook to `.zshrc' and installs a + package in the profile. relevance: 1 name: home-zsh-autosuggestions -location: gnu/home-services/shellutils.scm:43:2 +location: gnu/home/services/shellutils.scm:43:2 extends: home-zsh-plugin-manager home-zsh description: Enables Fish-like fast/unobtrusive autosuggestions for `zsh' and + sets reasonable default values for some plugin's variables to improve perfomance @@ -35934,13 +35934,13 @@ description: Enables Fish-like fast/unobtrusive autosuggestions for `zsh' and relevance: 1 name: home-zsh -location: gnu/home-services/shells.scm:236:2 +location: gnu/home/services/shells.scm:236:2 extends: home-files home-profile description: Install and configure Zsh. relevance: 1 name: home-bash -location: gnu/home-services/shells.scm:388:2 +location: gnu/home/services/shells.scm:388:2 extends: home-files home-profile description: Install and configure Bash. relevance: 1 -- cgit v1.2.3 From 0e8d2df0f1a4ab25c482e1c427c54e19903e62f3 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Sat, 9 Oct 2021 16:51:25 +0300 Subject: Move (gnu home-services) to (gnu home services). * gnu/home-services.scm (%guix-home-root-directory): Replace gnu/home-services.scm with "gnu/home/services.scm". Rename to gnu/home/services.scm. * gnu/local.mk (GNU_SYSTEM_MODULES): Rename gnu/home-services.scm to gnu/home/services.scm. * doc/he-config-bare-bones.scm: Replace (gnu home-services) with (gnu home services). * gnu/home.scm: Same. * gnu/home/services/fontutils.scm: Same. * gnu/home/services/mcron.scm: Same. * gnu/home/services/shells.scm: Same. * gnu/home/services/shepherd.scm: Same. * gnu/home/services/symlink-manager.scm: Same. * gnu/home/services/xdg.scm: Same. * guix/scripts/home.scm: Same. * guix/self.scm: Same. --- doc/he-config-bare-bones.scm | 2 +- gnu/home-services.scm | 524 ---------------------------------- gnu/home.scm | 2 +- gnu/home/services.scm | 524 ++++++++++++++++++++++++++++++++++ gnu/home/services/fontutils.scm | 2 +- gnu/home/services/mcron.scm | 2 +- gnu/home/services/shells.scm | 2 +- gnu/home/services/shepherd.scm | 2 +- gnu/home/services/symlink-manager.scm | 2 +- gnu/home/services/xdg.scm | 2 +- gnu/local.mk | 2 +- guix/scripts/home.scm | 2 +- guix/self.scm | 2 +- 13 files changed, 535 insertions(+), 535 deletions(-) delete mode 100644 gnu/home-services.scm create mode 100644 gnu/home/services.scm (limited to 'doc') diff --git a/doc/he-config-bare-bones.scm b/doc/he-config-bare-bones.scm index 1faf75b871..d2e4736e29 100644 --- a/doc/he-config-bare-bones.scm +++ b/doc/he-config-bare-bones.scm @@ -1,5 +1,5 @@ (use-modules (gnu home) - (gnu home-services) + (gnu home services) (gnu home services shells) (gnu services) (gnu packages admin) diff --git a/gnu/home-services.scm b/gnu/home-services.scm deleted file mode 100644 index a244a15511..0000000000 --- a/gnu/home-services.scm +++ /dev/null @@ -1,524 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Andrew Tropin -;;; Copyright © 2021 Xinglu Chen -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu home-services) - #:use-module (gnu services) - #:use-module (guix channels) - #:use-module (guix monads) - #:use-module (guix store) - #:use-module (guix gexp) - #:use-module (guix profiles) - #:use-module (guix sets) - #:use-module (guix ui) - #:use-module (guix discovery) - #:use-module (guix diagnostics) - - #:use-module (srfi srfi-1) - #:use-module (ice-9 match) - - #:export (home-service-type - home-profile-service-type - home-environment-variables-service-type - home-files-service-type - home-run-on-first-login-service-type - home-activation-service-type - home-run-on-change-service-type - home-provenance-service-type - - fold-home-service-types) - - #:re-export (service - service-type - service-extension)) - -;;; Comment: -;;; -;;; This module is similar to (gnu system services) module, but -;;; provides Home Services, which are supposed to be used for building -;;; home-environment. -;;; -;;; Home Services use the same extension as System Services. Consult -;;; (gnu system services) module or manual for more information. -;;; -;;; home-service-type is a root of home services DAG. -;;; -;;; home-profile-service-type is almost the same as profile-service-type, at least -;;; for now. -;;; -;;; home-environment-variables-service-type generates a @file{setup-environment} -;;; shell script, which is expected to be sourced by login shell or other program, -;;; which starts early and spawns all other processes. Home services for shells -;;; automatically add code for sourcing this file, if person do not use those home -;;; services they have to source this script manually in their's shell *profile -;;; file (details described in the manual). -;;; -;;; home-files-service-type is similar to etc-service-type, but doesn't extend -;;; home-activation, because deploy mechanism for config files is pluggable and -;;; can be different for different home environments: The default one is called -;;; symlink-manager (will be introudced in a separate patch series), which creates -;;; links for various dotfiles (like $XDG_CONFIG_HOME/$APP/...) to store, but is -;;; possible to implement alternative approaches like read-only home from Julien's -;;; guix-home-manager. -;;; -;;; home-run-on-first-login-service-type provides an @file{on-first-login} guile -;;; script, which runs provided gexps once, when user makes first login. It can -;;; be used to start user's Shepherd and maybe some other process. It relies on -;;; assumption that /run/user/$UID will be created on login by some login -;;; manager (elogind for example). -;;; -;;; home-activation-service-type provides an @file{activate} guile script, which -;;; do three main things: -;;; -;;; - Sets environment variables to the values declared in -;;; @file{setup-environment} shell script. It's necessary, because user can set -;;; for example XDG_CONFIG_HOME and it should be respected by activation gexp of -;;; symlink-manager. -;;; -;;; - Sets GUIX_NEW_HOME and possibly GUIX_OLD_HOME vars to paths in the store. -;;; Later those variables can be used by activation gexps, for example by -;;; symlink-manager or run-on-change services. -;;; -;;; - Run all activation gexps provided by other home services. -;;; -;;; home-run-on-change-service-type allows to trigger actions during -;;; activation if file or directory specified by pattern is changed. -;;; -;;; Code: - - -(define (home-derivation entries mextensions) - "Return as a monadic value the derivation of the 'home' -directory containing the given entries." - (mlet %store-monad ((extensions (mapm/accumulate-builds identity - mextensions))) - (lower-object - (file-union "home" (append entries (concatenate extensions)))))) - -(define home-service-type - ;; This is the ultimate service type, the root of the home service - ;; DAG. The service of this type is extended by monadic name/item - ;; pairs. These items end up in the "home-environment directory" as - ;; returned by 'home-environment-derivation'. - (service-type (name 'home) - (extensions '()) - (compose identity) - (extend home-derivation) - (default-value '()) - (description - "Build the home environment top-level directory, -which in turn refers to everything the home environment needs: its -packages, configuration files, activation script, and so on."))) - -(define (packages->profile-entry packages) - "Return a system entry for the profile containing PACKAGES." - ;; XXX: 'mlet' is needed here for one reason: to get the proper - ;; '%current-target' and '%current-target-system' bindings when - ;; 'packages->manifest' is called, and thus when the 'package-inputs' - ;; etc. procedures are called on PACKAGES. That way, conditionals in those - ;; inputs see the "correct" value of these two parameters. See - ;; . - (mlet %store-monad ((_ (current-target-system))) - (return `(("profile" ,(profile - (content (packages->manifest - (map identity - ;;(options->transformation transformations) - (delete-duplicates packages eq?)))))))))) - -;; MAYBE: Add a list of transformations for packages. It's better to -;; place it in home-profile-service-type to affect all profile -;; packages and prevent conflicts, when other packages relies on -;; non-transformed version of package. -(define home-profile-service-type - (service-type (name 'home-profile) - (extensions - (list (service-extension home-service-type - packages->profile-entry))) - (compose concatenate) - (extend append) - (description - "This is the @dfn{home profile} and can be found in -@file{~/.guix-home/profile}. It contains packages and -configuration files that the user has declared in their -@code{home-environment} record."))) - -(define (environment-variables->setup-environment-script vars) - "Return a file that can be sourced by a POSIX compliant shell which -initializes the environment. The file will source the home -environment profile, set some default environment variables, and set -environment variables provided in @code{vars}. @code{vars} is a list -of pairs (@code{(key . value)}), @code{key} is a string and -@code{value} is a string or gexp. - -If value is @code{#f} variable will be omitted. -If value is @code{#t} variable will be just exported. -For any other, value variable will be set to the @code{value} and -exported." - (define (warn-about-duplicate-defenitions) - (fold - (lambda (x acc) - (when (equal? (car x) (car acc)) - (warning - (G_ "duplicate definition for `~a' environment variable ~%") (car x))) - x) - (cons "" "") - (sort vars (lambda (a b) - (stringsetup-environment-script))) - (compose concatenate) - (extend append) - (default-value '()) - (description "Set the environment variables."))) - -(define (files->files-directory files) - "Return a @code{files} directory that contains FILES." - (define (assert-no-duplicates files) - (let loop ((files files) - (seen (set))) - (match files - (() #t) - (((file _) rest ...) - (when (set-contains? seen file) - (raise (formatted-message (G_ "duplicate '~a' entry for files/") - file))) - (loop rest (set-insert file seen)))))) - - ;; Detect duplicates early instead of letting them through, eventually - ;; leading to a build failure of "files.drv". - (assert-no-duplicates files) - - (file-union "files" files)) - -(define (files-entry files) - "Return an entry for the @file{~/.guix-home/files} -directory containing FILES." - (with-monad %store-monad - (return `(("files" ,(files->files-directory files)))))) - -(define home-files-service-type - (service-type (name 'home-files) - (extensions - (list (service-extension home-service-type - files-entry))) - (compose concatenate) - (extend append) - (default-value '()) - (description "Configuration files for programs that -will be put in @file{~/.guix-home/files}."))) - -(define (compute-on-first-login-script _ gexps) - (gexp->script - "on-first-login" - #~(let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR") - (format #f "/run/user/~a" (getuid)))) - (flag-file-path (string-append - xdg-runtime-dir "/on-first-login-executed")) - (touch (lambda (file-name) - (call-with-output-file file-name (const #t))))) - ;; XDG_RUNTIME_DIR dissapears on logout, that means such trick - ;; allows to launch on-first-login script on first login only - ;; after complete logout/reboot. - (when (not (file-exists? flag-file-path)) - (begin #$@gexps (touch flag-file-path)))))) - -(define (on-first-login-script-entry m-on-first-login) - "Return, as a monadic value, an entry for the on-first-login script -in the home environment directory." - (mlet %store-monad ((on-first-login m-on-first-login)) - (return `(("on-first-login" ,on-first-login))))) - -(define home-run-on-first-login-service-type - (service-type (name 'home-run-on-first-login) - (extensions - (list (service-extension - home-service-type - on-first-login-script-entry))) - (compose identity) - (extend compute-on-first-login-script) - (default-value #f) - (description "Run gexps on first user login. Can be -extended with one gexp."))) - - -(define (compute-activation-script init-gexp gexps) - (gexp->script - "activate" - #~(let* ((he-init-file (lambda (he) (string-append he "/setup-environment"))) - (he-path (string-append (getenv "HOME") "/.guix-home")) - (new-home-env (getenv "GUIX_NEW_HOME")) - (new-home (or new-home-env - ;; Path of the activation file if called interactively - (dirname (car (command-line))))) - (old-home-env (getenv "GUIX_OLD_HOME")) - (old-home (or old-home-env - (if (file-exists? (he-init-file he-path)) - (readlink he-path) - #f)))) - (if (file-exists? (he-init-file new-home)) - (let* ((port ((@ (ice-9 popen) open-input-pipe) - (format #f "source ~a && env -0" - (he-init-file new-home)))) - (result ((@ (ice-9 rdelim) read-delimited) "" port)) - (vars (map (lambda (x) - (let ((si (string-index x #\=))) - (cons (string-take x si) - (string-drop x (1+ si))))) - ((@ (srfi srfi-1) remove) - string-null? - (string-split result #\nul))))) - (close-port port) - (map (lambda (x) (setenv (car x) (cdr x))) vars) - - (setenv "GUIX_NEW_HOME" new-home) - (setenv "GUIX_OLD_HOME" old-home) - - #$@gexps - - ;; Do not unset env variable if it was set outside. - (unless new-home-env (setenv "GUIX_NEW_HOME" #f)) - (unless old-home-env (setenv "GUIX_OLD_HOME" #f))) - (format #t "\ -Activation script was either called or loaded by file from this direcotry: -~a -It doesn't seem that home environment is somewhere around. -Make sure that you call ./activate by symlink from -home store item.\n" - new-home))))) - -(define (activation-script-entry m-activation) - "Return, as a monadic value, an entry for the activation script -in the home environment directory." - (mlet %store-monad ((activation m-activation)) - (return `(("activate" ,activation))))) - -(define home-activation-service-type - (service-type (name 'home-activation) - (extensions - (list (service-extension - home-service-type - activation-script-entry))) - (compose identity) - (extend compute-activation-script) - (default-value #f) - (description "Run gexps to activate the current -generation of home environment and update the state of the home -directory. @command{activate} script automatically called during -reconfiguration or generation switching. This service can be extended -with one gexp, but many times, and all gexps must be idempotent."))) - - -;;; -;;; On-change. -;;; - -(define (compute-on-change-gexp eval-gexps? pattern-gexp-tuples) - #~(begin - (define (equal-regulars? file1 file2) - "Check if FILE1 and FILE2 are bit for bit identical." - (let* ((cmp-binary #$(file-append - (@ (gnu packages base) diffutils) "/bin/cmp")) - (stats1 (lstat file1)) - (stats2 (lstat file2))) - (cond - ((= (stat:ino stats1) (stat:ino stats2)) #t) - ((not (= (stat:size stats1) (stat:size stats2))) #f) - - (else (= (system* cmp-binary file1 file2) 0))))) - - (define (equal-symlinks? symlink1 symlink2) - "Check if SYMLINK1 and SYMLINK2 are pointing to the same target." - (string=? (readlink symlink1) (readlink symlink2))) - - (define (equal-directories? dir1 dir2) - "Check if DIR1 and DIR2 have the same content." - (define (ordinary-file file) - (not (or (string=? file ".") - (string=? file "..")))) - (let* ((files1 (scandir dir1 ordinary-file)) - (files2 (scandir dir2 ordinary-file))) - (if (equal? files1 files2) - (map (lambda (file) - (equal-files? - (string-append dir1 "/" file) - (string-append dir2 "/" file))) - files1) - #f))) - - (define (equal-files? file1 file2) - "Compares files, symlinks or directories of the same type." - (case (file-type file1) - ((directory) (equal-directories? file1 file2)) - ((symlink) (equal-symlinks? file1 file2)) - ((regular) (equal-regulars? file1 file2)) - (else - (display "The file type is unsupported by on-change service.\n") - #f))) - - (define (file-type file) - (stat:type (lstat file))) - - (define (something-changed? file1 file2) - (cond - ((and (not (file-exists? file1)) - (not (file-exists? file2))) #f) - ((or (not (file-exists? file1)) - (not (file-exists? file2))) #t) - - ((not (eq? (file-type file1) (file-type file2))) #t) - - (else - (not (equal-files? file1 file2))))) - - (define expressions-to-eval - (map - (lambda (x) - (let* ((file1 (string-append - (or (getenv "GUIX_OLD_HOME") - "/gnu/store/non-existing-generation") - "/" (car x))) - (file2 (string-append (getenv "GUIX_NEW_HOME") "/" (car x))) - (_ (format #t "Comparing ~a and\n~10t~a..." file1 file2)) - (any-changes? (something-changed? file1 file2)) - (_ (format #t " done (~a)\n" - (if any-changes? "changed" "same")))) - (if any-changes? (cadr x) ""))) - '#$pattern-gexp-tuples)) - - (if #$eval-gexps? - (begin - (display "Evaling on-change gexps.\n\n") - (for-each primitive-eval expressions-to-eval) - (display "On-change gexps evaluation finished.\n\n")) - (display "\ -On-change gexps won't be evaluated, disabled by service -configuration.\n")))) - -(define home-run-on-change-service-type - (service-type (name 'home-run-on-change) - (extensions - (list (service-extension - home-activation-service-type - identity))) - (compose concatenate) - (extend compute-on-change-gexp) - (default-value #t) - (description "\ -G-expressions to run if the specified files have changed since the -last generation. The extension should be a list of lists where the -first element is the pattern for file or directory that expected to be -changed, and the second element is the G-expression to be evaluated."))) - - -;;; -;;; Provenance tracking. -;;; - -(define home-provenance-service-type - (service-type - (name 'home-provenance) - (extensions - (list (service-extension - home-service-type - (service-extension-compute - (first (service-type-extensions provenance-service-type)))))) - (default-value #f) ;the HE config file - (description "\ -Store provenance information about the home environment in the home -environment itself: the channels used when building the home -environment, and its configuration file, when available."))) - -(define sexp->home-provenance sexp->system-provenance) -(define home-provenance system-provenance) - - -;;; -;;; Searching -;;; - -(define (parent-directory directory) - "Get the parent directory of DIRECTORY" - (string-join (drop-right (string-split directory #\/) 1) "/")) - -(define %guix-home-root-directory - ;; Absolute file name of the module hierarchy. - (parent-directory (dirname (search-path %load-path "gnu/home-services.scm")))) - -(define %service-type-path - ;; Search path for service types. - (make-parameter `((,%guix-home-root-directory . "gnu/home/services")))) - -(define (all-home-service-modules) - "Return the default set of `home service' modules." - (cons (resolve-interface '(gnu home-services)) - (all-modules (%service-type-path) - #:warn warn-about-load-error))) - -(define* (fold-home-service-types proc seed) - (fold-service-types proc seed (all-home-service-modules))) diff --git a/gnu/home.scm b/gnu/home.scm index 5ac382dc5a..d8134693e5 100644 --- a/gnu/home.scm +++ b/gnu/home.scm @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu home) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu home services symlink-manager) #:use-module (gnu home services shells) #:use-module (gnu home services xdg) diff --git a/gnu/home/services.scm b/gnu/home/services.scm new file mode 100644 index 0000000000..c497b14617 --- /dev/null +++ b/gnu/home/services.scm @@ -0,0 +1,524 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Andrew Tropin +;;; Copyright © 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu home services) + #:use-module (gnu services) + #:use-module (guix channels) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (guix gexp) + #:use-module (guix profiles) + #:use-module (guix sets) + #:use-module (guix ui) + #:use-module (guix discovery) + #:use-module (guix diagnostics) + + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + + #:export (home-service-type + home-profile-service-type + home-environment-variables-service-type + home-files-service-type + home-run-on-first-login-service-type + home-activation-service-type + home-run-on-change-service-type + home-provenance-service-type + + fold-home-service-types) + + #:re-export (service + service-type + service-extension)) + +;;; Comment: +;;; +;;; This module is similar to (gnu system services) module, but +;;; provides Home Services, which are supposed to be used for building +;;; home-environment. +;;; +;;; Home Services use the same extension as System Services. Consult +;;; (gnu system services) module or manual for more information. +;;; +;;; home-service-type is a root of home services DAG. +;;; +;;; home-profile-service-type is almost the same as profile-service-type, at least +;;; for now. +;;; +;;; home-environment-variables-service-type generates a @file{setup-environment} +;;; shell script, which is expected to be sourced by login shell or other program, +;;; which starts early and spawns all other processes. Home services for shells +;;; automatically add code for sourcing this file, if person do not use those home +;;; services they have to source this script manually in their's shell *profile +;;; file (details described in the manual). +;;; +;;; home-files-service-type is similar to etc-service-type, but doesn't extend +;;; home-activation, because deploy mechanism for config files is pluggable and +;;; can be different for different home environments: The default one is called +;;; symlink-manager (will be introudced in a separate patch series), which creates +;;; links for various dotfiles (like $XDG_CONFIG_HOME/$APP/...) to store, but is +;;; possible to implement alternative approaches like read-only home from Julien's +;;; guix-home-manager. +;;; +;;; home-run-on-first-login-service-type provides an @file{on-first-login} guile +;;; script, which runs provided gexps once, when user makes first login. It can +;;; be used to start user's Shepherd and maybe some other process. It relies on +;;; assumption that /run/user/$UID will be created on login by some login +;;; manager (elogind for example). +;;; +;;; home-activation-service-type provides an @file{activate} guile script, which +;;; do three main things: +;;; +;;; - Sets environment variables to the values declared in +;;; @file{setup-environment} shell script. It's necessary, because user can set +;;; for example XDG_CONFIG_HOME and it should be respected by activation gexp of +;;; symlink-manager. +;;; +;;; - Sets GUIX_NEW_HOME and possibly GUIX_OLD_HOME vars to paths in the store. +;;; Later those variables can be used by activation gexps, for example by +;;; symlink-manager or run-on-change services. +;;; +;;; - Run all activation gexps provided by other home services. +;;; +;;; home-run-on-change-service-type allows to trigger actions during +;;; activation if file or directory specified by pattern is changed. +;;; +;;; Code: + + +(define (home-derivation entries mextensions) + "Return as a monadic value the derivation of the 'home' +directory containing the given entries." + (mlet %store-monad ((extensions (mapm/accumulate-builds identity + mextensions))) + (lower-object + (file-union "home" (append entries (concatenate extensions)))))) + +(define home-service-type + ;; This is the ultimate service type, the root of the home service + ;; DAG. The service of this type is extended by monadic name/item + ;; pairs. These items end up in the "home-environment directory" as + ;; returned by 'home-environment-derivation'. + (service-type (name 'home) + (extensions '()) + (compose identity) + (extend home-derivation) + (default-value '()) + (description + "Build the home environment top-level directory, +which in turn refers to everything the home environment needs: its +packages, configuration files, activation script, and so on."))) + +(define (packages->profile-entry packages) + "Return a system entry for the profile containing PACKAGES." + ;; XXX: 'mlet' is needed here for one reason: to get the proper + ;; '%current-target' and '%current-target-system' bindings when + ;; 'packages->manifest' is called, and thus when the 'package-inputs' + ;; etc. procedures are called on PACKAGES. That way, conditionals in those + ;; inputs see the "correct" value of these two parameters. See + ;; . + (mlet %store-monad ((_ (current-target-system))) + (return `(("profile" ,(profile + (content (packages->manifest + (map identity + ;;(options->transformation transformations) + (delete-duplicates packages eq?)))))))))) + +;; MAYBE: Add a list of transformations for packages. It's better to +;; place it in home-profile-service-type to affect all profile +;; packages and prevent conflicts, when other packages relies on +;; non-transformed version of package. +(define home-profile-service-type + (service-type (name 'home-profile) + (extensions + (list (service-extension home-service-type + packages->profile-entry))) + (compose concatenate) + (extend append) + (description + "This is the @dfn{home profile} and can be found in +@file{~/.guix-home/profile}. It contains packages and +configuration files that the user has declared in their +@code{home-environment} record."))) + +(define (environment-variables->setup-environment-script vars) + "Return a file that can be sourced by a POSIX compliant shell which +initializes the environment. The file will source the home +environment profile, set some default environment variables, and set +environment variables provided in @code{vars}. @code{vars} is a list +of pairs (@code{(key . value)}), @code{key} is a string and +@code{value} is a string or gexp. + +If value is @code{#f} variable will be omitted. +If value is @code{#t} variable will be just exported. +For any other, value variable will be set to the @code{value} and +exported." + (define (warn-about-duplicate-defenitions) + (fold + (lambda (x acc) + (when (equal? (car x) (car acc)) + (warning + (G_ "duplicate definition for `~a' environment variable ~%") (car x))) + x) + (cons "" "") + (sort vars (lambda (a b) + (stringsetup-environment-script))) + (compose concatenate) + (extend append) + (default-value '()) + (description "Set the environment variables."))) + +(define (files->files-directory files) + "Return a @code{files} directory that contains FILES." + (define (assert-no-duplicates files) + (let loop ((files files) + (seen (set))) + (match files + (() #t) + (((file _) rest ...) + (when (set-contains? seen file) + (raise (formatted-message (G_ "duplicate '~a' entry for files/") + file))) + (loop rest (set-insert file seen)))))) + + ;; Detect duplicates early instead of letting them through, eventually + ;; leading to a build failure of "files.drv". + (assert-no-duplicates files) + + (file-union "files" files)) + +(define (files-entry files) + "Return an entry for the @file{~/.guix-home/files} +directory containing FILES." + (with-monad %store-monad + (return `(("files" ,(files->files-directory files)))))) + +(define home-files-service-type + (service-type (name 'home-files) + (extensions + (list (service-extension home-service-type + files-entry))) + (compose concatenate) + (extend append) + (default-value '()) + (description "Configuration files for programs that +will be put in @file{~/.guix-home/files}."))) + +(define (compute-on-first-login-script _ gexps) + (gexp->script + "on-first-login" + #~(let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR") + (format #f "/run/user/~a" (getuid)))) + (flag-file-path (string-append + xdg-runtime-dir "/on-first-login-executed")) + (touch (lambda (file-name) + (call-with-output-file file-name (const #t))))) + ;; XDG_RUNTIME_DIR dissapears on logout, that means such trick + ;; allows to launch on-first-login script on first login only + ;; after complete logout/reboot. + (when (not (file-exists? flag-file-path)) + (begin #$@gexps (touch flag-file-path)))))) + +(define (on-first-login-script-entry m-on-first-login) + "Return, as a monadic value, an entry for the on-first-login script +in the home environment directory." + (mlet %store-monad ((on-first-login m-on-first-login)) + (return `(("on-first-login" ,on-first-login))))) + +(define home-run-on-first-login-service-type + (service-type (name 'home-run-on-first-login) + (extensions + (list (service-extension + home-service-type + on-first-login-script-entry))) + (compose identity) + (extend compute-on-first-login-script) + (default-value #f) + (description "Run gexps on first user login. Can be +extended with one gexp."))) + + +(define (compute-activation-script init-gexp gexps) + (gexp->script + "activate" + #~(let* ((he-init-file (lambda (he) (string-append he "/setup-environment"))) + (he-path (string-append (getenv "HOME") "/.guix-home")) + (new-home-env (getenv "GUIX_NEW_HOME")) + (new-home (or new-home-env + ;; Path of the activation file if called interactively + (dirname (car (command-line))))) + (old-home-env (getenv "GUIX_OLD_HOME")) + (old-home (or old-home-env + (if (file-exists? (he-init-file he-path)) + (readlink he-path) + #f)))) + (if (file-exists? (he-init-file new-home)) + (let* ((port ((@ (ice-9 popen) open-input-pipe) + (format #f "source ~a && env -0" + (he-init-file new-home)))) + (result ((@ (ice-9 rdelim) read-delimited) "" port)) + (vars (map (lambda (x) + (let ((si (string-index x #\=))) + (cons (string-take x si) + (string-drop x (1+ si))))) + ((@ (srfi srfi-1) remove) + string-null? + (string-split result #\nul))))) + (close-port port) + (map (lambda (x) (setenv (car x) (cdr x))) vars) + + (setenv "GUIX_NEW_HOME" new-home) + (setenv "GUIX_OLD_HOME" old-home) + + #$@gexps + + ;; Do not unset env variable if it was set outside. + (unless new-home-env (setenv "GUIX_NEW_HOME" #f)) + (unless old-home-env (setenv "GUIX_OLD_HOME" #f))) + (format #t "\ +Activation script was either called or loaded by file from this direcotry: +~a +It doesn't seem that home environment is somewhere around. +Make sure that you call ./activate by symlink from -home store item.\n" + new-home))))) + +(define (activation-script-entry m-activation) + "Return, as a monadic value, an entry for the activation script +in the home environment directory." + (mlet %store-monad ((activation m-activation)) + (return `(("activate" ,activation))))) + +(define home-activation-service-type + (service-type (name 'home-activation) + (extensions + (list (service-extension + home-service-type + activation-script-entry))) + (compose identity) + (extend compute-activation-script) + (default-value #f) + (description "Run gexps to activate the current +generation of home environment and update the state of the home +directory. @command{activate} script automatically called during +reconfiguration or generation switching. This service can be extended +with one gexp, but many times, and all gexps must be idempotent."))) + + +;;; +;;; On-change. +;;; + +(define (compute-on-change-gexp eval-gexps? pattern-gexp-tuples) + #~(begin + (define (equal-regulars? file1 file2) + "Check if FILE1 and FILE2 are bit for bit identical." + (let* ((cmp-binary #$(file-append + (@ (gnu packages base) diffutils) "/bin/cmp")) + (stats1 (lstat file1)) + (stats2 (lstat file2))) + (cond + ((= (stat:ino stats1) (stat:ino stats2)) #t) + ((not (= (stat:size stats1) (stat:size stats2))) #f) + + (else (= (system* cmp-binary file1 file2) 0))))) + + (define (equal-symlinks? symlink1 symlink2) + "Check if SYMLINK1 and SYMLINK2 are pointing to the same target." + (string=? (readlink symlink1) (readlink symlink2))) + + (define (equal-directories? dir1 dir2) + "Check if DIR1 and DIR2 have the same content." + (define (ordinary-file file) + (not (or (string=? file ".") + (string=? file "..")))) + (let* ((files1 (scandir dir1 ordinary-file)) + (files2 (scandir dir2 ordinary-file))) + (if (equal? files1 files2) + (map (lambda (file) + (equal-files? + (string-append dir1 "/" file) + (string-append dir2 "/" file))) + files1) + #f))) + + (define (equal-files? file1 file2) + "Compares files, symlinks or directories of the same type." + (case (file-type file1) + ((directory) (equal-directories? file1 file2)) + ((symlink) (equal-symlinks? file1 file2)) + ((regular) (equal-regulars? file1 file2)) + (else + (display "The file type is unsupported by on-change service.\n") + #f))) + + (define (file-type file) + (stat:type (lstat file))) + + (define (something-changed? file1 file2) + (cond + ((and (not (file-exists? file1)) + (not (file-exists? file2))) #f) + ((or (not (file-exists? file1)) + (not (file-exists? file2))) #t) + + ((not (eq? (file-type file1) (file-type file2))) #t) + + (else + (not (equal-files? file1 file2))))) + + (define expressions-to-eval + (map + (lambda (x) + (let* ((file1 (string-append + (or (getenv "GUIX_OLD_HOME") + "/gnu/store/non-existing-generation") + "/" (car x))) + (file2 (string-append (getenv "GUIX_NEW_HOME") "/" (car x))) + (_ (format #t "Comparing ~a and\n~10t~a..." file1 file2)) + (any-changes? (something-changed? file1 file2)) + (_ (format #t " done (~a)\n" + (if any-changes? "changed" "same")))) + (if any-changes? (cadr x) ""))) + '#$pattern-gexp-tuples)) + + (if #$eval-gexps? + (begin + (display "Evaling on-change gexps.\n\n") + (for-each primitive-eval expressions-to-eval) + (display "On-change gexps evaluation finished.\n\n")) + (display "\ +On-change gexps won't be evaluated, disabled by service +configuration.\n")))) + +(define home-run-on-change-service-type + (service-type (name 'home-run-on-change) + (extensions + (list (service-extension + home-activation-service-type + identity))) + (compose concatenate) + (extend compute-on-change-gexp) + (default-value #t) + (description "\ +G-expressions to run if the specified files have changed since the +last generation. The extension should be a list of lists where the +first element is the pattern for file or directory that expected to be +changed, and the second element is the G-expression to be evaluated."))) + + +;;; +;;; Provenance tracking. +;;; + +(define home-provenance-service-type + (service-type + (name 'home-provenance) + (extensions + (list (service-extension + home-service-type + (service-extension-compute + (first (service-type-extensions provenance-service-type)))))) + (default-value #f) ;the HE config file + (description "\ +Store provenance information about the home environment in the home +environment itself: the channels used when building the home +environment, and its configuration file, when available."))) + +(define sexp->home-provenance sexp->system-provenance) +(define home-provenance system-provenance) + + +;;; +;;; Searching +;;; + +(define (parent-directory directory) + "Get the parent directory of DIRECTORY" + (string-join (drop-right (string-split directory #\/) 1) "/")) + +(define %guix-home-root-directory + ;; Absolute file name of the module hierarchy. + (parent-directory (dirname (search-path %load-path "gnu/home/services.scm")))) + +(define %service-type-path + ;; Search path for service types. + (make-parameter `((,%guix-home-root-directory . "gnu/home/services")))) + +(define (all-home-service-modules) + "Return the default set of `home service' modules." + (cons (resolve-interface '(gnu home services)) + (all-modules (%service-type-path) + #:warn warn-about-load-error))) + +(define* (fold-home-service-types proc seed) + (fold-service-types proc seed (all-home-service-modules))) diff --git a/gnu/home/services/fontutils.scm b/gnu/home/services/fontutils.scm index 72a84fdecd..772904367d 100644 --- a/gnu/home/services/fontutils.scm +++ b/gnu/home/services/fontutils.scm @@ -18,7 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu home services fontutils) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu packages fontutils) #:use-module (guix gexp) diff --git a/gnu/home/services/mcron.scm b/gnu/home/services/mcron.scm index cc6faac47f..0b3dbb810b 100644 --- a/gnu/home/services/mcron.scm +++ b/gnu/home/services/mcron.scm @@ -19,7 +19,7 @@ (define-module (gnu home services mcron) #:use-module (gnu packages guile-xyz) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu services shepherd) #:use-module (gnu home services shepherd) #:use-module (guix records) diff --git a/gnu/home/services/shells.scm b/gnu/home/services/shells.scm index 2308371dd0..21b250f35d 100644 --- a/gnu/home/services/shells.scm +++ b/gnu/home/services/shells.scm @@ -21,7 +21,7 @@ #:use-module (gnu services configuration) #:use-module (gnu home services configuration) #:use-module (gnu home services utils) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu packages shells) #:use-module (gnu packages bash) #:use-module (guix gexp) diff --git a/gnu/home/services/shepherd.scm b/gnu/home/services/shepherd.scm index 1a3e849bb2..7a9cc064bb 100644 --- a/gnu/home/services/shepherd.scm +++ b/gnu/home/services/shepherd.scm @@ -18,7 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu home services shepherd) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu packages admin) #:use-module (gnu services shepherd) #:use-module (guix sets) diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm index d53e8f5046..f4251e1e6a 100644 --- a/gnu/home/services/symlink-manager.scm +++ b/gnu/home/services/symlink-manager.scm @@ -18,7 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu home services symlink-manager) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (guix gexp) #:export (home-symlink-manager-service-type)) diff --git a/gnu/home/services/xdg.scm b/gnu/home/services/xdg.scm index 4aed9a5803..453c05ddbf 100644 --- a/gnu/home/services/xdg.scm +++ b/gnu/home/services/xdg.scm @@ -20,7 +20,7 @@ (define-module (gnu home services xdg) #:use-module (gnu services configuration) #:use-module (gnu home services configuration) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (gnu packages freedesktop) #:use-module (gnu home services utils) #:use-module (guix gexp) diff --git a/gnu/local.mk b/gnu/local.mk index bb3063c4ac..ff51c500d4 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -74,7 +74,7 @@ GNU_SYSTEM_MODULES = \ %D%/bootloader/depthcharge.scm \ %D%/ci.scm \ %D%/home.scm \ - %D%/home-services.scm \ + %D%/home/services.scm \ %D%/home/services/symlink-manager.scm \ %D%/home/services/fontutils.scm \ %D%/home/services/configuration.scm \ diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index a4d4aaa562..8656db22c9 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -23,7 +23,7 @@ #:use-module ((gnu services) #:hide (delete)) #:use-module (gnu packages) #:use-module (gnu home) - #:use-module (gnu home-services) + #:use-module (gnu home services) #:use-module (guix channels) #:use-module (guix derivations) #:use-module (guix ui) diff --git a/guix/self.scm b/guix/self.scm index 7bf6003261..61ff423086 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -961,7 +961,7 @@ itself." (define *home-modules* (scheme-node "guix-home" `((gnu home) - (gnu home-services) + (gnu home services) ,@(scheme-modules* source "gnu/home/services")) (list *core-package-modules* *package-modules* *extra-modules* *core-modules* *system-modules*) -- cgit v1.2.3 From 00a132222f62e43a76b1bf7c1973faa31906f29e Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Mon, 11 Oct 2021 14:57:03 +0300 Subject: doc: guix: Fix typo. Reported by Maxime Devos . * doc/guix.texi (Invoking guix home): Fix typo. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index b577684eb7..b0011e920d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -35888,7 +35888,7 @@ guix home @var{options}@dots{} @var{action} @var{file} @var{file} must be the name of a file containing a @code{home-environment} declaration. @var{action} specifies how the -home environment is instantiated, but there are few auxuliary actions +home environment is instantiated, but there are few auxiliary actions which don't instantiate it. Currently the following values are supported: -- cgit v1.2.3 From dc88999648aaeb9935737672ee6faa14e8120dd4 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Mon, 11 Oct 2021 18:55:46 +0200 Subject: doc: Fix typo. * doc/guix.texi (Virtualization Services): Adjust Ganeti service name. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc') diff --git a/doc/guix.texi b/doc/guix.texi index b0011e920d..7a4b2c040b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -30224,7 +30224,7 @@ It takes a @code{ganeti-luxid-configuration} object. @end defvr @deftp {Data Type} ganeti-luxid-configuration -This is the configuration for the @code{ganeti-wconfd} service. +This is the configuration for the @code{ganeti-luxid} service. @table @asis @item @code{ganeti} (default: @code{ganeti}) -- cgit v1.2.3